OSDN Git Service

fortran/
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-intrinsic.c
index 589e9df..b875299 100644 (file)
@@ -1,5 +1,6 @@
 /* Intrinsic translation
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -105,10 +106,10 @@ gfc_intrinsic_map_t;
     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 
-#define OTHER_BUILTIN(ID, NAME, TYPE) \
+#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
   { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
     BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
-    true, false, true, NAME, NULL_TREE, NULL_TREE, \
+    true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 
 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
@@ -139,7 +140,7 @@ static tree
 builtin_decl_for_precision (enum built_in_function base_built_in,
                            int precision)
 {
-  int i = END_BUILTINS;
+  enum built_in_function i = END_BUILTINS;
 
   gfc_intrinsic_map_t *m;
   for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
@@ -151,15 +152,34 @@ builtin_decl_for_precision (enum built_in_function base_built_in,
     i = m->double_built_in;
   else if (precision == TYPE_PRECISION (long_double_type_node))
     i = m->long_double_built_in;
+  else if (precision == TYPE_PRECISION (float128_type_node))
+    {
+      /* Special treatment, because it is not exactly a built-in, but
+        a library function.  */
+      return m->real16_decl;
+    }
 
-  return (i == END_BUILTINS ? NULL_TREE : built_in_decls[i]);
+  return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
 }
 
 
-static tree
-builtin_decl_for_float_kind (enum built_in_function double_built_in, int kind)
+tree
+gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
+                                int kind)
 {
   int i = gfc_validate_kind (BT_REAL, kind, false);
+
+  if (gfc_real_kinds[i].c_float128)
+    {
+      /* For __float128, the story is a bit different, because we return
+        a decl to a library function rather than a built-in.  */
+      gfc_intrinsic_map_t *m; 
+      for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
+       ;
+
+      return m->real16_decl;
+    }
+
   return builtin_decl_for_precision (double_built_in,
                                     gfc_real_kinds[i].mode_precision);
 }
@@ -312,7 +332,8 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
       tree artype;
 
       artype = TREE_TYPE (TREE_TYPE (args[0]));
-      args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
+      args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
+                                args[0]);
     }
 
   se->expr = convert (type, args[0]);
@@ -338,11 +359,12 @@ build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
   intval = gfc_evaluate_now (intval, pblock);
 
   tmp = convert (argtype, intval);
-  cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
+  cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
+                         boolean_type_node, tmp, arg);
 
-  tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
-                    build_int_cst (type, 1));
-  tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp);
+  tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
+                        intval, build_int_cst (type, 1));
+  tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
   return tmp;
 }
 
@@ -405,7 +427,7 @@ build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
       break;
 
     case RND_TRUNC:
-      return fold_build1 (FIX_TRUNC_EXPR, type, arg);
+      return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
       break;
 
     default:
@@ -437,18 +459,18 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
   int kind;
 
   kind = expr->ts.kind;
-  nargs =  gfc_intrinsic_argument_list_length (expr);
+  nargs = gfc_intrinsic_argument_list_length (expr);
 
   decl = NULL_TREE;
   /* We have builtin functions for some cases.  */
   switch (op)
     {
     case RND_ROUND:
-      decl = builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
+      decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
       break;
 
     case RND_TRUNC:
-      decl = builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
+      decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
       break;
 
     default:
@@ -477,17 +499,21 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
   n = gfc_validate_kind (BT_INTEGER, kind, false);
   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
-  cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
+  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
+                         tmp);
 
   mpfr_neg (huge, huge, GFC_RND_MODE);
   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
-  tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
-  cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
+  tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
+                        tmp);
+  cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+                         cond, tmp);
   itype = gfc_get_int_type (kind);
 
   tmp = build_fix_expr (&se->pre, arg[0], itype, op);
   tmp = convert (type, tmp);
-  se->expr = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]);
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
+                             arg[0]);
   mpfr_clear (huge);
 }
 
@@ -525,7 +551,8 @@ gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
          tree artype;
 
          artype = TREE_TYPE (TREE_TYPE (args[0]));
-         args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
+         args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
+                                    args[0]);
        }
 
       se->expr = build_fix_expr (&se->pre, args[0], type, op);
@@ -541,7 +568,8 @@ gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
   tree arg;
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
-  se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
+  se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
+                             TREE_TYPE (TREE_TYPE (arg)), arg);
 }
 
 
@@ -553,10 +581,32 @@ gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
   tree arg;
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
-  se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
+  se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
+}
+
+
+
+static tree
+define_quad_builtin (const char *name, tree type, bool is_const)
+{
+  tree fndecl;
+  fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
+                      type);
+
+  /* Mark the decl as external.  */
+  DECL_EXTERNAL (fndecl) = 1;
+  TREE_PUBLIC (fndecl) = 1;
+
+  /* Mark it __attribute__((const)).  */
+  TREE_READONLY (fndecl) = is_const;
+
+  rest_of_decl_compilation (fndecl, 1, 0);
+
+  return fndecl;
 }
 
 
+
 /* Initialize function decls for library functions.  The external functions
    are created as required.  Builtin functions are added here.  */
 
@@ -564,32 +614,107 @@ void
 gfc_build_intrinsic_lib_fndecls (void)
 {
   gfc_intrinsic_map_t *m;
+  tree quad_decls[END_BUILTINS + 1];
+
+  if (gfc_real16_is_float128)
+  {
+    /* If we have soft-float types, we create the decls for their
+       C99-like library functions.  For now, we only handle __float128
+       q-suffixed functions.  */
+
+    tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
+    tree func_lround, func_llround, func_scalbn, func_cpow;
+
+    memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
+
+    type = float128_type_node;
+    complex_type = complex_float128_type_node;
+    /* type (*) (type) */
+    func_1 = build_function_type_list (type, type, NULL_TREE);
+    /* long (*) (type) */
+    func_lround = build_function_type_list (long_integer_type_node,
+                                           type, NULL_TREE);
+    /* long long (*) (type) */
+    func_llround = build_function_type_list (long_long_integer_type_node,
+                                            type, NULL_TREE);
+    /* type (*) (type, type) */
+    func_2 = build_function_type_list (type, type, type, NULL_TREE);
+    /* type (*) (type, &int) */
+    func_frexp
+      = build_function_type_list (type,
+                                 type,
+                                 build_pointer_type (integer_type_node),
+                                 NULL_TREE);
+    /* type (*) (type, int) */
+    func_scalbn = build_function_type_list (type,
+                                           type, integer_type_node, NULL_TREE);
+    /* type (*) (complex type) */
+    func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
+    /* complex type (*) (complex type, complex type) */
+    func_cpow
+      = build_function_type_list (complex_type,
+                                 complex_type, complex_type, NULL_TREE);
+
+#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
+#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
+#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
+
+    /* Only these built-ins are actually needed here. These are used directly
+       from the code, when calling builtin_decl_for_precision() or
+       builtin_decl_for_float_type(). The others are all constructed by
+       gfc_get_intrinsic_lib_fndecl().  */
+#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
+  quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
+
+#include "mathbuiltins.def"
+
+#undef OTHER_BUILTIN
+#undef LIB_FUNCTION
+#undef DEFINE_MATH_BUILTIN
+#undef DEFINE_MATH_BUILTIN_C
+
+  }
 
   /* Add GCC builtin functions.  */
   for (m = gfc_intrinsic_map;
        m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
     {
       if (m->float_built_in != END_BUILTINS)
-       m->real4_decl = built_in_decls[m->float_built_in];
+       m->real4_decl = builtin_decl_explicit (m->float_built_in);
       if (m->complex_float_built_in != END_BUILTINS)
-       m->complex4_decl = built_in_decls[m->complex_float_built_in];
+       m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
       if (m->double_built_in != END_BUILTINS)
-       m->real8_decl = built_in_decls[m->double_built_in];
+       m->real8_decl = builtin_decl_explicit (m->double_built_in);
       if (m->complex_double_built_in != END_BUILTINS)
-       m->complex8_decl = built_in_decls[m->complex_double_built_in];
+       m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
 
       /* If real(kind=10) exists, it is always long double.  */
       if (m->long_double_built_in != END_BUILTINS)
-       m->real10_decl = built_in_decls[m->long_double_built_in];
+       m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
       if (m->complex_long_double_built_in != END_BUILTINS)
-       m->complex10_decl = built_in_decls[m->complex_long_double_built_in];
+       m->complex10_decl
+         = builtin_decl_explicit (m->complex_long_double_built_in);
 
-      /* For now, we assume that if real(kind=16) exists, it is long double.
-        Later, we will deal with __float128 and break this assumption.  */
-      if (m->long_double_built_in != END_BUILTINS)
-       m->real16_decl = built_in_decls[m->long_double_built_in];
-      if (m->complex_long_double_built_in != END_BUILTINS)
-       m->complex16_decl = built_in_decls[m->complex_long_double_built_in];
+      if (!gfc_real16_is_float128)
+       {
+         if (m->long_double_built_in != END_BUILTINS)
+           m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
+         if (m->complex_long_double_built_in != END_BUILTINS)
+           m->complex16_decl
+             = builtin_decl_explicit (m->complex_long_double_built_in);
+       }
+      else if (quad_decls[m->double_built_in] != NULL_TREE)
+        {
+         /* Quad-precision function calls are constructed when first
+            needed by builtin_decl_for_precision(), except for those
+            that will be used directly (define by OTHER_BUILTIN).  */
+         m->real16_decl = quad_decls[m->double_built_in];
+       }
+      else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
+        {
+         /* Same thing for the complex ones.  */
+         m->complex16_decl = quad_decls[m->double_built_in];
+       }
     }
 }
 
@@ -600,7 +725,7 @@ static tree
 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 {
   tree type;
-  tree argtypes;
+  VEC(tree,gc) *argtypes;
   tree fndecl;
   gfc_actual_arglist *actual;
   tree *pdecl;
@@ -668,6 +793,9 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
       else if (gfc_real_kinds[n].c_long_double)
        snprintf (name, sizeof (name), "%s%s%s",
                  ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
+      else if (gfc_real_kinds[n].c_float128)
+       snprintf (name, sizeof (name), "%s%s%s",
+                 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
       else
        gcc_unreachable ();
     }
@@ -678,14 +806,13 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
                ts->kind);
     }
 
-  argtypes = NULL_TREE;
+  argtypes = NULL;
   for (actual = expr->value.function.actual; actual; actual = actual->next)
     {
       type = gfc_typenode_for_spec (&actual->expr->ts);
-      argtypes = gfc_chainon_list (argtypes, type);
+      VEC_safe_push (tree, gc, argtypes, type);
     }
-  argtypes = gfc_chainon_list (argtypes, void_type_node);
-  type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
+  type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
   fndecl = build_decl (input_location,
                       FUNCTION_DECL, get_identifier (name), type);
 
@@ -759,7 +886,7 @@ gfc_trans_same_strlen_check (const char* intr_name, locus* where,
     return;
 
   /* Compare the two string lengths.  */
-  cond = fold_build2 (NE_EXPR, boolean_type_node, a, b);
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
 
   /* Output the runtime-check.  */
   name = gfc_build_cstring_const (intr_name);
@@ -782,7 +909,7 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
 {
   tree arg, type, res, tmp, frexp;
 
-  frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP,
+  frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
                                       expr->value.function.actual->expr->ts.kind);
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
@@ -796,6 +923,399 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
   se->expr = fold_convert (type, res);
 }
 
+
+/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
+   AR_FULL, suitable for the scalarizer.  */
+
+static gfc_ss *
+walk_coarray (gfc_expr *e)
+{
+  gfc_ss *ss;
+
+  gcc_assert (gfc_get_corank (e) > 0);
+
+  ss = gfc_walk_expr (e);
+
+  /* Fix scalar coarray.  */
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_ref *ref;
+
+      ref = e->ref;
+      while (ref)
+       {
+         if (ref->type == REF_ARRAY
+             && ref->u.ar.codimen > 0)
+           break;
+
+         ref = ref->next;
+       }
+
+      gcc_assert (ref != NULL);
+      if (ref->u.ar.type == AR_ELEMENT)
+       ref->u.ar.type = AR_SECTION;
+      ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
+    }
+
+  return ss;
+}
+
+
+static void
+trans_this_image (gfc_se * se, gfc_expr *expr)
+{
+  stmtblock_t loop;
+  tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
+       lbound, ubound, extent, ml;
+  gfc_se argse;
+  gfc_ss *ss;
+  int rank, corank;
+
+  /* The case -fcoarray=single is handled elsewhere.  */
+  gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
+
+  gfc_init_coarray_decl (false);
+
+  /* Argument-free version: THIS_IMAGE().  */
+  if (expr->value.function.actual->expr == NULL)
+    {
+      se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
+                              gfort_gvar_caf_this_image);
+      return;
+    }
+
+  /* Coarray-argument version: THIS_IMAGE(coarray [, dim]).  */
+
+  type = gfc_get_int_type (gfc_default_integer_kind);
+  corank = gfc_get_corank (expr->value.function.actual->expr);
+  rank = expr->value.function.actual->expr->rank;
+
+  /* Obtain the descriptor of the COARRAY.  */
+  gfc_init_se (&argse, NULL);
+  ss = walk_coarray (expr->value.function.actual->expr);
+  gcc_assert (ss != gfc_ss_terminator);
+  argse.want_coarray = 1;
+  gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  if (se->ss)
+    {
+      /* Create an implicit second parameter from the loop variable.  */
+      gcc_assert (!expr->value.function.actual->next->expr);
+      gcc_assert (corank > 0);
+      gcc_assert (se->loop->dimen == 1);
+      gcc_assert (se->ss->info->expr == expr);
+
+      dim_arg = se->loop->loopvar[0];
+      dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
+                                gfc_array_index_type, dim_arg,
+                                build_int_cst (TREE_TYPE (dim_arg), 1));
+      gfc_advance_se_ss_chain (se);
+    }
+  else
+    {
+      /* Use the passed DIM= argument.  */
+      gcc_assert (expr->value.function.actual->next->expr);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
+                         gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      dim_arg = argse.expr;
+
+      if (INTEGER_CST_P (dim_arg))
+       {
+         int hi, co_dim;
+
+         hi = TREE_INT_CST_HIGH (dim_arg);
+         co_dim = TREE_INT_CST_LOW (dim_arg);
+         if (hi || co_dim < 1
+             || co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+           gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+                      "dimension index", expr->value.function.isym->name,
+                      &expr->where);
+       }
+     else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+       {
+         dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
+         cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+                                 dim_arg,
+                                 build_int_cst (TREE_TYPE (dim_arg), 1));
+         tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
+         tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                                dim_arg, tmp);
+         cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+                                 boolean_type_node, cond, tmp);
+         gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+                                  gfc_msg_fault);
+       }
+    }
+
+  /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
+     one always has a dim_arg argument.
+
+     m = this_image() - 1
+     if (corank == 1)
+       {
+        sub(1) = m + lcobound(corank)
+        return;
+       }
+     i = rank
+     min_var = min (rank + corank - 2, rank + dim_arg - 1)
+     for (;;)
+       {
+        extent = gfc_extent(i)
+        ml = m
+        m  = m/extent
+        if (i >= min_var) 
+          goto exit_label
+        i++
+       }
+     exit_label:
+     sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
+                                      : m + lcobound(corank)
+  */
+
+  /* this_image () - 1.  */
+  tmp = fold_convert (type, gfort_gvar_caf_this_image);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
+                      build_int_cst (type, 1));
+  if (corank == 1)
+    {
+      /* sub(1) = m + lcobound(corank).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc,
+                       build_int_cst (TREE_TYPE (gfc_array_index_type),
+                                      corank+rank-1));
+      lbound = fold_convert (type, lbound);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
+
+      se->expr = tmp;
+      return;
+    }
+
+  m = gfc_create_var (type, NULL); 
+  ml = gfc_create_var (type, NULL); 
+  loop_var = gfc_create_var (integer_type_node, NULL); 
+  min_var = gfc_create_var (integer_type_node, NULL); 
+
+  /* m = this_image () - 1.  */
+  gfc_add_modify (&se->pre, m, tmp);
+
+  /* min_var = min (rank + corank-2, rank + dim_arg - 1).  */
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+                        fold_convert (integer_type_node, dim_arg),
+                        build_int_cst (integer_type_node, rank - 1));
+  tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
+                        build_int_cst (integer_type_node, rank + corank - 2),
+                        tmp);
+  gfc_add_modify (&se->pre, min_var, tmp);
+
+  /* i = rank.  */
+  tmp = build_int_cst (integer_type_node, rank);
+  gfc_add_modify (&se->pre, loop_var, tmp);
+
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  TREE_USED (exit_label) = 1;
+
+  /* Loop body.  */
+  gfc_init_block (&loop);
+
+  /* ml = m.  */
+  gfc_add_modify (&loop, ml, m);
+
+  /* extent = ...  */
+  lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
+  ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
+  extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+  extent = fold_convert (type, extent);
+
+  /* m = m/extent.  */
+  gfc_add_modify (&loop, m, 
+                 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
+                         m, extent));
+
+  /* Exit condition:  if (i >= min_var) goto exit_label.  */
+  cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
+                 min_var);
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+                         build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&loop, tmp);
+
+  /* Increment loop variable: i++.  */
+  gfc_add_modify (&loop, loop_var,
+                  fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+                                  loop_var,
+                                  build_int_cst (integer_type_node, 1)));
+
+  /* Making the loop... actually loop!  */
+  tmp = gfc_finish_block (&loop);
+  tmp = build1_v (LOOP_EXPR, tmp);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* The exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /*  sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
+                                     : m + lcobound(corank) */
+
+  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
+                         build_int_cst (TREE_TYPE (dim_arg), corank));
+
+  lbound = gfc_conv_descriptor_lbound_get (desc,
+               fold_build2_loc (input_location, PLUS_EXPR,
+                                gfc_array_index_type, dim_arg,
+                                build_int_cst (TREE_TYPE (dim_arg), rank-1)));
+  lbound = fold_convert (type, lbound);
+
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
+                        fold_build2_loc (input_location, MULT_EXPR, type,
+                                         m, extent));
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
+
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
+                             fold_build2_loc (input_location, PLUS_EXPR, type,
+                                              m, lbound));
+}
+
+
+static void
+trans_image_index (gfc_se * se, gfc_expr *expr)
+{
+  tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
+       tmp, invalid_bound;
+  gfc_se argse, subse;
+  gfc_ss *ss, *subss;
+  int rank, corank, codim;
+
+  type = gfc_get_int_type (gfc_default_integer_kind);
+  corank = gfc_get_corank (expr->value.function.actual->expr);
+  rank = expr->value.function.actual->expr->rank;
+
+  /* Obtain the descriptor of the COARRAY.  */
+  gfc_init_se (&argse, NULL);
+  ss = walk_coarray (expr->value.function.actual->expr);
+  gcc_assert (ss != gfc_ss_terminator);
+  argse.want_coarray = 1;
+  gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  /* Obtain a handle to the SUB argument.  */
+  gfc_init_se (&subse, NULL);
+  subss = gfc_walk_expr (expr->value.function.actual->next->expr);
+  gcc_assert (subss != gfc_ss_terminator);
+  gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
+                           subss);
+  gfc_add_block_to_block (&se->pre, &subse.pre);
+  gfc_add_block_to_block (&se->post, &subse.post);
+  subdesc = build_fold_indirect_ref_loc (input_location,
+                       gfc_conv_descriptor_data_get (subse.expr));
+
+  /* Fortran 2008 does not require that the values remain in the cobounds,
+     thus we need explicitly check this - and return 0 if they are exceeded.  */
+
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+  tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
+  invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+                                fold_convert (gfc_array_index_type, tmp),
+                                lbound);
+
+  for (codim = corank + rank - 2; codim >= rank; codim--)
+    {
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+      tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+      cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+                             fold_convert (gfc_array_index_type, tmp),
+                             lbound);
+      invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+                                      boolean_type_node, invalid_bound, cond);
+      cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                             fold_convert (gfc_array_index_type, tmp),
+                             ubound);
+      invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+                                      boolean_type_node, invalid_bound, cond);
+    }
+
+  invalid_bound = gfc_unlikely (invalid_bound);
+
+
+  /* See Fortran 2008, C.10 for the following algorithm.  */
+
+  /* coindex = sub(corank) - lcobound(n).  */
+  coindex = fold_convert (gfc_array_index_type,
+                         gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
+                                              NULL));
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+  coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                            fold_convert (gfc_array_index_type, coindex),
+                            lbound);
+
+  for (codim = corank + rank - 2; codim >= rank; codim--)
+    {
+      tree extent, ubound;
+
+      /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+      extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+
+      /* coindex *= extent.  */
+      coindex = fold_build2_loc (input_location, MULT_EXPR,
+                                gfc_array_index_type, coindex, extent);
+
+      /* coindex += sub(codim).  */
+      tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+      coindex = fold_build2_loc (input_location, PLUS_EXPR,
+                                gfc_array_index_type, coindex,
+                                fold_convert (gfc_array_index_type, tmp));
+
+      /* coindex -= lbound(codim).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      coindex = fold_build2_loc (input_location, MINUS_EXPR,
+                                gfc_array_index_type, coindex, lbound);
+    }
+
+  coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
+                            fold_convert(type, coindex),
+                            build_int_cst (type, 1));
+
+  /* Return 0 if "coindex" exceeds num_images().  */
+
+  if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+    num_images = build_int_cst (type, 1);
+  else
+    {
+      gfc_init_coarray_decl (false);
+      num_images = fold_convert (type, gfort_gvar_caf_num_images);
+    }
+
+  tmp = gfc_create_var (type, NULL);
+  gfc_add_modify (&se->pre, tmp, coindex);
+
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
+                         num_images);
+  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+                         cond,
+                         fold_convert (boolean_type_node, invalid_bound));
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+                             build_int_cst (type, 0), tmp);
+}
+
+
+static void
+trans_num_images (gfc_se * se)
+{
+  gfc_init_coarray_decl (false);
+  se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
+                          gfort_gvar_caf_num_images);
+}
+
+
 /* Evaluate a single upper or lower bound.  */
 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 
@@ -823,23 +1343,25 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
       /* Create an implicit second parameter from the loop variable.  */
       gcc_assert (!arg2->expr);
       gcc_assert (se->loop->dimen == 1);
-      gcc_assert (se->ss->expr == expr);
+      gcc_assert (se->ss->info->expr == expr);
       gfc_advance_se_ss_chain (se);
       bound = se->loop->loopvar[0];
-      bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
-                          se->loop->from[0]);
+      bound = fold_build2_loc (input_location, MINUS_EXPR,
+                              gfc_array_index_type, bound,
+                              se->loop->from[0]);
     }
   else
     {
       /* use the passed argument.  */
-      gcc_assert (arg->next->expr);
+      gcc_assert (arg2->expr);
       gfc_init_se (&argse, NULL);
-      gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
+      gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
       gfc_add_block_to_block (&se->pre, &argse.pre);
       bound = argse.expr;
       /* Convert from one based to zero based.  */
-      bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
-                          gfc_index_one_node);
+      bound = fold_build2_loc (input_location, MINUS_EXPR,
+                              gfc_array_index_type, bound,
+                              gfc_index_one_node);
     }
 
   /* TODO: don't re-evaluate the descriptor on each iteration.  */
@@ -869,11 +1391,13 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
         {
           bound = gfc_evaluate_now (bound, &se->pre);
-          cond = fold_build2 (LT_EXPR, boolean_type_node,
-                             bound, build_int_cst (TREE_TYPE (bound), 0));
+          cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+                                 bound, build_int_cst (TREE_TYPE (bound), 0));
           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);
+          tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+                                bound, tmp);
+          cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+                                 boolean_type_node, cond, tmp);
           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
                                   gfc_msg_fault);
         }
@@ -909,53 +1433,63 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
     {
       tree stride = gfc_conv_descriptor_stride_get (desc, bound);
 
-      cond1 = fold_build2 (GE_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);
+      cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+                              ubound, lbound);
+      cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+                              stride, gfc_index_zero_node);
+      cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+                              boolean_type_node, cond3, cond1);
+      cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+                              stride, gfc_index_zero_node);
 
       if (upper)
        {
          tree cond5;
-         cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
-
-         cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
-         cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
-
-         cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
-
-         se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
-                                 ubound, gfc_index_zero_node);
+         cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+                                 boolean_type_node, cond3, cond4);
+         cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                                  gfc_index_one_node, lbound);
+         cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+                                  boolean_type_node, cond4, cond5);
+
+         cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+                                 boolean_type_node, cond, cond5);
+
+         se->expr = fold_build3_loc (input_location, 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));
+           cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                                   bound, build_int_cst (TREE_TYPE (bound),
+                                                         arg->expr->rank - 1));
          else
            cond = boolean_false_node;
 
-         cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
-         cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
+         cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+                                  boolean_type_node, cond3, cond4);
+         cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+                                 boolean_type_node, cond, cond1);
 
-         se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
-                                 lbound, gfc_index_one_node);
+         se->expr = fold_build3_loc (input_location, COND_EXPR,
+                                     gfc_array_index_type, cond,
+                                     lbound, gfc_index_one_node);
        }
     }
   else
     {
       if (upper)
         {
-         size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
-         se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+         size = fold_build2_loc (input_location, MINUS_EXPR,
+                                 gfc_array_index_type, ubound, lbound);
+         se->expr = fold_build2_loc (input_location, PLUS_EXPR,
+                                     gfc_array_index_type, size,
                                  gfc_index_one_node);
-         se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
-                                 gfc_index_zero_node);
+         se->expr = fold_build2_loc (input_location, MAX_EXPR,
+                                     gfc_array_index_type, se->expr,
+                                     gfc_index_zero_node);
        }
       else
        se->expr = gfc_index_one_node;
@@ -967,6 +1501,168 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
 
 static void
+conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
+{
+  gfc_actual_arglist *arg;
+  gfc_actual_arglist *arg2;
+  gfc_se argse;
+  gfc_ss *ss;
+  tree bound, resbound, resbound2, desc, cond, tmp;
+  tree type;
+  int corank;
+
+  gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
+             || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
+             || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
+
+  arg = expr->value.function.actual;
+  arg2 = arg->next;
+
+  gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
+  corank = gfc_get_corank (arg->expr);
+
+  ss = walk_coarray (arg->expr);
+  gcc_assert (ss != gfc_ss_terminator);
+  gfc_init_se (&argse, NULL);
+  argse.want_coarray = 1;
+
+  gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  if (se->ss)
+    {
+      /* Create an implicit second parameter from the loop variable.  */
+      gcc_assert (!arg2->expr);
+      gcc_assert (corank > 0);
+      gcc_assert (se->loop->dimen == 1);
+      gcc_assert (se->ss->info->expr == expr);
+
+      bound = se->loop->loopvar[0];
+      bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+                              bound, gfc_rank_cst[arg->expr->rank]);
+      gfc_advance_se_ss_chain (se);
+    }
+  else
+    {
+      /* use the passed argument.  */
+      gcc_assert (arg2->expr);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      bound = argse.expr;
+
+      if (INTEGER_CST_P (bound))
+       {
+         int hi, low;
+
+         hi = TREE_INT_CST_HIGH (bound);
+         low = TREE_INT_CST_LOW (bound);
+         if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+           gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+                      "dimension index", expr->value.function.isym->name,
+                      &expr->where);
+       }
+      else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+        {
+         bound = gfc_evaluate_now (bound, &se->pre);
+         cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+                                 bound, build_int_cst (TREE_TYPE (bound), 1));
+         tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
+         tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                                bound, tmp);
+         cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+                                 boolean_type_node, cond, tmp);
+         gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+                                  gfc_msg_fault);
+       }
+
+
+      /* Substract 1 to get to zero based and add dimensions.  */
+      switch (arg->expr->rank)
+       {
+       case 0:
+         bound = fold_build2_loc (input_location, MINUS_EXPR,
+                                  gfc_array_index_type, bound,
+                                  gfc_index_one_node);
+       case 1:
+         break;
+       default:
+         bound = fold_build2_loc (input_location, PLUS_EXPR,
+                                  gfc_array_index_type, bound,
+                                  gfc_rank_cst[arg->expr->rank - 1]);
+       }
+    }
+
+  resbound = gfc_conv_descriptor_lbound_get (desc, bound);
+
+  /* Handle UCOBOUND with special handling of the last codimension.  */
+  if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
+    {
+      /* Last codimension: For -fcoarray=single just return
+        the lcobound - otherwise add
+          ceiling (real (num_images ()) / real (size)) - 1
+        = (num_images () + size - 1) / size - 1
+        = (num_images - 1) / size(),
+         where size is the product of the extent of all but the last
+        codimension.  */
+
+      if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
+       {
+          tree cosize;
+
+         gfc_init_coarray_decl (false);
+         cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
+
+         tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                                gfc_array_index_type,
+                                fold_convert (gfc_array_index_type,
+                                              gfort_gvar_caf_num_images),
+                                build_int_cst (gfc_array_index_type, 1));
+         tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+                                gfc_array_index_type, tmp,
+                                fold_convert (gfc_array_index_type, cosize));
+         resbound = fold_build2_loc (input_location, PLUS_EXPR,
+                                     gfc_array_index_type, resbound, tmp);
+       }
+      else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+       {
+         /* ubound = lbound + num_images() - 1.  */
+         gfc_init_coarray_decl (false);
+         tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                                gfc_array_index_type,
+                                fold_convert (gfc_array_index_type,
+                                              gfort_gvar_caf_num_images),
+                                build_int_cst (gfc_array_index_type, 1));
+         resbound = fold_build2_loc (input_location, PLUS_EXPR,
+                                     gfc_array_index_type, resbound, tmp);
+       }
+
+      if (corank > 1)
+       {
+         cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                                 bound,
+                                 build_int_cst (TREE_TYPE (bound),
+                                                arg->expr->rank + corank - 1));
+
+         resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
+         se->expr = fold_build3_loc (input_location, COND_EXPR,
+                                     gfc_array_index_type, cond,
+                                     resbound, resbound2);
+       }
+      else
+       se->expr = resbound;
+    }
+  else
+    se->expr = resbound;
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = convert (type, se->expr);
+}
+
+
+static void
 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 {
   tree arg, cabs;
@@ -977,11 +1673,12 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
     {
     case BT_INTEGER:
     case BT_REAL:
-      se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
+      se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
+                                 arg);
       break;
 
     case BT_COMPLEX:
-      cabs = builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
+      cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
       se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
       break;
 
@@ -1012,14 +1709,14 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
     imag = convert (TREE_TYPE (type), args[1]);
   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
     {
-      imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
-                         args[0]);
+      imag = fold_build1_loc (input_location, IMAGPART_EXPR,
+                             TREE_TYPE (TREE_TYPE (args[0])), args[0]);
       imag = convert (TREE_TYPE (type), imag);
     }
   else
     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
 
-  se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
+  se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
 }
 
 /* Remainder function MOD(A, P) = A - INT(A / P) * P
@@ -1048,15 +1745,17 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
       type = TREE_TYPE (args[0]);
 
       if (modulo)
-       se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
+       se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
+                                  args[0], args[1]);
       else
-       se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
+       se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
+                                  args[0], args[1]);
       break;
 
     case BT_REAL:
       fmod = NULL_TREE;
       /* Check if we have a builtin fmod.  */
-      fmod = builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
+      fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
 
       /* Use it if it exists.  */
       if (fmod != NULL_TREE)
@@ -1085,21 +1784,26 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
        {
          tree zero = gfc_build_const (type, integer_zero_node);
          tmp = gfc_evaluate_now (se->expr, &se->pre);
-         test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
-         test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
-         test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
-         test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
-         test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
+         test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+                                 args[0], zero);
+         test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+                                  args[1], zero);
+         test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
+                                  boolean_type_node, test, test2);
+         test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                                 tmp, zero);
+         test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+                                 boolean_type_node, test, test2);
          test = gfc_evaluate_now (test, &se->pre);
-         se->expr = fold_build3 (COND_EXPR, type, test,
-                                 fold_build2 (PLUS_EXPR, type, tmp, args[1]),
-                                 tmp);
+         se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
+                                 fold_build2_loc (input_location, PLUS_EXPR,
+                                                  type, tmp, args[1]), tmp);
          return;
        }
 
       /* If we do not have a built_in fmod, the calculation is going to
         have to be done longhand.  */
-      tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
+      tmp = fold_build2_loc (input_location, RDIV_EXPR, type, args[0], args[1]);
 
       /* Test if the value is too large to handle sensibly.  */
       gfc_set_model_kind (expr->ts.kind);
@@ -1113,12 +1817,15 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
        }
       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
-      test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
+      test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+                              tmp, test);
 
       mpfr_neg (huge, huge, GFC_RND_MODE);
       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
-      test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
-      test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
+      test = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
+                             test);
+      test2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+                              boolean_type_node, test, test2);
 
       itype = gfc_get_int_type (ikind);
       if (modulo)
@@ -1126,9 +1833,11 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
       else
        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
       tmp = convert (type, tmp);
-      tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
-      tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
-      se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
+      tmp = fold_build3_loc (input_location, COND_EXPR, type, test2, tmp,
+                            args[0]);
+      tmp = fold_build2_loc (input_location, MULT_EXPR, type, tmp, args[1]);
+      se->expr = fold_build2_loc (input_location, MINUS_EXPR, type, args[0],
+                                 tmp);
       mpfr_clear (huge);
       break;
 
@@ -1137,6 +1846,62 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
     }
 }
 
+/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
+   DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
+   where the right shifts are logical (i.e. 0's are shifted in).
+   Because SHIFT_EXPR's want shifts strictly smaller than the integral
+   type width, we have to special-case both S == 0 and S == BITSIZE(J):
+     DSHIFTL(I,J,0) = I
+     DSHIFTL(I,J,BITSIZE) = J
+     DSHIFTR(I,J,0) = J
+     DSHIFTR(I,J,BITSIZE) = I.  */
+
+static void
+gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
+{
+  tree type, utype, stype, arg1, arg2, shift, res, left, right;
+  tree args[3], cond, tmp;
+  int bitsize;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 3);
+
+  gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
+  type = TREE_TYPE (args[0]);
+  bitsize = TYPE_PRECISION (type);
+  utype = unsigned_type_for (type);
+  stype = TREE_TYPE (args[2]);
+
+  arg1 = gfc_evaluate_now (args[0], &se->pre);
+  arg2 = gfc_evaluate_now (args[1], &se->pre);
+  shift = gfc_evaluate_now (args[2], &se->pre);
+
+  /* The generic case.  */
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
+                        build_int_cst (stype, bitsize), shift);
+  left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+                         arg1, dshiftl ? shift : tmp);
+
+  right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
+                          fold_convert (utype, arg2), dshiftl ? tmp : shift);
+  right = fold_convert (type, right);
+
+  res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
+
+  /* Special cases.  */
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
+                         build_int_cst (stype, 0));
+  res = fold_build3_loc (input_location, COND_EXPR, type, cond,
+                        dshiftl ? arg1 : arg2, res);
+
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
+                         build_int_cst (stype, bitsize));
+  res = fold_build3_loc (input_location, COND_EXPR, type, cond,
+                        dshiftl ? arg2 : arg1, res);
+
+  se->expr = res;
+}
+
+
 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
 
 static void
@@ -1151,12 +1916,12 @@ gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
   gfc_conv_intrinsic_function_args (se, expr, args, 2);
   type = TREE_TYPE (args[0]);
 
-  val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
+  val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
   val = gfc_evaluate_now (val, &se->pre);
 
   zero = gfc_build_const (type, integer_zero_node);
-  tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
-  se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
+  tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
 }
 
 
@@ -1178,8 +1943,8 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
     {
       tree abs;
 
-      tmp = builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
-      abs = builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
+      tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
+      abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
 
       /* We explicitly have to ignore the minus sign. We do so by using
         result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1).  */
@@ -1188,10 +1953,14 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
        {
          tree cond, zero;
          zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
-         cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
-         se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
-                                 build_call_expr (abs, 1, args[0]),
-                                 build_call_expr (tmp, 2, args[0], args[1]));
+         cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                                 args[1], zero);
+         se->expr = fold_build3_loc (input_location, COND_EXPR,
+                                 TREE_TYPE (args[0]), cond,
+                                 build_call_expr_loc (input_location, abs, 1,
+                                                      args[0]),
+                                 build_call_expr_loc (input_location, tmp, 2,
+                                                      args[0], args[1]));
        }
       else
         se->expr = build_call_expr_loc (input_location, tmp, 2,
@@ -1208,16 +1977,16 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 
   /* 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, args[0], args[1]);
-  tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
-                    build_int_cst (type, TYPE_PRECISION (type) - 1));
+  tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
+  tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
+                        build_int_cst (type, TYPE_PRECISION (type) - 1));
   tmp = gfc_evaluate_now (tmp, &se->pre);
 
   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
      is all ones (i.e. -1).  */
-  se->expr = fold_build2 (BIT_XOR_EXPR, type,
-                         fold_build2 (PLUS_EXPR, type, args[0], tmp),
-                         tmp);
+  se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
+                             fold_build2_loc (input_location, PLUS_EXPR,
+                                              type, args[0], tmp), tmp);
 }
 
 
@@ -1249,7 +2018,8 @@ gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
   type = gfc_typenode_for_spec (&expr->ts);
   args[0] = convert (type, args[0]);
   args[1] = convert (type, args[1]);
-  se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
+  se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
+                             args[1]);
 }
 
 
@@ -1269,10 +2039,10 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
   type = gfc_get_char_type (expr->ts.kind);
   var = gfc_create_var (type, "char");
 
-  arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
+  arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
   gfc_add_modify (&se->pre, var, arg[0]);
   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
-  se->string_length = integer_one_node;
+  se->string_length = build_int_cst (gfc_charlen_type_node, 1);
 }
 
 
@@ -1291,7 +2061,7 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
   args = XALLOCAVEC (tree, num_args);
 
   var = gfc_create_var (pchar_type_node, "pstr");
-  len = gfc_create_var (gfc_get_int_type (8), "len");
+  len = gfc_create_var (gfc_charlen_type_node, "len");
 
   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
   args[0] = gfc_build_addr_expr (NULL_TREE, var);
@@ -1304,8 +2074,8 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
-  cond = fold_build2 (GT_EXPR, boolean_type_node,
-                     len, build_int_cst (TREE_TYPE (len), 0));
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                         len, build_int_cst (TREE_TYPE (len), 0));
   tmp = gfc_call_free (var);
   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
   gfc_add_expr_to_block (&se->post, tmp);
@@ -1343,8 +2113,8 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
-  cond = fold_build2 (GT_EXPR, boolean_type_node,
-                     len, build_int_cst (TREE_TYPE (len), 0));
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                         len, build_int_cst (TREE_TYPE (len), 0));
   tmp = gfc_call_free (var);
   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
   gfc_add_expr_to_block (&se->post, tmp);
@@ -1384,8 +2154,8 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
-  cond = fold_build2 (GT_EXPR, boolean_type_node,
-                     len, build_int_cst (TREE_TYPE (len), 0));
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                         len, build_int_cst (TREE_TYPE (len), 0));
   tmp = gfc_call_free (var);
   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
   gfc_add_expr_to_block (&se->post, tmp);
@@ -1462,7 +2232,8 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
 
       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
 
-      tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
+      tmp = fold_build2_loc (input_location, op, boolean_type_node,
+                            convert (type, val), mvar);
 
       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
         __builtin_isnan might be made dependent on that module being loaded,
@@ -1470,9 +2241,11 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
       if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
        {
          isnan = build_call_expr_loc (input_location,
-                                  built_in_decls[BUILT_IN_ISNAN], 1, mvar);
-         tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
-                            fold_convert (boolean_type_node, isnan));
+                                      builtin_decl_explicit (BUILT_IN_ISNAN),
+                                      1, mvar);
+         tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+                                boolean_type_node, tmp,
+                                fold_convert (boolean_type_node, isnan));
        }
       tmp = build3_v (COND_EXPR, tmp, thencase,
                      build_empty_stmt (input_location));
@@ -1506,8 +2279,8 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
   args[0] = gfc_build_addr_expr (NULL_TREE, len);
   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
-  args[2] = build_int_cst (NULL_TREE, op);
-  args[3] = build_int_cst (NULL_TREE, nargs / 2);
+  args[2] = build_int_cst (integer_type_node, op);
+  args[3] = build_int_cst (integer_type_node, nargs / 2);
 
   if (expr->ts.kind == 1)
     function = gfor_fndecl_string_minmax;
@@ -1524,8 +2297,8 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
-  cond = fold_build2 (GT_EXPR, boolean_type_node,
-                     len, build_int_cst (TREE_TYPE (len), 0));
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                         len, build_int_cst (TREE_TYPE (len), 0));
   tmp = gfc_call_free (var);
   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
   gfc_add_expr_to_block (&se->post, tmp);
@@ -1562,7 +2335,8 @@ gfc_get_symbol_for_expr (gfc_expr * expr)
       sym->as->rank = expr->rank;
     }
 
-  /* TODO: proper argument lists for external intrinsics.  */
+  gfc_copy_formal_args_intr (sym, expr->value.function.isym);
+
   return sym;
 }
 
@@ -1573,7 +2347,7 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
   gfc_symbol *sym;
   VEC(tree,gc) *append_args;
 
-  gcc_assert (!se->ss || se->ss->expr == expr);
+  gcc_assert (!se->ss || se->ss->info->expr == expr);
 
   if (se->ss)
     gcc_assert (expr->rank > 0);
@@ -1630,7 +2404,7 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
 
   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
                          append_args);
-  gfc_free (sym);
+  gfc_free_symbol (sym);
 }
 
 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
@@ -1722,8 +2496,8 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
   gfc_conv_expr_val (&arrayse, actual->expr);
 
   gfc_add_block_to_block (&body, &arrayse.pre);
-  tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
-                    build_int_cst (TREE_TYPE (arrayse.expr), 0));
+  tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
+                        build_int_cst (TREE_TYPE (arrayse.expr), 0));
   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
   gfc_add_expr_to_block (&body, tmp);
   gfc_add_block_to_block (&body, &arrayse.post);
@@ -1783,8 +2557,8 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
   /* Generate the loop body.  */
   gfc_start_scalarized_body (&loop, &body);
 
-  tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
-                    resvar, build_int_cst (TREE_TYPE (resvar), 1));
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
+                        resvar, build_int_cst (TREE_TYPE (resvar), 1));
   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
 
   gfc_init_se (&arrayse, NULL);
@@ -1807,79 +2581,134 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
   se->expr = resvar;
 }
 
+
+/* Update given gfc_se to have ss component pointing to the nested gfc_ss
+   struct and return the corresponding loopinfo.  */
+
+static gfc_loopinfo *
+enter_nested_loop (gfc_se *se)
+{
+  se->ss = se->ss->nested_ss;
+  gcc_assert (se->ss == se->ss->loop->ss);
+
+  return se->ss->loop;
+}
+
+
 /* Inline implementation of the sum and product intrinsics.  */
 static void
-gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
+gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
+                         bool norm2)
 {
   tree resvar;
+  tree scale = NULL_TREE;
   tree type;
   stmtblock_t body;
   stmtblock_t block;
   tree tmp;
-  gfc_loopinfo loop;
-  gfc_actual_arglist *actual;
-  gfc_ss *arrayss;
-  gfc_ss *maskss;
+  gfc_loopinfo loop, *ploop;
+  gfc_actual_arglist *arg_array, *arg_mask;
+  gfc_ss *arrayss = NULL;
+  gfc_ss *maskss = NULL;
   gfc_se arrayse;
   gfc_se maskse;
+  gfc_se *parent_se;
   gfc_expr *arrayexpr;
   gfc_expr *maskexpr;
 
-  if (se->ss)
+  if (expr->rank > 0)
     {
-      gfc_conv_intrinsic_funcall (se, expr);
-      return;
+      gcc_assert (gfc_inline_intrinsic_function_p (expr));
+      parent_se = se;
     }
+  else
+    parent_se = NULL;
 
   type = gfc_typenode_for_spec (&expr->ts);
   /* Initialize the result.  */
   resvar = gfc_create_var (type, "val");
-  if (op == PLUS_EXPR)
+  if (norm2)
+    {
+      /* result = 0.0;
+        scale = 1.0.  */
+      scale = gfc_create_var (type, "scale");
+      gfc_add_modify (&se->pre, scale,
+                     gfc_build_const (type, integer_one_node));
+      tmp = gfc_build_const (type, integer_zero_node);
+    }
+  else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
     tmp = gfc_build_const (type, integer_zero_node);
+  else if (op == NE_EXPR)
+    /* PARITY.  */
+    tmp = convert (type, boolean_false_node);
+  else if (op == BIT_AND_EXPR)
+    tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
+                                                 type, integer_one_node));
   else
     tmp = gfc_build_const (type, integer_one_node);
 
   gfc_add_modify (&se->pre, resvar, tmp);
 
-  /* Walk the arguments.  */
-  actual = expr->value.function.actual;
-  arrayexpr = actual->expr;
-  arrayss = gfc_walk_expr (arrayexpr);
-  gcc_assert (arrayss != gfc_ss_terminator);
+  arg_array = expr->value.function.actual;
 
-  actual = actual->next->next;
-  gcc_assert (actual);
-  maskexpr = actual->expr;
-  if (maskexpr && maskexpr->rank != 0)
+  arrayexpr = arg_array->expr;
+
+  if (op == NE_EXPR || norm2)
+    /* PARITY and NORM2.  */
+    maskexpr = NULL;
+  else
     {
-      maskss = gfc_walk_expr (maskexpr);
-      gcc_assert (maskss != gfc_ss_terminator);
+      arg_mask  = arg_array->next->next;
+      gcc_assert (arg_mask != NULL);
+      maskexpr = arg_mask->expr;
     }
-  else
-    maskss = NULL;
 
-  /* Initialize the scalarizer.  */
-  gfc_init_loopinfo (&loop);
-  gfc_add_ss_to_loop (&loop, arrayss);
-  if (maskss)
-    gfc_add_ss_to_loop (&loop, maskss);
+  if (expr->rank == 0)
+    {
+      /* Walk the arguments.  */
+      arrayss = gfc_walk_expr (arrayexpr);
+      gcc_assert (arrayss != gfc_ss_terminator);
 
-  /* Initialize the loop.  */
-  gfc_conv_ss_startstride (&loop);
-  gfc_conv_loop_setup (&loop, &expr->where);
+      if (maskexpr && maskexpr->rank > 0)
+       {
+         maskss = gfc_walk_expr (maskexpr);
+         gcc_assert (maskss != gfc_ss_terminator);
+       }
+      else
+       maskss = NULL;
+
+      /* Initialize the scalarizer.  */
+      gfc_init_loopinfo (&loop);
+      gfc_add_ss_to_loop (&loop, arrayss);
+      if (maskexpr && maskexpr->rank > 0)
+       gfc_add_ss_to_loop (&loop, maskss);
+
+      /* Initialize the loop.  */
+      gfc_conv_ss_startstride (&loop);
+      gfc_conv_loop_setup (&loop, &expr->where);
+
+      gfc_mark_ss_chain_used (arrayss, 1);
+      if (maskexpr && maskexpr->rank > 0)
+       gfc_mark_ss_chain_used (maskss, 1);
+
+      ploop = &loop;
+    }
+  else
+    /* All the work has been done in the parent loops.  */
+    ploop = enter_nested_loop (se);
+
+  gcc_assert (ploop);
 
-  gfc_mark_ss_chain_used (arrayss, 1);
-  if (maskss)
-    gfc_mark_ss_chain_used (maskss, 1);
   /* Generate the loop body.  */
-  gfc_start_scalarized_body (&loop, &body);
+  gfc_start_scalarized_body (ploop, &body);
 
   /* If we have a mask, only add this element if the mask is set.  */
-  if (maskss)
+  if (maskexpr && maskexpr->rank > 0)
     {
-      gfc_init_se (&maskse, NULL);
-      gfc_copy_loopinfo_to_se (&maskse, &loop);
-      maskse.ss = maskss;
+      gfc_init_se (&maskse, parent_se);
+      gfc_copy_loopinfo_to_se (&maskse, ploop);
+      if (expr->rank == 0)
+       maskse.ss = maskss;
       gfc_conv_expr_val (&maskse, maskexpr);
       gfc_add_block_to_block (&body, &maskse.pre);
 
@@ -1889,21 +2718,89 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
     gfc_init_block (&block);
 
   /* Do the actual summation/product.  */
-  gfc_init_se (&arrayse, NULL);
-  gfc_copy_loopinfo_to_se (&arrayse, &loop);
-  arrayse.ss = arrayss;
+  gfc_init_se (&arrayse, parent_se);
+  gfc_copy_loopinfo_to_se (&arrayse, ploop);
+  if (expr->rank == 0)
+    arrayse.ss = arrayss;
   gfc_conv_expr_val (&arrayse, arrayexpr);
   gfc_add_block_to_block (&block, &arrayse.pre);
 
-  tmp = fold_build2 (op, type, resvar, arrayse.expr);
-  gfc_add_modify (&block, resvar, tmp);
+  if (norm2)
+    {
+      /* if (x(i) != 0.0)
+          {
+            absX = abs(x(i))
+            if (absX > scale)
+              {
+                 val = scale/absX;
+                result = 1.0 + result * val * val;
+                scale = absX;
+              }
+            else
+              {
+                 val = absX/scale;
+                result += val * val;
+              }
+          }  */
+      tree res1, res2, cond, absX, val;
+      stmtblock_t ifblock1, ifblock2, ifblock3;
+
+      gfc_init_block (&ifblock1);
+
+      absX = gfc_create_var (type, "absX");
+      gfc_add_modify (&ifblock1, absX,
+                     fold_build1_loc (input_location, ABS_EXPR, type,
+                                      arrayse.expr));
+      val = gfc_create_var (type, "val");
+      gfc_add_expr_to_block (&ifblock1, val);
+
+      gfc_init_block (&ifblock2);
+      gfc_add_modify (&ifblock2, val,
+                     fold_build2_loc (input_location, RDIV_EXPR, type, scale,
+                                      absX));
+      res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); 
+      res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
+      res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
+                             gfc_build_const (type, integer_one_node));
+      gfc_add_modify (&ifblock2, resvar, res1);
+      gfc_add_modify (&ifblock2, scale, absX);
+      res1 = gfc_finish_block (&ifblock2); 
+
+      gfc_init_block (&ifblock3);
+      gfc_add_modify (&ifblock3, val,
+                     fold_build2_loc (input_location, RDIV_EXPR, type, absX,
+                                      scale));
+      res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); 
+      res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
+      gfc_add_modify (&ifblock3, resvar, res2);
+      res2 = gfc_finish_block (&ifblock3);
+
+      cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                             absX, scale);
+      tmp = build3_v (COND_EXPR, cond, res1, res2);
+      gfc_add_expr_to_block (&ifblock1, tmp);  
+      tmp = gfc_finish_block (&ifblock1);
+
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                             arrayse.expr,
+                             gfc_build_const (type, integer_zero_node));
+
+      tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);  
+    }
+  else
+    {
+      tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
+      gfc_add_modify (&block, resvar, tmp);
+    }
+
   gfc_add_block_to_block (&block, &arrayse.post);
 
-  if (maskss)
+  if (maskexpr && maskexpr->rank > 0)
     {
       /* We enclose the above in if (mask) {...} .  */
-      tmp = gfc_finish_block (&block);
 
+      tmp = gfc_finish_block (&block);
       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
                      build_empty_stmt (input_location));
     }
@@ -1911,30 +2808,53 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
     tmp = gfc_finish_block (&block);
   gfc_add_expr_to_block (&body, tmp);
 
-  gfc_trans_scalarizing_loops (&loop, &body);
+  gfc_trans_scalarizing_loops (ploop, &body);
 
   /* For a scalar mask, enclose the loop in an if statement.  */
-  if (maskexpr && maskss == NULL)
+  if (maskexpr && maskexpr->rank == 0)
     {
-      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);
+      gfc_add_block_to_block (&block, &ploop->pre);
+      gfc_add_block_to_block (&block, &ploop->post);
       tmp = gfc_finish_block (&block);
 
-      tmp = build3_v (COND_EXPR, maskse.expr, tmp,
-                     build_empty_stmt (input_location));
+      if (expr->rank > 0)
+       {
+         tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
+                         build_empty_stmt (input_location));
+         gfc_advance_se_ss_chain (se);
+       }
+      else
+       {
+         gcc_assert (expr->rank == 0);
+         gfc_init_se (&maskse, NULL);
+         gfc_conv_expr_val (&maskse, maskexpr);
+         tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+                         build_empty_stmt (input_location));
+       }
+
       gfc_add_expr_to_block (&block, tmp);
       gfc_add_block_to_block (&se->pre, &block);
+      gcc_assert (se->post.head == NULL);
     }
   else
     {
-      gfc_add_block_to_block (&se->pre, &loop.pre);
-      gfc_add_block_to_block (&se->pre, &loop.post);
+      gfc_add_block_to_block (&se->pre, &ploop->pre);
+      gfc_add_block_to_block (&se->pre, &ploop->post);
     }
 
-  gfc_cleanup_loop (&loop);
+  if (expr->rank == 0)
+    gfc_cleanup_loop (ploop);
+
+  if (norm2)
+    {
+      /* result = scale * sqrt(result).  */
+      tree sqrt;
+      sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
+      resvar = build_call_expr_loc (input_location,
+                                   sqrt, 1, resvar);
+      resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
+    }
 
   se->expr = resvar;
 }
@@ -2001,7 +2921,8 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
   arrayse1.ss = arrayss1;
   gfc_conv_expr_val (&arrayse1, arrayexpr1);
   if (expr->ts.type == BT_COMPLEX)
-    arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
+    arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
+                                    arrayse1.expr);
   gfc_add_block_to_block (&block, &arrayse1.pre);
 
   /* Make the tree expression for array2.  */
@@ -2014,13 +2935,15 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
   /* Do the actual product and sum.  */
   if (expr->ts.type == BT_LOGICAL)
     {
-      tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
-      tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
+      tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
+                            arrayse1.expr, arrayse2.expr);
+      tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
     }
   else
     {
-      tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
-      tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
+      tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
+                            arrayse2.expr);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
     }
   gfc_add_modify (&block, resvar, tmp);
 
@@ -2163,29 +3086,22 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
        {
          nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
          mpz_clear (asize);
-         nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
-                                 gfc_index_zero_node);
+         nonempty = fold_build2_loc (input_location, GT_EXPR,
+                                     boolean_type_node, nonempty,
+                                     gfc_index_zero_node);
        }
       maskss = NULL;
     }
 
   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
-  n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
   switch (arrayexpr->ts.type)
     {
     case BT_REAL:
-      if (HONOR_INFINITIES (DECL_MODE (limit)))
-       {
-         REAL_VALUE_TYPE real;
-         real_inf (&real);
-         tmp = build_real (TREE_TYPE (limit), real);
-       }
-      else
-       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
-                                    arrayexpr->ts.kind, 0);
+      tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
       break;
 
     case BT_INTEGER:
+      n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
                                  arrayexpr->ts.kind);
       break;
@@ -2199,10 +3115,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
      -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);
+    tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
-    tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
-                      build_int_cst (type, 1));
+    tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
+                          build_int_cst (type, 1));
 
   gfc_add_modify (&se->pre, limit, tmp);
 
@@ -2214,12 +3130,29 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
 
   /* Initialize the loop.  */
   gfc_conv_ss_startstride (&loop);
+
+  /* The code generated can have more than one loop in sequence (see the
+     comment at the function header).  This doesn't work well with the
+     scalarizer, which changes arrays' offset when the scalarization loops
+     are generated (see gfc_trans_preloop_setup).  Fortunately, {min,max}loc
+     are  currently inlined in the scalar case only (for which loop is of rank
+     one).  As there is no dependency to care about in that case, there is no
+     temporary, so that we can use the scalarizer temporary code to handle
+     multiple loops.  Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
+     with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
+     to restore offset.
+     TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
+     should eventually go away.  We could either create two loops properly,
+     or find another way to save/restore the array offsets between the two
+     loops (without conflicting with temporary management), or use a single
+     loop minmaxloc implementation.  See PR 31067.  */
+  loop.temp_dim = loop.dimen;
   gfc_conv_loop_setup (&loop, &expr->where);
 
   gcc_assert (loop.dimen == 1);
   if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
-    nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
-                           loop.to[0]);
+    nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+                               loop.from[0], loop.to[0]);
 
   lab1 = NULL;
   lab2 = NULL;
@@ -2230,9 +3163,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
      the inner loop.  */
   if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
     gfc_add_modify (&loop.pre, pos,
-                   fold_build3 (COND_EXPR, gfc_array_index_type,
-                                nonempty, gfc_index_one_node,
-                                gfc_index_zero_node));
+                   fold_build3_loc (input_location, COND_EXPR,
+                                    gfc_array_index_type,
+                                    nonempty, gfc_index_one_node,
+                                    gfc_index_zero_node));
   else
     {
       gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
@@ -2242,9 +3176,17 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
       TREE_USED (lab2) = 1;
     }
 
-  gfc_mark_ss_chain_used (arrayss, 1);
+  /* An offset must be added to the loop
+     counter to obtain the required position.  */
+  gcc_assert (loop.from[0]);
+
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                        gfc_index_one_node, loop.from[0]);
+  gfc_add_modify (&loop.pre, offset, tmp);
+
+  gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
   if (maskss)
-    gfc_mark_ss_chain_used (maskss, 1);
+    gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
   /* Generate the loop body.  */
   gfc_start_scalarized_body (&loop, &body);
 
@@ -2275,35 +3217,25 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
   /* Assign the value to the limit...  */
   gfc_add_modify (&ifblock, limit, arrayse.expr);
 
-  /* Remember where we are.  An offset must be added to the loop
-     counter to obtain the required position.  */
-  if (loop.from[0])
-    tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-                      gfc_index_one_node, loop.from[0]);
-  else
-    tmp = gfc_index_one_node;
-
-  gfc_add_modify (&block, offset, tmp);
-
   if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
     {
       stmtblock_t ifblock2;
       tree ifbody2;
 
       gfc_start_block (&ifblock2);
-      tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
-                        loop.loopvar[0], offset);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+                            loop.loopvar[0], offset);
       gfc_add_modify (&ifblock2, pos, tmp);
       ifbody2 = gfc_finish_block (&ifblock2);
-      cond = fold_build2 (EQ_EXPR, boolean_type_node, pos,
-                         gfc_index_zero_node);
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
+                             gfc_index_zero_node);
       tmp = build3_v (COND_EXPR, cond, ifbody2,
                      build_empty_stmt (input_location));
       gfc_add_expr_to_block (&block, tmp);
     }
 
-  tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
-                    loop.loopvar[0], offset);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+                        loop.loopvar[0], offset);
   gfc_add_modify (&ifblock, pos, tmp);
 
   if (lab1)
@@ -2314,10 +3246,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
   if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
     {
       if (lab1)
-       cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
-                           boolean_type_node, arrayse.expr, limit);
+       cond = fold_build2_loc (input_location,
+                               op == GT_EXPR ? GE_EXPR : LE_EXPR,
+                               boolean_type_node, arrayse.expr, limit);
       else
-       cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+       cond = fold_build2_loc (input_location, op, boolean_type_node,
+                               arrayse.expr, limit);
 
       ifbody = build3_v (COND_EXPR, cond, ifbody,
                         build_empty_stmt (input_location));
@@ -2338,7 +3272,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
 
   if (lab1)
     {
-      gfc_trans_scalarized_loop_end (&loop, 0, &body);
+      gfc_trans_scalarized_loop_boundary (&loop, &body);
 
       if (HONOR_NANS (DECL_MODE (limit)))
        {
@@ -2353,7 +3287,6 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
 
       gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
-      gfc_start_block (&body);
 
       /* If we have a mask, only check this element if the mask is set.  */
       if (maskss)
@@ -2382,23 +3315,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
       /* Assign the value to the limit...  */
       gfc_add_modify (&ifblock, limit, arrayse.expr);
 
-      /* Remember where we are.  An offset must be added to the loop
-        counter to obtain the required position.  */
-      if (loop.from[0])
-       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-                          gfc_index_one_node, loop.from[0]);
-      else
-       tmp = gfc_index_one_node;
-
-      gfc_add_modify (&block, offset, tmp);
-
-      tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
-                        loop.loopvar[0], offset);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+                            loop.loopvar[0], offset);
       gfc_add_modify (&ifblock, pos, tmp);
 
       ifbody = gfc_finish_block (&ifblock);
 
-      cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+      cond = fold_build2_loc (input_location, op, boolean_type_node,
+                             arrayse.expr, limit);
 
       tmp = build3_v (COND_EXPR, cond, ifbody,
                      build_empty_stmt (input_location));
@@ -2618,14 +3542,15 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
      possible value is HUGE in both cases.  */
   if (op == GT_EXPR)
     {
-      tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+      tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
       if (huge_cst)
-       huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
+       huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
+                                   TREE_TYPE (huge_cst), huge_cst);
     }
 
   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
-    tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
-                      tmp, build_int_cst (type, 1));
+    tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
+                          tmp, build_int_cst (type, 1));
 
   gfc_add_modify (&se->pre, limit, tmp);
 
@@ -2651,8 +3576,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
        {
          nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
          mpz_clear (asize);
-         nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
-                                 gfc_index_zero_node);
+         nonempty = fold_build2_loc (input_location, GT_EXPR,
+                                     boolean_type_node, nonempty,
+                                     gfc_index_zero_node);
        }
       maskss = NULL;
     }
@@ -2665,12 +3591,28 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
 
   /* Initialize the loop.  */
   gfc_conv_ss_startstride (&loop);
+
+  /* The code generated can have more than one loop in sequence (see the
+     comment at the function header).  This doesn't work well with the
+     scalarizer, which changes arrays' offset when the scalarization loops
+     are generated (see gfc_trans_preloop_setup).  Fortunately, {min,max}val
+     are  currently inlined in the scalar case only.  As there is no dependency
+     to care about in that case, there is no temporary, so that we can use the
+     scalarizer temporary code to handle multiple loops.  Thus, we set temp_dim
+     here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
+     gfc_trans_scalarized_loop_boundary even later to restore offset.
+     TODO: this prevents inlining of rank > 0 minmaxval calls, so this
+     should eventually go away.  We could either create two loops properly,
+     or find another way to save/restore the array offsets between the two
+     loops (without conflicting with temporary management), or use a single
+     loop minmaxval implementation.  See PR 31067.  */
+  loop.temp_dim = loop.dimen;
   gfc_conv_loop_setup (&loop, &expr->where);
 
   if (nonempty == NULL && maskss == NULL
       && loop.dimen == 1 && loop.from[0] && loop.to[0])
-    nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
-                           loop.to[0]);
+    nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+                               loop.from[0], loop.to[0]);
   nonempty_var = NULL;
   if (nonempty == NULL
       && (HONOR_INFINITIES (DECL_MODE (limit))
@@ -2696,9 +3638,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
        }
     }
 
-  gfc_mark_ss_chain_used (arrayss, 1);
+  gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
   if (maskss)
-    gfc_mark_ss_chain_used (maskss, 1);
+    gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
   /* Generate the loop body.  */
   gfc_start_scalarized_body (&loop, &body);
 
@@ -2730,8 +3672,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
 
   if (HONOR_NANS (DECL_MODE (limit)))
     {
-      tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
-                        boolean_type_node, arrayse.expr, limit);
+      tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
+                            boolean_type_node, arrayse.expr, limit);
       if (lab)
        ifbody = build1_v (GOTO_EXPR, lab);
       else
@@ -2753,7 +3695,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
         signed zeros.  */
       if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
        {
-         tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+         tmp = fold_build2_loc (input_location, op, boolean_type_node,
+                                arrayse.expr, limit);
          ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
          tmp = build3_v (COND_EXPR, tmp, ifbody,
                          build_empty_stmt (input_location));
@@ -2761,8 +3704,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
        }
       else
        {
-         tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
-                            type, arrayse.expr, limit);
+         tmp = fold_build2_loc (input_location,
+                                op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+                                type, arrayse.expr, limit);
          gfc_add_modify (&block2, limit, tmp);
        }
     }
@@ -2776,15 +3720,17 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
       if (HONOR_NANS (DECL_MODE (limit))
          || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
        {
-         tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+         tmp = fold_build2_loc (input_location, op, boolean_type_node,
+                                arrayse.expr, limit);
          ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
          ifbody = build3_v (COND_EXPR, tmp, ifbody,
                             build_empty_stmt (input_location));
        }
       else
        {
-         tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
-                            type, arrayse.expr, limit);
+         tmp = fold_build2_loc (input_location,
+                                op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+                                type, arrayse.expr, limit);
          ifbody = build2_v (MODIFY_EXPR, limit, tmp);
        }
       tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
@@ -2804,14 +3750,13 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
 
   if (lab)
     {
-      gfc_trans_scalarized_loop_end (&loop, 0, &body);
+      gfc_trans_scalarized_loop_boundary (&loop, &body);
 
-      tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
+      tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
+                            nan_cst, huge_cst);
       gfc_add_modify (&loop.code[0], limit, tmp);
       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
 
-      gfc_start_block (&body);
-
       /* If we have a mask, only add this element if the mask is set.  */
       if (maskss)
        {
@@ -2838,7 +3783,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
       if (HONOR_NANS (DECL_MODE (limit))
          || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
        {
-         tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+         tmp = fold_build2_loc (input_location, op, boolean_type_node,
+                                arrayse.expr, limit);
          ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
          tmp = build3_v (COND_EXPR, tmp, ifbody,
                          build_empty_stmt (input_location));
@@ -2846,8 +3792,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
        }
       else
        {
-         tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
-                            type, arrayse.expr, limit);
+         tmp = fold_build2_loc (input_location,
+                                op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+                                type, arrayse.expr, limit);
          gfc_add_modify (&block, limit, tmp);
        }
 
@@ -2867,7 +3814,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
 
   if (fast)
     {
-      tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
+      tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
+                            nan_cst, huge_cst);
       ifbody = build2_v (MODIFY_EXPR, limit, tmp);
       tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
                      ifbody);
@@ -2875,7 +3823,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
     }
   else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
     {
-      tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst);
+      tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
+                            huge_cst);
       gfc_add_modify (&loop.pre, limit, tmp);
     }
 
@@ -2921,14 +3870,42 @@ gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
   gfc_conv_intrinsic_function_args (se, expr, args, 2);
   type = TREE_TYPE (args[0]);
 
-  tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
-  tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
-  tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
-                    build_int_cst (type, 0));
+  tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+                        build_int_cst (type, 1), args[1]);
+  tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+                        build_int_cst (type, 0));
   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, tmp);
 }
 
+
+/* Generate code for BGE, BGT, BLE and BLT intrinsics.  */
+static void
+gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
+{
+  tree args[2];
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+  /* Convert both arguments to the unsigned type of the same size.  */
+  args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
+  args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
+
+  /* If they have unequal type size, convert to the larger one.  */
+  if (TYPE_PRECISION (TREE_TYPE (args[0]))
+      > TYPE_PRECISION (TREE_TYPE (args[1])))
+    args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
+  else if (TYPE_PRECISION (TREE_TYPE (args[1]))
+          > TYPE_PRECISION (TREE_TYPE (args[0])))
+    args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
+
+  /* Now, we compare them.  */
+  se->expr = fold_build2_loc (input_location, op, boolean_type_node,
+                             args[0], args[1]);
+}
+
+
 /* Generate code to perform the specified operation.  */
 static void
 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
@@ -2936,7 +3913,8 @@ gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
   tree args[2];
 
   gfc_conv_intrinsic_function_args (se, expr, args, 2);
-  se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
+  se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
+                             args[0], args[1]);
 }
 
 /* Bitwise not.  */
@@ -2946,7 +3924,8 @@ gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
   tree arg;
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
-  se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
+  se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
+                             TREE_TYPE (arg), arg);
 }
 
 /* Set or clear a single bit.  */
@@ -2961,15 +3940,16 @@ gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
   gfc_conv_intrinsic_function_args (se, expr, args, 2);
   type = TREE_TYPE (args[0]);
 
-  tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
+  tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+                        build_int_cst (type, 1), args[1]);
   if (set)
     op = BIT_IOR_EXPR;
   else
     {
       op = BIT_AND_EXPR;
-      tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
+      tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
     }
-  se->expr = fold_build2 (op, type, args[0], tmp);
+  se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
 }
 
 /* Extract a sequence of bits.
@@ -2986,25 +3966,47 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
   type = TREE_TYPE (args[0]);
 
   mask = build_int_cst (type, -1);
-  mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
-  mask = fold_build1 (BIT_NOT_EXPR, type, mask);
+  mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
+  mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
 
-  tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
+  tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
 
-  se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
+  se->expr = fold_build2_loc (input_location, 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)
+gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
+                         bool arithmetic)
 {
-  tree args[2];
+  tree args[2], type, num_bits, cond;
 
   gfc_conv_intrinsic_function_args (se, expr, args, 2);
 
-  se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
-                         TREE_TYPE (args[0]), args[0], args[1]);
+  args[0] = gfc_evaluate_now (args[0], &se->pre);
+  args[1] = gfc_evaluate_now (args[1], &se->pre);
+  type = TREE_TYPE (args[0]);
+
+  if (!arithmetic)
+    args[0] = fold_convert (unsigned_type_for (type), args[0]);
+  else
+    gcc_assert (right_shift);
+
+  se->expr = fold_build2_loc (input_location,
+                             right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
+                             TREE_TYPE (args[0]), args[0], args[1]);
+
+  if (!arithmetic)
+    se->expr = fold_convert (type, se->expr);
+
+  /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
+     gcc requires a shift width < BIT_SIZE(I), so we have to catch this
+     special case.  */
+  num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
+  cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+                         args[1], num_bits);
+
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+                             build_int_cst (type, 0), se->expr);
 }
 
 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
@@ -3025,34 +4027,39 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
   tree rshift;
 
   gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+  args[0] = gfc_evaluate_now (args[0], &se->pre);
+  args[1] = gfc_evaluate_now (args[1], &se->pre);
+
   type = TREE_TYPE (args[0]);
   utype = unsigned_type_for (type);
 
-  width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
+  width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
+                          args[1]);
 
   /* Left shift if positive.  */
-  lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
+  lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
 
   /* Right shift if negative.
      We convert to an unsigned type because we want a logical shift.
      The standard doesn't define the case of shifting negative
      numbers, and we try to be compatible with other compilers, most
      notably g77, here.  */
-  rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype, 
-                                           convert (utype, args[0]), width));
+  rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
+                                   utype, convert (utype, args[0]), width));
 
-  tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
-                    build_int_cst (TREE_TYPE (args[1]), 0));
-  tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
+  tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
+                        build_int_cst (TREE_TYPE (args[1]), 0));
+  tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
 
   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
      special case.  */
   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
-  cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
-
-  se->expr = fold_build3 (COND_EXPR, type, cond,
-                         build_int_cst (type, 0), tmp);
+  cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
+                         num_bits);
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+                             build_int_cst (type, 0), tmp);
 }
 
 
@@ -3110,7 +4117,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
          gcc_unreachable ();
        }
       se->expr = build_call_expr_loc (input_location,
-                                 tmp, 3, args[0], args[1], args[2]);
+                                     tmp, 3, args[0], args[1], args[2]);
       /* Convert the result back to the original type, if we extended
         the first argument's width above.  */
       if (expr->ts.kind < 4)
@@ -3120,22 +4127,31 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
     }
   type = TREE_TYPE (args[0]);
 
+  /* Evaluate arguments only once.  */
+  args[0] = gfc_evaluate_now (args[0], &se->pre);
+  args[1] = gfc_evaluate_now (args[1], &se->pre);
+
   /* Rotate left if positive.  */
-  lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
+  lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
 
   /* Rotate right if negative.  */
-  tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
-  rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
+  tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
+                        args[1]);
+  rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
 
   zero = build_int_cst (TREE_TYPE (args[1]), 0);
-  tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
-  rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
+  tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
+                        zero);
+  rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
 
   /* Do nothing if shift == 0.  */
-  tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
-  se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
+  tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
+                        zero);
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
+                             rrot);
 }
 
+
 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
                        : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
 
@@ -3166,23 +4182,23 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
   if (argsize <= INT_TYPE_SIZE)
     {
       arg_type = unsigned_type_node;
-      func = built_in_decls[BUILT_IN_CLZ];
+      func = builtin_decl_explicit (BUILT_IN_CLZ);
     }
   else if (argsize <= LONG_TYPE_SIZE)
     {
       arg_type = long_unsigned_type_node;
-      func = built_in_decls[BUILT_IN_CLZL];
+      func = builtin_decl_explicit (BUILT_IN_CLZL);
     }
   else if (argsize <= LONG_LONG_TYPE_SIZE)
     {
       arg_type = long_long_unsigned_type_node;
-      func = built_in_decls[BUILT_IN_CLZLL];
+      func = builtin_decl_explicit (BUILT_IN_CLZLL);
     }
   else
     {
-      gcc_assert (argsize == 128);
+      gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
       arg_type = gfc_build_uint_type (argsize);
-      func = gfor_fndecl_clz128;
+      func = NULL_TREE;
     }
 
   /* Convert the actual argument twice: first, to the unsigned type of the
@@ -3190,22 +4206,74 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
      function.  But the return type is of the default INTEGER kind.  */
   arg = fold_convert (gfc_build_uint_type (argsize), arg);
   arg = fold_convert (arg_type, arg);
+  arg = gfc_evaluate_now (arg, &se->pre);
   result_type = gfc_get_int_type (gfc_default_integer_kind);
 
   /* Compute LEADZ for the case i .ne. 0.  */
-  s = TYPE_PRECISION (arg_type) - argsize;
-  tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
-  leadz = fold_build2 (MINUS_EXPR, result_type,
-                      tmp, build_int_cst (result_type, s));
+  if (func)
+    {
+      s = TYPE_PRECISION (arg_type) - argsize;
+      tmp = fold_convert (result_type,
+                         build_call_expr_loc (input_location, func,
+                                              1, arg));
+      leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
+                              tmp, build_int_cst (result_type, s));
+    }
+  else
+    {
+      /* We end up here if the argument type is larger than 'long long'.
+        We generate this code:
+  
+           if (x & (ULL_MAX << ULL_SIZE) != 0)
+             return clzll ((unsigned long long) (x >> ULLSIZE));
+           else
+             return ULL_SIZE + clzll ((unsigned long long) x);
+        where ULL_MAX is the largest value that a ULL_MAX can hold
+        (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
+        is the bit-size of the long long type (64 in this example).  */
+      tree ullsize, ullmax, tmp1, tmp2, btmp;
+
+      ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
+      ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
+                               long_long_unsigned_type_node,
+                               build_int_cst (long_long_unsigned_type_node,
+                                              0));
+
+      cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
+                             fold_convert (arg_type, ullmax), ullsize);
+      cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
+                             arg, cond);
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                             cond, build_int_cst (arg_type, 0));
+
+      tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
+                             arg, ullsize);
+      tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
+      btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
+      tmp1 = fold_convert (result_type,
+                          build_call_expr_loc (input_location, btmp, 1, tmp1));
+
+      tmp2 = fold_convert (long_long_unsigned_type_node, arg);
+      btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
+      tmp2 = fold_convert (result_type,
+                          build_call_expr_loc (input_location, btmp, 1, tmp2));
+      tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
+                             tmp2, ullsize);
+
+      leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
+                              cond, tmp1, tmp2);
+    }
 
   /* Build BIT_SIZE.  */
   bit_size = build_int_cst (result_type, argsize);
 
-  cond = fold_build2 (EQ_EXPR, boolean_type_node,
-                     arg, build_int_cst (arg_type, 0));
-  se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                         arg, build_int_cst (arg_type, 0));
+  se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
+                             bit_size, leadz);
 }
 
+
 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
 
    The conditional expression is necessary because the result of TRAILZ(0)
@@ -3231,23 +4299,23 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
   if (argsize <= INT_TYPE_SIZE)
     {
       arg_type = unsigned_type_node;
-      func = built_in_decls[BUILT_IN_CTZ];
+      func = builtin_decl_explicit (BUILT_IN_CTZ);
     }
   else if (argsize <= LONG_TYPE_SIZE)
     {
       arg_type = long_unsigned_type_node;
-      func = built_in_decls[BUILT_IN_CTZL];
+      func = builtin_decl_explicit (BUILT_IN_CTZL);
     }
   else if (argsize <= LONG_LONG_TYPE_SIZE)
     {
       arg_type = long_long_unsigned_type_node;
-      func = built_in_decls[BUILT_IN_CTZLL];
+      func = builtin_decl_explicit (BUILT_IN_CTZLL);
     }
   else
     {
-      gcc_assert (argsize == 128);
+      gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
       arg_type = gfc_build_uint_type (argsize);
-      func = gfor_fndecl_ctz128;
+      func = NULL_TREE;
     }
 
   /* Convert the actual argument twice: first, to the unsigned type of the
@@ -3255,20 +4323,157 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
      function.  But the return type is of the default INTEGER kind.  */
   arg = fold_convert (gfc_build_uint_type (argsize), arg);
   arg = fold_convert (arg_type, arg);
+  arg = gfc_evaluate_now (arg, &se->pre);
   result_type = gfc_get_int_type (gfc_default_integer_kind);
 
   /* Compute TRAILZ for the case i .ne. 0.  */
-  trailz = fold_convert (result_type, build_call_expr_loc (input_location,
-                                                      func, 1, arg));
+  if (func)
+    trailz = fold_convert (result_type, build_call_expr_loc (input_location,
+                                                            func, 1, arg));
+  else
+    {
+      /* We end up here if the argument type is larger than 'long long'.
+        We generate this code:
+  
+           if ((x & ULL_MAX) == 0)
+             return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
+           else
+             return ctzll ((unsigned long long) x);
+
+        where ULL_MAX is the largest value that a ULL_MAX can hold
+        (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
+        is the bit-size of the long long type (64 in this example).  */
+      tree ullsize, ullmax, tmp1, tmp2, btmp;
+
+      ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
+      ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
+                               long_long_unsigned_type_node,
+                               build_int_cst (long_long_unsigned_type_node, 0));
+
+      cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
+                             fold_convert (arg_type, ullmax));
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
+                             build_int_cst (arg_type, 0));
+
+      tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
+                             arg, ullsize);
+      tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
+      btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
+      tmp1 = fold_convert (result_type,
+                          build_call_expr_loc (input_location, btmp, 1, tmp1));
+      tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
+                             tmp1, ullsize);
+
+      tmp2 = fold_convert (long_long_unsigned_type_node, arg);
+      btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
+      tmp2 = fold_convert (result_type,
+                          build_call_expr_loc (input_location, btmp, 1, tmp2));
+
+      trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
+                               cond, tmp1, tmp2);
+    }
 
   /* Build BIT_SIZE.  */
   bit_size = build_int_cst (result_type, argsize);
 
-  cond = fold_build2 (EQ_EXPR, boolean_type_node,
-                     arg, build_int_cst (arg_type, 0));
-  se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                         arg, build_int_cst (arg_type, 0));
+  se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
+                             bit_size, trailz);
+}
+
+/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
+   for types larger than "long long", we call the long long built-in for
+   the lower and higher bits and combine the result.  */
+static void
+gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
+{
+  tree arg;
+  tree arg_type;
+  tree result_type;
+  tree func;
+  int argsize;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  argsize = TYPE_PRECISION (TREE_TYPE (arg));
+  result_type = gfc_get_int_type (gfc_default_integer_kind);
+
+  /* Which variant of the builtin should we call?  */
+  if (argsize <= INT_TYPE_SIZE)
+    {
+      arg_type = unsigned_type_node;
+      func = builtin_decl_explicit (parity
+                                   ? BUILT_IN_PARITY
+                                   : BUILT_IN_POPCOUNT);
+    }
+  else if (argsize <= LONG_TYPE_SIZE)
+    {
+      arg_type = long_unsigned_type_node;
+      func = builtin_decl_explicit (parity
+                                   ? BUILT_IN_PARITYL
+                                   : BUILT_IN_POPCOUNTL);
+    }
+  else if (argsize <= LONG_LONG_TYPE_SIZE)
+    {
+      arg_type = long_long_unsigned_type_node;
+      func = builtin_decl_explicit (parity
+                                   ? BUILT_IN_PARITYLL
+                                   : BUILT_IN_POPCOUNTLL);
+    }
+  else
+    {
+      /* Our argument type is larger than 'long long', which mean none
+        of the POPCOUNT builtins covers it.  We thus call the 'long long'
+        variant multiple times, and add the results.  */
+      tree utype, arg2, call1, call2;
+
+      /* For now, we only cover the case where argsize is twice as large
+        as 'long long'.  */
+      gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
+
+      func = builtin_decl_explicit (parity
+                                   ? BUILT_IN_PARITYLL
+                                   : BUILT_IN_POPCOUNTLL);
+
+      /* Convert it to an integer, and store into a variable.  */
+      utype = gfc_build_uint_type (argsize);
+      arg = fold_convert (utype, arg);
+      arg = gfc_evaluate_now (arg, &se->pre);
+
+      /* Call the builtin twice.  */
+      call1 = build_call_expr_loc (input_location, func, 1,
+                                  fold_convert (long_long_unsigned_type_node,
+                                                arg));
+
+      arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
+                             build_int_cst (utype, LONG_LONG_TYPE_SIZE));
+      call2 = build_call_expr_loc (input_location, func, 1,
+                                  fold_convert (long_long_unsigned_type_node,
+                                                arg2));
+                         
+      /* Combine the results.  */
+      if (parity)
+       se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
+                                   call1, call2);
+      else
+       se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
+                                   call1, call2);
+
+      return;
+    }
+
+  /* Convert the actual argument twice: first, to the unsigned type of the
+     same size; then, to the proper argument type for the built-in
+     function.  */
+  arg = fold_convert (gfc_build_uint_type (argsize), arg);
+  arg = fold_convert (arg_type, arg);
+
+  se->expr = fold_convert (result_type,
+                          build_call_expr_loc (input_location, func, 1, arg));
 }
 
+
 /* Process an intrinsic with unspecified argument-types that has an optional
    argument (which could be of type character), e.g. EOSHIFT.  For those, we
    need to append the string length of the optional argument if it is not
@@ -3324,7 +4529,7 @@ conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
   sym = gfc_get_symbol_for_expr (expr);
   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
                          append_args);
-  gfc_free (sym);
+  free (sym);
 }
 
 
@@ -3348,7 +4553,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
   switch (arg->expr_type)
     {
     case EXPR_CONSTANT:
-      len = build_int_cst (NULL_TREE, arg->value.character.length);
+      len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
       break;
 
     case EXPR_ARRAY:
@@ -3459,12 +4664,14 @@ gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
 static void
 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
 {
-  tree args[2], type, pchartype;
+  tree args[3], type, pchartype;
+  int nargs;
 
-  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  gfc_conv_intrinsic_function_args (se, expr, args, nargs);
   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
   pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
-  args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
+  args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
   type = gfc_typenode_for_spec (&expr->ts);
 
   se->expr = build_fold_indirect_ref_loc (input_location,
@@ -3482,7 +4689,8 @@ gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
   se->expr = build_call_expr_loc (input_location,
-                             built_in_decls[BUILT_IN_ISNAN], 1, arg);
+                                 builtin_decl_explicit (BUILT_IN_ISNAN),
+                                 1, arg);
   STRIP_TYPE_NOPS (se->expr);
   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
 }
@@ -3497,8 +4705,9 @@ gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
   tree arg;
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
-  se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
-                         arg, build_int_cst (TREE_TYPE (arg), value));
+  se->expr = fold_build2_loc (input_location, EQ_EXPR,
+                             gfc_typenode_for_spec (&expr->ts),
+                             arg, build_int_cst (TREE_TYPE (arg), value));
 }
 
 
@@ -3542,8 +4751,86 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
       se->string_length = len;
     }
   type = TREE_TYPE (tsource);
-  se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
-                         fold_convert (type, fsource));
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
+                             fold_convert (type, fsource));
+}
+
+
+/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)).  */
+
+static void
+gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
+{
+  tree args[3], mask, type;
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 3);
+  mask = gfc_evaluate_now (args[2], &se->pre);
+
+  type = TREE_TYPE (args[0]);
+  gcc_assert (TREE_TYPE (args[1]) == type);
+  gcc_assert (TREE_TYPE (mask) == type);
+
+  args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
+  args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
+                            fold_build1_loc (input_location, BIT_NOT_EXPR,
+                                             type, mask));
+  se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
+                             args[0], args[1]);
+}
+
+
+/* MASKL(n)  =  n == 0 ? 0 : (~0) << (BIT_SIZE - n)
+   MASKR(n)  =  n == BIT_SIZE ? ~0 : ~((~0) << n)  */
+
+static void
+gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
+{
+  tree arg, allones, type, utype, res, cond, bitsize;
+  int i;
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  arg = gfc_evaluate_now (arg, &se->pre);
+
+  type = gfc_get_int_type (expr->ts.kind);
+  utype = unsigned_type_for (type);
+
+  i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
+  bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
+
+  allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
+                            build_int_cst (utype, 0));
+
+  if (left)
+    {
+      /* Left-justified mask.  */
+      res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
+                            bitsize, arg);
+      res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
+                            fold_convert (utype, res));
+
+      /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
+        smaller than type width.  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
+                             build_int_cst (TREE_TYPE (arg), 0));
+      res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
+                            build_int_cst (utype, 0), res);
+    }
+  else
+    {
+      /* Right-justified mask.  */
+      res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
+                            fold_convert (utype, arg));
+      res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
+
+      /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
+        strictly smaller than type width.  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                             arg, bitsize);
+      res = fold_build3_loc (input_location, COND_EXPR, utype,
+                            cond, allones, res);
+    }
+
+  se->expr = fold_convert (type, res);
 }
 
 
@@ -3553,7 +4840,7 @@ gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
 {
   tree arg, type, tmp, frexp;
 
-  frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+  frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
 
   type = gfc_typenode_for_spec (&expr->ts);
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
@@ -3574,14 +4861,14 @@ gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
 {
   tree args[2], type, tmp, nextafter, copysign, huge_val;
 
-  nextafter = builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
-  copysign = builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
-  huge_val = builtin_decl_for_float_kind (BUILT_IN_HUGE_VAL, expr->ts.kind);
+  nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
+  copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
 
   type = gfc_typenode_for_spec (&expr->ts);
   gfc_conv_intrinsic_function_args (se, expr, args, 2);
-  tmp = build_call_expr_loc (input_location, copysign, 2,
-                            build_call_expr_loc (input_location, huge_val, 0),
+
+  huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
+  tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
                             fold_convert (type, args[1]));
   se->expr = build_call_expr_loc (input_location, nextafter, 2,
                                  fold_convert (type, args[0]), tmp);
@@ -3615,12 +4902,12 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
   stmtblock_t block;
 
   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
-  prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
-  emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
+  prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
+  emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
   tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
 
-  frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
-  scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+  frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+  scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
   arg = gfc_evaluate_now (arg, &se->pre);
@@ -3636,17 +4923,18 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
                             gfc_build_addr_expr (NULL_TREE, e));
   gfc_add_expr_to_block (&block, tmp);
 
-  tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
-  gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
-                                         tmp, emin));
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
+                        prec);
+  gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
+                                             integer_type_node, tmp, emin));
 
   tmp = build_call_expr_loc (input_location, scalbn, 2,
                         build_real_from_int_cst (type, integer_one_node), e);
   gfc_add_modify (&block, res, tmp);
 
   /* Finish by building the IF statement.  */
-  cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
-                     build_real_from_int_cst (type, integer_zero_node));
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
+                         build_real_from_int_cst (type, integer_zero_node));
   tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
                  gfc_finish_block (&block));
 
@@ -3678,9 +4966,9 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
   prec = gfc_real_kinds[k].digits;
 
-  frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
-  scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
-  fabs = builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
+  frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+  scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+  fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
 
   type = gfc_typenode_for_spec (&expr->ts);
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
@@ -3697,14 +4985,14 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
                             gfc_build_addr_expr (NULL_TREE, e));
   gfc_add_expr_to_block (&block, tmp);
 
-  tmp = fold_build2 (MINUS_EXPR, integer_type_node,
-                    build_int_cst (NULL_TREE, prec), e);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
+                        build_int_cst (integer_type_node, prec), e);
   tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
   gfc_add_modify (&block, x, tmp);
   stmt = gfc_finish_block (&block);
 
-  cond = fold_build2 (NE_EXPR, boolean_type_node, x,
-                     build_real_from_int_cst (type, integer_zero_node));
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
+                         build_real_from_int_cst (type, integer_zero_node));
   tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
   gfc_add_expr_to_block (&se->pre, tmp);
 
@@ -3718,7 +5006,7 @@ gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
 {
   tree args[2], type, scalbn;
 
-  scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+  scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
 
   type = gfc_typenode_for_spec (&expr->ts);
   gfc_conv_intrinsic_function_args (se, expr, args, 2);
@@ -3736,8 +5024,8 @@ gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
 {
   tree args[2], type, tmp, frexp, scalbn;
 
-  frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
-  scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+  frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+  scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
 
   type = gfc_typenode_for_spec (&expr->ts);
   gfc_conv_intrinsic_function_args (se, expr, args, 2);
@@ -3766,6 +5054,9 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
   gfc_init_se (&argse, NULL);
   actual = expr->value.function.actual;
 
+  if (actual->expr->ts.type == BT_CLASS)
+    gfc_add_class_array_ref (actual->expr);
+
   ss = gfc_walk_expr (actual->expr);
   gcc_assert (ss != gfc_ss_terminator);
   argse.want_pointer = 1;
@@ -3805,17 +5096,18 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
          argse.data_not_needed = 1;
          gfc_conv_expr (&argse, actual->expr);
          gfc_add_block_to_block (&se->pre, &argse.pre);
-         tmp = fold_build2 (NE_EXPR, boolean_type_node,
-                            argse.expr, null_pointer_node);
+         tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                                argse.expr, null_pointer_node);
          tmp = gfc_evaluate_now (tmp, &se->pre);
-         se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
-                                 tmp, fncall1, fncall0);
+         se->expr = fold_build3_loc (input_location, COND_EXPR,
+                                     pvoid_type_node, tmp, fncall1, fncall0);
        }
       else
        {
          se->expr = NULL_TREE;
-         argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-                                   argse.expr, gfc_index_one_node);
+         argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
+                                       gfc_array_index_type,
+                                       argse.expr, gfc_index_one_node);
        }
     }
   else if (expr->value.function.actual->expr->rank == 1)
@@ -3834,12 +5126,14 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
                                      arg1);
       ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
       lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
-      se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-                             ubound, lbound);
-      se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
-                             gfc_index_one_node);
-      se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
-                             gfc_index_zero_node);
+      se->expr = fold_build2_loc (input_location, MINUS_EXPR,
+                                 gfc_array_index_type, ubound, lbound);
+      se->expr = fold_build2_loc (input_location, PLUS_EXPR,
+                                 gfc_array_index_type,
+                                 se->expr, gfc_index_one_node);
+      se->expr = fold_build2_loc (input_location, MAX_EXPR,
+                                 gfc_array_index_type, se->expr,
+                                 gfc_index_zero_node);
     }
 
   type = gfc_typenode_for_spec (&expr->ts);
@@ -3860,8 +5154,9 @@ size_of_string_in_bytes (int kind, tree string_length)
   bytesize = build_int_cst (gfc_array_index_type,
                            gfc_character_kinds[i].bit_size / 8);
 
-  return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
-                     fold_convert (gfc_array_index_type, string_length));
+  return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                         bytesize,
+                         fold_convert (gfc_array_index_type, string_length));
 }
 
 
@@ -3886,7 +5181,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
   if (ss == gfc_ss_terminator)
     {
       if (arg->ts.type == BT_CLASS)
-       gfc_add_component_ref (arg, "$data");
+       gfc_add_data_component (arg);
 
       gfc_conv_expr_reference (&argse, arg);
 
@@ -3922,12 +5217,12 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
          idx = gfc_rank_cst[n];
          lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
          upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
-         tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-                            upper, lower);
-         tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
-                            tmp, gfc_index_one_node);
-         tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
-                            tmp, source_bytes);
+         tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                                gfc_array_index_type, upper, lower);
+         tmp = fold_build2_loc (input_location, PLUS_EXPR,
+                                gfc_array_index_type, tmp, gfc_index_one_node);
+         tmp = fold_build2_loc (input_location, MULT_EXPR,
+                                gfc_array_index_type, tmp, source_bytes);
          gfc_add_modify (&argse.pre, source_bytes, tmp);
        }
       se->expr = source_bytes;
@@ -3957,8 +5252,8 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
     {
       if (arg->ts.type == BT_CLASS)
       {
-       gfc_add_component_ref (arg, "$vptr");
-       gfc_add_component_ref (arg, "$size");
+       gfc_add_vptr_component (arg);
+       gfc_add_size_component (arg);
        gfc_conv_expr (&argse, arg);
        tmp = fold_convert (result_type, argse.expr);
        goto done;
@@ -3982,7 +5277,8 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
     tmp = fold_convert (result_type, size_in_bytes (type)); 
 
 done:
-  se->expr = fold_build2 (MULT_EXPR, result_type, tmp, eight.expr);
+  se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
+                             eight.expr);
   gfc_add_block_to_block (&se->pre, &argse.pre);
 }
 
@@ -4000,8 +5296,9 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
     = gfc_build_compare_string (args[0], args[1], args[2], args[3],
                                expr->value.function.actual->expr->ts.kind,
                                op);
-  se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
-                         build_int_cst (TREE_TYPE (se->expr), 0));
+  se->expr = fold_build2_loc (input_location, op,
+                             gfc_typenode_for_spec (&expr->ts), se->expr,
+                             build_int_cst (TREE_TYPE (se->expr), 0));
 }
 
 /* Generate a call to the adjustl/adjustr library function.  */
@@ -4064,14 +5361,14 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
   gfc_actual_arglist *arg;
   gfc_se argse;
   gfc_ss *ss;
-  gfc_ss_info *info;
+  gfc_array_info *info;
   stmtblock_t block;
   int n;
   bool scalar_mold;
 
   info = NULL;
   if (se->loop)
-    info = &se->ss->data.info;
+    info = &se->ss->info->data.array;
 
   /* Convert SOURCE.  The output from this stage is:-
        source_bytes = length of the source in bytes
@@ -4117,9 +5414,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
       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)
+      /* Repack the source if not simply contiguous.  */
+      if (!gfc_is_simply_contiguous (arg->expr, false))
        {
          tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
 
@@ -4139,7 +5435,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
          /* Clean up if it was repacked.  */
          gfc_init_block (&block);
          tmp = gfc_conv_array_data (argse.expr);
-         tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
+         tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                                source, tmp);
          tmp = build3_v (COND_EXPR, tmp, stmt,
                          build_empty_stmt (input_location));
          gfc_add_expr_to_block (&block, tmp);
@@ -4165,13 +5462,14 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
          gfc_add_modify (&argse.pre, source_bytes, tmp);
          lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
          upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
-         tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-                            upper, lower);
+         tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                                gfc_array_index_type, upper, lower);
          gfc_add_modify (&argse.pre, extent, tmp);
-         tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
-                            extent, gfc_index_one_node);
-         tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
-                            tmp, source_bytes);
+         tmp = fold_build2_loc (input_location, PLUS_EXPR,
+                                gfc_array_index_type, extent,
+                                gfc_index_one_node);
+         tmp = fold_build2_loc (input_location, MULT_EXPR,
+                                gfc_array_index_type, tmp, source_bytes);
        }
     }
 
@@ -4249,15 +5547,16 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 
   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
   if (tmp != NULL_TREE)
-    tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
-                      tmp, dest_word_len);
+    tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                          tmp, dest_word_len);
   else
     tmp = source_bytes;
 
   gfc_add_modify (&se->pre, size_bytes, tmp);
   gfc_add_modify (&se->pre, size_words,
-                      fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
-                                   size_bytes, dest_word_len));
+                      fold_build2_loc (input_location, CEIL_DIV_EXPR,
+                                       gfc_array_index_type,
+                                       size_bytes, dest_word_len));
 
   /* Evaluate the bounds of the result.  If the loop range exists, we have
      to check if it is too large.  If so, we modify loop->to be consistent
@@ -4266,25 +5565,26 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
   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 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
-                        tmp, gfc_index_one_node);
-      tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                            se->loop->to[n], se->loop->from[n]);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+                            tmp, gfc_index_one_node);
+      tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
                         tmp, size_words);
       gfc_add_modify (&se->pre, size_words, tmp);
       gfc_add_modify (&se->pre, size_bytes,
-                          fold_build2 (MULT_EXPR, gfc_array_index_type,
-                                       size_words, dest_word_len));
-      upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
-                          size_words, se->loop->from[n]);
-      upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-                          upper, gfc_index_one_node);
+                          fold_build2_loc (input_location, MULT_EXPR,
+                                           gfc_array_index_type,
+                                           size_words, dest_word_len));
+      upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+                              size_words, se->loop->from[n]);
+      upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                              upper, gfc_index_one_node);
     }
   else
     {
-      upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-                          size_words, gfc_index_one_node);
+      upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                              size_words, gfc_index_one_node);
       se->loop->from[n] = gfc_index_zero_node;
     }
 
@@ -4292,9 +5592,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 
   /* Build a destination descriptor, using the pointer, source, as the
      data field.  */
-  gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
-                              info, mold_type, NULL_TREE, false, true, false,
-                              &expr->where);
+  gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
+                              NULL_TREE, false, true, false, &expr->where);
 
   /* Cast the pointer to the result.  */
   tmp = gfc_conv_descriptor_data_get (info->descriptor);
@@ -4302,31 +5601,31 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 
   /* Use memcpy to do the transfer.  */
   tmp = build_call_expr_loc (input_location,
-                        built_in_decls[BUILT_IN_MEMCPY],
+                        builtin_decl_explicit (BUILT_IN_MEMCPY),
                         3,
                         tmp,
                         fold_convert (pvoid_type_node, source),
-                        fold_build2 (MIN_EXPR, gfc_array_index_type,
-                                     size_bytes, source_bytes));
+                        fold_build2_loc (input_location, MIN_EXPR,
+                                         gfc_array_index_type,
+                                         size_bytes, source_bytes));
   gfc_add_expr_to_block (&se->pre, tmp);
 
   se->expr = info->descriptor;
   if (expr->ts.type == BT_CHARACTER)
-    se->string_length = dest_word_len;
+    se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
 
   return;
 
 /* Deal with scalar results.  */
 scalar_transfer:
-  extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
-                       dest_word_len, source_bytes);
-  extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
-                       extent, gfc_index_zero_node);
+  extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
+                           dest_word_len, source_bytes);
+  extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+                           extent, gfc_index_zero_node);
 
   if (expr->ts.type == BT_CHARACTER)
     {
-      tree direct;
-      tree indirect;
+      tree direct, indirect, free;
 
       ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
       tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
@@ -4346,7 +5645,7 @@ scalar_transfer:
       gfc_add_modify (&block, tmpdecl,
                      fold_convert (TREE_TYPE (ptr), tmp));
       tmp = build_call_expr_loc (input_location,
-                            built_in_decls[BUILT_IN_MEMCPY], 3,
+                            builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
                             fold_convert (pvoid_type_node, tmpdecl),
                             fold_convert (pvoid_type_node, ptr),
                             extent);
@@ -4354,13 +5653,20 @@ scalar_transfer:
       indirect = gfc_finish_block (&block);
 
       /* Wrap it up with the condition.  */
-      tmp = fold_build2 (LE_EXPR, boolean_type_node,
-                        dest_word_len, source_bytes);
+      tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+                            dest_word_len, source_bytes);
       tmp = build3_v (COND_EXPR, tmp, direct, indirect);
       gfc_add_expr_to_block (&se->pre, tmp);
 
+      /* Free the temporary string, if necessary.  */
+      free = gfc_call_free (tmpdecl);
+      tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                            dest_word_len, source_bytes);
+      tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&se->post, tmp);
+
       se->expr = tmpdecl;
-      se->string_length = dest_word_len;
+      se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
     }
   else
     {
@@ -4371,7 +5677,7 @@ scalar_transfer:
       /* Use memcpy to do the transfer.  */
       tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
       tmp = build_call_expr_loc (input_location,
-                            built_in_decls[BUILT_IN_MEMCPY], 3,
+                            builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
                             fold_convert (pvoid_type_node, tmp),
                             fold_convert (pvoid_type_node, ptr),
                             extent);
@@ -4395,14 +5701,24 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
 
   gfc_init_se (&arg1se, NULL);
   arg1 = expr->value.function.actual;
+
+  if (arg1->expr->ts.type == BT_CLASS)
+    {
+      /* Make sure that class array expressions have both a _data
+        component reference and an array reference....  */
+      if (CLASS_DATA (arg1->expr)->attr.dimension)
+       gfc_add_class_array_ref (arg1->expr);
+      /* .... whilst scalars only need the _data component.  */
+      else
+       gfc_add_data_component (arg1->expr);
+    }
+
   ss1 = gfc_walk_expr (arg1->expr);
 
   if (ss1 == gfc_ss_terminator)
     {
       /* Allocatable scalar.  */
       arg1se.want_pointer = 1;
-      if (arg1->expr->ts.type == BT_CLASS)
-       gfc_add_component_ref (arg1->expr, "$data");
       gfc_conv_expr (&arg1se, arg1->expr);
       tmp = arg1se.expr;
     }
@@ -4414,8 +5730,8 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
       tmp = gfc_conv_descriptor_data_get (arg1se.expr);
     }
 
-  tmp = fold_build2 (NE_EXPR, boolean_type_node,
-                    tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+                        fold_convert (TREE_TYPE (tmp), null_pointer_node));
   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
 }
 
@@ -4443,7 +5759,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
   gfc_init_se (&arg2se, NULL);
   arg1 = expr->value.function.actual;
   if (arg1->expr->ts.type == BT_CLASS)
-    gfc_add_component_ref (arg1->expr, "$data");
+    gfc_add_data_component (arg1->expr);
   arg2 = arg1->next;
   ss1 = gfc_walk_expr (arg1->expr);
 
@@ -4465,22 +5781,23 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
         }
       gfc_add_block_to_block (&se->pre, &arg1se.pre);
       gfc_add_block_to_block (&se->post, &arg1se.post);
-      tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
-                        fold_convert (TREE_TYPE (tmp2), null_pointer_node));
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
+                            fold_convert (TREE_TYPE (tmp2), null_pointer_node));
       se->expr = tmp;
     }
   else
     {
       /* An optional target.  */
       if (arg2->expr->ts.type == BT_CLASS)
-       gfc_add_component_ref (arg2->expr, "$data");
+       gfc_add_data_component (arg2->expr);
       ss2 = gfc_walk_expr (arg2->expr);
 
       nonzero_charlen = NULL_TREE;
       if (arg1->expr->ts.type == BT_CHARACTER)
-       nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
-                                      arg1->expr->ts.u.cl->backend_decl,
-                                      integer_zero_node);
+       nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
+                                          boolean_type_node,
+                                          arg1->expr->ts.u.cl->backend_decl,
+                                          integer_zero_node);
 
       if (ss1 == gfc_ss_terminator)
         {
@@ -4492,12 +5809,12 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
           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 = fold_build2 (EQ_EXPR, boolean_type_node,
-                            arg1se.expr, arg2se.expr);
-          tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
-                             arg1se.expr, null_pointer_node);
-          se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
-                                 tmp, tmp2);
+          tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                                arg1se.expr, arg2se.expr);
+          tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                                 arg1se.expr, null_pointer_node);
+          se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+                                     boolean_type_node, tmp, tmp2);
         }
       else
         {
@@ -4507,8 +5824,9 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
          gfc_conv_expr_lhs (&arg1se, arg1->expr);
          tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
                                            gfc_rank_cst[arg1->expr->rank - 1]);
-         nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
-                                         build_int_cst (TREE_TYPE (tmp), 0));
+         nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
+                                             boolean_type_node, tmp,
+                                             build_int_cst (TREE_TYPE (tmp), 0));
 
           /* A pointer to an array, call library function _gfor_associated.  */
           gcc_assert (ss2 != gfc_ss_terminator);
@@ -4523,15 +5841,17 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
                                      gfor_fndecl_associated, 2,
                                      arg1se.expr, arg2se.expr);
          se->expr = convert (boolean_type_node, se->expr);
-         se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
-                                 se->expr, nonzero_arraylen);
+         se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+                                     boolean_type_node, se->expr,
+                                     nonzero_arraylen);
         }
 
       /* If target is present zero character length pointers cannot
         be associated.  */
       if (nonzero_charlen != NULL_TREE)
-       se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
-                               se->expr, nonzero_charlen);
+       se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+                                   boolean_type_node,
+                                   se->expr, nonzero_charlen);
     }
 
   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
@@ -4556,8 +5876,8 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
 
   if (a->ts.type == BT_CLASS)
     {
-      gfc_add_component_ref (a, "$vptr");
-      gfc_add_component_ref (a, "$hash");
+      gfc_add_vptr_component (a);
+      gfc_add_hash_component (a);
     }
   else if (a->ts.type == BT_DERIVED)
     a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
@@ -4565,8 +5885,8 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
 
   if (b->ts.type == BT_CLASS)
     {
-      gfc_add_component_ref (b, "$vptr");
-      gfc_add_component_ref (b, "$hash");
+      gfc_add_vptr_component (b);
+      gfc_add_hash_component (b);
     }
   else if (b->ts.type == BT_DERIVED)
     b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
@@ -4575,8 +5895,8 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
   gfc_conv_expr (&se1, a);
   gfc_conv_expr (&se2, b);
 
-  tmp = fold_build2 (EQ_EXPR, boolean_type_node,
-                    se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
+  tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                        se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
 }
 
@@ -4616,7 +5936,7 @@ gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
 }
 
 
-/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
+/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function.  */
 
 static void
 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
@@ -4701,8 +6021,8 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
-  cond = fold_build2 (GT_EXPR, boolean_type_node,
-                     len, build_int_cst (TREE_TYPE (len), 0));
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                         len, build_int_cst (TREE_TYPE (len), 0));
   tmp = gfc_call_free (var);
   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
   gfc_add_expr_to_block (&se->post, tmp);
@@ -4735,20 +6055,20 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
   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));
+  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
+                         build_int_cst (ncopies_type, 0));
   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
                           "Argument NCOPIES of REPEAT intrinsic is negative "
-                          "(its value is %lld)",
+                          "(its value is %ld)",
                           fold_convert (long_integer_type_node, ncopies));
 
   /* If the source length is zero, any non negative value of NCOPIES
      is valid, and nothing happens.  */
   n = gfc_create_var (ncopies_type, "ncopies");
-  cond = fold_build2 (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);
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
+                         build_int_cst (size_type_node, 0));
+  tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
+                        build_int_cst (ncopies_type, 0), ncopies);
   gfc_add_modify (&se->pre, n, tmp);
   ncopies = n;
 
@@ -4758,24 +6078,24 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
      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);
+  max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
+                         fold_convert (size_type_node, max), slen);
   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
              ? size_type_node : ncopies_type;
-  cond = fold_build2 (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);
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+                         fold_convert (largest, ncopies),
+                         fold_convert (largest, max));
+  tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
+                        build_int_cst (size_type_node, 0));
+  cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
+                         boolean_false_node, cond);
   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
                           "Argument NCOPIES of REPEAT intrinsic is too large");
 
   /* Compute the destination length.  */
-  dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
-                     fold_convert (gfc_charlen_type_node, slen),
-                     fold_convert (gfc_charlen_type_node, ncopies));
+  dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
+                         fold_convert (gfc_charlen_type_node, slen),
+                         fold_convert (gfc_charlen_type_node, ncopies));
   type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
 
@@ -4791,31 +6111,34 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
   gfc_start_block (&body);
 
   /* Exit the loop if count >= ncopies.  */
-  cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
+  cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
+                         ncopies);
   tmp = build1_v (GOTO_EXPR, exit_label);
   TREE_USED (exit_label) = 1;
-  tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
-                    build_empty_stmt (input_location));
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+                        build_empty_stmt (input_location));
   gfc_add_expr_to_block (&body, tmp);
 
   /* Call memmove (dest + (i*slen*size), src, slen*size).  */
-  tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
-                    fold_convert (gfc_charlen_type_node, slen),
-                    fold_convert (gfc_charlen_type_node, count));
-  tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
-                    tmp, fold_convert (gfc_charlen_type_node, size));
-  tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
-                    fold_convert (pvoid_type_node, dest),
-                    fold_convert (sizetype, tmp));
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
+                        fold_convert (gfc_charlen_type_node, slen),
+                        fold_convert (gfc_charlen_type_node, count));
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
+                        tmp, fold_convert (gfc_charlen_type_node, size));
+  tmp = fold_build_pointer_plus_loc (input_location,
+                                    fold_convert (pvoid_type_node, dest), tmp);
   tmp = build_call_expr_loc (input_location,
-                        built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
-                        fold_build2 (MULT_EXPR, size_type_node, slen,
-                                     fold_convert (size_type_node, size)));
+                            builtin_decl_explicit (BUILT_IN_MEMMOVE),
+                            3, tmp, src,
+                            fold_build2_loc (input_location, MULT_EXPR,
+                                             size_type_node, slen,
+                                             fold_convert (size_type_node,
+                                                           size)));
   gfc_add_expr_to_block (&body, tmp);
 
   /* Increment count.  */
-  tmp = fold_build2 (PLUS_EXPR, ncopies_type,
-                    count, build_int_cst (TREE_TYPE (count), 1));
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
+                        count, build_int_cst (TREE_TYPE (count), 1));
   gfc_add_modify (&body, count, tmp);
 
   /* Build the loop.  */
@@ -4898,7 +6221,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 
   name = &expr->value.function.name[2];
 
-  if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
+  if (expr->rank > 0)
     {
       lib = gfc_is_intrinsic_libcall (expr);
       if (lib != 0)
@@ -5044,6 +6367,22 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_btest (se, expr);
       break;
 
+    case GFC_ISYM_BGE:
+      gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
+      break;
+
+    case GFC_ISYM_BGT:
+      gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
+      break;
+
+    case GFC_ISYM_BLE:
+      gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
+      break;
+
+    case GFC_ISYM_BLT:
+      gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
+      break;
+
     case GFC_ISYM_ACHAR:
     case GFC_ISYM_CHAR:
       gfc_conv_intrinsic_char (se, expr);
@@ -5121,6 +6460,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_dprod (se, expr);
       break;
 
+    case GFC_ISYM_DSHIFTL:
+      gfc_conv_intrinsic_dshift (se, expr, true);
+      break;
+
+    case GFC_ISYM_DSHIFTR:
+      gfc_conv_intrinsic_dshift (se, expr, false);
+      break;
+
     case GFC_ISYM_FDATE:
       gfc_conv_intrinsic_fdate (se, expr);
       break;
@@ -5129,10 +6476,18 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_fraction (se, expr);
       break;
 
+    case GFC_ISYM_IALL:
+      gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
+      break;
+
     case GFC_ISYM_IAND:
       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
       break;
 
+    case GFC_ISYM_IANY:
+      gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
+      break;
+
     case GFC_ISYM_IBCLR:
       gfc_conv_intrinsic_singlebitop (se, expr, 0);
       break;
@@ -5175,6 +6530,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
       break;
 
+    case GFC_ISYM_IPARITY:
+      gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
+      break;
+
     case GFC_ISYM_IS_IOSTAT_END:
       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
       break;
@@ -5188,11 +6547,23 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_LSHIFT:
-      gfc_conv_intrinsic_rlshift (se, expr, 0);
+      gfc_conv_intrinsic_shift (se, expr, false, false);
       break;
 
     case GFC_ISYM_RSHIFT:
-      gfc_conv_intrinsic_rlshift (se, expr, 1);
+      gfc_conv_intrinsic_shift (se, expr, true, true);
+      break;
+
+    case GFC_ISYM_SHIFTA:
+      gfc_conv_intrinsic_shift (se, expr, true, true);
+      break;
+
+    case GFC_ISYM_SHIFTL:
+      gfc_conv_intrinsic_shift (se, expr, false, false);
+      break;
+
+    case GFC_ISYM_SHIFTR:
+      gfc_conv_intrinsic_shift (se, expr, true, false);
       break;
 
     case GFC_ISYM_ISHFT:
@@ -5211,18 +6582,26 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_trailz (se, expr);
       break;
 
+    case GFC_ISYM_POPCNT:
+      gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
+      break;
+
+    case GFC_ISYM_POPPAR:
+      gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
+      break;
+
     case GFC_ISYM_LBOUND:
       gfc_conv_intrinsic_bound (se, expr, 0);
       break;
 
+    case GFC_ISYM_LCOBOUND:
+      conv_intrinsic_cobound (se, expr);
+      break;
+
     case GFC_ISYM_TRANSPOSE:
-      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);
+      /* The scalarizer has already been set up for reversed dimension access
+        order ; now we just get the argument value normally.  */
+      gfc_conv_expr (se, expr->value.function.actual->expr);
       break;
 
     case GFC_ISYM_LEN:
@@ -5249,6 +6628,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
       break;
 
+    case GFC_ISYM_MASKL:
+      gfc_conv_intrinsic_mask (se, expr, 1);
+      break;
+
+    case GFC_ISYM_MASKR:
+      gfc_conv_intrinsic_mask (se, expr, 0);
+      break;
+
     case GFC_ISYM_MAX:
       if (expr->ts.type == BT_CHARACTER)
        gfc_conv_intrinsic_minmax_char (se, expr, 1);
@@ -5268,6 +6655,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_merge (se, expr);
       break;
 
+    case GFC_ISYM_MERGE_BITS:
+      gfc_conv_intrinsic_merge_bits (se, expr);
+      break;
+
     case GFC_ISYM_MIN:
       if (expr->ts.type == BT_CHARACTER)
        gfc_conv_intrinsic_minmax_char (se, expr, -1);
@@ -5287,6 +6678,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_nearest (se, expr);
       break;
 
+    case GFC_ISYM_NORM2:
+      gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
+      break;
+
     case GFC_ISYM_NOT:
       gfc_conv_intrinsic_not (se, expr);
       break;
@@ -5295,12 +6690,16 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
       break;
 
+    case GFC_ISYM_PARITY:
+      gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
+      break;
+
     case GFC_ISYM_PRESENT:
       gfc_conv_intrinsic_present (se, expr);
       break;
 
     case GFC_ISYM_PRODUCT:
-      gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
+      gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
       break;
 
     case GFC_ISYM_RRSPACING:
@@ -5337,16 +6736,13 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_SUM:
-      gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
+      gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
       break;
 
     case GFC_ISYM_TRANSFER:
-      if (se->ss && se->ss->useflags)
-       {
-         /* Access the previously obtained result.  */
-         gfc_conv_tmp_array_ref (se);
-         gfc_advance_se_ss_chain (se);
-       }
+      if (se->ss && se->ss->info->useflags)
+       /* Access the previously obtained result.  */
+       gfc_conv_tmp_array_ref (se);
       else
        gfc_conv_intrinsic_transfer (se, expr);
       break;
@@ -5359,6 +6755,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bound (se, expr, 1);
       break;
 
+    case GFC_ISYM_UCOBOUND:
+      conv_intrinsic_cobound (se, expr);
+      break;
+
     case GFC_ISYM_XOR:
       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
       break;
@@ -5367,6 +6767,23 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_loc (se, expr);
       break;
 
+    case GFC_ISYM_THIS_IMAGE:
+      /* For num_images() == 1, handle as LCOBOUND.  */
+      if (expr->value.function.actual->expr
+         && gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+       conv_intrinsic_cobound (se, expr);
+      else
+       trans_this_image (se, expr);
+      break;
+
+    case GFC_ISYM_IMAGE_INDEX:
+      trans_image_index (se, expr);
+      break;
+
+    case GFC_ISYM_NUM_IMAGES:
+      trans_num_images (se);
+      break;
+
     case GFC_ISYM_ACCESS:
     case GFC_ISYM_CHDIR:
     case GFC_ISYM_CHMOD:
@@ -5389,6 +6806,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
     case GFC_ISYM_IERRNO:
     case GFC_ISYM_IRAND:
     case GFC_ISYM_ISATTY:
+    case GFC_ISYM_JN2:
     case GFC_ISYM_LINK:
     case GFC_ISYM_LSTAT:
     case GFC_ISYM_MALLOC:
@@ -5407,6 +6825,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
     case GFC_ISYM_TIME8:
     case GFC_ISYM_UMASK:
     case GFC_ISYM_UNLINK:
+    case GFC_ISYM_YN2:
       gfc_conv_intrinsic_funcall (se, expr);
       break;
 
@@ -5425,16 +6844,190 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 }
 
 
+static gfc_ss *
+walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
+{
+  gfc_ss *arg_ss, *tmp_ss;
+  gfc_actual_arglist *arg;
+
+  arg = expr->value.function.actual;
+
+  gcc_assert (arg->expr);
+
+  arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
+  gcc_assert (arg_ss != gfc_ss_terminator);
+
+  for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
+    {
+      if (tmp_ss->info->type != GFC_SS_SCALAR
+         && tmp_ss->info->type != GFC_SS_REFERENCE)
+       {
+         int tmp_dim;
+
+         gcc_assert (tmp_ss->dimen == 2);
+
+         /* We just invert dimensions.  */
+         tmp_dim = tmp_ss->dim[0];
+         tmp_ss->dim[0] = tmp_ss->dim[1];
+         tmp_ss->dim[1] = tmp_dim;
+       }
+
+      /* Stop when tmp_ss points to the last valid element of the chain...  */
+      if (tmp_ss->next == gfc_ss_terminator)
+       break;
+    }
+
+  /* ... so that we can attach the rest of the chain to it.  */
+  tmp_ss->next = ss;
+
+  return arg_ss;
+}
+
+
+/* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
+   This has the side effect of reversing the nested list, so there is no
+   need to call gfc_reverse_ss on it (the given list is assumed not to be
+   reversed yet).   */
+
+static gfc_ss *
+nest_loop_dimension (gfc_ss *ss, int dim)
+{
+  int ss_dim, i;
+  gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
+  gfc_loopinfo *new_loop;
+
+  gcc_assert (ss != gfc_ss_terminator);
+
+  for (; ss != gfc_ss_terminator; ss = ss->next)
+    {
+      new_ss = gfc_get_ss ();
+      new_ss->next = prev_ss;
+      new_ss->parent = ss;
+      new_ss->info = ss->info;
+      new_ss->info->refcount++;
+      if (ss->dimen != 0)
+       {
+         gcc_assert (ss->info->type != GFC_SS_SCALAR
+                     && ss->info->type != GFC_SS_REFERENCE);
+
+         new_ss->dimen = 1;
+         new_ss->dim[0] = ss->dim[dim];
+
+         gcc_assert (dim < ss->dimen);
+
+         ss_dim = --ss->dimen;
+         for (i = dim; i < ss_dim; i++)
+           ss->dim[i] = ss->dim[i + 1];
+
+         ss->dim[ss_dim] = 0;
+       }
+      prev_ss = new_ss;
+
+      if (ss->nested_ss)
+       {
+         ss->nested_ss->parent = new_ss;
+         new_ss->nested_ss = ss->nested_ss;
+       }
+      ss->nested_ss = new_ss;
+    }
+
+  new_loop = gfc_get_loopinfo ();
+  gfc_init_loopinfo (new_loop);
+
+  gcc_assert (prev_ss != NULL);
+  gcc_assert (prev_ss != gfc_ss_terminator);
+  gfc_add_ss_to_loop (new_loop, prev_ss);
+  return new_ss->parent;
+}
+
+
+/* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
+   is to be inlined.  */
+
+static gfc_ss *
+walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
+{
+  gfc_ss *tmp_ss, *tail, *array_ss;
+  gfc_actual_arglist *arg1, *arg2, *arg3;
+  int sum_dim;
+  bool scalar_mask = false;
+
+  /* The rank of the result will be determined later.  */
+  arg1 = expr->value.function.actual;
+  arg2 = arg1->next;
+  arg3 = arg2->next;
+  gcc_assert (arg3 != NULL);
+
+  if (expr->rank == 0)
+    return ss;
+
+  tmp_ss = gfc_ss_terminator;
+
+  if (arg3->expr)
+    {
+      gfc_ss *mask_ss;
+
+      mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
+      if (mask_ss == tmp_ss)
+       scalar_mask = 1;
+
+      tmp_ss = mask_ss;
+    }
+
+  array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
+  gcc_assert (array_ss != tmp_ss);
+
+  /* Odd thing: If the mask is scalar, it is used by the frontend after
+     the array (to make an if around the nested loop). Thus it shall
+     be after array_ss once the gfc_ss list is reversed.  */
+  if (scalar_mask)
+    tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
+  else
+    tmp_ss = array_ss;
+
+  /* "Hide" the dimension on which we will sum in the first arg's scalarization
+     chain.  */
+  sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
+  tail = nest_loop_dimension (tmp_ss, sum_dim);
+  tail->next = ss;
+
+  return tmp_ss;
+}
+
+
+static gfc_ss *
+walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
+{
+
+  switch (expr->value.function.isym->id)
+    {
+      case GFC_ISYM_PRODUCT:
+      case GFC_ISYM_SUM:
+       return walk_inline_intrinsic_arith (ss, expr);
+
+      case GFC_ISYM_TRANSPOSE:
+       return walk_inline_intrinsic_transpose (ss, expr);
+
+      default:
+       gcc_unreachable ();
+    }
+  gcc_unreachable ();
+}
+
+
 /* This generates code to execute before entering the scalarization loop.
    Currently does nothing.  */
 
 void
 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
 {
-  switch (ss->expr->value.function.isym->id)
+  switch (ss->info->expr->value.function.isym->id)
     {
     case GFC_ISYM_UBOUND:
     case GFC_ISYM_LBOUND:
+    case GFC_ISYM_UCOBOUND:
+    case GFC_ISYM_LCOBOUND:
+    case GFC_ISYM_THIS_IMAGE:
       break;
 
     default:
@@ -5443,25 +7036,20 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
 }
 
 
-/* UBOUND and LBOUND intrinsics with one parameter are expanded into code
-   inside the scalarization loop.  */
+/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
+   are expanded into code inside the scalarization loop.  */
 
 static gfc_ss *
 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
 {
-  gfc_ss *newss;
+  if (expr->value.function.actual->expr->ts.type == BT_CLASS)
+    gfc_add_class_array_ref (expr->value.function.actual->expr);
 
   /* The two argument version returns a scalar.  */
   if (expr->value.function.actual->next->expr)
     return ss;
 
-  newss = gfc_get_ss ();
-  newss->type = GFC_SS_INTRINSIC;
-  newss->expr = expr;
-  newss->next = ss;
-  newss->data.info.dimen = 1;
-
-  return newss;
+  return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
 }
 
 
@@ -5470,17 +7058,43 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
 static gfc_ss *
 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
 {
-  gfc_ss *newss;
-
   gcc_assert (expr->rank > 0);
+  return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
+}
+
+
+/* Return whether the function call expression EXPR will be expanded
+   inline by gfc_conv_intrinsic_function.  */
+
+bool
+gfc_inline_intrinsic_function_p (gfc_expr *expr)
+{
+  gfc_actual_arglist *args;
+
+  if (!expr->value.function.isym)
+    return false;
+
+  switch (expr->value.function.isym->id)
+    {
+    case GFC_ISYM_PRODUCT:
+    case GFC_ISYM_SUM:
+      /* Disable inline expansion if code size matters.  */
+      if (optimize_size)
+       return false;
+
+      args = expr->value.function.actual;
+      /* We need to be able to subset the SUM argument at compile-time.  */
+      if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT)
+       return false;
 
-  newss = gfc_get_ss ();
-  newss->type = GFC_SS_FUNCTION;
-  newss->expr = expr;
-  newss->next = ss;
-  newss->data.info.dimen = expr->rank;
+      return true;
 
-  return newss;
+    case GFC_ISYM_TRANSPOSE:
+      return true;
+
+    default:
+      return false;
+    }
 }
 
 
@@ -5494,21 +7108,30 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
   gcc_assert (expr->rank > 0);
 
+  if (gfc_inline_intrinsic_function_p (expr))
+    return 0;
+
   switch (expr->value.function.isym->id)
     {
     case GFC_ISYM_ALL:
     case GFC_ISYM_ANY:
     case GFC_ISYM_COUNT:
+    case GFC_ISYM_JN2:
+    case GFC_ISYM_IANY:
+    case GFC_ISYM_IALL:
+    case GFC_ISYM_IPARITY:
     case GFC_ISYM_MATMUL:
     case GFC_ISYM_MAXLOC:
     case GFC_ISYM_MAXVAL:
     case GFC_ISYM_MINLOC:
     case GFC_ISYM_MINVAL:
+    case GFC_ISYM_NORM2:
+    case GFC_ISYM_PARITY:
     case GFC_ISYM_PRODUCT:
     case GFC_ISYM_SUM:
     case GFC_ISYM_SHAPE:
     case GFC_ISYM_SPREAD:
-    case GFC_ISYM_TRANSPOSE:
+    case GFC_ISYM_YN2:
       /* Ignore absent optional parameters.  */
       return 1;
 
@@ -5533,11 +7156,15 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
   gcc_assert (isym);
 
   if (isym->elemental)
-    return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
+    return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
+                                            NULL, GFC_SS_SCALAR);
 
   if (expr->rank == 0)
     return ss;
 
+  if (gfc_inline_intrinsic_function_p (expr))
+    return walk_inline_intrinsic_function (ss, expr);
+
   if (gfc_is_intrinsic_libcall (expr))
     return gfc_walk_intrinsic_libfunc (ss, expr);
 
@@ -5545,7 +7172,10 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
   switch (isym->id)
     {
     case GFC_ISYM_LBOUND:
+    case GFC_ISYM_LCOBOUND:
     case GFC_ISYM_UBOUND:
+    case GFC_ISYM_UCOBOUND:
+    case GFC_ISYM_THIS_IMAGE:
       return gfc_walk_intrinsic_bound (ss, expr);
 
     case GFC_ISYM_TRANSFER:
@@ -5560,41 +7190,223 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
 }
 
 
-tree
-gfc_conv_intrinsic_move_alloc (gfc_code *code)
+static tree
+conv_intrinsic_atomic_def (gfc_code *code)
 {
-  if (code->ext.actual->expr->rank == 0)
-    {
-      /* Scalar arguments: Generate pointer assignments.  */
-      gfc_expr *from, *to;
-      stmtblock_t block;
-      tree tmp;
+  gfc_se atom, value;
+  stmtblock_t block;
 
-      from = code->ext.actual->expr;
-      to = code->ext.actual->next->expr;
+  gfc_init_se (&atom, NULL);
+  gfc_init_se (&value, NULL);
+  gfc_conv_expr (&atom, code->ext.actual->expr);
+  gfc_conv_expr (&value, code->ext.actual->next->expr);
 
-      gfc_start_block (&block);
+  gfc_init_block (&block);
+  gfc_add_modify (&block, atom.expr,
+                 fold_convert (TREE_TYPE (atom.expr), value.expr));
+  return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_atomic_ref (gfc_code *code)
+{
+  gfc_se atom, value;
+  stmtblock_t block;
+
+  gfc_init_se (&atom, NULL);
+  gfc_init_se (&value, NULL);
+  gfc_conv_expr (&value, code->ext.actual->expr);
+  gfc_conv_expr (&atom, code->ext.actual->next->expr);
+
+  gfc_init_block (&block);
+  gfc_add_modify (&block, value.expr,
+                 fold_convert (TREE_TYPE (value.expr), atom.expr));
+  return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_move_alloc (gfc_code *code)
+{
+  stmtblock_t block;
+  gfc_expr *from_expr, *to_expr;
+  gfc_expr *to_expr2, *from_expr2 = NULL;
+  gfc_se from_se, to_se;
+  gfc_ss *from_ss, *to_ss;
+  tree tmp;
+
+  gfc_start_block (&block);
+
+  from_expr = code->ext.actual->expr;
+  to_expr = code->ext.actual->next->expr;
 
-      if (to->ts.type == BT_CLASS)
-       tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
+  gfc_init_se (&from_se, NULL);
+  gfc_init_se (&to_se, NULL);
+
+  gcc_assert (from_expr->ts.type != BT_CLASS
+             || to_expr->ts.type == BT_CLASS);
+
+  if (from_expr->rank == 0)
+    {
+      if (from_expr->ts.type != BT_CLASS)
+       from_expr2 = from_expr;
       else
-       tmp = gfc_trans_pointer_assignment (to, from);
-      gfc_add_expr_to_block (&block, tmp);
+       {
+         from_expr2 = gfc_copy_expr (from_expr);
+         gfc_add_data_component (from_expr2);
+       }
 
-      if (from->ts.type == BT_CLASS)
-       tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
-                                     EXEC_POINTER_ASSIGN);
+      if (to_expr->ts.type != BT_CLASS)
+       to_expr2 = to_expr;
       else
-       tmp = gfc_trans_pointer_assignment (from,
-                                           gfc_get_null_expr (NULL));
+       {
+         to_expr2 = gfc_copy_expr (to_expr);
+         gfc_add_data_component (to_expr2);
+       }
+
+      from_se.want_pointer = 1;
+      to_se.want_pointer = 1;
+      gfc_conv_expr (&from_se, from_expr2);
+      gfc_conv_expr (&to_se, to_expr2);
+      gfc_add_block_to_block (&block, &from_se.pre);
+      gfc_add_block_to_block (&block, &to_se.pre);
+
+      /* Deallocate "to".  */
+      tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
+                                              to_expr2, to_expr->ts);
       gfc_add_expr_to_block (&block, tmp);
 
+      /* Assign (_data) pointers.  */
+      gfc_add_modify_loc (input_location, &block, to_se.expr,
+                         fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+
+      /* Set "from" to NULL.  */
+      gfc_add_modify_loc (input_location, &block, from_se.expr,
+                         fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
+
+      gfc_add_block_to_block (&block, &from_se.post);
+      gfc_add_block_to_block (&block, &to_se.post);
+
+      /* Set _vptr.  */
+      if (to_expr->ts.type == BT_CLASS)
+       {
+         gfc_free_expr (to_expr2);
+         gfc_init_se (&to_se, NULL);
+         to_se.want_pointer = 1;
+         gfc_add_vptr_component (to_expr);
+         gfc_conv_expr (&to_se, to_expr);
+
+         if (from_expr->ts.type == BT_CLASS)
+           {
+             gfc_free_expr (from_expr2);
+             gfc_init_se (&from_se, NULL);
+             from_se.want_pointer = 1;
+             gfc_add_vptr_component (from_expr);
+             gfc_conv_expr (&from_se, from_expr);
+             tmp = from_se.expr;
+           }
+         else
+           {
+             gfc_symbol *vtab;
+             vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+             gcc_assert (vtab);
+             tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+           }
+
+         gfc_add_modify_loc (input_location, &block, to_se.expr,
+                             fold_convert (TREE_TYPE (to_se.expr), tmp));
+       }
+
       return gfc_finish_block (&block);
     }
-  else
-    /* Array arguments: Generate library code.  */
-    return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
+
+  /* Update _vptr component.  */
+  if (to_expr->ts.type == BT_CLASS)
+    {
+      to_se.want_pointer = 1;
+      to_expr2 = gfc_copy_expr (to_expr);
+      gfc_add_vptr_component (to_expr2);
+      gfc_conv_expr (&to_se, to_expr2);
+
+      if (from_expr->ts.type == BT_CLASS)
+       {
+         from_se.want_pointer = 1;
+         from_expr2 = gfc_copy_expr (from_expr);
+         gfc_add_vptr_component (from_expr2);
+         gfc_conv_expr (&from_se, from_expr2);
+         tmp = from_se.expr;
+       }
+      else
+       {
+         gfc_symbol *vtab;
+         vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+         gcc_assert (vtab);
+         tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+       }
+
+      gfc_add_modify_loc (input_location, &block, to_se.expr,
+                         fold_convert (TREE_TYPE (to_se.expr), tmp));
+      gfc_free_expr (to_expr2);
+      gfc_init_se (&to_se, NULL);
+
+      if (from_expr->ts.type == BT_CLASS)
+       {
+         gfc_free_expr (from_expr2);
+         gfc_init_se (&from_se, NULL);
+       }
+    }
+
+  /* Deallocate "to".  */
+  to_ss = gfc_walk_expr (to_expr);
+  from_ss = gfc_walk_expr (from_expr);
+  gfc_conv_expr_descriptor (&to_se, to_expr, to_ss);
+  gfc_conv_expr_descriptor (&from_se, from_expr, from_ss);
+
+  tmp = gfc_conv_descriptor_data_get (to_se.expr);
+  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
+                                   NULL_TREE, true, to_expr, false);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Move the pointer and update the array descriptor data.  */
+  gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
+
+  /* Set "to" to NULL.  */
+  tmp = gfc_conv_descriptor_data_get (from_se.expr);
+  gfc_add_modify_loc (input_location, &block, tmp,
+                     fold_convert (TREE_TYPE (tmp), null_pointer_node));
+
+  return gfc_finish_block (&block);
 }
 
 
+tree
+gfc_conv_intrinsic_subroutine (gfc_code *code)
+{
+  tree res;
+
+  gcc_assert (code->resolved_isym);
+
+  switch (code->resolved_isym->id)
+    {
+    case GFC_ISYM_MOVE_ALLOC:
+      res = conv_intrinsic_move_alloc (code);
+      break;
+
+    case GFC_ISYM_ATOMIC_DEF:
+      res = conv_intrinsic_atomic_def (code);
+      break;
+
+    case GFC_ISYM_ATOMIC_REF:
+      res = conv_intrinsic_atomic_ref (code);
+      break;
+
+    default:
+      res = NULL_TREE;
+      break;
+    }
+
+  return res;
+}
+
 #include "gt-fortran-trans-intrinsic.h"