gcc/fortran:

[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-intrinsic.c

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 9d6a0b7..c10d44a 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1,5 +1,6 @@
 /* Intrinsic translation
 /* Intrinsic translation

-   Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+   Free Software Foundation, Inc.

    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 


@@ -7,7 +8,7 @@ This file is part of GCC.
 
 GCC is free software; you can redistribute it and/or modify it under
 the terms of the GNU General Public License as published by the Free
 
 GCC is free software; you can redistribute it and/or modify it under
 the terms of the GNU General Public License as published by the Free

-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later

 version.
 
 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
 version.
 
 GCC is distributed in the hope that it will be useful, but WITHOUT ANY


@@ -16,15 +17,15 @@ FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 for more details.
 
 You should have received a copy of the GNU General Public License
 for more details.
 
 You should have received a copy of the GNU General Public License

-along with GCC; see the file COPYING.  If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA.  */
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */

 
 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics.  */
 
 #include "config.h"
 #include "system.h"
 #include "coretypes.h"
 
 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics.  */
 
 #include "config.h"
 #include "system.h"
 #include "coretypes.h"

+#include "tm.h"

 #include "tree.h"
 #include "ggc.h"
 #include "toplev.h"
 #include "tree.h"
 #include "ggc.h"
 #include "toplev.h"


@@ -48,7 +49,7 @@ typedef struct gfc_intrinsic_map_t    GTY(())
 {
   /* The explicit enum is required to work around inadequacies in the
      garbage collection/gengtype parsing mechanism.  */
 {
   /* The explicit enum is required to work around inadequacies in the
      garbage collection/gengtype parsing mechanism.  */

-  enum gfc_generic_isym_id id;
+  enum gfc_isym_id id;

 
   /* Enum value from the "language-independent", aka C-centric, part
      of gcc, or END_BUILTINS of no such value set.  */
 
   /* Enum value from the "language-independent", aka C-centric, part
      of gcc, or END_BUILTINS of no such value set.  */


@@ -129,7 +130,9 @@ static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
   /* Functions in libgfortran.  */
   LIBF_FUNCTION (FRACTION, "fraction", false),
   LIBF_FUNCTION (NEAREST, "nearest", false),
   /* Functions in libgfortran.  */
   LIBF_FUNCTION (FRACTION, "fraction", false),
   LIBF_FUNCTION (NEAREST, "nearest", false),

+  LIBF_FUNCTION (RRSPACING, "rrspacing", false),

   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),

+  LIBF_FUNCTION (SPACING, "spacing", false),

 
   /* End the list.  */
   LIBF_FUNCTION (NONE, NULL, false)
 
   /* End the list.  */
   LIBF_FUNCTION (NONE, NULL, false)


@@ -158,28 +161,38 @@ typedef struct
 }
 real_compnt_info;
 
 }
 real_compnt_info;
 

+enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };

 
 

-/* Evaluate the arguments to an intrinsic function.  */
+/* Evaluate the arguments to an intrinsic function.  The value
+   of NARGS may be less than the actual number of arguments in EXPR
+   to allow optional "KIND" arguments that are not included in the
+   generated code to be ignored.  */

 
 

-static tree
-gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
+static void
+gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
+                                 tree *argarray, int nargs)

 {
   gfc_actual_arglist *actual;
   gfc_expr *e;
   gfc_intrinsic_arg  *formal;
   gfc_se argse;
 {
   gfc_actual_arglist *actual;
   gfc_expr *e;
   gfc_intrinsic_arg  *formal;
   gfc_se argse;

-  tree args;
+  int curr_arg;

 
 

-  args = NULL_TREE;

   formal = expr->value.function.isym->formal;
   formal = expr->value.function.isym->formal;

+  actual = expr->value.function.actual;

 
 

-  for (actual = expr->value.function.actual; actual; actual = actual->next,
-       formal = formal ? formal->next : NULL)
+   for (curr_arg = 0; curr_arg < nargs; curr_arg++,
+       actual = actual->next,
+       formal = formal ? formal->next : NULL)

     {
     {

+      gcc_assert (actual);

       e = actual->expr;
       /* Skip omitted optional arguments.  */
       if (!e)
       e = actual->expr;
       /* Skip omitted optional arguments.  */
       if (!e)

-       continue;
+       {
+         --curr_arg;
+         continue;
+       }

 
       /* Evaluate the parameter.  This will substitute scalarized
          references automatically.  */
 
       /* Evaluate the parameter.  This will substitute scalarized
          references automatically.  */


@@ -189,24 +202,47 @@ gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
        {
          gfc_conv_expr (&argse, e);
          gfc_conv_string_parameter (&argse);
        {
          gfc_conv_expr (&argse, e);
          gfc_conv_string_parameter (&argse);

-         args = gfc_chainon_list (args, argse.string_length);
+          argarray[curr_arg++] = argse.string_length;
+         gcc_assert (curr_arg < nargs);

        }
       else
         gfc_conv_expr_val (&argse, e);
 
       /* If an optional argument is itself an optional dummy argument,
         check its presence and substitute a null if absent.  */
        }
       else
         gfc_conv_expr_val (&argse, e);
 
       /* If an optional argument is itself an optional dummy argument,
         check its presence and substitute a null if absent.  */

-      if (e->expr_type ==EXPR_VARIABLE
+      if (e->expr_type == EXPR_VARIABLE

            && e->symtree->n.sym->attr.optional
            && formal
            && formal->optional)
            && e->symtree->n.sym->attr.optional
            && formal
            && formal->optional)

-       gfc_conv_missing_dummy (&argse, e, formal->ts);
+       gfc_conv_missing_dummy (&argse, e, formal->ts, 0);

 
       gfc_add_block_to_block (&se->pre, &argse.pre);
       gfc_add_block_to_block (&se->post, &argse.post);
 
       gfc_add_block_to_block (&se->pre, &argse.pre);
       gfc_add_block_to_block (&se->post, &argse.post);

-      args = gfc_chainon_list (args, argse.expr);
+      argarray[curr_arg] = argse.expr;

     }
     }

-  return args;
+}
+
+/* Count the number of actual arguments to the intrinsic function EXPR
+   including any "hidden" string length arguments.  */
+
+static unsigned int
+gfc_intrinsic_argument_list_length (gfc_expr *expr)
+{
+  int n = 0;
+  gfc_actual_arglist *actual;
+
+  for (actual = expr->value.function.actual; actual; actual = actual->next)
+    {
+      if (!actual->expr)
+       continue;
+
+      if (actual->expr->ts.type == BT_CHARACTER)
+       n += 2;
+      else
+       n++;
+    }
+
+  return n;

 }
 
 
 }
 
 


@@ -217,26 +253,31 @@ static void
 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 {
   tree type;
 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 {
   tree type;

-  tree arg;
+  tree *args;
+  int nargs;

 
 

-  /* Evaluate the argument.  */
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  args = alloca (sizeof (tree) * nargs);
+
+  /* Evaluate all the arguments passed. Whilst we're only interested in the 
+     first one here, there are other parts of the front-end that assume this 
+     and will trigger an ICE if it's not the case.  */

   type = gfc_typenode_for_spec (&expr->ts);
   gcc_assert (expr->value.function.actual->expr);
   type = gfc_typenode_for_spec (&expr->ts);
   gcc_assert (expr->value.function.actual->expr);

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg = TREE_VALUE (arg);
+  gfc_conv_intrinsic_function_args (se, expr, args, nargs);

 
   /* Conversion from complex to non-complex involves taking the real
      component of the value.  */
 
   /* Conversion from complex to non-complex involves taking the real
      component of the value.  */

-  if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
+  if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE

       && expr->ts.type != BT_COMPLEX)
     {
       tree artype;
 
       && expr->ts.type != BT_COMPLEX)
     {
       tree artype;
 

-      artype = TREE_TYPE (TREE_TYPE (arg));
-      arg = build1 (REALPART_EXPR, artype, arg);
+      artype = TREE_TYPE (TREE_TYPE (args[0]));
+      args[0] = build1 (REALPART_EXPR, artype, args[0]);

     }
 
     }
 

-  se->expr = convert (type, arg);
+  se->expr = convert (type, args[0]);

 }
 
 /* This is needed because the gcc backend only implements
 }
 
 /* This is needed because the gcc backend only implements


@@ -268,34 +309,41 @@ build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 }
 
 
 }
 
 

-/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
-   NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)).  */
+/* Round to nearest integer, away from zero.  */

 
 static tree
 
 static tree

-build_round_expr (stmtblock_t * pblock, tree arg, tree type)
+build_round_expr (tree arg, tree restype)

 {
 {

-  tree tmp;
-  tree cond;
-  tree neg;
-  tree pos;

   tree argtype;
   tree argtype;

-  REAL_VALUE_TYPE r;
+  tree fn;
+  bool longlong;
+  int argprec, resprec;

 
   argtype = TREE_TYPE (arg);
 
   argtype = TREE_TYPE (arg);

-  arg = gfc_evaluate_now (arg, pblock);
-
-  real_from_string (&r, "0.5");
-  pos = build_real (argtype, r);
-
-  real_from_string (&r, "-0.5");
-  neg = build_real (argtype, r);
+  argprec = TYPE_PRECISION (argtype);
+  resprec = TYPE_PRECISION (restype);
+
+  /* Depending on the type of the result, choose the long int intrinsic
+     (lround family) or long long intrinsic (llround).  We might also
+     need to convert the result afterwards.  */
+  if (resprec <= LONG_TYPE_SIZE)
+    longlong = false;
+  else if (resprec <= LONG_LONG_TYPE_SIZE)
+    longlong = true;
+  else
+    gcc_unreachable ();

 
 

-  tmp = gfc_build_const (argtype, integer_zero_node);
-  cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp);
+  /* Now, depending on the argument type, we choose between intrinsics.  */
+  if (argprec == TYPE_PRECISION (float_type_node))
+    fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
+  else if (argprec == TYPE_PRECISION (double_type_node))
+    fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
+  else if (argprec == TYPE_PRECISION (long_double_type_node))
+    fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
+  else
+    gcc_unreachable ();

 
 

-  tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg);
-  tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp);
-  return fold_build1 (FIX_TRUNC_EXPR, type, tmp);
+  return fold_convert (restype, build_call_expr (fn, 1, arg));

 }
 
 
 }
 
 


@@ -305,23 +353,28 @@ build_round_expr (stmtblock_t * pblock, tree arg, tree type)
 
 static tree
 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
 
 static tree
 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,

-               enum tree_code op)
+               enum rounding_mode op)

 {
   switch (op)
     {
 {
   switch (op)
     {

-    case FIX_FLOOR_EXPR:
+    case RND_FLOOR:

       return build_fixbound_expr (pblock, arg, type, 0);
       break;
 
       return build_fixbound_expr (pblock, arg, type, 0);
       break;
 

-    case FIX_CEIL_EXPR:
+    case RND_CEIL:

       return build_fixbound_expr (pblock, arg, type, 1);
       break;
 
       return build_fixbound_expr (pblock, arg, type, 1);
       break;
 

-    case FIX_ROUND_EXPR:
-      return build_round_expr (pblock, arg, type);
+    case RND_ROUND:
+      return build_round_expr (arg, type);
+      break;
+
+    case RND_TRUNC:
+      return build1 (FIX_TRUNC_EXPR, type, arg);
+      break;

 
     default:
 
     default:

-      return build1 (op, type, arg);
+      gcc_unreachable ();

     }
 }
 
     }
 }
 


@@ -336,24 +389,25 @@ build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
    */
 
 static void
    */
 
 static void

-gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
+gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)

 {
   tree type;
   tree itype;
 {
   tree type;
   tree itype;

-  tree arg;
+  tree arg[2];

   tree tmp;
   tree cond;
   mpfr_t huge;
   tree tmp;
   tree cond;
   mpfr_t huge;

-  int n;
+  int n, nargs;

   int kind;
 
   kind = expr->ts.kind;
   int kind;
 
   kind = expr->ts.kind;

+  nargs =  gfc_intrinsic_argument_list_length (expr);

 
   n = END_BUILTINS;
   /* We have builtin functions for some cases.  */
   switch (op)
     {
 
   n = END_BUILTINS;
   /* We have builtin functions for some cases.  */
   switch (op)
     {

-    case FIX_ROUND_EXPR:
+    case RND_ROUND:

       switch (kind)
        {
        case 4:
       switch (kind)
        {
        case 4:


@@ -371,7 +425,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
        }
       break;
 
        }
       break;
 

-    case FIX_TRUNC_EXPR:
+    case RND_TRUNC:

       switch (kind)
        {
        case 4:
       switch (kind)
        {
        case 4:


@@ -395,21 +449,20 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
 
   /* Evaluate the argument.  */
   gcc_assert (expr->value.function.actual->expr);
 
   /* Evaluate the argument.  */
   gcc_assert (expr->value.function.actual->expr);

-  arg = gfc_conv_intrinsic_function_args (se, expr);
+  gfc_conv_intrinsic_function_args (se, expr, arg, nargs);

 
   /* Use a builtin function if one exists.  */
   if (n != END_BUILTINS)
     {
       tmp = built_in_decls[n];
 
   /* Use a builtin function if one exists.  */
   if (n != END_BUILTINS)
     {
       tmp = built_in_decls[n];

-      se->expr = build_function_call_expr (tmp, arg);
+      se->expr = build_call_expr (tmp, 1, arg[0]);

       return;
     }
 
   /* This code is probably redundant, but we'll keep it lying around just
      in case.  */
   type = gfc_typenode_for_spec (&expr->ts);
       return;
     }
 
   /* This code is probably redundant, but we'll keep it lying around just
      in case.  */
   type = gfc_typenode_for_spec (&expr->ts);

-  arg = TREE_VALUE (arg);
-  arg = gfc_evaluate_now (arg, &se->pre);
+  arg[0] = gfc_evaluate_now (arg[0], &se->pre);

 
   /* Test if the value is too large to handle sensibly.  */
   gfc_set_model_kind (kind);
 
   /* Test if the value is too large to handle sensibly.  */
   gfc_set_model_kind (kind);


@@ -417,17 +470,17 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code 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);
   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);

-  cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
+  cond = build2 (LT_EXPR, boolean_type_node, arg[0], tmp);

 
   mpfr_neg (huge, huge, GFC_RND_MODE);
   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 
   mpfr_neg (huge, huge, GFC_RND_MODE);
   tmp = gfc_conv_mpfr_to_tree (huge, kind);

-  tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
+  tmp = build2 (GT_EXPR, boolean_type_node, arg[0], tmp);

   cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
   itype = gfc_get_int_type (kind);
 
   cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
   itype = gfc_get_int_type (kind);
 

-  tmp = build_fix_expr (&se->pre, arg, itype, op);
+  tmp = build_fix_expr (&se->pre, arg[0], itype, op);

   tmp = convert (type, tmp);
   tmp = convert (type, tmp);

-  se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
+  se->expr = build3 (COND_EXPR, type, cond, tmp, arg[0]);

   mpfr_clear (huge);
 }
 
   mpfr_clear (huge);
 }
 


@@ -435,36 +488,40 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
 /* Convert to an integer using the specified rounding mode.  */
 
 static void
 /* Convert to an integer using the specified rounding mode.  */
 
 static void

-gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)

 {
   tree type;
 {
   tree type;

-  tree arg;
+  tree *args;
+  int nargs;

 
 

-  /* Evaluate the argument.  */
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  args = alloca (sizeof (tree) * nargs);
+
+  /* Evaluate the argument, we process all arguments even though we only 
+     use the first one for code generation purposes.  */

   type = gfc_typenode_for_spec (&expr->ts);
   gcc_assert (expr->value.function.actual->expr);
   type = gfc_typenode_for_spec (&expr->ts);
   gcc_assert (expr->value.function.actual->expr);

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg = TREE_VALUE (arg);
+  gfc_conv_intrinsic_function_args (se, expr, args, nargs);

 
 

-  if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
+  if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)

     {
       /* Conversion to a different integer kind.  */
     {
       /* Conversion to a different integer kind.  */

-      se->expr = convert (type, arg);
+      se->expr = convert (type, args[0]);

     }
   else
     {
       /* Conversion from complex to non-complex involves taking the real
          component of the value.  */
     }
   else
     {
       /* Conversion from complex to non-complex involves taking the real
          component of the value.  */

-      if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
+      if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE

          && expr->ts.type != BT_COMPLEX)
        {
          tree artype;
 
          && expr->ts.type != BT_COMPLEX)
        {
          tree artype;
 

-         artype = TREE_TYPE (TREE_TYPE (arg));
-         arg = build1 (REALPART_EXPR, artype, arg);
+         artype = TREE_TYPE (TREE_TYPE (args[0]));
+         args[0] = build1 (REALPART_EXPR, artype, args[0]);

        }
 
        }
 

-      se->expr = build_fix_expr (&se->pre, arg, type, op);
+      se->expr = build_fix_expr (&se->pre, args[0], type, op);

     }
 }
 
     }
 }
 


@@ -476,8 +533,7 @@ gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 {
   tree arg;
 
 {
   tree arg;
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg = TREE_VALUE (arg);
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);

   se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 }
 
   se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 }
 


@@ -489,8 +545,7 @@ gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 {
   tree arg;
 
 {
   tree arg;
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg = TREE_VALUE (arg);
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);

   se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 }
 
   se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 }
 


@@ -590,12 +645,18 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 
   if (m->libm_name)
     {
 
   if (m->libm_name)
     {

-      gcc_assert (ts->kind == 4 || ts->kind == 8 || ts->kind == 10
-                 || ts->kind == 16);
-      snprintf (name, sizeof (name), "%s%s%s",
-               ts->type == BT_COMPLEX ? "c" : "",
-               m->name,
-               ts->kind == 4 ? "f" : "");
+      if (ts->kind == 4)
+       snprintf (name, sizeof (name), "%s%s%s",
+               ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
+      else if (ts->kind == 8)
+       snprintf (name, sizeof (name), "%s%s",
+               ts->type == BT_COMPLEX ? "c" : "", m->name);
+      else
+       {
+         gcc_assert (ts->kind == 10 || ts->kind == 16);
+         snprintf (name, sizeof (name), "%s%s%s",
+               ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
+       }

     }
   else
     {
     }
   else
     {


@@ -634,11 +695,13 @@ static void
 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 {
   gfc_intrinsic_map_t *m;
 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 {
   gfc_intrinsic_map_t *m;

-  tree args;

   tree fndecl;
   tree fndecl;

-  gfc_generic_isym_id id;
+  tree rettype;
+  tree *args;
+  unsigned int num_args;
+  gfc_isym_id id;

 
 

-  id = expr->value.function.isym->generic_id;
+  id = expr->value.function.isym->id;

   /* Find the entry for this function.  */
   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
     {
   /* Find the entry for this function.  */
   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
     {


@@ -653,20 +716,26 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
     }
 
   /* Get the decl and generate the call.  */
     }
 
   /* Get the decl and generate the call.  */

-  args = gfc_conv_intrinsic_function_args (se, expr);
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  args = alloca (sizeof (tree) * num_args);
+
+  gfc_conv_intrinsic_function_args (se, expr, args, num_args);

   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);

-  se->expr = build_function_call_expr (fndecl, args);
+  rettype = TREE_TYPE (TREE_TYPE (fndecl));
+
+  fndecl = build_addr (fndecl, current_function_decl);
+  se->expr = build_call_array (rettype, fndecl, num_args, args);

 }
 
 /* Generate code for EXPONENT(X) intrinsic function.  */
 
 static void
 }
 
 /* Generate code for EXPONENT(X) intrinsic function.  */
 
 static void

-gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)

 {
 {

-  tree args, fndecl;
+  tree arg, fndecl, type;

   gfc_expr *a1;
 
   gfc_expr *a1;
 

-  args = gfc_conv_intrinsic_function_args (se, expr);
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);

 
   a1 = expr->value.function.actual->expr;
   switch (a1->ts.kind)
 
   a1 = expr->value.function.actual->expr;
   switch (a1->ts.kind)


@@ -687,7 +756,9 @@ gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
       gcc_unreachable ();
     }
 
       gcc_unreachable ();
     }
 

-  se->expr = build_function_call_expr (fndecl, args);
+  /* Convert it to the required type.  */
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = fold_convert (type, build_call_expr (fndecl, 1, arg));

 }
 
 /* Evaluate a single upper or lower bound.  */
 }
 
 /* Evaluate a single upper or lower bound.  */


@@ -702,10 +773,13 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   tree type;
   tree bound;
   tree tmp;
   tree type;
   tree bound;
   tree tmp;

-  tree cond;
+  tree cond, cond1, cond2, cond3, cond4, size;
+  tree ubound;
+  tree lbound;

   gfc_se argse;
   gfc_ss *ss;
   gfc_se argse;
   gfc_ss *ss;

-  int i;
+  gfc_array_spec * as;
+  gfc_ref *ref;

 
   arg = expr->value.function.actual;
   arg2 = arg->next;
 
   arg = expr->value.function.actual;
   arg2 = arg->next;


@@ -747,9 +821,14 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
   if (INTEGER_CST_P (bound))
     {
 
   if (INTEGER_CST_P (bound))
     {

-      gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
-      i = TREE_INT_CST_LOW (bound);
-      gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
+      int hi, low;
+
+      hi = TREE_INT_CST_HIGH (bound);
+      low = TREE_INT_CST_LOW (bound);
+      if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+       gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+                  "dimension index", upper ? "UBOUND" : "LBOUND",
+                  &expr->where);

     }
   else
     {
     }
   else
     {


@@ -761,14 +840,119 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);

-          gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, NULL);
+          gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_msg_fault);

         }
     }
 
         }
     }
 

-  if (upper)
-    se->expr = gfc_conv_descriptor_ubound(desc, bound);
+  ubound = gfc_conv_descriptor_ubound (desc, bound);
+  lbound = gfc_conv_descriptor_lbound (desc, bound);
+  
+  /* Follow any component references.  */
+  if (arg->expr->expr_type == EXPR_VARIABLE
+      || arg->expr->expr_type == EXPR_CONSTANT)
+    {
+      as = arg->expr->symtree->n.sym->as;
+      for (ref = arg->expr->ref; ref; ref = ref->next)
+       {
+         switch (ref->type)
+           {
+           case REF_COMPONENT:
+             as = ref->u.c.component->as;
+             continue;
+
+           case REF_SUBSTRING:
+             continue;
+
+           case REF_ARRAY:
+             {
+               switch (ref->u.ar.type)
+                 {
+                 case AR_ELEMENT:
+                 case AR_SECTION:
+                 case AR_UNKNOWN:
+                   as = NULL;
+                   continue;
+
+                 case AR_FULL:
+                   break;
+                 }
+             }
+           }
+       }
+    }
+  else
+    as = NULL;
+
+  /* 13.14.53: Result value for LBOUND
+
+     Case (i): For an array section or for an array expression other than a
+               whole array or array structure component, LBOUND(ARRAY, DIM)
+               has the value 1.  For a whole array or array structure
+               component, LBOUND(ARRAY, DIM) has the value:
+                 (a) equal to the lower bound for subscript DIM of ARRAY if
+                     dimension DIM of ARRAY does not have extent zero
+                     or if ARRAY is an assumed-size array of rank DIM,
+              or (b) 1 otherwise.
+
+     13.14.113: Result value for UBOUND
+
+     Case (i): For an array section or for an array expression other than a
+               whole array or array structure component, UBOUND(ARRAY, DIM)
+               has the value equal to the number of elements in the given
+               dimension; otherwise, it has a value equal to the upper bound
+               for subscript DIM of ARRAY if dimension DIM of ARRAY does
+               not have size zero and has value zero if dimension DIM has
+               size zero.  */
+
+  if (as)
+    {
+      tree stride = gfc_conv_descriptor_stride (desc, bound);
+
+      cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
+      cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
+
+      cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
+                          gfc_index_zero_node);
+      cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
+
+      cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
+                          gfc_index_zero_node);
+      cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
+
+      if (upper)
+       {
+         cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
+
+         se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+                                 ubound, gfc_index_zero_node);
+       }
+      else
+       {
+         if (as->type == AS_ASSUMED_SIZE)
+           cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
+                               build_int_cst (TREE_TYPE (bound),
+                                              arg->expr->rank - 1));
+         else
+           cond = boolean_false_node;
+
+         cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
+         cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
+
+         se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+                                 lbound, gfc_index_one_node);
+       }
+    }

   else
   else

-    se->expr = gfc_conv_descriptor_lbound(desc, bound);
+    {
+      if (upper)
+        {
+         size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
+         se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+                                 gfc_index_one_node);
+       }
+      else
+       se->expr = gfc_index_one_node;
+    }

 
   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, se->expr);
 
   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, se->expr);


@@ -778,19 +962,16 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 static void
 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 {
 static void
 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 {

-  tree args;
-  tree val;
+  tree arg;

   int n;
 
   int n;
 

-  args = gfc_conv_intrinsic_function_args (se, expr);
-  gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
-  val = TREE_VALUE (args);
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);

 
   switch (expr->value.function.actual->expr->ts.type)
     {
     case BT_INTEGER:
     case BT_REAL:
 
   switch (expr->value.function.actual->expr->ts.type)
     {
     case BT_INTEGER:
     case BT_REAL:

-      se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
+      se->expr = build1 (ABS_EXPR, TREE_TYPE (arg), arg);

       break;
 
     case BT_COMPLEX:
       break;
 
     case BT_COMPLEX:


@@ -809,7 +990,7 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
        default:
          gcc_unreachable ();
        }
        default:
          gcc_unreachable ();
        }

-      se->expr = build_function_call_expr (built_in_decls[n], args);
+      se->expr = build_call_expr (built_in_decls[n], 1, arg);

       break;
 
     default:
       break;
 
     default:


@@ -823,20 +1004,23 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 static void
 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 {
 static void
 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 {

-  tree arg;

   tree real;
   tree imag;
   tree type;
   tree real;
   tree imag;
   tree type;

+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  args = alloca (sizeof (tree) * num_args);

 
   type = gfc_typenode_for_spec (&expr->ts);
 
   type = gfc_typenode_for_spec (&expr->ts);

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  real = convert (TREE_TYPE (type), TREE_VALUE (arg));
+  gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+  real = convert (TREE_TYPE (type), args[0]);

   if (both)
   if (both)

-    imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
-  else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
+    imag = convert (TREE_TYPE (type), args[1]);
+  else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)

     {
     {

-      arg = TREE_VALUE (arg);
-      imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
+      imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])), args[0]);

       imag = convert (TREE_TYPE (type), imag);
     }
   else
       imag = convert (TREE_TYPE (type), imag);
     }
   else


@@ -852,41 +1036,102 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 static void
 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 {
 static void
 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 {

-  tree arg;
-  tree arg2;

   tree type;
   tree itype;
   tree tmp;
   tree test;
   tree test2;
   mpfr_t huge;
   tree type;
   tree itype;
   tree tmp;
   tree test;
   tree test2;
   mpfr_t huge;

-  int n;
+  int n, ikind;
+  tree args[2];

 
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_VALUE (TREE_CHAIN (arg));
-  arg = TREE_VALUE (arg);
-  type = TREE_TYPE (arg);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);

 
   switch (expr->ts.type)
     {
     case BT_INTEGER:
       /* Integer case is easy, we've got a builtin op.  */
 
   switch (expr->ts.type)
     {
     case BT_INTEGER:
       /* Integer case is easy, we've got a builtin op.  */

+      type = TREE_TYPE (args[0]);
+

       if (modulo)
       if (modulo)

-       se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
+       se->expr = build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);

       else
       else

-       se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
+       se->expr = build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);

       break;
 
     case BT_REAL:
       break;
 
     case BT_REAL:

-      /* Real values we have to do the hard way.  */
-      arg = gfc_evaluate_now (arg, &se->pre);
-      arg2 = gfc_evaluate_now (arg2, &se->pre);
+      n = END_BUILTINS;
+      /* Check if we have a builtin fmod.  */
+      switch (expr->ts.kind)
+       {
+       case 4:
+         n = BUILT_IN_FMODF;
+         break;
+
+       case 8:
+         n = BUILT_IN_FMOD;
+         break;
+
+       case 10:
+       case 16:
+         n = BUILT_IN_FMODL;
+         break;
+
+       default:
+         break;
+       }
+
+      /* Use it if it exists.  */
+      if (n != END_BUILTINS)
+       {
+         tmp = build_addr (built_in_decls[n], current_function_decl);
+         se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
+                                       tmp, 2, args);
+         if (modulo == 0)
+           return;
+       }
+
+      type = TREE_TYPE (args[0]);
+
+      args[0] = gfc_evaluate_now (args[0], &se->pre);
+      args[1] = gfc_evaluate_now (args[1], &se->pre);
+
+      /* Definition:
+        modulo = arg - floor (arg/arg2) * arg2, so
+               = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2, 
+        where
+         test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
+        thereby avoiding another division and retaining the accuracy
+        of the builtin function.  */
+      if (n != END_BUILTINS && modulo)
+       {
+         tree zero = gfc_build_const (type, integer_zero_node);
+         tmp = gfc_evaluate_now (se->expr, &se->pre);
+         test = build2 (LT_EXPR, boolean_type_node, args[0], zero);
+         test2 = build2 (LT_EXPR, boolean_type_node, args[1], zero);
+         test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
+         test = build2 (NE_EXPR, boolean_type_node, tmp, zero);
+         test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
+         test = gfc_evaluate_now (test, &se->pre);
+         se->expr = build3 (COND_EXPR, type, test,
+                            build2 (PLUS_EXPR, type, tmp, args[1]), tmp);
+         return;
+       }
+
+      /* If we do not have a built_in fmod, the calculation is going to
+        have to be done longhand.  */
+      tmp = build2 (RDIV_EXPR, type, args[0], args[1]);

 
 

-      tmp = build2 (RDIV_EXPR, type, arg, arg2);

       /* Test if the value is too large to handle sensibly.  */
       gfc_set_model_kind (expr->ts.kind);
       mpfr_init (huge);
       /* Test if the value is too large to handle sensibly.  */
       gfc_set_model_kind (expr->ts.kind);
       mpfr_init (huge);

-      n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
+      n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
+      ikind = expr->ts.kind;
+      if (n < 0)
+       {
+         n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
+         ikind = gfc_max_integer_kind;
+       }

       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);


@@ -896,15 +1141,15 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 
       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 

-      itype = gfc_get_int_type (expr->ts.kind);
+      itype = gfc_get_int_type (ikind);

       if (modulo)
       if (modulo)

-       tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
+       tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);

       else
       else

-       tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
+       tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);

       tmp = convert (type, tmp);
       tmp = convert (type, tmp);

-      tmp = build3 (COND_EXPR, type, test2, tmp, arg);
-      tmp = build2 (MULT_EXPR, type, tmp, arg2);
-      se->expr = build2 (MINUS_EXPR, type, arg, tmp);
+      tmp = build3 (COND_EXPR, type, test2, tmp, args[0]);
+      tmp = build2 (MULT_EXPR, type, tmp, args[1]);
+      se->expr = build2 (MINUS_EXPR, type, args[0], tmp);

       mpfr_clear (huge);
       break;
 
       mpfr_clear (huge);
       break;
 


@@ -918,19 +1163,16 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 static void
 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 {
 static void
 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 {

-  tree arg;
-  tree arg2;

   tree val;
   tree tmp;
   tree type;
   tree zero;
   tree val;
   tree tmp;
   tree type;
   tree zero;

+  tree args[2];

 
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_VALUE (TREE_CHAIN (arg));
-  arg = TREE_VALUE (arg);
-  type = TREE_TYPE (arg);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  type = TREE_TYPE (args[0]);

 
 

-  val = build2 (MINUS_EXPR, type, arg, arg2);
+  val = build2 (MINUS_EXPR, type, args[0], args[1]);

   val = gfc_evaluate_now (val, &se->pre);
 
   zero = gfc_build_const (type, integer_zero_node);
   val = gfc_evaluate_now (val, &se->pre);
 
   zero = gfc_build_const (type, integer_zero_node);


@@ -942,22 +1184,17 @@ gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 /* SIGN(A, B) is absolute value of A times sign of B.
    The real value versions use library functions to ensure the correct
    handling of negative zero.  Integer case implemented as:
 /* SIGN(A, B) is absolute value of A times sign of B.
    The real value versions use library functions to ensure the correct
    handling of negative zero.  Integer case implemented as:

-   SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
+   SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }

   */
 
 static void
 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 {
   tree tmp;
   */
 
 static void
 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 {
   tree tmp;

-  tree arg;
-  tree arg2;

   tree type;
   tree type;

-  tree zero;
-  tree testa;
-  tree testb;
+  tree args[2];

 
 

-
-  arg = gfc_conv_intrinsic_function_args (se, expr);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);

   if (expr->ts.type == BT_REAL)
     {
       switch (expr->ts.kind)
   if (expr->ts.type == BT_REAL)
     {
       switch (expr->ts.kind)


@@ -975,20 +1212,29 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
        default:
          gcc_unreachable ();
        }
        default:
          gcc_unreachable ();
        }

-      se->expr = build_function_call_expr (tmp, arg);
+      se->expr = build_call_expr (tmp, 2, args[0], args[1]);

       return;
     }
 
       return;
     }
 

-  arg2 = TREE_VALUE (TREE_CHAIN (arg));
-  arg = TREE_VALUE (arg);
-  type = TREE_TYPE (arg);
-  zero = gfc_build_const (type, integer_zero_node);
-
-  testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
-  testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);
-  tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb);
-  se->expr = fold_build3 (COND_EXPR, type, tmp,
-                         build1 (NEGATE_EXPR, type, arg), arg);
+  /* Having excluded floating point types, we know we are now dealing
+     with signed integer types.  */
+  type = TREE_TYPE (args[0]);
+
+  /* Args[0] is used multiple times below.  */
+  args[0] = gfc_evaluate_now (args[0], &se->pre);
+
+  /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
+     the signs of A and B are the same, and of all ones if they differ.  */
+  tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
+  tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
+                    build_int_cst (type, TYPE_PRECISION (type) - 1));
+  tmp = gfc_evaluate_now (tmp, &se->pre);
+
+  /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
+     is all ones (i.e. -1).  */
+  se->expr = fold_build2 (BIT_XOR_EXPR, type,
+                         fold_build2 (PLUS_EXPR, type, args[0], tmp),
+                         tmp);

 }
 
 
 }
 
 


@@ -1011,19 +1257,16 @@ gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
 static void
 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
 {
 static void
 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
 {

-  tree arg;
-  tree arg2;

   tree type;
   tree type;

+  tree args[2];

 
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_VALUE (TREE_CHAIN (arg));
-  arg = TREE_VALUE (arg);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);

 
   /* Convert the args to double precision before multiplying.  */
   type = gfc_typenode_for_spec (&expr->ts);
 
   /* Convert the args to double precision before multiplying.  */
   type = gfc_typenode_for_spec (&expr->ts);

-  arg = convert (type, arg);
-  arg2 = convert (type, arg2);
-  se->expr = build2 (MULT_EXPR, type, arg, arg2);
+  args[0] = convert (type, args[0]);
+  args[1] = convert (type, args[1]);
+  se->expr = build2 (MULT_EXPR, type, args[0], args[1]);

 }
 
 
 }
 
 


@@ -1036,8 +1279,7 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
   tree var;
   tree type;
 
   tree var;
   tree type;
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg = TREE_VALUE (arg);
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);

 
   /* We currently don't support character types != 1.  */
   gcc_assert (expr->ts.kind == 1);
 
   /* We currently don't support character types != 1.  */
   gcc_assert (expr->ts.kind == 1);


@@ -1057,28 +1299,33 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
   tree var;
   tree len;
   tree tmp;
   tree var;
   tree len;
   tree tmp;

-  tree arglist;

   tree type;
   tree cond;
   tree gfc_int8_type_node = gfc_get_int_type (8);
   tree type;
   tree cond;
   tree gfc_int8_type_node = gfc_get_int_type (8);

+  tree fndecl;
+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+  args = alloca (sizeof (tree) * num_args);

 
   type = build_pointer_type (gfc_character1_type_node);
   var = gfc_create_var (type, "pstr");
   len = gfc_create_var (gfc_int8_type_node, "len");
 
 
   type = build_pointer_type (gfc_character1_type_node);
   var = gfc_create_var (type, "pstr");
   len = gfc_create_var (gfc_int8_type_node, "len");
 

-  tmp = gfc_conv_intrinsic_function_args (se, expr);
-  arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
-  arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
-  arglist = chainon (arglist, tmp);
+  gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+  args[0] = build_fold_addr_expr (var);
+  args[1] = build_fold_addr_expr (len);

 
 

-  tmp = build_function_call_expr (gfor_fndecl_ctime, arglist);
+  fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
+  tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
+                         fndecl, num_args, args);

   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
   cond = build2 (GT_EXPR, boolean_type_node, len,
                 build_int_cst (TREE_TYPE (len), 0));
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
   cond = build2 (GT_EXPR, boolean_type_node, len,
                 build_int_cst (TREE_TYPE (len), 0));

-  arglist = gfc_chainon_list (NULL_TREE, var);
-  tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
+  tmp = gfc_call_free (var);

   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
   gfc_add_expr_to_block (&se->post, tmp);
 
   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
   gfc_add_expr_to_block (&se->post, tmp);
 


@@ -1093,28 +1340,33 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
   tree var;
   tree len;
   tree tmp;
   tree var;
   tree len;
   tree tmp;

-  tree arglist;

   tree type;
   tree cond;
   tree gfc_int4_type_node = gfc_get_int_type (4);
   tree type;
   tree cond;
   tree gfc_int4_type_node = gfc_get_int_type (4);

+  tree fndecl;
+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+  args = alloca (sizeof (tree) * num_args);

 
   type = build_pointer_type (gfc_character1_type_node);
   var = gfc_create_var (type, "pstr");
   len = gfc_create_var (gfc_int4_type_node, "len");
 
 
   type = build_pointer_type (gfc_character1_type_node);
   var = gfc_create_var (type, "pstr");
   len = gfc_create_var (gfc_int4_type_node, "len");
 

-  tmp = gfc_conv_intrinsic_function_args (se, expr);
-  arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
-  arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
-  arglist = chainon (arglist, tmp);
+  gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+  args[0] = build_fold_addr_expr (var);
+  args[1] = build_fold_addr_expr (len);

 
 

-  tmp = build_function_call_expr (gfor_fndecl_fdate, arglist);
+  fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
+  tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
+                         fndecl, num_args, args);

   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
   cond = build2 (GT_EXPR, boolean_type_node, len,
                 build_int_cst (TREE_TYPE (len), 0));
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
   cond = build2 (GT_EXPR, boolean_type_node, len,
                 build_int_cst (TREE_TYPE (len), 0));

-  arglist = gfc_chainon_list (NULL_TREE, var);
-  tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
+  tmp = gfc_call_free (var);

   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
   gfc_add_expr_to_block (&se->post, tmp);
 
   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
   gfc_add_expr_to_block (&se->post, tmp);
 


@@ -1131,28 +1383,33 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
   tree var;
   tree len;
   tree tmp;
   tree var;
   tree len;
   tree tmp;

-  tree arglist;

   tree type;
   tree cond;
   tree type;
   tree cond;

+  tree fndecl;

   tree gfc_int4_type_node = gfc_get_int_type (4);
   tree gfc_int4_type_node = gfc_get_int_type (4);

+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+  args = alloca (sizeof (tree) * num_args);

 
   type = build_pointer_type (gfc_character1_type_node);
   var = gfc_create_var (type, "pstr");
   len = gfc_create_var (gfc_int4_type_node, "len");
 
 
   type = build_pointer_type (gfc_character1_type_node);
   var = gfc_create_var (type, "pstr");
   len = gfc_create_var (gfc_int4_type_node, "len");
 

-  tmp = gfc_conv_intrinsic_function_args (se, expr);
-  arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
-  arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
-  arglist = chainon (arglist, tmp);
+  gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+  args[0] = build_fold_addr_expr (var);
+  args[1] = build_fold_addr_expr (len);

 
 

-  tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist);
+  fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
+  tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
+                         fndecl, num_args, args);

   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
   cond = build2 (GT_EXPR, boolean_type_node, len,
                 build_int_cst (TREE_TYPE (len), 0));
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
   cond = build2 (GT_EXPR, boolean_type_node, len,
                 build_int_cst (TREE_TYPE (len), 0));

-  arglist = gfc_chainon_list (NULL_TREE, var);
-  tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
+  tmp = gfc_call_free (var);

   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
   gfc_add_expr_to_block (&se->post, tmp);
 
   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
   gfc_add_expr_to_block (&se->post, tmp);
 


@@ -1164,11 +1421,10 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
 /* Get the minimum/maximum value of all the parameters.
     minmax (a1, a2, a3, ...)
     {
 /* Get the minimum/maximum value of all the parameters.
     minmax (a1, a2, a3, ...)
     {

-      if (a2 .op. a1)
+      mvar = a1;
+      if (a2 .op. mvar || isnan(mvar))

         mvar = a2;
         mvar = a2;

-      else
-        mvar = a1;
-      if (a3 .op. mvar)
+      if (a3 .op. mvar || isnan(mvar))

         mvar = a3;
       ...
       return mvar
         mvar = a3;
       ...
       return mvar


@@ -1180,49 +1436,115 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
 static void
 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
 {
 static void
 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
 {

-  tree limit;

   tree tmp;
   tree mvar;
   tree val;
   tree thencase;
   tree tmp;
   tree mvar;
   tree val;
   tree thencase;

-  tree elsecase;
-  tree arg;
+  tree *args;

   tree type;
   tree type;

+  gfc_actual_arglist *argexpr;
+  unsigned int i, nargs;
+
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  args = alloca (sizeof (tree) * nargs);

 
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
+  gfc_conv_intrinsic_function_args (se, expr, args, nargs);

   type = gfc_typenode_for_spec (&expr->ts);
 
   type = gfc_typenode_for_spec (&expr->ts);
 

-  limit = TREE_VALUE (arg);
-  if (TREE_TYPE (limit) != type)
-    limit = convert (type, limit);
+  argexpr = expr->value.function.actual;
+  if (TREE_TYPE (args[0]) != type)
+    args[0] = convert (type, args[0]);

   /* Only evaluate the argument once.  */
   /* Only evaluate the argument once.  */

-  if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
-    limit = gfc_evaluate_now(limit, &se->pre);
+  if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
+    args[0] = gfc_evaluate_now (args[0], &se->pre);

 
   mvar = gfc_create_var (type, "M");
 
   mvar = gfc_create_var (type, "M");

-  elsecase = build2_v (MODIFY_EXPR, mvar, limit);
-  for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
+  gfc_add_modify_expr (&se->pre, mvar, args[0]);
+  for (i = 1, argexpr = argexpr->next; i < nargs; i++)

     {
     {

-      val = TREE_VALUE (arg);
-      if (TREE_TYPE (val) != type)
-       val = convert (type, val);
+      tree cond, isnan;

 
 

-      /* Only evaluate the argument once.  */
-      if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
-        val = gfc_evaluate_now(val, &se->pre);
+      val = args[i]; 
+
+      /* Handle absent optional arguments by ignoring the comparison.  */
+      if (argexpr->expr->expr_type == EXPR_VARIABLE
+         && argexpr->expr->symtree->n.sym->attr.optional
+         && TREE_CODE (val) == INDIRECT_REF)
+       cond = build2 (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
+                      build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
+      else
+      {
+       cond = NULL_TREE;
+
+       /* Only evaluate the argument once.  */
+       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
+         val = gfc_evaluate_now (val, &se->pre);
+      }

 
       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
 
 
       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
 

-      tmp = build2 (op, boolean_type_node, val, limit);
-      tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
+      tmp = build2 (op, boolean_type_node, convert (type, val), mvar);
+
+      /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
+        __builtin_isnan might be made dependent on that module being loaded,
+        to help performance of programs that don't rely on IEEE semantics.  */
+      if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
+       {
+         isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, mvar);
+         tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
+                            fold_convert (boolean_type_node, isnan));
+       }
+      tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt ());
+
+      if (cond != NULL_TREE)
+       tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+

       gfc_add_expr_to_block (&se->pre, tmp);
       gfc_add_expr_to_block (&se->pre, tmp);

-      elsecase = build_empty_stmt ();
-      limit = mvar;
+      argexpr = argexpr->next;

     }
   se->expr = mvar;
 }
 
 
     }
   se->expr = mvar;
 }
 
 

+/* Generate library calls for MIN and MAX intrinsics for character
+   variables.  */
+static void
+gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
+{
+  tree *args;
+  tree var, len, fndecl, tmp, cond;
+  unsigned int nargs;
+
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  args = alloca (sizeof (tree) * (nargs + 4));
+  gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
+
+  /* Create the result variables.  */
+  len = gfc_create_var (gfc_charlen_type_node, "len");
+  args[0] = build_fold_addr_expr (len);
+  var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "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);
+
+  /* Make the function call.  */
+  fndecl = build_addr (gfor_fndecl_string_minmax, current_function_decl);
+  tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax)),
+                         fndecl, nargs + 4, args);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = build2 (GT_EXPR, boolean_type_node, len,
+                build_int_cst (TREE_TYPE (len), 0));
+  tmp = gfc_call_free (var);
+  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+

 /* Create a symbol node for this intrinsic.  The symbol from the frontend
    has the generic name.  */
 
 /* Create a symbol node for this intrinsic.  The symbol from the frontend
    has the generic name.  */
 


@@ -1259,6 +1581,7 @@ static void
 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
 {
   gfc_symbol *sym;
 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
 {
   gfc_symbol *sym;

+  tree append_args;

 
   gcc_assert (!se->ss || se->ss->expr == expr);
 
 
   gcc_assert (!se->ss || se->ss->expr == expr);
 


@@ -1268,7 +1591,54 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
     gcc_assert (expr->rank == 0);
 
   sym = gfc_get_symbol_for_expr (expr);
     gcc_assert (expr->rank == 0);
 
   sym = gfc_get_symbol_for_expr (expr);

-  gfc_conv_function_call (se, sym, expr->value.function.actual);
+
+  /* Calls to libgfortran_matmul need to be appended special arguments,
+     to be able to call the BLAS ?gemm functions if required and possible.  */
+  append_args = NULL_TREE;
+  if (expr->value.function.isym->id == GFC_ISYM_MATMUL
+      && sym->ts.type != BT_LOGICAL)
+    {
+      tree cint = gfc_get_int_type (gfc_c_int_kind);
+
+      if (gfc_option.flag_external_blas
+         && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
+         && (sym->ts.kind == gfc_default_real_kind
+             || sym->ts.kind == gfc_default_double_kind))
+       {
+         tree gemm_fndecl;
+
+         if (sym->ts.type == BT_REAL)
+           {
+             if (sym->ts.kind == gfc_default_real_kind)
+               gemm_fndecl = gfor_fndecl_sgemm;
+             else
+               gemm_fndecl = gfor_fndecl_dgemm;
+           }
+         else
+           {
+             if (sym->ts.kind == gfc_default_real_kind)
+               gemm_fndecl = gfor_fndecl_cgemm;
+             else
+               gemm_fndecl = gfor_fndecl_zgemm;
+           }
+
+         append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
+         append_args = gfc_chainon_list
+                         (append_args, build_int_cst
+                                         (cint, gfc_option.blas_matmul_limit));
+         append_args = gfc_chainon_list (append_args,
+                                         gfc_build_addr_expr (NULL_TREE,
+                                                              gemm_fndecl));
+       }
+      else
+       {
+         append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
+         append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
+         append_args = gfc_chainon_list (append_args, null_pointer_node);
+       }
+    }
+
+  gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);

   gfc_free (sym);
 }
 
   gfc_free (sym);
 }
 


@@ -1361,8 +1731,8 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
   gfc_conv_expr_val (&arrayse, actual->expr);
 
   gfc_add_block_to_block (&body, &arrayse.pre);
   gfc_conv_expr_val (&arrayse, actual->expr);
 
   gfc_add_block_to_block (&body, &arrayse.pre);

-  tmp = build2 (op, boolean_type_node, arrayse.expr,
-               build_int_cst (TREE_TYPE (arrayse.expr), 0));
+  tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
+                    build_int_cst (TREE_TYPE (arrayse.expr), 0));

   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
   gfc_add_expr_to_block (&body, tmp);
   gfc_add_block_to_block (&body, &arrayse.post);
   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
   gfc_add_expr_to_block (&body, tmp);
   gfc_add_block_to_block (&body, &arrayse.post);


@@ -1597,7 +1967,7 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
   /* Initialize the result.  */
   resvar = gfc_create_var (type, "val");
   if (expr->ts.type == BT_LOGICAL)
   /* Initialize the result.  */
   resvar = gfc_create_var (type, "val");
   if (expr->ts.type == BT_LOGICAL)

-    tmp = convert (type, integer_zero_node);
+    tmp = build_int_cst (type, 0);

   else
     tmp = gfc_build_const (type, integer_zero_node);
 
   else
     tmp = gfc_build_const (type, integer_zero_node);
 


@@ -1685,6 +2055,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
   tree tmp;
   tree elsetmp;
   tree ifbody;
   tree tmp;
   tree elsetmp;
   tree ifbody;

+  tree offset;

   gfc_loopinfo loop;
   gfc_actual_arglist *actual;
   gfc_ss *arrayss;
   gfc_loopinfo loop;
   gfc_actual_arglist *actual;
   gfc_ss *arrayss;


@@ -1704,6 +2075,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
 
   /* Initialize the result.  */
   pos = gfc_create_var (gfc_array_index_type, "pos");
 
   /* Initialize the result.  */
   pos = gfc_create_var (gfc_array_index_type, "pos");

+  offset = gfc_create_var (gfc_array_index_type, "offset");

   type = gfc_typenode_for_spec (&expr->ts);
 
   /* Walk the arguments.  */
   type = gfc_typenode_for_spec (&expr->ts);
 
   /* Walk the arguments.  */


@@ -1740,11 +2112,18 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
       gcc_unreachable ();
     }
 
       gcc_unreachable ();
     }
 

-  /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
+  /* We start with the most negative possible value for MAXLOC, and the most
+     positive possible value for MINLOC. The most negative possible value is
+     -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
+     possible value is HUGE in both cases.  */

   if (op == GT_EXPR)
     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
   gfc_add_modify_expr (&se->pre, limit, tmp);
 
   if (op == GT_EXPR)
     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
   gfc_add_modify_expr (&se->pre, limit, tmp);
 

+  if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+    tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
+                 build_int_cst (type, 1));
+

   /* Initialize the scalarizer.  */
   gfc_init_loopinfo (&loop);
   gfc_add_ss_to_loop (&loop, arrayss);
   /* Initialize the scalarizer.  */
   gfc_init_loopinfo (&loop);
   gfc_add_ss_to_loop (&loop, arrayss);


@@ -1795,15 +2174,28 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
   /* Assign the value to the limit...  */
   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
 
   /* Assign the value to the limit...  */
   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
 

-  /* Remember where we are.  */
-  gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
+  /* Remember where we are.  An offset must be added to the loop
+     counter to obtain the required position.  */
+  if (loop.temp_dim)
+    tmp = build_int_cst (gfc_array_index_type, 1);
+  else
+    tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type,
+                        gfc_index_one_node, loop.from[0]);
+  gfc_add_modify_expr (&block, offset, tmp);
+
+  tmp = build2 (PLUS_EXPR, TREE_TYPE (pos),
+               loop.loopvar[0], offset);
+  gfc_add_modify_expr (&ifblock, pos, tmp);

 
   ifbody = gfc_finish_block (&ifblock);
 
 
   ifbody = gfc_finish_block (&ifblock);
 

-  /* If it is a more extreme value or pos is still zero.  */
+  /* If it is a more extreme value or pos is still zero and the value
+     equal to the limit.  */
+  tmp = build2 (TRUTH_AND_EXPR, boolean_type_node,
+               build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node),
+               build2 (EQ_EXPR, boolean_type_node, arrayse.expr, limit));

   tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
   tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,

-                 build2 (op, boolean_type_node, arrayse.expr, limit),
-                 build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node));
+               build2 (op, boolean_type_node, arrayse.expr, limit), tmp);

   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
   gfc_add_expr_to_block (&block, tmp);
 
   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
   gfc_add_expr_to_block (&block, tmp);
 


@@ -1848,12 +2240,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
     }
   gfc_cleanup_loop (&loop);
 
     }
   gfc_cleanup_loop (&loop);
 

-  /* Return a value in the range 1..SIZE(array).  */
-  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
-                    gfc_index_one_node);
-  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp);
-  /* And convert to the required type.  */
-  se->expr = convert (type, tmp);
+  se->expr = convert (type, pos);

 }
 
 static void
 }
 
 static void


@@ -1899,9 +2286,17 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
       gcc_unreachable ();
     }
 
       gcc_unreachable ();
     }
 

-  /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
+  /* We start with the most negative possible value for MAXVAL, and the most
+     positive possible value for MINVAL. The most negative possible value is
+     -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
+     possible value is HUGE in both cases.  */

   if (op == GT_EXPR)
     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
   if (op == GT_EXPR)
     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);

+
+  if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+    tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
+                 build_int_cst (type, 1));
+

   gfc_add_modify_expr (&se->pre, limit, tmp);
 
   /* Walk the arguments.  */
   gfc_add_modify_expr (&se->pre, limit, tmp);
 
   /* Walk the arguments.  */


@@ -2004,18 +2399,15 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
 static void
 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
 {
 static void
 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
 {

-  tree arg;
-  tree arg2;
+  tree args[2];

   tree type;
   tree tmp;
 
   tree type;
   tree tmp;
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_VALUE (TREE_CHAIN (arg));
-  arg = TREE_VALUE (arg);
-  type = TREE_TYPE (arg);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  type = TREE_TYPE (args[0]);

 
 

-  tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
-  tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
+  tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
+  tmp = build2 (BIT_AND_EXPR, type, args[0], tmp);

   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
                     build_int_cst (type, 0));
   type = gfc_typenode_for_spec (&expr->ts);
   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
                     build_int_cst (type, 0));
   type = gfc_typenode_for_spec (&expr->ts);


@@ -2026,16 +2418,10 @@ gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
 static void
 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
 {
 static void
 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
 {

-  tree arg;
-  tree arg2;
-  tree type;
-
-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_VALUE (TREE_CHAIN (arg));
-  arg = TREE_VALUE (arg);
-  type = TREE_TYPE (arg);
+  tree args[2];

 
 

-  se->expr = fold_build2 (op, type, arg, arg2);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);

 }
 
 /* Bitwise not.  */
 }
 
 /* Bitwise not.  */


@@ -2044,9 +2430,7 @@ gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
 {
   tree arg;
 
 {
   tree arg;
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg = TREE_VALUE (arg);
-
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);

   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
 }
 
   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
 }
 


@@ -2054,18 +2438,15 @@ gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
 static void
 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
 {
 static void
 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
 {

-  tree arg;
-  tree arg2;
+  tree args[2];

   tree type;
   tree tmp;
   int op;
 
   tree type;
   tree tmp;
   int op;
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_VALUE (TREE_CHAIN (arg));
-  arg = TREE_VALUE (arg);
-  type = TREE_TYPE (arg);
+  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), arg2);
+  tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);

   if (set)
     op = BIT_IOR_EXPR;
   else
   if (set)
     op = BIT_IOR_EXPR;
   else


@@ -2073,7 +2454,7 @@ gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
       op = BIT_AND_EXPR;
       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
     }
       op = BIT_AND_EXPR;
       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
     }

-  se->expr = fold_build2 (op, type, arg, tmp);
+  se->expr = fold_build2 (op, type, args[0], tmp);

 }
 
 /* Extract a sequence of bits.
 }
 
 /* Extract a sequence of bits.


@@ -2081,29 +2462,36 @@ gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
 static void
 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
 {
 static void
 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
 {

-  tree arg;
-  tree arg2;
-  tree arg3;
+  tree args[3];

   tree type;
   tree tmp;
   tree mask;
 
   tree type;
   tree tmp;
   tree mask;
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_CHAIN (arg);
-  arg3 = TREE_VALUE (TREE_CHAIN (arg2));
-  arg = TREE_VALUE (arg);
-  arg2 = TREE_VALUE (arg2);
-  type = TREE_TYPE (arg);
+  gfc_conv_intrinsic_function_args (se, expr, args, 3);
+  type = TREE_TYPE (args[0]);

 
 

-  mask = build_int_cst (NULL_TREE, -1);
-  mask = build2 (LSHIFT_EXPR, type, mask, arg3);
+  mask = build_int_cst (type, -1);
+  mask = build2 (LSHIFT_EXPR, type, mask, args[2]);

   mask = build1 (BIT_NOT_EXPR, type, mask);
 
   mask = build1 (BIT_NOT_EXPR, type, mask);
 

-  tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
+  tmp = build2 (RSHIFT_EXPR, type, args[0], args[1]);

 
   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
 }
 
 
   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
 }
 

+/* RSHIFT (I, SHIFT) = I >> SHIFT
+   LSHIFT (I, SHIFT) = I << SHIFT  */
+static void
+gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
+{
+  tree args[2];
+
+  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]);
+}
+

 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
                         ? 0
                        : ((shift >= 0) ? i << shift : i >> -shift)
 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
                         ? 0
                        : ((shift >= 0) ? i << shift : i >> -shift)


@@ -2111,8 +2499,7 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
 static void
 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
 {
 static void
 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
 {

-  tree arg;
-  tree arg2;
+  tree args[2];

   tree type;
   tree utype;
   tree tmp;
   tree type;
   tree utype;
   tree tmp;


@@ -2122,16 +2509,14 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
   tree lshift;
   tree rshift;
 
   tree lshift;
   tree rshift;
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_VALUE (TREE_CHAIN (arg));
-  arg = TREE_VALUE (arg);
-  type = TREE_TYPE (arg);
-  utype = gfc_unsigned_type (type);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  type = TREE_TYPE (args[0]);
+  utype = unsigned_type_for (type);

 
 

-  width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
+  width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);

 
   /* Left shift if positive.  */
 
   /* Left shift if positive.  */

-  lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);
+  lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);

 
   /* Right shift if negative.
      We convert to an unsigned type because we want a logical shift.
 
   /* Right shift if negative.
      We convert to an unsigned type because we want a logical shift.


@@ -2139,58 +2524,59 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
      numbers, and we try to be compatible with other compilers, most
      notably g77, here.  */
   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype, 
      numbers, and we try to be compatible with other compilers, most
      notably g77, here.  */
   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype, 

-                                      convert (utype, arg), width));
+                                      convert (utype, args[0]), width));

 
 

-  tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
-                    build_int_cst (TREE_TYPE (arg2), 0));
+  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);
 
   /* 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.  */
   tmp = fold_build3 (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 (arg2), TYPE_PRECISION (type));
+  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 (GE_EXPR, boolean_type_node, width, num_bits);
 
   se->expr = fold_build3 (COND_EXPR, type, cond,
                          build_int_cst (type, 0), tmp);
 }
 

+

 /* Circular shift.  AKA rotate or barrel shift.  */
 /* Circular shift.  AKA rotate or barrel shift.  */

+

 static void
 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
 {
 static void
 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
 {

-  tree arg;
-  tree arg2;
-  tree arg3;
+  tree *args;

   tree type;
   tree tmp;
   tree lrot;
   tree rrot;
   tree zero;
   tree type;
   tree tmp;
   tree lrot;
   tree rrot;
   tree zero;

+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  args = alloca (sizeof (tree) * num_args);

 
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_CHAIN (arg);
-  arg3 = TREE_CHAIN (arg2);
-  if (arg3)
+  gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+
+  if (num_args == 3)

     {
       /* Use a library function for the 3 parameter version.  */
       tree int4type = gfc_get_int_type (4);
 
     {
       /* Use a library function for the 3 parameter version.  */
       tree int4type = gfc_get_int_type (4);
 

-      type = TREE_TYPE (TREE_VALUE (arg));
+      type = TREE_TYPE (args[0]);

       /* We convert the first argument to at least 4 bytes, and
         convert back afterwards.  This removes the need for library
         functions for all argument sizes, and function will be
         aligned to at least 32 bits, so there's no loss.  */
       if (expr->ts.kind < 4)
       /* We convert the first argument to at least 4 bytes, and
         convert back afterwards.  This removes the need for library
         functions for all argument sizes, and function will be
         aligned to at least 32 bits, so there's no loss.  */
       if (expr->ts.kind < 4)

-       {
-         tmp = convert (int4type, TREE_VALUE (arg));
-         TREE_VALUE (arg) = tmp;
-       }
+       args[0] = convert (int4type, args[0]);
+

       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
          need loads of library  functions.  They cannot have values >
         BIT_SIZE (I) so the conversion is safe.  */
       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
          need loads of library  functions.  They cannot have values >
         BIT_SIZE (I) so the conversion is safe.  */

-      TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
-      TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
+      args[1] = convert (int4type, args[1]);
+      args[2] = convert (int4type, args[2]);

 
       switch (expr->ts.kind)
        {
 
       switch (expr->ts.kind)
        {


@@ -2208,7 +2594,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
        default:
          gcc_unreachable ();
        }
        default:
          gcc_unreachable ();
        }

-      se->expr = build_function_call_expr (tmp, arg);
+      se->expr = build_call_expr (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)
       /* Convert the result back to the original type, if we extended
         the first argument's width above.  */
       if (expr->ts.kind < 4)


@@ -2216,24 +2602,22 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
 
       return;
     }
 
       return;
     }

-  arg = TREE_VALUE (arg);
-  arg2 = TREE_VALUE (arg2);
-  type = TREE_TYPE (arg);
+  type = TREE_TYPE (args[0]);

 
   /* Rotate left if positive.  */
 
   /* Rotate left if positive.  */

-  lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);
+  lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);

 
   /* Rotate right if negative.  */
 
   /* Rotate right if negative.  */

-  tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
-  rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);
+  tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
+  rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);

 
 

-  zero = build_int_cst (TREE_TYPE (arg2), 0);
-  tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
+  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);
 
   /* Do nothing if shift == 0.  */
   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
 
   /* Do nothing if shift == 0.  */

-  tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero);
-  se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
+  tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
+  se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);

 }
 
 /* The length of a character string.  */
 }
 
 /* The length of a character string.  */


@@ -2246,6 +2630,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
   gfc_symbol *sym;
   gfc_se argse;
   gfc_expr *arg;
   gfc_symbol *sym;
   gfc_se argse;
   gfc_expr *arg;

+  gfc_ss *ss;

 
   gcc_assert (!se->ss);
 
 
   gcc_assert (!se->ss);
 


@@ -2262,35 +2647,40 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
       /* Obtain the string length from the function used by
          trans-array.c(gfc_trans_array_constructor).  */
       len = NULL_TREE;
       /* Obtain the string length from the function used by
          trans-array.c(gfc_trans_array_constructor).  */
       len = NULL_TREE;

-      get_array_ctor_strlen (arg->value.constructor, &len);
+      get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);

       break;
 
       break;
 

-    default:
-       if (arg->expr_type == EXPR_VARIABLE
-           && (arg->ref == NULL || (arg->ref->next == NULL
-                                    && arg->ref->type == REF_ARRAY)))
-         {
-           /* This doesn't catch all cases.
-              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
-              and the surrounding thread.  */
-           sym = arg->symtree->n.sym;
-           decl = gfc_get_symbol_decl (sym);
-           if (decl == current_function_decl && sym->attr.function
+    case EXPR_VARIABLE:
+      if (arg->ref == NULL
+           || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
+       {
+         /* This doesn't catch all cases.
+            See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
+            and the surrounding thread.  */
+         sym = arg->symtree->n.sym;
+         decl = gfc_get_symbol_decl (sym);
+         if (decl == current_function_decl && sym->attr.function

                && (sym->result == sym))
                && (sym->result == sym))

-             decl = gfc_get_fake_result_decl (sym, 0);
-
-           len = sym->ts.cl->backend_decl;
-           gcc_assert (len);
-         }
-       else
-         {
-           /* Anybody stupid enough to do this deserves inefficient code.  */
-           gfc_init_se (&argse, se);
-           gfc_conv_expr (&argse, arg);
-           gfc_add_block_to_block (&se->pre, &argse.pre);
-           gfc_add_block_to_block (&se->post, &argse.post);
-           len = argse.string_length;
+           decl = gfc_get_fake_result_decl (sym, 0);
+
+         len = sym->ts.cl->backend_decl;
+         gcc_assert (len);
+         break;

        }
        }

+
+      /* Otherwise fall through.  */
+
+    default:
+      /* Anybody stupid enough to do this deserves inefficient code.  */
+      ss = gfc_walk_expr (arg);
+      gfc_init_se (&argse, se);
+      if (ss == gfc_ss_terminator)
+       gfc_conv_expr (&argse, arg);
+      else
+       gfc_conv_expr_descriptor (&argse, arg, ss);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      len = argse.string_length;

       break;
     }
   se->expr = convert (type, len);
       break;
     }
   se->expr = convert (type, len);


@@ -2300,12 +2690,12 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
 static void
 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
 {
 static void
 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
 {

-  tree args;
+  tree args[2];

   tree type;
 
   tree type;
 

-  args = gfc_conv_intrinsic_function_args (se, expr);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);

   type = gfc_typenode_for_spec (&expr->ts);
   type = gfc_typenode_for_spec (&expr->ts);

-  se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args);
+  se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]);

   se->expr = convert (type, se->expr);
 }
 
   se->expr = convert (type, se->expr);
 }
 


@@ -2313,82 +2703,112 @@ gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
 /* Returns the starting position of a substring within a string.  */
 
 static void
 /* Returns the starting position of a substring within a string.  */
 
 static void

-gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
+                                     tree function)

 {
   tree logical4_type_node = gfc_get_logical_type (4);
 {
   tree logical4_type_node = gfc_get_logical_type (4);

-  tree args;
-  tree back;

   tree type;
   tree type;

-  tree tmp;
+  tree fndecl;
+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  args = alloca (sizeof (tree) * 5);

 
 

-  args = gfc_conv_intrinsic_function_args (se, expr);
+  gfc_conv_intrinsic_function_args (se, expr, args,
+                                   num_args >= 5 ? 5 : num_args);

   type = gfc_typenode_for_spec (&expr->ts);
   type = gfc_typenode_for_spec (&expr->ts);

-  tmp = gfc_advance_chain (args, 3);
-  if (TREE_CHAIN (tmp) == NULL_TREE)
-    {
-      back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
-                       NULL_TREE);
-      TREE_CHAIN (tmp) = back;
-    }
+
+  if (num_args == 4)
+    args[4] = build_int_cst (logical4_type_node, 0);

   else
   else

-    {
-      back = TREE_CHAIN (tmp);
-      TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
-    }
+    args[4] = convert (logical4_type_node, args[4]);

 
 

-  se->expr = build_function_call_expr (gfor_fndecl_string_index, args);
+  fndecl = build_addr (function, current_function_decl);
+  se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+                              5, args);

   se->expr = convert (type, se->expr);
   se->expr = convert (type, se->expr);

+

 }
 
 /* The ascii value for a single character.  */
 static void
 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
 {
 }
 
 /* The ascii value for a single character.  */
 static void
 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
 {

-  tree arg;
+  tree args[2];

   tree type;
 
   tree type;
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
-  arg = TREE_VALUE (TREE_CHAIN (arg));
-  gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
-  arg = build1 (NOP_EXPR, pchar_type_node, arg);
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
+  args[1] = build1 (NOP_EXPR, pchar_type_node, args[1]);

   type = gfc_typenode_for_spec (&expr->ts);
 
   type = gfc_typenode_for_spec (&expr->ts);
 

-  se->expr = build_fold_indirect_ref (arg);
+  se->expr = build_fold_indirect_ref (args[1]);

   se->expr = convert (type, se->expr);
 }
 
 
   se->expr = convert (type, se->expr);
 }
 
 

+/* Intrinsic ISNAN calls __builtin_isnan.  */
+
+static void
+gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
+{
+  tree arg;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg);
+  STRIP_TYPE_NOPS (se->expr);
+  se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
+
+
+/* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
+   their argument against a constant integer value.  */
+
+static void
+gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
+{
+  tree arg;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
+                         arg, build_int_cst (TREE_TYPE (arg), value));
+}
+
+
+

 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
 
 static void
 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
 {
 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
 
 static void
 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
 {

-  tree arg;

   tree tsource;
   tree fsource;
   tree mask;
   tree type;
   tree len;
   tree tsource;
   tree fsource;
   tree mask;
   tree type;
   tree len;

+  tree *args;
+  unsigned int num_args;
+
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  args = alloca (sizeof (tree) * num_args);

 
 

-  arg = gfc_conv_intrinsic_function_args (se, expr);
+  gfc_conv_intrinsic_function_args (se, expr, args, num_args);

   if (expr->ts.type != BT_CHARACTER)
     {
   if (expr->ts.type != BT_CHARACTER)
     {

-      tsource = TREE_VALUE (arg);
-      arg = TREE_CHAIN (arg);
-      fsource = TREE_VALUE (arg);
-      mask = TREE_VALUE (TREE_CHAIN (arg));
+      tsource = args[0];
+      fsource = args[1];
+      mask = args[2];

     }
   else
     {
       /* We do the same as in the non-character case, but the argument
         list is different because of the string length arguments. We
         also have to set the string length for the result.  */
     }
   else
     {
       /* We do the same as in the non-character case, but the argument
         list is different because of the string length arguments. We
         also have to set the string length for the result.  */

-      len = TREE_VALUE (arg);
-      arg = TREE_CHAIN (arg);
-      tsource = TREE_VALUE (arg);
-      arg = TREE_CHAIN (TREE_CHAIN (arg));
-      fsource = TREE_VALUE (arg);
-      mask = TREE_VALUE (TREE_CHAIN (arg));
+      len = args[0];
+      tsource = args[1];
+      fsource = args[3];
+      mask = args[4];

 
       se->string_length = len;
     }
 
       se->string_length = len;
     }


@@ -2401,9 +2821,10 @@ static void
 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
 {
   gfc_actual_arglist *actual;
 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
 {
   gfc_actual_arglist *actual;

-  tree args;
+  tree arg1;

   tree type;
   tree type;

-  tree fndecl;
+  tree fncall0;
+  tree fncall1;

   gfc_se argse;
   gfc_ss *ss;
 
   gfc_se argse;
   gfc_ss *ss;
 


@@ -2417,95 +2838,165 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);
   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);

-  args = gfc_chainon_list (NULL_TREE, argse.expr);
+  arg1 = gfc_evaluate_now (argse.expr, &se->pre);
+
+  /* Build the call to size0.  */
+  fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);

 
   actual = actual->next;
 
   actual = actual->next;

+

   if (actual->expr)
     {
       gfc_init_se (&argse, NULL);
   if (actual->expr)
     {
       gfc_init_se (&argse, NULL);

-      gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
+      gfc_conv_expr_type (&argse, actual->expr,
+                         gfc_array_index_type);

       gfc_add_block_to_block (&se->pre, &argse.pre);
       gfc_add_block_to_block (&se->pre, &argse.pre);

-      args = gfc_chainon_list (args, argse.expr);
-      fndecl = gfor_fndecl_size1;
+
+      /* Build the call to size1.  */
+      fncall1 = build_call_expr (gfor_fndecl_size1, 2,
+                                arg1, argse.expr);
+
+      /* Unusually, for an intrinsic, size does not exclude
+        an optional arg2, so we must test for it.  */  
+      if (actual->expr->expr_type == EXPR_VARIABLE
+           && actual->expr->symtree->n.sym->attr.dummy
+           && actual->expr->symtree->n.sym->attr.optional)
+       {
+         tree tmp;
+         gfc_init_se (&argse, NULL);
+         argse.want_pointer = 1;
+         argse.data_not_needed = 1;
+         gfc_conv_expr (&argse, actual->expr);
+         gfc_add_block_to_block (&se->pre, &argse.pre);
+         tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
+                       null_pointer_node);
+         tmp = gfc_evaluate_now (tmp, &se->pre);
+         se->expr = build3 (COND_EXPR, pvoid_type_node,
+                            tmp, fncall1, fncall0);
+       }
+      else
+       se->expr = fncall1;

     }
   else
     }
   else

-    fndecl = gfor_fndecl_size0;
+    se->expr = fncall0;

 
 

-  se->expr = build_function_call_expr (fndecl, args);

   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, se->expr);
 }
 
 
   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, se->expr);
 }
 
 

+static void
+gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
+{
+  gfc_expr *arg;
+  gfc_ss *ss;
+  gfc_se argse;
+  tree source;
+  tree source_bytes;
+  tree type;
+  tree tmp;
+  tree lower;
+  tree upper;
+  /*tree stride;*/
+  int n;
+
+  arg = expr->value.function.actual->expr;
+
+  gfc_init_se (&argse, NULL);
+  ss = gfc_walk_expr (arg);
+
+  source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
+
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_conv_expr_reference (&argse, arg);
+      source = argse.expr;
+
+      type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+
+      /* Obtain the source word length.  */
+      if (arg->ts.type == BT_CHARACTER)
+       source_bytes = fold_convert (gfc_array_index_type,
+                                    argse.string_length);
+      else
+       source_bytes = fold_convert (gfc_array_index_type,
+                                    size_in_bytes (type)); 
+    }
+  else
+    {
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg, ss);
+      source = gfc_conv_descriptor_data_get (argse.expr);
+      type = gfc_get_element_type (TREE_TYPE (argse.expr));
+
+      /* Obtain the argument's word length.  */
+      if (arg->ts.type == BT_CHARACTER)
+       tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      else
+       tmp = fold_convert (gfc_array_index_type,
+                           size_in_bytes (type)); 
+      gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+
+      /* Obtain the size of the array in bytes.  */
+      for (n = 0; n < arg->rank; n++)
+       {
+         tree idx;
+         idx = gfc_rank_cst[n];
+         lower = gfc_conv_descriptor_lbound (argse.expr, idx);
+         upper = gfc_conv_descriptor_ubound (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);
+         gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+       }
+    }
+
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  se->expr = source_bytes;
+}
+
+

 /* Intrinsic string comparison functions.  */
 
 /* Intrinsic string comparison functions.  */
 

-  static void
+static void

 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
 {
 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
 {

-  tree type;
-  tree args;
-  tree arg2;
-
-  args = gfc_conv_intrinsic_function_args (se, expr);
-  arg2 = TREE_CHAIN (TREE_CHAIN (args));
+  tree args[4];

 
 

-  se->expr = gfc_build_compare_string (TREE_VALUE (args),
-               TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
-               TREE_VALUE (TREE_CHAIN (arg2)));
+  gfc_conv_intrinsic_function_args (se, expr, args, 4);

 
 

-  type = gfc_typenode_for_spec (&expr->ts);
-  se->expr = fold_build2 (op, type, se->expr,
-                    build_int_cst (TREE_TYPE (se->expr), 0));
+  se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
+  se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
+                         build_int_cst (TREE_TYPE (se->expr), 0));

 }
 
 /* Generate a call to the adjustl/adjustr library function.  */
 static void
 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
 {
 }
 
 /* Generate a call to the adjustl/adjustr library function.  */
 static void
 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
 {

-  tree args;
+  tree args[3];

   tree len;
   tree type;
   tree var;
   tree tmp;
 
   tree len;
   tree type;
   tree var;
   tree tmp;
 

-  args = gfc_conv_intrinsic_function_args (se, expr);
-  len = TREE_VALUE (args);
+  gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
+  len = args[1];

 
 

-  type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
+  type = TREE_TYPE (args[2]);

   var = gfc_conv_string_tmp (se, type, len);
   var = gfc_conv_string_tmp (se, type, len);

-  args = tree_cons (NULL_TREE, var, args);
+  args[0] = var;

 
 

-  tmp = build_function_call_expr (fndecl, args);
+  tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);

   gfc_add_expr_to_block (&se->pre, tmp);
   se->expr = var;
   se->string_length = len;
 }
 
 
   gfc_add_expr_to_block (&se->pre, tmp);
   se->expr = var;
   se->string_length = len;
 }
 
 

-/* A helper function for gfc_conv_intrinsic_array_transfer to compute
-   the size of tree expressions in bytes.  */
-static tree
-gfc_size_in_bytes (gfc_se *se, gfc_expr *e)
-{
-  tree tmp;
-
-  if (e->ts.type == BT_CHARACTER)
-    tmp = se->string_length;
-  else
-    {
-      if (e->rank)
-       {
-         tmp = gfc_get_element_type (TREE_TYPE (se->expr));
-         tmp = size_in_bytes (tmp);
-       }
-      else
-       tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr)));
-    }
-
-  return fold_convert (gfc_array_index_type, tmp);
-}
-
-

 /* Array transfer statement.
      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
    where:
 /* Array transfer statement.
      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
    where:


@@ -2520,7 +3011,9 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   tree tmp;
   tree extent;
   tree source;
   tree tmp;
   tree extent;
   tree source;

+  tree source_type;

   tree source_bytes;
   tree source_bytes;

+  tree mold_type;

   tree dest_word_len;
   tree size_words;
   tree size_bytes;
   tree dest_word_len;
   tree size_words;
   tree size_bytes;


@@ -2528,7 +3021,6 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   tree lower;
   tree stride;
   tree stmt;
   tree lower;
   tree stride;
   tree stmt;

-  tree args;

   gfc_actual_arglist *arg;
   gfc_se argse;
   gfc_ss *ss;
   gfc_actual_arglist *arg;
   gfc_se argse;
   gfc_ss *ss;


@@ -2554,30 +3046,33 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
       gfc_conv_expr_reference (&argse, arg->expr);
       source = argse.expr;
 
       gfc_conv_expr_reference (&argse, arg->expr);
       source = argse.expr;
 

+      source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+

       /* Obtain the source word length.  */
       /* Obtain the source word length.  */

-      tmp = gfc_size_in_bytes (&argse, arg->expr);
+      if (arg->expr->ts.type == BT_CHARACTER)
+       tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      else
+       tmp = fold_convert (gfc_array_index_type,
+                           size_in_bytes (source_type)); 

     }
   else
     {
     }
   else
     {

-      gfc_init_se (&argse, NULL);

       argse.want_pointer = 0;
       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
       source = gfc_conv_descriptor_data_get (argse.expr);
       argse.want_pointer = 0;
       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
       source = gfc_conv_descriptor_data_get (argse.expr);

+      source_type = gfc_get_element_type (TREE_TYPE (argse.expr));

 
       /* Repack the source if not a full variable array.  */
       if (!(arg->expr->expr_type == EXPR_VARIABLE
              && arg->expr->ref->u.ar.type == AR_FULL))
        {
          tmp = build_fold_addr_expr (argse.expr);
 
       /* Repack the source if not a full variable array.  */
       if (!(arg->expr->expr_type == EXPR_VARIABLE
              && arg->expr->ref->u.ar.type == AR_FULL))
        {
          tmp = build_fold_addr_expr (argse.expr);

-         tmp = gfc_chainon_list (NULL_TREE, tmp);
-         source = build_function_call_expr (gfor_fndecl_in_pack, tmp);
+         source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);

          source = gfc_evaluate_now (source, &argse.pre);
 
          /* Free the temporary.  */
          gfc_start_block (&block);
          source = gfc_evaluate_now (source, &argse.pre);
 
          /* Free the temporary.  */
          gfc_start_block (&block);

-         tmp = convert (pvoid_type_node, source);
-         tmp = gfc_chainon_list (NULL_TREE, tmp);
-         tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+         tmp = gfc_call_free (convert (pvoid_type_node, source));

          gfc_add_expr_to_block (&block, tmp);
          stmt = gfc_finish_block (&block);
 
          gfc_add_expr_to_block (&block, tmp);
          stmt = gfc_finish_block (&block);
 


@@ -2593,7 +3088,11 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
        }
 
       /* Obtain the source word length.  */
        }
 
       /* Obtain the source word length.  */

-      tmp = gfc_size_in_bytes (&argse, arg->expr);
+      if (arg->expr->ts.type == BT_CHARACTER)
+       tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      else
+       tmp = fold_convert (gfc_array_index_type,
+                           size_in_bytes (source_type)); 

 
       /* Obtain the size of the array in bytes.  */
       extent = gfc_create_var (gfc_array_index_type, NULL);
 
       /* Obtain the size of the array in bytes.  */
       extent = gfc_create_var (gfc_array_index_type, NULL);


@@ -2605,13 +3104,13 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
          stride = gfc_conv_descriptor_stride (argse.expr, idx);
          lower = gfc_conv_descriptor_lbound (argse.expr, idx);
          upper = gfc_conv_descriptor_ubound (argse.expr, idx);
          stride = gfc_conv_descriptor_stride (argse.expr, idx);
          lower = gfc_conv_descriptor_lbound (argse.expr, idx);
          upper = gfc_conv_descriptor_ubound (argse.expr, idx);

-         tmp = build2 (MINUS_EXPR, gfc_array_index_type,
-                       upper, lower);
+         tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+                            upper, lower);

          gfc_add_modify_expr (&argse.pre, extent, tmp);
          gfc_add_modify_expr (&argse.pre, extent, tmp);

-         tmp = build2 (PLUS_EXPR, gfc_array_index_type,
-                       extent, gfc_index_one_node);
-         tmp = build2 (MULT_EXPR, gfc_array_index_type,
-                       tmp, source_bytes);
+         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);

        }
     }
 
        }
     }
 


@@ -2619,7 +3118,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);
 
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);
 

-  /* Now convert MOLD.  The sole output is:
+  /* Now convert MOLD.  The outputs are:
+       mold_type = the TREE type of MOLD

        dest_word_len = destination word length in bytes.  */
   arg = arg->next;
 
        dest_word_len = destination word length in bytes.  */
   arg = arg->next;
 


@@ -2629,20 +3129,25 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   if (ss == gfc_ss_terminator)
     {
       gfc_conv_expr_reference (&argse, arg->expr);
   if (ss == gfc_ss_terminator)
     {
       gfc_conv_expr_reference (&argse, arg->expr);

-
-      /* Obtain the source word length.  */
-      tmp = gfc_size_in_bytes (&argse, arg->expr);
+      mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));

     }
   else
     {
       gfc_init_se (&argse, NULL);
       argse.want_pointer = 0;
       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
     }
   else
     {
       gfc_init_se (&argse, NULL);
       argse.want_pointer = 0;
       gfc_conv_expr_descriptor (&argse, arg->expr, ss);

-
-      /* Obtain the source word length.  */
-      tmp = gfc_size_in_bytes (&argse, arg->expr);
+      mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));

     }
 
     }
 

+  if (arg->expr->ts.type == BT_CHARACTER)
+    {
+      tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
+    }
+  else
+    tmp = fold_convert (gfc_array_index_type,
+                       size_in_bytes (mold_type)); 
+ 

   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
 
   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
 


@@ -2665,17 +3170,18 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
   if (tmp != NULL_TREE)
     {
   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
   if (tmp != NULL_TREE)
     {

-      tmp = build2 (MULT_EXPR, gfc_array_index_type,
-                   tmp, dest_word_len);
-      tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
+      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+                        tmp, dest_word_len);
+      tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
+                        tmp, source_bytes);

     }
   else
     tmp = source_bytes;
 
   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
   gfc_add_modify_expr (&se->pre, size_words,
     }
   else
     tmp = source_bytes;
 
   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
   gfc_add_modify_expr (&se->pre, size_words,

-                      build2 (CEIL_DIV_EXPR, gfc_array_index_type,
-                              size_bytes, dest_word_len));
+                      fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
+                                   size_bytes, dest_word_len));

 
   /* Evaluate the bounds of the result.  If the loop range exists, we have
      to check if it is too large.  If so, we modify loop->to be consistent
 
   /* 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


@@ -2686,42 +3192,45 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
     {
       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
                         se->loop->to[n], se->loop->from[n]);
     {
       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
                         se->loop->to[n], se->loop->from[n]);

-      tmp = build2 (PLUS_EXPR, gfc_array_index_type,
-                   tmp, gfc_index_one_node);
-      tmp = build2 (MIN_EXPR, gfc_array_index_type,
-                   tmp, size_words);
+      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+                        tmp, gfc_index_one_node);
+      tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
+                        tmp, size_words);

       gfc_add_modify_expr (&se->pre, size_words, tmp);
       gfc_add_modify_expr (&se->pre, size_bytes,
       gfc_add_modify_expr (&se->pre, size_words, tmp);
       gfc_add_modify_expr (&se->pre, size_bytes,

-                          build2 (MULT_EXPR, gfc_array_index_type,
-                          size_words, dest_word_len));
-      upper = build2 (PLUS_EXPR, gfc_array_index_type,
-                     size_words, se->loop->from[n]);
-      upper = build2 (MINUS_EXPR, gfc_array_index_type,
-                     upper, gfc_index_one_node);
+                          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);

     }
   else
     {
     }
   else
     {

-      upper = build2 (MINUS_EXPR, gfc_array_index_type,
-                     size_words, gfc_index_one_node);
+      upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+                          size_words, gfc_index_one_node);

       se->loop->from[n] = gfc_index_zero_node;
     }
 
   se->loop->to[n] = upper;
 
   /* Build a destination descriptor, using the pointer, source, as the
       se->loop->from[n] = gfc_index_zero_node;
     }
 
   se->loop->to[n] = upper;
 
   /* Build a destination descriptor, using the pointer, source, as the

-     data field.  This is already allocated so set callee_alloc.  */
-  tmp = gfc_typenode_for_spec (&expr->ts);
+     data field.  This is already allocated so set callee_alloc.
+     FIXME callee_alloc is not set!  */
+

   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,

-                              info, tmp, false, true, false, false);
+                              info, mold_type, false, true, false);

 
 

-  /* Use memcpy to do the transfer.  */
+  /* Cast the pointer to the result.  */

   tmp = gfc_conv_descriptor_data_get (info->descriptor);
   tmp = gfc_conv_descriptor_data_get (info->descriptor);

-  args = gfc_chainon_list (NULL_TREE, tmp);
-  tmp = fold_convert (pvoid_type_node, source);
-  args = gfc_chainon_list (args, source);
-  args = gfc_chainon_list (args, size_bytes);
-  tmp = built_in_decls[BUILT_IN_MEMCPY];
-  tmp = build_function_call_expr (tmp, args);
+  tmp = fold_convert (pvoid_type_node, tmp);
+
+  /* Use memcpy to do the transfer.  */
+  tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
+                        3,
+                        tmp,
+                        fold_convert (pvoid_type_node, source),
+                        size_bytes);

   gfc_add_expr_to_block (&se->pre, tmp);
 
   se->expr = info->descriptor;
   gfc_add_expr_to_block (&se->pre, tmp);
 
   se->expr = info->descriptor;


@@ -2731,7 +3240,7 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
 
 
 /* Scalar transfer statement.
 
 
 /* Scalar transfer statement.

-   TRANSFER (source, mold) = *(typeof<mold> *)&source.  */
+   TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl.  */

 
 static void
 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 
 static void
 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)


@@ -2741,6 +3250,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
   tree type;
   tree ptr;
   gfc_ss *ss;
   tree type;
   tree ptr;
   gfc_ss *ss;

+  tree tmpdecl, tmp;

 
   /* Get a pointer to the source.  */
   arg = expr->value.function.actual;
 
   /* Get a pointer to the source.  */
   arg = expr->value.function.actual;


@@ -2756,9 +3266,10 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 
   arg = arg->next;
   type = gfc_typenode_for_spec (&expr->ts);
 
   arg = arg->next;
   type = gfc_typenode_for_spec (&expr->ts);

-  ptr = convert (build_pointer_type (type), ptr);
+

   if (expr->ts.type == BT_CHARACTER)
     {
   if (expr->ts.type == BT_CHARACTER)
     {

+      ptr = convert (build_pointer_type (type), ptr);

       gfc_init_se (&argse, NULL);
       gfc_conv_expr (&argse, arg->expr);
       gfc_add_block_to_block (&se->pre, &argse.pre);
       gfc_init_se (&argse, NULL);
       gfc_conv_expr (&argse, arg->expr);
       gfc_add_block_to_block (&se->pre, &argse.pre);


@@ -2768,7 +3279,19 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
     }
   else
     {
     }
   else
     {

-      se->expr = build_fold_indirect_ref (ptr);
+      tree moldsize;
+      tmpdecl = gfc_create_var (type, "transfer");
+      moldsize = size_in_bytes (type);
+
+      /* Use memcpy to do the transfer.  */
+      tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
+      tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+                            fold_convert (pvoid_type_node, tmp),
+                            fold_convert (pvoid_type_node, ptr),
+                            moldsize);
+      gfc_add_expr_to_block (&se->pre, tmp);
+
+      se->expr = tmpdecl;

     }
 }
 
     }
 }
 


@@ -2812,7 +3335,6 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
   gfc_se arg2se;
   tree tmp2;
   tree tmp;
   gfc_se arg2se;
   tree tmp2;
   tree tmp;

-  tree args, fndecl;

   tree nonzero_charlen;
   tree nonzero_arraylen;
   gfc_ss *ss1, *ss2;
   tree nonzero_charlen;
   tree nonzero_arraylen;
   gfc_ss *ss1, *ss2;


@@ -2836,10 +3358,11 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
       else
         {
           /* A pointer to an array.  */
       else
         {
           /* A pointer to an array.  */

-          arg1se.descriptor_only = 1;
-          gfc_conv_expr_lhs (&arg1se, arg1->expr);
+          gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);

           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
         }
           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
         }

+      gfc_add_block_to_block (&se->pre, &arg1se.pre);
+      gfc_add_block_to_block (&se->post, &arg1se.post);

       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
                    fold_convert (TREE_TYPE (tmp2), null_pointer_node));
       se->expr = tmp;
       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
                    fold_convert (TREE_TYPE (tmp2), null_pointer_node));
       se->expr = tmp;


@@ -2863,12 +3386,15 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
           gfc_conv_expr (&arg1se, arg1->expr);
           arg2se.want_pointer = 1;
           gfc_conv_expr (&arg2se, arg2->expr);
           gfc_conv_expr (&arg1se, arg1->expr);
           arg2se.want_pointer = 1;
           gfc_conv_expr (&arg2se, arg2->expr);

+         gfc_add_block_to_block (&se->pre, &arg1se.pre);
+         gfc_add_block_to_block (&se->post, &arg1se.post);

           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);

-          se->expr = tmp;
+          tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
+                         null_pointer_node);
+          se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);

         }
       else
         {
         }
       else
         {

-

          /* An array pointer of zero length is not associated if target is
             present.  */
          arg1se.descriptor_only = 1;
          /* An array pointer of zero length is not associated if target is
             present.  */
          arg1se.descriptor_only = 1;


@@ -2876,25 +3402,22 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
          tmp = gfc_conv_descriptor_stride (arg1se.expr,
                                            gfc_rank_cst[arg1->expr->rank - 1]);
          nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
          tmp = gfc_conv_descriptor_stride (arg1se.expr,
                                            gfc_rank_cst[arg1->expr->rank - 1]);
          nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,

-                                tmp, integer_zero_node);
+                                    tmp, build_int_cst (TREE_TYPE (tmp), 0));

 
           /* A pointer to an array, call library function _gfor_associated.  */
           gcc_assert (ss2 != gfc_ss_terminator);
 
           /* A pointer to an array, call library function _gfor_associated.  */
           gcc_assert (ss2 != gfc_ss_terminator);

-          args = NULL_TREE;

           arg1se.want_pointer = 1;
           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
           arg1se.want_pointer = 1;
           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);

-          args = gfc_chainon_list (args, arg1se.expr);

 
           arg2se.want_pointer = 1;
           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
           gfc_add_block_to_block (&se->pre, &arg2se.pre);
           gfc_add_block_to_block (&se->post, &arg2se.post);
 
           arg2se.want_pointer = 1;
           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
           gfc_add_block_to_block (&se->pre, &arg2se.pre);
           gfc_add_block_to_block (&se->post, &arg2se.post);

-          args = gfc_chainon_list (args, arg2se.expr);
-          fndecl = gfor_fndecl_associated;
-          se->expr = build_function_call_expr (fndecl, args);
+          se->expr = build_call_expr (gfor_fndecl_associated, 2,
+                                     arg1se.expr, arg2se.expr);
+         se->expr = convert (boolean_type_node, se->expr);

          se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
                             se->expr, nonzero_arraylen);
          se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
                             se->expr, nonzero_arraylen);

-

         }
 
       /* If target is present zero character length pointers cannot
         }
 
       /* If target is present zero character length pointers cannot


@@ -2908,288 +3431,33 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
 }
 
 
 }
 
 

-/* Scan a string for any one of the characters in a set of characters.  */
+/* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */

 
 static void
 
 static void

-gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)

 {
 {

-  tree logical4_type_node = gfc_get_logical_type (4);
-  tree args;
-  tree back;
-  tree type;
-  tree tmp;
-
-  args = gfc_conv_intrinsic_function_args (se, expr);
-  type = gfc_typenode_for_spec (&expr->ts);
-  tmp = gfc_advance_chain (args, 3);
-  if (TREE_CHAIN (tmp) == NULL_TREE)
-    {
-      back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
-                       NULL_TREE);
-      TREE_CHAIN (tmp) = back;
-    }
-  else
-    {
-      back = TREE_CHAIN (tmp);
-      TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
-    }
+  tree arg, type;

 
 

-  se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
-  se->expr = convert (type, se->expr);
-}
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);

 
 

+  /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
+  type = gfc_get_int_type (4); 
+  arg = build_fold_addr_expr (fold_convert (type, arg));

 
 

-/* Verify that a set of characters contains all the characters in a string
-   by identifying the position of the first character in a string of
-   characters that does not appear in a given set of characters.  */
-
-static void
-gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
-{
-  tree logical4_type_node = gfc_get_logical_type (4);
-  tree args;
-  tree back;
-  tree type;
-  tree tmp;
-
-  args = gfc_conv_intrinsic_function_args (se, expr);
+  /* Convert it to the required type.  */

   type = gfc_typenode_for_spec (&expr->ts);
   type = gfc_typenode_for_spec (&expr->ts);

-  tmp = gfc_advance_chain (args, 3);
-  if (TREE_CHAIN (tmp) == NULL_TREE)
-    {
-      back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
-                       NULL_TREE);
-      TREE_CHAIN (tmp) = back;
-    }
-  else
-    {
-      back = TREE_CHAIN (tmp);
-      TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
-    }
-
-  se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
-  se->expr = convert (type, se->expr);
+  se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
+  se->expr = fold_convert (type, se->expr);

 }
 
 }
 

-/* Prepare components and related information of a real number which is
-   the first argument of a elemental functions to manipulate reals.  */
-
-static void
-prepare_arg_info (gfc_se * se, gfc_expr * expr,
-                 real_compnt_info * rcs, int all)
-{
-   tree arg;
-   tree masktype;
-   tree tmp;
-   tree wbits;
-   tree one;
-   tree exponent, fraction;
-   int n;
-   gfc_expr *a1;
-
-   if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
-     gfc_todo_error ("Non-IEEE floating format");
-
-   gcc_assert (expr->expr_type == EXPR_FUNCTION);
-
-   arg = gfc_conv_intrinsic_function_args (se, expr);
-   arg = TREE_VALUE (arg);
-   rcs->type = TREE_TYPE (arg);
-
-   /* Force arg'type to integer by unaffected convert  */
-   a1 = expr->value.function.actual->expr;
-   masktype = gfc_get_int_type (a1->ts.kind);
-   rcs->mtype = masktype;
-   tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
-   arg = gfc_create_var (masktype, "arg");
-   gfc_add_modify_expr(&se->pre, arg, tmp);
-   rcs->arg = arg;
-
-   /* Calculate the numbers of bits of exponent, fraction and word  */
-   n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
-   tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
-   rcs->fdigits = convert (masktype, tmp);
-   wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
-   wbits = convert (masktype, wbits);
-   rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp);
-
-   /* Form masks for exponent/fraction/sign  */
-   one = gfc_build_const (masktype, integer_one_node);
-   rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits);
-   rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits);
-   rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1);
-   rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one);
-   /* Form bias.  */
-   tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one);
-   tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp);
-   rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one);
-
-   if (all)
-     {
-       /* exponent, and fraction  */
-       tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
-       tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
-       exponent = gfc_create_var (masktype, "exponent");
-       gfc_add_modify_expr(&se->pre, exponent, tmp);
-       rcs->expn = exponent;
-
-       tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
-       fraction = gfc_create_var (masktype, "fraction");
-       gfc_add_modify_expr(&se->pre, fraction, tmp);
-       rcs->frac = fraction;
-     }
-}
-
-/* Build a call to __builtin_clz.  */
-
-static tree
-call_builtin_clz (tree result_type, tree op0)
-{
-  tree fn, parms, call;
-  enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
-
-  if (op0_mode == TYPE_MODE (integer_type_node))
-    fn = built_in_decls[BUILT_IN_CLZ];
-  else if (op0_mode == TYPE_MODE (long_integer_type_node))
-    fn = built_in_decls[BUILT_IN_CLZL];
-  else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
-    fn = built_in_decls[BUILT_IN_CLZLL];
-  else
-    gcc_unreachable ();
-
-  parms = tree_cons (NULL, op0, NULL);
-  call = build_function_call_expr (fn, parms);
-
-  return convert (result_type, call);
-}
-
-
-/* Generate code for SPACING (X) intrinsic function.
-   SPACING (X) = POW (2, e-p)
-
-   We generate:
-
-    t = expn - fdigits // e - p.
-    res = t << fdigits // Form the exponent. Fraction is zero.
-    if (t < 0) // The result is out of range. Denormalized case.
-      res = tiny(X)
- */
-
-static void
-gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
-{
-   tree arg;
-   tree masktype;
-   tree tmp, t1, cond;
-   tree tiny, zero;
-   tree fdigits;
-   real_compnt_info rcs;
-
-   prepare_arg_info (se, expr, &rcs, 0);
-   arg = rcs.arg;
-   masktype = rcs.mtype;
-   fdigits = rcs.fdigits;
-   tiny = rcs.f1;
-   zero = gfc_build_const (masktype, integer_zero_node);
-   tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
-   tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
-   tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
-   cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
-   t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
-   tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
-   tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
-
-   se->expr = tmp;
-}
-
-/* Generate code for RRSPACING (X) intrinsic function.
-   RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
-
-   So the result's exponent is p. And if X is normalized, X's fraction part
-   is the result's fraction. If X is denormalized, to get the X's fraction we
-   shift X's fraction part to left until the first '1' is removed.
-
-   We generate:
-
-    if (expn == 0 && frac == 0)
-       res = 0;
-    else
-    {
-       // edigits is the number of exponent bits. Add the sign bit.
-       sedigits = edigits + 1;
-
-       if (expn == 0) // Denormalized case.
-       {
-         t1 = leadzero (frac);
-         frac = frac << (t1 + 1); //Remove the first '1'.
-         frac = frac >> (sedigits); //Form the fraction.
-       }
-
-       //fdigits is the number of fraction bits. Form the exponent.
-       t = bias + fdigits;
-
-       res = (t << fdigits) | frac;
-    }
-*/
-
-static void
-gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
-{
-   tree masktype;
-   tree tmp, t1, t2, cond, cond2;
-   tree one, zero;
-   tree fdigits, fraction;
-   real_compnt_info rcs;
-
-   prepare_arg_info (se, expr, &rcs, 1);
-   masktype = rcs.mtype;
-   fdigits = rcs.fdigits;
-   fraction = rcs.frac;
-   one = gfc_build_const (masktype, integer_one_node);
-   zero = gfc_build_const (masktype, integer_zero_node);
-   t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
-
-   t1 = call_builtin_clz (masktype, fraction);
-   tmp = build2 (PLUS_EXPR, masktype, t1, one);
-   tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
-   tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
-   cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
-   fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
-
-   tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
-   tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
-   tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
-
-   cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
-   cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
-   tmp = build3 (COND_EXPR, masktype, cond,
-                build_int_cst (masktype, 0), tmp);
-
-   tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
-   se->expr = tmp;
-}
-
-/* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
-
-static void
-gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
-{
-  tree args;
-
-  args = gfc_conv_intrinsic_function_args (se, expr);
-  args = TREE_VALUE (args);
-  args = build_fold_addr_expr (args);
-  args = tree_cons (NULL_TREE, args, NULL_TREE);
-  se->expr = build_function_call_expr (gfor_fndecl_si_kind, args);
-}

 
 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
 
 static void
 
 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
 
 static void

-gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)

 {
   gfc_actual_arglist *actual;
 {
   gfc_actual_arglist *actual;

-  tree args;
+  tree args, type;

   gfc_se argse;
 
   args = NULL_TREE;
   gfc_se argse;
 
   args = NULL_TREE;


@@ -3201,13 +3469,27 @@ gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
       if (actual->expr == NULL)
         argse.expr = null_pointer_node;
       else
       if (actual->expr == NULL)
         argse.expr = null_pointer_node;
       else

-        gfc_conv_expr_reference (&argse, actual->expr);
+       {
+         gfc_typespec ts;
+         if (actual->expr->ts.kind != gfc_c_int_kind)
+           {
+             /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
+             ts.type = BT_INTEGER;
+             ts.kind = gfc_c_int_kind;
+             gfc_convert_type (actual->expr, &ts, 2);
+           }
+         gfc_conv_expr_reference (&argse, actual->expr);
+       } 

 
       gfc_add_block_to_block (&se->pre, &argse.pre);
       gfc_add_block_to_block (&se->post, &argse.post);
       args = gfc_chainon_list (args, argse.expr);
     }
 
       gfc_add_block_to_block (&se->pre, &argse.pre);
       gfc_add_block_to_block (&se->post, &argse.post);
       args = gfc_chainon_list (args, argse.expr);
     }

+
+  /* Convert it to the required type.  */
+  type = gfc_typenode_for_spec (&expr->ts);

   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);

+  se->expr = fold_convert (type, se->expr);

 }
 
 
 }
 
 


@@ -3221,30 +3503,33 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
   tree len;
   tree addr;
   tree tmp;
   tree len;
   tree addr;
   tree tmp;

-  tree arglist;

   tree type;
   tree cond;
   tree type;
   tree cond;

+  tree fndecl;
+  tree *args;
+  unsigned int num_args;

 
 

-  arglist = NULL_TREE;
+  num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+  args = alloca (sizeof (tree) * num_args);

 
   type = build_pointer_type (gfc_character1_type_node);
   var = gfc_create_var (type, "pstr");
   addr = gfc_build_addr_expr (ppvoid_type_node, var);
   len = gfc_create_var (gfc_int4_type_node, "len");
 
 
   type = build_pointer_type (gfc_character1_type_node);
   var = gfc_create_var (type, "pstr");
   addr = gfc_build_addr_expr (ppvoid_type_node, var);
   len = gfc_create_var (gfc_int4_type_node, "len");
 

-  tmp = gfc_conv_intrinsic_function_args (se, expr);
-  arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
-  arglist = gfc_chainon_list (arglist, addr);
-  arglist = chainon (arglist, tmp);
+  gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+  args[0] = build_fold_addr_expr (len);
+  args[1] = addr;

 
 

-  tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
+  fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
+  tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
+                         fndecl, num_args, args);

   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
   cond = build2 (GT_EXPR, boolean_type_node, len,
                 build_int_cst (TREE_TYPE (len), 0));
   gfc_add_expr_to_block (&se->pre, tmp);
 
   /* Free the temporary afterwards, if necessary.  */
   cond = build2 (GT_EXPR, boolean_type_node, len,
                 build_int_cst (TREE_TYPE (len), 0));

-  arglist = gfc_chainon_list (NULL_TREE, var);
-  tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
+  tmp = gfc_call_free (var);

   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
   gfc_add_expr_to_block (&se->post, tmp);
 
   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
   gfc_add_expr_to_block (&se->post, tmp);
 


@@ -3258,31 +3543,114 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
 static void
 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
 {
 static void
 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
 {

-  tree gfc_int4_type_node = gfc_get_int_type (4);
-  tree tmp;
-  tree len;
-  tree args;
-  tree arglist;
-  tree ncopies;
-  tree var;
-  tree type;
+  tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
+  tree type, cond, tmp, count, exit_label, n, max, largest;
+  stmtblock_t block, body;
+  int i;

 
 

-  args = gfc_conv_intrinsic_function_args (se, expr);
-  len = TREE_VALUE (args);
-  tmp = gfc_advance_chain (args, 2);
-  ncopies = TREE_VALUE (tmp);
-  len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
+  /* Get the arguments.  */
+  gfc_conv_intrinsic_function_args (se, expr, args, 3);
+  slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
+  src = args[1];
+  ncopies = gfc_evaluate_now (args[2], &se->pre);
+  ncopies_type = TREE_TYPE (ncopies);
+
+  /* Check that NCOPIES is not negative.  */
+  cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
+                     build_int_cst (ncopies_type, 0));
+  gfc_trans_runtime_check (cond, &se->pre, &expr->where,
+                          "Argument NCOPIES of REPEAT intrinsic is negative "
+                          "(its value is %lld)",
+                          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);
+  gfc_add_modify_expr (&se->pre, n, tmp);
+  ncopies = n;
+
+  /* Check that ncopies is not too large: ncopies should be less than
+     (or equal to) MAX / slen, where MAX is the maximal integer of
+     the gfc_charlen_type_node type.  If slen == 0, we need a special
+     case to avoid the division by zero.  */
+  i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+  max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
+  max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
+                    fold_convert (size_type_node, max), slen);
+  largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
+             ? size_type_node : ncopies_type;
+  cond = fold_build2 (GT_EXPR, boolean_type_node,
+                     fold_convert (largest, ncopies),
+                     fold_convert (largest, max));
+  tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
+                    build_int_cst (size_type_node, 0));
+  cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
+                     cond);
+  gfc_trans_runtime_check (cond, &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));

   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);

-  var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
+  dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
+
+  /* Generate the code to do the repeat operation:
+       for (i = 0; i < ncopies; i++)
+         memmove (dest + (i * slen), src, slen);  */
+  gfc_start_block (&block);
+  count = gfc_create_var (ncopies_type, "count");
+  gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
+  exit_label = gfc_build_label_decl (NULL_TREE);
+
+  /* Start the loop body.  */
+  gfc_start_block (&body);
+
+  /* Exit the loop if count >= ncopies.  */
+  cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  TREE_USED (exit_label) = 1;
+  tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
+                    build_empty_stmt ());
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Call memmove (dest + (i*slen), src, slen).  */
+  tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
+                    fold_convert (gfc_charlen_type_node, slen),
+                    fold_convert (gfc_charlen_type_node, count));
+  tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
+                    fold_convert (pchar_type_node, dest),
+                    fold_convert (sizetype, tmp));
+  tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
+                        tmp, src, slen);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Increment count.  */
+  tmp = build2 (PLUS_EXPR, ncopies_type, count,
+               build_int_cst (TREE_TYPE (count), 1));
+  gfc_add_modify_expr (&body, count, tmp);

 
 

-  arglist = NULL_TREE;
-  arglist = gfc_chainon_list (arglist, var);
-  arglist = chainon (arglist, args);
-  tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
+  /* Build the loop.  */
+  tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Add the exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Finish the block.  */
+  tmp = gfc_finish_block (&block);

   gfc_add_expr_to_block (&se->pre, tmp);
 
   gfc_add_expr_to_block (&se->pre, tmp);
 

-  se->expr = var;
-  se->string_length = len;
+  /* Set the result value.  */
+  se->expr = dest;
+  se->string_length = dlen;

 }
 
 
 }
 
 


@@ -3297,7 +3665,7 @@ gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
 
   /* Call the library function.  This always returns an INTEGER(4).  */
   fndecl = gfor_fndecl_iargc;
 
   /* Call the library function.  This always returns an INTEGER(4).  */
   fndecl = gfor_fndecl_iargc;

-  tmp = build_function_call_expr (fndecl, NULL_TREE);
+  tmp = build_call_expr (fndecl, 0);

 
   /* Convert it to the required type.  */
   type = gfc_typenode_for_spec (&expr->ts);
 
   /* Convert it to the required type.  */
   type = gfc_typenode_for_spec (&expr->ts);


@@ -3311,7 +3679,7 @@ gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
    gfc_index_integer_kind integer.  */
 
 static void
    gfc_index_integer_kind integer.  */
 
 static void

-gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)

 {
   tree temp_var;
   gfc_expr *arg_expr;
 {
   tree temp_var;
   gfc_expr *arg_expr;


@@ -3325,13 +3693,11 @@ gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
     gfc_conv_expr_reference (se, arg_expr);
   else
     gfc_conv_array_parameter (se, arg_expr, ss, 1); 
     gfc_conv_expr_reference (se, arg_expr);
   else
     gfc_conv_array_parameter (se, arg_expr, ss, 1); 

-  se->expr= convert (gfc_unsigned_type (long_integer_type_node), 
-                    se->expr);
+  se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);

    
   /* Create a temporary variable for loc return value.  Without this, 
      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
    
   /* Create a temporary variable for loc return value.  Without this, 
      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */

-  temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node), 
-                            NULL);
+  temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);

   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
   se->expr = temp_var;
 }
   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
   se->expr = temp_var;
 }


@@ -3363,7 +3729,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
        }
     }
 
        }
     }
 

-  switch (expr->value.function.isym->generic_id)
+  switch (expr->value.function.isym->id)

     {
     case GFC_ISYM_NONE:
       gcc_unreachable ();
     {
     case GFC_ISYM_NONE:
       gcc_unreachable ();


@@ -3388,20 +3754,12 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_exponent (se, expr);
       break;
 
       gfc_conv_intrinsic_exponent (se, expr);
       break;
 

-    case GFC_ISYM_SPACING:
-      gfc_conv_intrinsic_spacing (se, expr);
-      break;
-
-    case GFC_ISYM_RRSPACING:
-      gfc_conv_intrinsic_rrspacing (se, expr);
-      break;
-

     case GFC_ISYM_SCAN:
     case GFC_ISYM_SCAN:

-      gfc_conv_intrinsic_scan (se, expr);
+      gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan);

       break;
 
     case GFC_ISYM_VERIFY:
       break;
 
     case GFC_ISYM_VERIFY:

-      gfc_conv_intrinsic_verify (se, expr);
+      gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify);

       break;
 
     case GFC_ISYM_ALLOCATED:
       break;
 
     case GFC_ISYM_ALLOCATED:


@@ -3429,7 +3787,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_AINT:
       break;
 
     case GFC_ISYM_AINT:

-      gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
+      gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);

       break;
 
     case GFC_ISYM_ALL:
       break;
 
     case GFC_ISYM_ALL:


@@ -3437,7 +3795,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_ANINT:
       break;
 
     case GFC_ISYM_ANINT:

-      gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
+      gfc_conv_intrinsic_aint (se, expr, RND_ROUND);

       break;
 
     case GFC_ISYM_AND:
       break;
 
     case GFC_ISYM_AND:


@@ -3467,19 +3825,22 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       /* Integer conversions are handled separately to make sure we get the
          correct rounding mode.  */
     case GFC_ISYM_INT:
       /* Integer conversions are handled separately to make sure we get the
          correct rounding mode.  */
     case GFC_ISYM_INT:

-      gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
+    case GFC_ISYM_INT2:
+    case GFC_ISYM_INT8:
+    case GFC_ISYM_LONG:
+      gfc_conv_intrinsic_int (se, expr, RND_TRUNC);

       break;
 
     case GFC_ISYM_NINT:
       break;
 
     case GFC_ISYM_NINT:

-      gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
+      gfc_conv_intrinsic_int (se, expr, RND_ROUND);

       break;
 
     case GFC_ISYM_CEILING:
       break;
 
     case GFC_ISYM_CEILING:

-      gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
+      gfc_conv_intrinsic_int (se, expr, RND_CEIL);

       break;
 
     case GFC_ISYM_FLOOR:
       break;
 
     case GFC_ISYM_FLOOR:

-      gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
+      gfc_conv_intrinsic_int (se, expr, RND_FLOOR);

       break;
 
     case GFC_ISYM_MOD:
       break;
 
     case GFC_ISYM_MOD:


@@ -3561,13 +3922,33 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_INDEX:
       break;
 
     case GFC_ISYM_INDEX:

-      gfc_conv_intrinsic_index (se, expr);
+      gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index);

       break;
 
     case GFC_ISYM_IOR:
       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
       break;
 
       break;
 
     case GFC_ISYM_IOR:
       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
       break;
 

+    case GFC_ISYM_IS_IOSTAT_END:
+      gfc_conv_has_intvalue (se, expr, LIBERROR_END);
+      break;
+
+    case GFC_ISYM_IS_IOSTAT_EOR:
+      gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
+      break;
+
+    case GFC_ISYM_ISNAN:
+      gfc_conv_intrinsic_isnan (se, expr);
+      break;
+
+    case GFC_ISYM_LSHIFT:
+      gfc_conv_intrinsic_rlshift (se, expr, 0);
+      break;
+
+    case GFC_ISYM_RSHIFT:
+      gfc_conv_intrinsic_rlshift (se, expr, 1);
+      break;
+

     case GFC_ISYM_ISHFT:
       gfc_conv_intrinsic_ishft (se, expr);
       break;
     case GFC_ISYM_ISHFT:
       gfc_conv_intrinsic_ishft (se, expr);
       break;


@@ -3615,7 +3996,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_MAX:
       break;
 
     case GFC_ISYM_MAX:

-      gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
+      if (expr->ts.type == BT_CHARACTER)
+       gfc_conv_intrinsic_minmax_char (se, expr, 1);
+      else
+       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);

       break;
 
     case GFC_ISYM_MAXLOC:
       break;
 
     case GFC_ISYM_MAXLOC:


@@ -3631,7 +4015,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_MIN:
       break;
 
     case GFC_ISYM_MIN:

-      gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
+      if (expr->ts.type == BT_CHARACTER)
+       gfc_conv_intrinsic_minmax_char (se, expr, -1);
+      else
+       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);

       break;
 
     case GFC_ISYM_MINLOC:
       break;
 
     case GFC_ISYM_MINLOC:


@@ -3666,6 +4053,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_size (se, expr);
       break;
 
       gfc_conv_intrinsic_size (se, expr);
       break;
 

+    case GFC_ISYM_SIZEOF:
+      gfc_conv_intrinsic_sizeof (se, expr);
+      break;
+

     case GFC_ISYM_SUM:
       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
       break;
     case GFC_ISYM_SUM:
       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
       break;


@@ -3703,7 +4094,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_loc (se, expr);
       break;
 
       gfc_conv_intrinsic_loc (se, expr);
       break;
 

+    case GFC_ISYM_ACCESS:

     case GFC_ISYM_CHDIR:
     case GFC_ISYM_CHDIR:

+    case GFC_ISYM_CHMOD:
+    case GFC_ISYM_DTIME:

     case GFC_ISYM_ETIME:
     case GFC_ISYM_FGET:
     case GFC_ISYM_FGETC:
     case GFC_ISYM_ETIME:
     case GFC_ISYM_FGET:
     case GFC_ISYM_FGETC:


@@ -3722,8 +4116,11 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
     case GFC_ISYM_IRAND:
     case GFC_ISYM_ISATTY:
     case GFC_ISYM_LINK:
     case GFC_ISYM_IRAND:
     case GFC_ISYM_ISATTY:
     case GFC_ISYM_LINK:

+    case GFC_ISYM_LSTAT:

     case GFC_ISYM_MALLOC:
     case GFC_ISYM_MATMUL:
     case GFC_ISYM_MALLOC:
     case GFC_ISYM_MATMUL:

+    case GFC_ISYM_MCLOCK:
+    case GFC_ISYM_MCLOCK8:

     case GFC_ISYM_RAND:
     case GFC_ISYM_RENAME:
     case GFC_ISYM_SECOND:
     case GFC_ISYM_RAND:
     case GFC_ISYM_RENAME:
     case GFC_ISYM_SECOND:


@@ -3752,7 +4149,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 void
 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
 {
 void
 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
 {

-  switch (ss->expr->value.function.isym->generic_id)
+  switch (ss->expr->value.function.isym->id)

     {
     case GFC_ISYM_UBOUND:
     case GFC_ISYM_LBOUND:
     {
     case GFC_ISYM_UBOUND:
     case GFC_ISYM_LBOUND:


@@ -3815,7 +4212,7 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
   gcc_assert (expr->rank > 0);
 
   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
   gcc_assert (expr->rank > 0);
 

-  switch (expr->value.function.isym->generic_id)
+  switch (expr->value.function.isym->id)

     {
     case GFC_ISYM_ALL:
     case GFC_ISYM_ANY:
     {
     case GFC_ISYM_ALL:
     case GFC_ISYM_ANY:


@@ -3863,7 +4260,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
     return gfc_walk_intrinsic_libfunc (ss, expr);
 
   /* Special cases.  */
     return gfc_walk_intrinsic_libfunc (ss, expr);
 
   /* Special cases.  */

-  switch (isym->generic_id)
+  switch (isym->id)

     {
     case GFC_ISYM_LBOUND:
     case GFC_ISYM_UBOUND:
     {
     case GFC_ISYM_LBOUND:
     case GFC_ISYM_UBOUND:


@@ -3874,10 +4271,9 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
 
     default:
       /* This probably meant someone forgot to add an intrinsic to the above
 
     default:
       /* This probably meant someone forgot to add an intrinsic to the above

-         list(s) when they implemented it, or something's gone horribly wrong.
-       */
-      gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
-                     expr->value.function.name);
+         list(s) when they implemented it, or something's gone horribly
+        wrong.  */
+      gcc_unreachable ();

     }
 }
 
     }
 }