OSDN Git Service

(root) / pf3gnuchains / gcc-fork.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
2010-09-24 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / iresolve.c
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 66a3c2f..e7a92da 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1,5 +1,6 @@
 /* Intrinsic function resolution.
 /* Intrinsic function resolution.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+   2009, 2010
    Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
    Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
@@ -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,9 +17,8 @@ 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/>.  */
 
 
 /* Assign name and types to intrinsic procedures.  For functions, the
 
 
 /* Assign name and types to intrinsic procedures.  For functions, the
@@ -34,6 +34,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "tree.h"
 #include "gfortran.h"
 #include "intrinsic.h"
 #include "tree.h"
 #include "gfortran.h"
 #include "intrinsic.h"
+#include "constructor.h"
 
 /* Given printf-like arguments, return a stable version of the result string. 
 
 
 /* Given printf-like arguments, return a stable version of the result string. 
 
@@ -63,16 +64,117 @@ gfc_get_string (const char *format, ...)
 static void
 check_charlen_present (gfc_expr *source)
 {
 static void
 check_charlen_present (gfc_expr *source)
 {
-  if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
+  if (source->ts.u.cl == NULL)
+    source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+  if (source->expr_type == EXPR_CONSTANT)
     {
     {
-      source->ts.cl = gfc_get_charlen ();
-      source->ts.cl->next = gfc_current_ns->cl_list;
-      gfc_current_ns->cl_list = source->ts.cl;
-      source->ts.cl->length = gfc_int_expr (source->value.character.length);
+      source->ts.u.cl->length
+               = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+                                   source->value.character.length);
       source->rank = 0;
     }
       source->rank = 0;
     }
+  else if (source->expr_type == EXPR_ARRAY)
+    {
+      gfc_constructor *c = gfc_constructor_first (source->value.constructor);
+      source->ts.u.cl->length
+               = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+                                   c->expr->value.character.length);
+    }
 }
 
 }
 
+/* Helper function for resolving the "mask" argument.  */
+
+static void
+resolve_mask_arg (gfc_expr *mask)
+{
+
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  if (mask->rank == 0)
+    {
+      /* For the scalar case, coerce the mask to kind=4 unconditionally
+        (because this is the only kind we have a library function
+        for).  */
+
+      if (mask->ts.kind != 4)
+       {
+         ts.type = BT_LOGICAL;
+         ts.kind = 4;
+         gfc_convert_type (mask, &ts, 2);
+       }
+    }
+  else
+    {
+      /* In the library, we access the mask with a GFC_LOGICAL_1
+        argument.  No need to waste memory if we are about to create
+        a temporary array.  */
+      if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
+       {
+         ts.type = BT_LOGICAL;
+         ts.kind = 1;
+         gfc_convert_type_warn (mask, &ts, 2, 0);
+       }
+    }
+}
+
+
+static void
+resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
+              const char *name, bool coarray)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+
+  if (dim == NULL)
+    {
+      f->rank = 1;
+      f->shape = gfc_get_shape (1);
+      mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
+                                           : array->rank);
+    }
+
+  f->value.function.name = xstrdup (name);
+}
+
+
+static void
+resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
+                         gfc_expr *dim, gfc_expr *mask)
+{
+  const char *prefix;
+
+  f->ts = array->ts;
+
+  if (mask)
+    {
+      if (mask->rank == 0)
+       prefix = "s";
+      else
+       prefix = "m";
+
+      resolve_mask_arg (mask);
+    }
+  else
+    prefix = "";
+
+  if (dim != NULL)
+    {
+      f->rank = array->rank - 1;
+      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+      gfc_resolve_dim_arg (dim);
+    }
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
+                   gfc_type_letter (array->ts.type), array->ts.kind);
+}
+
+
 /********************** Resolution functions **********************/
 
 
 /********************** Resolution functions **********************/
 
 
@@ -99,18 +201,43 @@ gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
 
 
 void
 
 
 void
-gfc_resolve_achar (gfc_expr *f, gfc_expr *x)
+gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
 {
 {
-  
   f->ts.type = BT_CHARACTER;
   f->ts.type = BT_CHARACTER;
-  f->ts.kind = gfc_default_character_kind;
-  f->ts.cl = gfc_get_charlen ();
-  f->ts.cl->next = gfc_current_ns->cl_list;
-  gfc_current_ns->cl_list = f->ts.cl;
-  f->ts.cl->length = gfc_int_expr (1);
+  f->ts.kind = string->ts.kind;
+  f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
+}
 
 
-  f->value.function.name
-    = gfc_get_string ("__achar_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+
+void
+gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
+{
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = string->ts.kind;
+  f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
+}
+
+
+static void
+gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
+                       const char *name)
+{
+  f->ts.type = BT_CHARACTER;
+  f->ts.kind = (kind == NULL)
+            ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
+  f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+  f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+
+  f->value.function.name = gfc_get_string (name, f->ts.kind,
+                                          gfc_type_letter (x->ts.type),
+                                          x->ts.kind);
+}
+
+
+void
+gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
+{
+  gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
 }
 
 
 }
 
 
@@ -167,6 +294,7 @@ void
 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
   gfc_typespec ts;
 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
   
   f->ts.type = a->ts.type;
   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
   
   f->ts.type = a->ts.type;
   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
@@ -213,6 +341,7 @@ void
 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
   gfc_typespec ts;
 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
   
   f->ts.type = a->ts.type;
   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
   
   f->ts.type = a->ts.type;
   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
@@ -307,6 +436,7 @@ void
 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
 {
   gfc_typespec ts;
 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
   
   f->ts = x->ts;
   if (n->ts.kind != gfc_c_int_kind)
   
   f->ts = x->ts;
   if (n->ts.kind != gfc_c_int_kind)
@@ -320,6 +450,45 @@ gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
 
 
 void
 
 
 void
+gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  
+  f->ts = x->ts;
+  f->rank = 1;
+  if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
+    {
+      f->shape = gfc_get_shape (1);
+      mpz_init (f->shape[0]);
+      mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
+      mpz_add_ui (f->shape[0], f->shape[0], 1);
+    }
+
+  if (n1->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      gfc_convert_type (n1, &ts, 2);
+    }
+
+  if (n2->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      gfc_convert_type (n2, &ts, 2);
+    }
+
+  if (f->value.function.isym->id == GFC_ISYM_JN2)
+    f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
+                                            f->ts.kind);
+  else
+    f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
+                                            f->ts.kind);
+}
+
+
+void
 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
 {
   f->ts.type = BT_LOGICAL;
 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
 {
   f->ts.type = BT_LOGICAL;
@@ -344,12 +513,7 @@ gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 void
 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
 void
 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
-  f->ts.type = BT_CHARACTER;
-  f->ts.kind = (kind == NULL)
-            ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
-  f->value.function.name
-    = gfc_get_string ("__char_%d_%c%d", f->ts.kind,
-                     gfc_type_letter (a->ts.type), a->ts.kind);
+  gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
 }
 
 
 }
 
 
@@ -426,7 +590,8 @@ gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
 void
 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
 {
 void
 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
 {
-  gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
+  gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
+                                               gfc_default_double_kind));
 }
 
 
 }
 
 
@@ -486,10 +651,13 @@ gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
 
 
 void
 
 
 void
-gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
+gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
 
   if (dim != NULL)
     {
 
   if (dim != NULL)
     {
@@ -498,9 +666,11 @@ gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
     }
 
       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
     }
 
+  resolve_mask_arg (mask);
+
   f->value.function.name
   f->value.function.name
-    = gfc_get_string (PREFIX ("count_%d_%c%d"), f->ts.kind,
-                     gfc_type_letter (mask->ts.type), mask->ts.kind);
+    = gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind,
+                     gfc_type_letter (mask->ts.type));
 }
 
 
 }
 
 
@@ -508,7 +678,10 @@ void
 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
                    gfc_expr *dim)
 {
 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
                    gfc_expr *dim)
 {
-  int n;
+  int n, m;
+
+  if (array->ts.type == BT_CHARACTER && array->ref)
+    gfc_resolve_substring_charlen (array);
 
   f->ts = array->ts;
   f->rank = array->rank;
 
   f->ts = array->ts;
   f->rank = array->rank;
@@ -519,26 +692,52 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
   else
     n = 0;
 
   else
     n = 0;
 
-  /* Convert shift to at least gfc_default_integer_kind, so we don't need
-     kind=1 and kind=2 versions of the library functions.  */
-  if (shift->ts.kind < gfc_default_integer_kind)
+  /* If dim kind is greater than default integer we need to use the larger.  */
+  m = gfc_default_integer_kind;
+  if (dim != NULL)
+    m = m < dim->ts.kind ? dim->ts.kind : m;
+  
+  /* Convert shift to at least m, so we don't need
+      kind=1 and kind=2 versions of the library functions.  */
+  if (shift->ts.kind < m)
     {
       gfc_typespec ts;
     {
       gfc_typespec ts;
+      gfc_clear_ts (&ts);
       ts.type = BT_INTEGER;
       ts.type = BT_INTEGER;
-      ts.kind = gfc_default_integer_kind;
+      ts.kind = m;
       gfc_convert_type_warn (shift, &ts, 2, 0);
     }
       gfc_convert_type_warn (shift, &ts, 2, 0);
     }
-
+ 
   if (dim != NULL)
     {
   if (dim != NULL)
     {
-      gfc_resolve_dim_arg (dim);
-      /* Convert dim to shift's kind, so we don't need so many variations.  */
-      if (dim->ts.kind != shift->ts.kind)
-       gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+      if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
+         && dim->symtree->n.sym->attr.optional)
+       {
+         /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
+         dim->representation.length = shift->ts.kind;
+       }
+      else
+       {
+         gfc_resolve_dim_arg (dim);
+         /* Convert dim to shift's kind to reduce variations.  */
+         if (dim->ts.kind != shift->ts.kind)
+           gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+        }
     }
     }
-  f->value.function.name
-    = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
-                     array->ts.type == BT_CHARACTER ? "_char" : "");
+
+  if (array->ts.type == BT_CHARACTER)
+    {
+      if (array->ts.kind == gfc_default_character_kind)
+       f->value.function.name
+         = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
+      else
+       f->value.function.name
+         = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
+                           array->ts.kind);
+    }
+  else
+    f->value.function.name
+       = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
 }
 
 
 }
 
 
@@ -546,6 +745,7 @@ void
 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
 {
   gfc_typespec ts;
 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
   
   f->ts.type = BT_CHARACTER;
   f->ts.kind = gfc_default_character_kind;
   
   f->ts.type = BT_CHARACTER;
   f->ts.kind = gfc_default_character_kind;
@@ -555,8 +755,8 @@ gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
     {
       ts.type = BT_INTEGER;
       ts.kind = 8;
     {
       ts.type = BT_INTEGER;
       ts.kind = 8;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (time, &ts, 2);
     }
 
       gfc_convert_type (time, &ts, 2);
     }
 
@@ -603,10 +803,10 @@ gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
 
   temp.expr_type = EXPR_OP;
   gfc_clear_ts (&temp.ts);
 
   temp.expr_type = EXPR_OP;
   gfc_clear_ts (&temp.ts);
-  temp.value.op.operator = INTRINSIC_NONE;
+  temp.value.op.op = INTRINSIC_NONE;
   temp.value.op.op1 = a;
   temp.value.op.op2 = b;
   temp.value.op.op1 = a;
   temp.value.op.op2 = b;
-  gfc_type_convert_binary (&temp);
+  gfc_type_convert_binary (&temp, 1);
   f->ts = temp.ts;
   f->value.function.name
     = gfc_get_string (PREFIX ("dot_product_%c%d"),
   f->ts = temp.ts;
   f->value.function.name
     = gfc_get_string (PREFIX ("dot_product_%c%d"),
@@ -625,10 +825,27 @@ gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
 
 
 void
 
 
 void
+gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
+                   gfc_expr *shift ATTRIBUTE_UNUSED)
+{
+  f->ts = i->ts;
+  if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
+    f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind);
+  else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
+    f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind);
+  else
+    gcc_unreachable ();
+}
+
+
+void
 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
                     gfc_expr *boundary, gfc_expr *dim)
 {
 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
                     gfc_expr *boundary, gfc_expr *dim)
 {
-  int n;
+  int n, m;
+
+  if (array->ts.type == BT_CHARACTER && array->ref)
+    gfc_resolve_substring_charlen (array);
 
   f->ts = array->ts;
   f->rank = array->rank;
 
   f->ts = array->ts;
   f->rank = array->rank;
@@ -640,27 +857,52 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
   if (boundary && boundary->rank > 0)
     n = n | 2;
 
   if (boundary && boundary->rank > 0)
     n = n | 2;
 
-  /* Convert shift to at least gfc_default_integer_kind, so we don't need
-     kind=1 and kind=2 versions of the library functions.  */
-  if (shift->ts.kind < gfc_default_integer_kind)
+  /* If dim kind is greater than default integer we need to use the larger.  */
+  m = gfc_default_integer_kind;
+  if (dim != NULL)
+    m = m < dim->ts.kind ? dim->ts.kind : m;
+  
+  /* Convert shift to at least m, so we don't need
+      kind=1 and kind=2 versions of the library functions.  */
+  if (shift->ts.kind < m)
     {
       gfc_typespec ts;
     {
       gfc_typespec ts;
+      gfc_clear_ts (&ts);
       ts.type = BT_INTEGER;
       ts.type = BT_INTEGER;
-      ts.kind = gfc_default_integer_kind;
+      ts.kind = m;
       gfc_convert_type_warn (shift, &ts, 2, 0);
     }
       gfc_convert_type_warn (shift, &ts, 2, 0);
     }
-
+ 
   if (dim != NULL)
     {
   if (dim != NULL)
     {
-      gfc_resolve_dim_arg (dim);
-      /* Convert dim to shift's kind, so we don't need so many variations.  */
-      if (dim->ts.kind != shift->ts.kind)
-       gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+      if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
+         && dim->symtree->n.sym->attr.optional)
+       {
+         /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
+         dim->representation.length = shift->ts.kind;
+       }
+      else
+       {
+         gfc_resolve_dim_arg (dim);
+         /* Convert dim to shift's kind to reduce variations.  */
+         if (dim->ts.kind != shift->ts.kind)
+           gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+        }
     }
 
     }
 
-  f->value.function.name
-    = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind,
-                     array->ts.type == BT_CHARACTER ? "_char" : "");
+  if (array->ts.type == BT_CHARACTER)
+    {
+      if (array->ts.kind == gfc_default_character_kind)
+       f->value.function.name
+         = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
+      else
+       f->value.function.name
+         = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
+                           array->ts.kind);
+    }
+  else
+    f->value.function.name
+       = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
 }
 
 
 }
 
 
@@ -682,6 +924,61 @@ gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
 }
 
 
 }
 
 
+/* Resolve the EXTENDS_TYPE_OF intrinsic function.  */
+
+void
+gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
+{
+  gfc_symbol *vtab;
+  gfc_symtree *st;
+
+  /* Prevent double resolution.  */
+  if (f->ts.type == BT_LOGICAL)
+    return;
+
+  /* Replace the first argument with the corresponding vtab.  */
+  if (a->ts.type == BT_CLASS)
+    gfc_add_component_ref (a, "$vptr");
+  else if (a->ts.type == BT_DERIVED)
+    {
+      vtab = gfc_find_derived_vtab (a->ts.u.derived);
+      /* Clear the old expr.  */
+      gfc_free_ref_list (a->ref);
+      memset (a, '\0', sizeof (gfc_expr));
+      /* Construct a new one.  */
+      a->expr_type = EXPR_VARIABLE;
+      st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+      a->symtree = st;
+      a->ts = vtab->ts;
+    }
+
+  /* Replace the second argument with the corresponding vtab.  */
+  if (mo->ts.type == BT_CLASS)
+    gfc_add_component_ref (mo, "$vptr");
+  else if (mo->ts.type == BT_DERIVED)
+    {
+      vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+      /* Clear the old expr.  */
+      gfc_free_ref_list (mo->ref);
+      memset (mo, '\0', sizeof (gfc_expr));
+      /* Construct a new one.  */
+      mo->expr_type = EXPR_VARIABLE;
+      st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+      mo->symtree = st;
+      mo->ts = vtab->ts;
+    }
+
+  f->ts.type = BT_LOGICAL;
+  f->ts.kind = 4;
+
+  f->value.function.isym->formal->ts = a->ts;
+  f->value.function.isym->formal->next->ts = mo->ts;
+
+  /* Call library function.  */
+  f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+}
+
+
 void
 gfc_resolve_fdate (gfc_expr *f)
 {
 void
 gfc_resolve_fdate (gfc_expr *f)
 {
@@ -733,6 +1030,15 @@ gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
 
 
 void
 
 
 void
+gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__tgamma_%d", x->ts.kind);
+}
+
+
+void
 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
 {
   f->ts.type = BT_INTEGER;
 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
 {
   f->ts.type = BT_INTEGER;
@@ -778,6 +1084,21 @@ gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
 
 
 void
 
 
 void
+gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
+{
+  f->ts = x->ts;
+  f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind);
+}
+
+
+void
+gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("iall", f, array, dim, mask);
+}
+
+
+void
 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 {
   /* If the kind of i and j are different, then g77 cross-promoted the
 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 {
   /* If the kind of i and j are different, then g77 cross-promoted the
@@ -797,6 +1118,13 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 
 
 void
 
 
 void
+gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("iany", f, array, dim, mask);
+}
+
+
+void
 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 {
   f->ts = i->ts;
 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 {
   f->ts = i->ts;
@@ -822,10 +1150,25 @@ gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 
 
 void
 
 
 void
-gfc_resolve_ichar (gfc_expr *f, gfc_expr *c)
+gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
+}
+
+
+void
+gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 }
 
   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 }
 
@@ -886,19 +1229,24 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 
 void
 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
 
 void
 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
-                       gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back)
+                       gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
+                       gfc_expr *kind)
 {
   gfc_typespec ts;
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
 
   f->ts.type = BT_INTEGER;
 
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
 
   if (back && back->ts.kind != gfc_default_integer_kind)
     {
       ts.type = BT_LOGICAL;
       ts.kind = gfc_default_integer_kind;
 
   if (back && back->ts.kind != gfc_default_integer_kind)
     {
       ts.type = BT_LOGICAL;
       ts.kind = gfc_default_integer_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (back, &ts, 2);
     }
 
       gfc_convert_type (back, &ts, 2);
     }
 
@@ -953,9 +1301,17 @@ gfc_resolve_long (gfc_expr *f, gfc_expr *a)
 
 
 void
 
 
 void
+gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("iparity", f, array, dim, mask);
+}
+
+
+void
 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
 {
   gfc_typespec ts;
 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
   
   f->ts.type = BT_LOGICAL;
   f->ts.kind = gfc_default_integer_kind;
   
   f->ts.type = BT_LOGICAL;
   f->ts.kind = gfc_default_integer_kind;
@@ -963,8 +1319,8 @@ gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (u, &ts, 2);
     }
 
       gfc_convert_type (u, &ts, 2);
     }
 
@@ -1023,29 +1379,27 @@ gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
 
 
 void
 
 
 void
-gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
 {
-  static char lbound[] = "__lbound";
-
-  f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  resolve_bound (f, array, dim, kind, "__lbound", false);
+}
 
 
-  if (dim == NULL)
-    {
-      f->rank = 1;
-      f->shape = gfc_get_shape (1);
-      mpz_init_set_ui (f->shape[0], array->rank);
-    }
 
 
-  f->value.function.name = lbound;
+void
+gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  resolve_bound (f, array, dim, kind, "__lcobound", true);
 }
 
 
 void
 }
 
 
 void
-gfc_resolve_len (gfc_expr *f, gfc_expr *string)
+gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name
     = gfc_get_string ("__len_%d_i%d", string->ts.kind,
                      gfc_default_integer_kind);
   f->value.function.name
     = gfc_get_string ("__len_%d_i%d", string->ts.kind,
                      gfc_default_integer_kind);
@@ -1053,15 +1407,27 @@ gfc_resolve_len (gfc_expr *f, gfc_expr *string)
 
 
 void
 
 
 void
-gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string)
+gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
 }
 
 
 void
   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
 }
 
 
 void
+gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__lgamma_%d", x->ts.kind);
+}
+
+
+void
 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
                  gfc_expr *p2 ATTRIBUTE_UNUSED)
 {
 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
                  gfc_expr *p2 ATTRIBUTE_UNUSED)
 {
@@ -1119,6 +1485,7 @@ gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
   if (size->ts.kind < gfc_index_integer_kind)
     {
       gfc_typespec ts;
   if (size->ts.kind < gfc_index_integer_kind)
     {
       gfc_typespec ts;
+      gfc_clear_ts (&ts);
 
       ts.type = BT_INTEGER;
       ts.kind = gfc_index_integer_kind;
 
       ts.type = BT_INTEGER;
       ts.kind = gfc_index_integer_kind;
@@ -1145,15 +1512,43 @@ gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
     {
       temp.expr_type = EXPR_OP;
       gfc_clear_ts (&temp.ts);
     {
       temp.expr_type = EXPR_OP;
       gfc_clear_ts (&temp.ts);
-      temp.value.op.operator = INTRINSIC_NONE;
+      temp.value.op.op = INTRINSIC_NONE;
       temp.value.op.op1 = a;
       temp.value.op.op2 = b;
       temp.value.op.op1 = a;
       temp.value.op.op2 = b;
-      gfc_type_convert_binary (&temp);
+      gfc_type_convert_binary (&temp, 1);
       f->ts = temp.ts;
     }
 
   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
 
       f->ts = temp.ts;
     }
 
   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
 
+  if (a->rank == 2 && b->rank == 2)
+    {
+      if (a->shape && b->shape)
+       {
+         f->shape = gfc_get_shape (f->rank);
+         mpz_init_set (f->shape[0], a->shape[0]);
+         mpz_init_set (f->shape[1], b->shape[1]);
+       }
+    }
+  else if (a->rank == 1)
+    {
+      if (b->shape)
+       {
+         f->shape = gfc_get_shape (f->rank);
+         mpz_init_set (f->shape[0], b->shape[1]);
+       }
+    }
+  else 
+    {
+      /* b->rank == 1 and a->rank == 2 here, all other cases have
+        been caught in check.c.   */
+      if (a->shape)
+       {
+         f->shape = gfc_get_shape (f->rank);
+         mpz_init_set (f->shape[0], a->shape[0]);
+       }
+    }
+
   f->value.function.name
     = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
                      f->ts.kind);
   f->value.function.name
     = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
                      f->ts.kind);
@@ -1233,16 +1628,7 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
        name = "mmaxloc";
 
       else
        name = "mmaxloc";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
+      resolve_mask_arg (mask);
     }
   else
     name = "maxloc";
     }
   else
     name = "maxloc";
@@ -1287,16 +1673,7 @@ gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
        name = "mmaxval";
 
       else
        name = "mmaxval";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
+      resolve_mask_arg (mask);
     }
   else
     name = "maxval";
     }
   else
     name = "maxval";
@@ -1326,10 +1703,31 @@ gfc_resolve_mclock8 (gfc_expr *f)
 
 
 void
 
 
 void
+gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
+                 gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = kind ? mpz_get_si (kind->value.integer)
+                   : gfc_default_integer_kind;
+
+  if (f->value.function.isym->id == GFC_ISYM_MASKL)
+    f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
+  else
+    f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
+}
+
+
+void
 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
                   gfc_expr *fsource ATTRIBUTE_UNUSED,
                   gfc_expr *mask ATTRIBUTE_UNUSED)
 {
 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
                   gfc_expr *fsource ATTRIBUTE_UNUSED,
                   gfc_expr *mask ATTRIBUTE_UNUSED)
 {
+  if (tsource->ts.type == BT_CHARACTER && tsource->ref)
+    gfc_resolve_substring_charlen (tsource);
+
+  if (fsource->ts.type == BT_CHARACTER && fsource->ref)
+    gfc_resolve_substring_charlen (fsource);
+
   if (tsource->ts.type == BT_CHARACTER)
     check_charlen_present (tsource);
 
   if (tsource->ts.type == BT_CHARACTER)
     check_charlen_present (tsource);
 
@@ -1341,6 +1739,16 @@ gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
 
 
 void
 
 
 void
+gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
+                       gfc_expr *j ATTRIBUTE_UNUSED,
+                       gfc_expr *mask ATTRIBUTE_UNUSED)
+{
+  f->ts = i->ts;
+  f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
+}
+
+
+void
 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
 {
   gfc_resolve_minmax ("__min_%c%d", f, args);
 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
 {
   gfc_resolve_minmax ("__min_%c%d", f, args);
@@ -1387,16 +1795,7 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
        name = "mminloc";
 
       else
        name = "mminloc";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
+      resolve_mask_arg (mask);
     }
   else
     name = "minloc";
     }
   else
     name = "minloc";
@@ -1441,16 +1840,7 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
        name = "mminval";
 
       else
        name = "mminval";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
+      resolve_mask_arg (mask);
     }
   else
     name = "minval";
     }
   else
     name = "minval";
@@ -1506,8 +1896,11 @@ gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
 }
 
 void
 }
 
 void
-gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p ATTRIBUTE_UNUSED)
+gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
 {
 {
+  if (p->ts.kind != a->ts.kind)
+    gfc_convert_type (p, &a->ts, 2);
+
   f->ts = a->ts;
   f->value.function.name
     = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
   f->ts = a->ts;
   f->value.function.name
     = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
@@ -1526,6 +1919,13 @@ gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 
 
 void
 
 
 void
+gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  resolve_transformational ("norm2", f, array, dim, NULL);
+}
+
+
+void
 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
 {
   f->ts = i->ts;
 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
 {
   f->ts = i->ts;
@@ -1556,42 +1956,43 @@ void
 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
                  gfc_expr *vector ATTRIBUTE_UNUSED)
 {
 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
                  gfc_expr *vector ATTRIBUTE_UNUSED)
 {
-  int newkind;
+  if (array->ts.type == BT_CHARACTER && array->ref)
+    gfc_resolve_substring_charlen (array);
 
   f->ts = array->ts;
   f->rank = 1;
 
 
   f->ts = array->ts;
   f->rank = 1;
 
-  /* The mask can be kind 4 or 8 for the array case.  For the scalar
-     case, coerce it to kind=4 unconditionally (because this is the only
-     kind we have a library function for).  */
+  resolve_mask_arg (mask);
 
 
-  newkind = 0;
-  if (mask->rank == 0)
+  if (mask->rank != 0)
     {
     {
-      if (mask->ts.kind != 4)
-       newkind = 4;
+      if (array->ts.type == BT_CHARACTER)
+       f->value.function.name
+         = array->ts.kind == 1 ? PREFIX ("pack_char")
+                               : gfc_get_string
+                                       (PREFIX ("pack_char%d"),
+                                        array->ts.kind);
+      else
+       f->value.function.name = PREFIX ("pack");
     }
   else
     {
     }
   else
     {
-      if (mask->ts.kind < 4)
-       newkind = gfc_default_logical_kind;
+      if (array->ts.type == BT_CHARACTER)
+       f->value.function.name
+         = array->ts.kind == 1 ? PREFIX ("pack_s_char")
+                               : gfc_get_string
+                                       (PREFIX ("pack_s_char%d"),
+                                        array->ts.kind);
+      else
+       f->value.function.name = PREFIX ("pack_s");
     }
     }
+}
 
 
-  if (newkind)
-    {
-      gfc_typespec ts;
-
-      ts.type = BT_LOGICAL;
-      ts.kind = gfc_default_logical_kind;
-      gfc_convert_type (mask, &ts, 2);
-    }
 
 
-  if (mask->rank != 0)
-    f->value.function.name = (array->ts.type == BT_CHARACTER
-                             ? PREFIX ("pack_char") : PREFIX ("pack"));
-  else
-    f->value.function.name = (array->ts.type == BT_CHARACTER
-                             ? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
+void
+gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  resolve_transformational ("parity", f, array, dim, NULL);
 }
 
 
 }
 
 
@@ -1599,40 +2000,7 @@ void
 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
                     gfc_expr *mask)
 {
 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
                     gfc_expr *mask)
 {
-  const char *name;
-
-  f->ts = array->ts;
-
-  if (dim != NULL)
-    {
-      f->rank = array->rank - 1;
-      gfc_resolve_dim_arg (dim);
-    }
-
-  if (mask)
-    {
-      if (mask->rank == 0)
-       name = "sproduct";
-      else
-       name = "mproduct";
-
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
-    }
-  else
-    name = "product";
-
-  f->value.function.name
-    = gfc_get_string (PREFIX ("%s_%c%d"), name,
-                     gfc_type_letter (array->ts.type), array->ts.kind);
+  resolve_transformational ("product", f, array, dim, mask);
 }
 
 
 }
 
 
@@ -1693,6 +2061,9 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
   int kind;
   int i;
 
   int kind;
   int i;
 
+  if (source->ts.type == BT_CHARACTER && source->ref)
+    gfc_resolve_substring_charlen (source);
+
   f->ts = source->ts;
 
   gfc_array_size (shape, &rank);
   f->ts = source->ts;
 
   gfc_array_size (shape, &rank);
@@ -1704,6 +2075,7 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
     case BT_REAL:
     case BT_INTEGER:
     case BT_LOGICAL:
     case BT_REAL:
     case BT_INTEGER:
     case BT_LOGICAL:
+    case BT_CHARACTER:
       kind = source->ts.kind;
       break;
 
       kind = source->ts.kind;
       break;
 
@@ -1723,15 +2095,17 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
          = gfc_get_string (PREFIX ("reshape_%c%d"),
                            gfc_type_letter (source->ts.type),
                            source->ts.kind);
          = gfc_get_string (PREFIX ("reshape_%c%d"),
                            gfc_type_letter (source->ts.type),
                            source->ts.kind);
+      else if (source->ts.type == BT_CHARACTER)
+       f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
+                                                kind);
       else
        f->value.function.name
          = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
       else
        f->value.function.name
          = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
-
       break;
 
     default:
       f->value.function.name = (source->ts.type == BT_CHARACTER
       break;
 
     default:
       f->value.function.name = (source->ts.type == BT_CHARACTER
-                            ? PREFIX ("reshape_char") : PREFIX ("reshape"));
+                               ? PREFIX ("reshape_char") : PREFIX ("reshape"));
       break;
     }
 
       break;
     }
 
@@ -1742,11 +2116,11 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
     {
       gfc_constructor *c;
       f->shape = gfc_get_shape (f->rank);
     {
       gfc_constructor *c;
       f->shape = gfc_get_shape (f->rank);
-      c = shape->value.constructor;
+      c = gfc_constructor_first (shape->value.constructor);
       for (i = 0; i < f->rank; i++)
        {
          mpz_init_set (f->shape[i], c->expr->value.integer);
       for (i = 0; i < f->rank; i++)
        {
          mpz_init_set (f->shape[i], c->expr->value.integer);
-         c = c->next;
+         c = gfc_constructor_next (c);
        }
     }
 
        }
     }
 
@@ -1766,37 +2140,15 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
 void
 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
 {
 void
 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
 {
-  int k;
-  gfc_actual_arglist *prec;
-
   f->ts = x->ts;
   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
   f->ts = x->ts;
   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
-
-  /* Create a hidden argument to the library routines for rrspacing.  This
-     hidden argument is the precision of x.  */
-  k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
-  prec = gfc_get_actual_arglist ();
-  prec->name = "p";
-  prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
-  f->value.function.actual->next = prec;
 }
 
 
 void
 }
 
 
 void
-gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
+gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
 {
   f->ts = x->ts;
 {
   f->ts = x->ts;
-
-  /* The implementation calls scalbn which takes an int as the
-     second argument.  */
-  if (i->ts.kind != gfc_c_int_kind)
-    {
-      gfc_typespec ts;
-      ts.type = BT_INTEGER;
-      ts.kind = gfc_default_integer_kind;
-      gfc_convert_type_warn (i, &ts, 2, 0);
-    }
-
   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
 }
 
   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
 }
 
@@ -1804,10 +2156,13 @@ gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
 void
 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
                  gfc_expr *set ATTRIBUTE_UNUSED,
 void
 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
                  gfc_expr *set ATTRIBUTE_UNUSED,
-                 gfc_expr *back ATTRIBUTE_UNUSED)
+                 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
 }
 
   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
 }
 
@@ -1821,21 +2176,10 @@ gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
 
 
 void
 
 
 void
-gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, gfc_expr *i)
+gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
+                         gfc_expr *i ATTRIBUTE_UNUSED)
 {
   f->ts = x->ts;
 {
   f->ts = x->ts;
-
-  /* The library implementation uses GFC_INTEGER_4 unconditionally,
-     convert type so we don't have to implement all possible
-     permutations.  */
-  if (i->ts.kind != 4)
-    {
-      gfc_typespec ts;
-      ts.type = BT_INTEGER;
-      ts.kind = gfc_default_integer_kind;
-      gfc_convert_type_warn (i, &ts, 2, 0);
-    }
-
   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
 }
 
   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
 }
 
@@ -1853,6 +2197,21 @@ gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
 
 
 void
 
 
 void
+gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
+{
+  f->ts = i->ts;
+  if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
+    f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
+  else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
+    f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
+  else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
+    f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
+  else
+    gcc_unreachable ();
+}
+
+
+void
 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
 {
   f->ts = a->ts;
 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
 {
   f->ts = a->ts;
@@ -1901,41 +2260,22 @@ gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
 
 
 void
 
 
 void
+gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+                 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+}
+
+
+void
 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
 {
 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
 {
-  int k; 
-  gfc_actual_arglist *prec, *tiny, *emin_1;
- 
   f->ts = x->ts;
   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
   f->ts = x->ts;
   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
-
-  /* Create hidden arguments to the library routine for spacing.  These
-     hidden arguments are tiny(x), min_exponent - 1,  and the precision
-     of x.  */
-
-  k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
-
-  tiny = gfc_get_actual_arglist ();
-  tiny->name = "tiny";
-  tiny->expr = gfc_get_expr ();
-  tiny->expr->expr_type = EXPR_CONSTANT;
-  tiny->expr->where = gfc_current_locus;
-  tiny->expr->ts.type = x->ts.type;
-  tiny->expr->ts.kind = x->ts.kind;
-  mpfr_init (tiny->expr->value.real);
-  mpfr_set (tiny->expr->value.real, gfc_real_kinds[k].tiny, GFC_RND_MODE);
-
-  emin_1 = gfc_get_actual_arglist ();
-  emin_1->name = "emin";
-  emin_1->expr = gfc_int_expr (gfc_real_kinds[k].min_exponent - 1);
-  emin_1->next = tiny;
-
-  prec = gfc_get_actual_arglist ();
-  prec->name = "prec";
-  prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
-  prec->next = emin_1;
-
-  f->value.function.actual->next = prec;
 }
 
 
 }
 
 
@@ -1943,19 +2283,36 @@ void
 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
                    gfc_expr *ncopies)
 {
 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
                    gfc_expr *ncopies)
 {
+  if (source->ts.type == BT_CHARACTER && source->ref)
+    gfc_resolve_substring_charlen (source);
+
   if (source->ts.type == BT_CHARACTER)
     check_charlen_present (source);
 
   f->ts = source->ts;
   f->rank = source->rank + 1;
   if (source->rank == 0)
   if (source->ts.type == BT_CHARACTER)
     check_charlen_present (source);
 
   f->ts = source->ts;
   f->rank = source->rank + 1;
   if (source->rank == 0)
-    f->value.function.name = (source->ts.type == BT_CHARACTER
-                             ? PREFIX ("spread_char_scalar")
-                             : PREFIX ("spread_scalar"));
+    {
+      if (source->ts.type == BT_CHARACTER)
+       f->value.function.name
+         = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
+                                : gfc_get_string
+                                       (PREFIX ("spread_char%d_scalar"),
+                                        source->ts.kind);
+      else
+       f->value.function.name = PREFIX ("spread_scalar");
+    }
   else
   else
-    f->value.function.name = (source->ts.type == BT_CHARACTER
-                             ? PREFIX ("spread_char")
-                             : PREFIX ("spread"));
+    {
+      if (source->ts.type == BT_CHARACTER)
+       f->value.function.name
+         = source->ts.kind == 1 ? PREFIX ("spread_char")
+                                : gfc_get_string
+                                       (PREFIX ("spread_char%d"),
+                                        source->ts.kind);
+      else
+       f->value.function.name = PREFIX ("spread");
+    }
 
   if (dim && gfc_is_constant_expr (dim)
       && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
 
   if (dim && gfc_is_constant_expr (dim)
       && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
@@ -2025,6 +2382,7 @@ void
 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
 {
   gfc_typespec ts;
 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
 
   f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_c_int_kind;
 
   f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_c_int_kind;
@@ -2032,8 +2390,8 @@ gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (u, &ts, 2);
     }
 
       gfc_convert_type (u, &ts, 2);
     }
 
@@ -2054,6 +2412,7 @@ void
 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
 {
   gfc_typespec ts;
 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
 
   f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_c_int_kind;
 
   f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_c_int_kind;
@@ -2061,8 +2420,8 @@ gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (u, &ts, 2);
     }
 
       gfc_convert_type (u, &ts, 2);
     }
 
@@ -2083,6 +2442,7 @@ void
 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
 {
   gfc_typespec ts;
 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
 
   f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_index_integer_kind;
 
   f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_index_integer_kind;
@@ -2090,8 +2450,8 @@ gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (u, &ts, 2);
     }
 
       gfc_convert_type (u, &ts, 2);
     }
 
@@ -2100,42 +2460,21 @@ gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
 
 
 void
 
 
 void
-gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
+                         gfc_expr *kind)
 {
 {
-  const char *name;
-
-  f->ts = array->ts;
-
-  if (mask)
-    {
-      if (mask->rank == 0)
-       name = "ssum";
-      else
-       name = "msum";
-
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
-    }
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
   else
   else
-    name = "sum";
+    f->ts.kind = gfc_default_integer_kind;
+}
 
 
-  if (dim != NULL)
-    {
-      f->rank = array->rank - 1;
-      gfc_resolve_dim_arg (dim);
-    }
 
 
-  f->value.function.name
-    = gfc_get_string (PREFIX ("%s_%c%d"), name,
-                   gfc_type_letter (array->ts.type), array->ts.kind);
+void
+gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("sum", f, array, dim, mask);
 }
 
 
 }
 
 
@@ -2179,6 +2518,23 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
 
 
 void
 
 
 void
+gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+                        gfc_expr *sub ATTRIBUTE_UNUSED)
+{
+  static char this_image[] = "__image_index";
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = this_image;
+}
+
+
+void
+gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  resolve_bound (f, array, dim, NULL, "__this_image", true);
+}
+
+
+void
 gfc_resolve_time (gfc_expr *f)
 {
   f->ts.type = BT_INTEGER;
 gfc_resolve_time (gfc_expr *f)
 {
   f->ts.type = BT_INTEGER;
@@ -2203,6 +2559,26 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
   /* TODO: Make this do something meaningful.  */
   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
 
   /* TODO: Make this do something meaningful.  */
   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
 
+  if (mold->ts.type == BT_CHARACTER
+       && !mold->ts.u.cl->length
+       && gfc_is_constant_expr (mold))
+    {
+      int len;
+      if (mold->expr_type == EXPR_CONSTANT)
+        {
+         len = mold->value.character.length;
+         mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+                                                   NULL, len);
+       }
+      else
+       {
+         gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
+         len = c->expr->value.character.length;
+         mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+                                                   NULL, len);
+       }
+    }
+
   f->ts = mold->ts;
 
   if (size == NULL && mold->rank == 0)
   f->ts = mold->ts;
 
   if (size == NULL && mold->rank == 0)
@@ -2226,6 +2602,10 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
 void
 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
 {
 void
 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
 {
+
+  if (matrix->ts.type == BT_CHARACTER && matrix->ref)
+    gfc_resolve_substring_charlen (matrix);
+
   f->ts = matrix->ts;
   f->rank = 2;
   if (matrix->shape)
   f->ts = matrix->ts;
   f->rank = 2;
   if (matrix->shape)
@@ -2260,7 +2640,10 @@ gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
          break;
 
        default:
          break;
 
        default:
-         f->value.function.name = PREFIX ("transpose");
+         if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
+           f->value.function.name = PREFIX ("transpose_char4");
+         else
+           f->value.function.name = PREFIX ("transpose");
          break;
        }
       break;
          break;
        }
       break;
@@ -2284,21 +2667,16 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
 
 
 void
 
 
 void
-gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
 {
-  static char ubound[] = "__ubound";
-
-  f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  resolve_bound (f, array, dim, kind, "__ubound", false);
+}
 
 
-  if (dim == NULL)
-    {
-      f->rank = 1;
-      f->shape = gfc_get_shape (1);
-      mpz_init_set_ui (f->shape[0], array->rank);
-    }
 
 
-  f->value.function.name = ubound;
+void
+gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  resolve_bound (f, array, dim, kind, "__ucobound", true);
 }
 
 
 }
 
 
@@ -2328,6 +2706,7 @@ void
 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
 {
   gfc_typespec ts;
 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
   
   f->ts.type = BT_CHARACTER;
   f->ts.kind = gfc_default_character_kind;
   
   f->ts.type = BT_CHARACTER;
   f->ts.kind = gfc_default_character_kind;
@@ -2336,8 +2715,8 @@ gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (unit, &ts, 2);
     }
 
       gfc_convert_type (unit, &ts, 2);
     }
 
@@ -2349,33 +2728,39 @@ void
 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
                    gfc_expr *field ATTRIBUTE_UNUSED)
 {
 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
                    gfc_expr *field ATTRIBUTE_UNUSED)
 {
+  if (vector->ts.type == BT_CHARACTER && vector->ref)
+    gfc_resolve_substring_charlen (vector);
+
   f->ts = vector->ts;
   f->rank = mask->rank;
   f->ts = vector->ts;
   f->rank = mask->rank;
+  resolve_mask_arg (mask);
 
 
-  /* Coerce the mask to default logical kind if it has kind < 4.  */
-
-  if (mask->ts.kind < 4)
+  if (vector->ts.type == BT_CHARACTER)
     {
     {
-      gfc_typespec ts;
-
-      ts.type = BT_LOGICAL;
-      ts.kind = gfc_default_logical_kind;
-      gfc_convert_type (mask, &ts, 2);
+      if (vector->ts.kind == 1)
+       f->value.function.name
+         = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
+      else
+       f->value.function.name
+         = gfc_get_string (PREFIX ("unpack%d_char%d"),
+                           field->rank > 0 ? 1 : 0, vector->ts.kind);
     }
     }
-
-  f->value.function.name
-    = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
-                     vector->ts.type == BT_CHARACTER ? "_char" : "");
+  else
+    f->value.function.name
+      = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
 }
 
 
 void
 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
                    gfc_expr *set ATTRIBUTE_UNUSED,
 }
 
 
 void
 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
                    gfc_expr *set ATTRIBUTE_UNUSED,
-                   gfc_expr *back ATTRIBUTE_UNUSED)
+                   gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
 }
 
   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
 }
 
@@ -2405,24 +2790,28 @@ void
 gfc_resolve_alarm_sub (gfc_code *c)
 {
   const char *name;
 gfc_resolve_alarm_sub (gfc_code *c)
 {
   const char *name;
-  gfc_expr *seconds, *handler, *status;
+  gfc_expr *seconds, *handler;
   gfc_typespec ts;
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
 
   seconds = c->ext.actual->expr;
   handler = c->ext.actual->next->expr;
 
   seconds = c->ext.actual->expr;
   handler = c->ext.actual->next->expr;
-  status = c->ext.actual->next->next->expr;
   ts.type = BT_INTEGER;
   ts.kind = gfc_c_int_kind;
 
   ts.type = BT_INTEGER;
   ts.kind = gfc_c_int_kind;
 
-  /* handler can be either BT_INTEGER or BT_PROCEDURE  */
+  /* handler can be either BT_INTEGER or BT_PROCEDURE.
+     In all cases, the status argument is of default integer kind
+     (enforced in check.c) so that the function suffix is fixed.  */
   if (handler->ts.type == BT_INTEGER)
     {
       if (handler->ts.kind != gfc_c_int_kind)
        gfc_convert_type (handler, &ts, 2);
   if (handler->ts.type == BT_INTEGER)
     {
       if (handler->ts.kind != gfc_c_int_kind)
        gfc_convert_type (handler, &ts, 2);
-      name = gfc_get_string (PREFIX ("alarm_sub_int"));
+      name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
+                            gfc_default_integer_kind);
     }
   else
     }
   else
-    name = gfc_get_string (PREFIX ("alarm_sub"));
+    name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
+                          gfc_default_integer_kind);
 
   if (seconds->ts.kind != gfc_c_int_kind)
     gfc_convert_type (seconds, &ts, 2);
 
   if (seconds->ts.kind != gfc_c_int_kind)
     gfc_convert_type (seconds, &ts, 2);
@@ -2439,14 +2828,68 @@ gfc_resolve_cpu_time (gfc_code *c)
 }
 
 
 }
 
 
+/* Create a formal arglist based on an actual one and set the INTENTs given.  */
+
+static gfc_formal_arglist*
+create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
+{
+  gfc_formal_arglist* head;
+  gfc_formal_arglist* tail;
+  int i;
+
+  if (!actual)
+    return NULL;
+
+  head = tail = gfc_get_formal_arglist ();
+  for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
+    {
+      gfc_symbol* sym;
+
+      sym = gfc_new_symbol ("dummyarg", NULL);
+      sym->ts = actual->expr->ts;
+
+      sym->attr.intent = ints[i];
+      tail->sym = sym;
+
+      if (actual->next)
+       tail->next = gfc_get_formal_arglist ();
+    }
+
+  return head;
+}
+
+
 void
 gfc_resolve_mvbits (gfc_code *c)
 {
 void
 gfc_resolve_mvbits (gfc_code *c)
 {
+  static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
+                                      INTENT_INOUT, INTENT_IN};
+
   const char *name;
   const char *name;
-  int kind;
-  kind = c->ext.actual->expr->ts.kind;
-  name = gfc_get_string (PREFIX ("mvbits_i%d"), kind);
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+
+  /* FROMPOS, LEN and TOPOS are restricted to small values.  As such,
+     they will be converted so that they fit into a C int.  */
+  ts.type = BT_INTEGER;
+  ts.kind = gfc_c_int_kind;
+  if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
+    gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
+  if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
+    gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
+  if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
+    gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
+
+  /* TO and FROM are guaranteed to have the same kind parameter.  */
+  name = gfc_get_string (PREFIX ("mvbits_i%d"),
+                        c->ext.actual->expr->ts.kind);
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  /* Mark as elemental subroutine as this does not happen automatically.  */
+  c->resolved_sym->attr.elemental = 1;
+
+  /* Create a dummy formal arglist so the INTENTs are known later for purpose
+     of creating temporaries.  */
+  c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
 }
 
 
 }
 
 
@@ -2467,6 +2910,16 @@ gfc_resolve_random_number (gfc_code *c)
 
 
 void
 
 
 void
+gfc_resolve_random_seed (gfc_code *c)
+{
+  const char *name;
+
+  name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
 gfc_resolve_rename_sub (gfc_code *c)
 {
   const char *name;
 gfc_resolve_rename_sub (gfc_code *c)
 {
   const char *name;
@@ -2530,7 +2983,15 @@ gfc_resolve_symlnk_sub (gfc_code *c)
 }
 
 
 }
 
 
-/* G77 compatibility subroutines etime() and dtime().  */
+/* G77 compatibility subroutines dtime() and etime().  */
+
+void
+gfc_resolve_dtime_sub (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("dtime_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
 
 void
 gfc_resolve_etime_sub (gfc_code *c)
 
 void
 gfc_resolve_etime_sub (gfc_code *c)
@@ -2620,9 +3081,19 @@ void
 gfc_resolve_getarg (gfc_code *c)
 {
   const char *name;
 gfc_resolve_getarg (gfc_code *c)
 {
   const char *name;
-  int kind;
-  kind = gfc_default_integer_kind;
-  name = gfc_get_string (PREFIX ("getarg_i%d"), kind);
+
+  if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_default_integer_kind;
+
+      gfc_convert_type (c->ext.actual->expr, &ts, 2);
+    }
+
+  name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
@@ -2690,6 +3161,7 @@ gfc_resolve_signal_sub (gfc_code *c)
   const char *name;
   gfc_expr *number, *handler, *status;
   gfc_typespec ts;
   const char *name;
   gfc_expr *number, *handler, *status;
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
 
   number = c->ext.actual->expr;
   handler = c->ext.actual->next->expr;
 
   number = c->ext.actual->expr;
   handler = c->ext.actual->next->expr;
@@ -2749,20 +3221,36 @@ gfc_resolve_system_clock (gfc_code *c)
 }
 
 
 }
 
 
+/* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine.  */
+void
+gfc_resolve_execute_command_line (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
+                        gfc_default_integer_kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
 /* Resolve the EXIT intrinsic subroutine.  */
 
 void
 gfc_resolve_exit (gfc_code *c)
 {
   const char *name;
 /* Resolve the EXIT intrinsic subroutine.  */
 
 void
 gfc_resolve_exit (gfc_code *c)
 {
   const char *name;
-  int kind;
+  gfc_typespec ts;
+  gfc_expr *n;
+  gfc_clear_ts (&ts);
 
 
-  if (c->ext.actual->expr != NULL)
-    kind = c->ext.actual->expr->ts.kind;
-  else
-    kind = gfc_default_integer_kind;
+  /* The STATUS argument has to be of default kind.  If it is not,
+     we convert it.  */
+  ts.type = BT_INTEGER;
+  ts.kind = gfc_default_integer_kind;
+  n = c->ext.actual->expr;
+  if (n != NULL && n->ts.kind != ts.kind)
+    gfc_convert_type (n, &ts, 2);
 
 
-  name = gfc_get_string (PREFIX ("exit_i%d"), kind);
+  name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
@@ -2775,6 +3263,7 @@ gfc_resolve_flush (gfc_code *c)
   const char *name;
   gfc_typespec ts;
   gfc_expr *n;
   const char *name;
   gfc_typespec ts;
   gfc_expr *n;
+  gfc_clear_ts (&ts);
 
   ts.type = BT_INTEGER;
   ts.kind = gfc_default_integer_kind;
 
   ts.type = BT_INTEGER;
   ts.kind = gfc_default_integer_kind;
@@ -2792,6 +3281,7 @@ gfc_resolve_free (gfc_code *c)
 {
   gfc_typespec ts;
   gfc_expr *n;
 {
   gfc_typespec ts;
   gfc_expr *n;
+  gfc_clear_ts (&ts);
 
   ts.type = BT_INTEGER;
   ts.kind = gfc_index_integer_kind;
 
   ts.type = BT_INTEGER;
   ts.kind = gfc_index_integer_kind;
@@ -2807,14 +3297,15 @@ void
 gfc_resolve_ctime_sub (gfc_code *c)
 {
   gfc_typespec ts;
 gfc_resolve_ctime_sub (gfc_code *c)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
   
   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
   if (c->ext.actual->expr->ts.kind != 8)
     {
       ts.type = BT_INTEGER;
       ts.kind = 8;
   
   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
   if (c->ext.actual->expr->ts.kind != 8)
     {
       ts.type = BT_INTEGER;
       ts.kind = 8;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (c->ext.actual->expr, &ts, 2);
     }
 
       gfc_convert_type (c->ext.actual->expr, &ts, 2);
     }
 
@@ -2907,6 +3398,7 @@ gfc_resolve_fgetc_sub (gfc_code *c)
   const char *name;
   gfc_typespec ts;
   gfc_expr *u, *st;
   const char *name;
   gfc_typespec ts;
   gfc_expr *u, *st;
+  gfc_clear_ts (&ts);
 
   u = c->ext.actual->expr;
   st = c->ext.actual->next->next->expr;
 
   u = c->ext.actual->expr;
   st = c->ext.actual->next->next->expr;
@@ -2915,8 +3407,8 @@ gfc_resolve_fgetc_sub (gfc_code *c)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (u, &ts, 2);
     }
 
       gfc_convert_type (u, &ts, 2);
     }
 
@@ -2951,6 +3443,7 @@ gfc_resolve_fputc_sub (gfc_code *c)
   const char *name;
   gfc_typespec ts;
   gfc_expr *u, *st;
   const char *name;
   gfc_typespec ts;
   gfc_expr *u, *st;
+  gfc_clear_ts (&ts);
 
   u = c->ext.actual->expr;
   st = c->ext.actual->next->next->expr;
 
   u = c->ext.actual->expr;
   st = c->ext.actual->next->next->expr;
@@ -2959,8 +3452,8 @@ gfc_resolve_fputc_sub (gfc_code *c)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (u, &ts, 2);
     }
 
       gfc_convert_type (u, &ts, 2);
     }
 
@@ -2995,20 +3488,19 @@ gfc_resolve_fseek_sub (gfc_code *c)
   gfc_expr *unit;
   gfc_expr *offset;
   gfc_expr *whence;
   gfc_expr *unit;
   gfc_expr *offset;
   gfc_expr *whence;
-  gfc_expr *status;
   gfc_typespec ts;
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
 
   unit   = c->ext.actual->expr;
   offset = c->ext.actual->next->expr;
   whence = c->ext.actual->next->next->expr;
 
   unit   = c->ext.actual->expr;
   offset = c->ext.actual->next->expr;
   whence = c->ext.actual->next->next->expr;
-  status = c->ext.actual->next->next->next->expr;
 
   if (unit->ts.kind != gfc_c_int_kind)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
 
   if (unit->ts.kind != gfc_c_int_kind)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (unit, &ts, 2);
     }
 
       gfc_convert_type (unit, &ts, 2);
     }
 
@@ -3016,8 +3508,8 @@ gfc_resolve_fseek_sub (gfc_code *c)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_intio_kind;
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_intio_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (offset, &ts, 2);
     }
 
       gfc_convert_type (offset, &ts, 2);
     }
 
@@ -3025,8 +3517,8 @@ gfc_resolve_fseek_sub (gfc_code *c)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (whence, &ts, 2);
     }
 
       gfc_convert_type (whence, &ts, 2);
     }
 
@@ -3040,6 +3532,7 @@ gfc_resolve_ftell_sub (gfc_code *c)
   gfc_expr *unit;
   gfc_expr *offset;
   gfc_typespec ts;
   gfc_expr *unit;
   gfc_expr *offset;
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
 
   unit = c->ext.actual->expr;
   offset = c->ext.actual->next->expr;
 
   unit = c->ext.actual->expr;
   offset = c->ext.actual->next->expr;
@@ -3048,8 +3541,8 @@ gfc_resolve_ftell_sub (gfc_code *c)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (unit, &ts, 2);
     }
 
       gfc_convert_type (unit, &ts, 2);
     }
 
@@ -3062,13 +3555,14 @@ void
 gfc_resolve_ttynam_sub (gfc_code *c)
 {
   gfc_typespec ts;
 gfc_resolve_ttynam_sub (gfc_code *c)
 {
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
   
   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
   
   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
     {
       ts.type = BT_INTEGER;
       ts.kind = gfc_c_int_kind;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (c->ext.actual->expr, &ts, 2);
     }
 
       gfc_convert_type (c->ext.actual->expr, &ts, 2);
     }
 
About OSDN
Find Software
Develop Software
Help