X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Firesolve.c;h=66df99e3bf5d445603317091984c8483a28e58ae;hb=fe2de951b1669a22661733f2f4496f7bcf2f02f2;hp=22de74d49c4492ac9f9f53714c21d907e83c2045;hpb=4ccd5f95f19d90935dbb048430cbc0b1fc75203f;p=pf3gnuchains%2Fgcc-fork.git

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 22de74d49c4..66df99e3bf5 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1,5 +1,6 @@
 /* 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
 
@@ -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
-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
@@ -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
-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
@@ -34,6 +34,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "tree.h"
 #include "gfortran.h"
 #include "intrinsic.h"
+#include "constructor.h"
 
 /* Given printf-like arguments, return a stable version of the result string. 
 
@@ -63,14 +64,81 @@ gfc_get_string (const char *format, ...)
 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;
     }
+  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);
 }
 
 /********************** Resolution functions **********************/
@@ -99,18 +167,43 @@ gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
 
 
 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.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 +260,7 @@ void
 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);
@@ -213,6 +307,7 @@ void
 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);
@@ -307,6 +402,7 @@ void
 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)
@@ -320,6 +416,45 @@ gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
 
 
 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;
@@ -344,12 +479,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)
 {
-  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 +556,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)
 {
-  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 +617,13 @@ gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
 
 
 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.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)
     {
@@ -498,9 +632,11 @@ gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
     }
 
+  resolve_mask_arg (mask);
+
   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 +644,10 @@ void
 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;
@@ -519,26 +658,52 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
   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_clear_ts (&ts);
       ts.type = BT_INTEGER;
-      ts.kind = gfc_default_integer_kind;
+      ts.kind = m;
       gfc_convert_type_warn (shift, &ts, 2, 0);
     }
-
+ 
   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 +711,7 @@ void
 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;
@@ -555,8 +721,8 @@ gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
     {
       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);
     }
 
@@ -603,10 +769,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.value.op.operator = INTRINSIC_NONE;
+  temp.value.op.op = INTRINSIC_NONE;
   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"),
@@ -628,7 +794,10 @@ void
 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;
@@ -640,27 +809,52 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
   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_clear_ts (&ts);
       ts.type = BT_INTEGER;
-      ts.kind = gfc_default_integer_kind;
+      ts.kind = m;
       gfc_convert_type_warn (shift, &ts, 2, 0);
     }
-
+ 
   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 +876,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)
 {
@@ -733,6 +982,15 @@ gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
 
 
 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;
@@ -778,6 +1036,14 @@ gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
 
 
 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_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 {
   /* If the kind of i and j are different, then g77 cross-promoted the
@@ -822,10 +1088,25 @@ gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 
 
 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.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);
 }
 
@@ -886,19 +1167,24 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 
 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_clear_ts (&ts);
 
   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;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (back, &ts, 2);
     }
 
@@ -956,6 +1242,7 @@ void
 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;
@@ -963,8 +1250,8 @@ gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
     {
       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);
     }
 
@@ -1023,29 +1310,27 @@ gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
 
 
 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
-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.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);
@@ -1053,15 +1338,27 @@ gfc_resolve_len (gfc_expr *f, gfc_expr *string)
 
 
 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.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
+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)
 {
@@ -1119,6 +1416,7 @@ gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
   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;
@@ -1145,15 +1443,43 @@ gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
     {
       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;
-      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;
 
+  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);
@@ -1233,16 +1559,7 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       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";
@@ -1287,16 +1604,7 @@ gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       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";
@@ -1330,6 +1638,12 @@ 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);
 
@@ -1387,16 +1701,7 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       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";
@@ -1441,16 +1746,7 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       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";
@@ -1506,8 +1802,11 @@ gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
 }
 
 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),
@@ -1526,6 +1825,23 @@ gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 
 
 void
+gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  f->ts = array->ts;
+
+  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 ("norm2_r%d"), array->ts.kind);
+}
+
+
+void
 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
 {
   f->ts = i->ts;
@@ -1556,42 +1872,55 @@ void
 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;
 
-  /* 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
     {
-      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);
+void
+gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  f->ts = array->ts;
+
+  if (dim != NULL)
+    {
+      f->rank = array->rank - 1;
+      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+      gfc_resolve_dim_arg (dim);
     }
 
-  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"));
+  resolve_mask_arg (array);
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("parity_l%d"), array->ts.kind);
 }
 
 
@@ -1606,6 +1935,7 @@ gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
   if (dim != NULL)
     {
       f->rank = array->rank - 1;
+      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
       gfc_resolve_dim_arg (dim);
     }
 
@@ -1616,16 +1946,7 @@ gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       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);
-	}
+      resolve_mask_arg (mask);
     }
   else
     name = "product";
@@ -1693,6 +2014,9 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
   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);
@@ -1704,6 +2028,7 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
     case BT_REAL:
     case BT_INTEGER:
     case BT_LOGICAL:
+    case BT_CHARACTER:
       kind = source->ts.kind;
       break;
 
@@ -1723,15 +2048,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);
+      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);
-
       break;
 
     default:
       f->value.function.name = (source->ts.type == BT_CHARACTER
-			     ? PREFIX ("reshape_char") : PREFIX ("reshape"));
+				? PREFIX ("reshape_char") : PREFIX ("reshape"));
       break;
     }
 
@@ -1742,11 +2069,11 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
     {
       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);
-	  c = c->next;
+	  c = gfc_constructor_next (c);
 	}
     }
 
@@ -1766,37 +2093,15 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
 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);
-
-  /* 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
-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;
-
-  /* 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);
 }
 
@@ -1804,10 +2109,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,
-		  gfc_expr *back ATTRIBUTE_UNUSED)
+		  gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
 {
   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);
 }
 
@@ -1821,21 +2129,10 @@ gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
 
 
 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;
-
-  /* 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);
 }
 
@@ -1901,41 +2198,22 @@ gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
 
 
 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)
 {
-  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);
-
-  /* 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 +2221,36 @@ void
 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)
-    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
-    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])
@@ -2025,6 +2320,7 @@ void
 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;
@@ -2032,8 +2328,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.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (u, &ts, 2);
     }
 
@@ -2054,6 +2350,7 @@ void
 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;
@@ -2061,8 +2358,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.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (u, &ts, 2);
     }
 
@@ -2083,6 +2380,7 @@ void
 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;
@@ -2090,8 +2388,8 @@ gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
     {
       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);
     }
 
@@ -2100,6 +2398,18 @@ gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
 
 
 void
+gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a 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_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
   const char *name;
@@ -2113,16 +2423,7 @@ gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
       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);
-	}
+      resolve_mask_arg (mask);
     }
   else
     name = "sum";
@@ -2130,6 +2431,7 @@ gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
   if (dim != NULL)
     {
       f->rank = array->rank - 1;
+      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
       gfc_resolve_dim_arg (dim);
     }
 
@@ -2179,6 +2481,23 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
 
 
 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;
@@ -2203,6 +2522,26 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
   /* 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)
@@ -2226,6 +2565,10 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
 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)
@@ -2260,7 +2603,10 @@ gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
 	  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;
@@ -2284,21 +2630,16 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
 
 
 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 +2669,7 @@ void
 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;
@@ -2336,8 +2678,8 @@ gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
     {
       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);
     }
 
@@ -2349,33 +2691,39 @@ void
 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;
+  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,
-		    gfc_expr *back ATTRIBUTE_UNUSED)
+		    gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
 {
   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);
 }
 
@@ -2405,24 +2753,28 @@ void
 gfc_resolve_alarm_sub (gfc_code *c)
 {
   const char *name;
-  gfc_expr *seconds, *handler, *status;
+  gfc_expr *seconds, *handler;
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
 
   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;
 
-  /* 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);
-      name = gfc_get_string (PREFIX ("alarm_sub_int"));
+      name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
+			     gfc_default_integer_kind);
     }
   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);
@@ -2439,11 +2791,46 @@ 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)
 {
+  static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
+				       INTENT_INOUT, INTENT_IN};
+
   const char *name;
   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.  */
@@ -2460,6 +2847,12 @@ gfc_resolve_mvbits (gfc_code *c)
   name = gfc_get_string (PREFIX ("mvbits_i%d"),
 			 c->ext.actual->expr->ts.kind);
   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);
 }
 
 
@@ -2480,6 +2873,16 @@ gfc_resolve_random_number (gfc_code *c)
 
 
 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;
@@ -2543,7 +2946,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)
@@ -2633,9 +3044,19 @@ void
 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);
 }
 
@@ -2703,6 +3124,7 @@ gfc_resolve_signal_sub (gfc_code *c)
   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;
@@ -2762,20 +3184,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;
-  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);
 }
 
@@ -2788,6 +3226,7 @@ gfc_resolve_flush (gfc_code *c)
   const char *name;
   gfc_typespec ts;
   gfc_expr *n;
+  gfc_clear_ts (&ts);
 
   ts.type = BT_INTEGER;
   ts.kind = gfc_default_integer_kind;
@@ -2805,6 +3244,7 @@ gfc_resolve_free (gfc_code *c)
 {
   gfc_typespec ts;
   gfc_expr *n;
+  gfc_clear_ts (&ts);
 
   ts.type = BT_INTEGER;
   ts.kind = gfc_index_integer_kind;
@@ -2820,14 +3260,15 @@ void
 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;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (c->ext.actual->expr, &ts, 2);
     }
 
@@ -2920,6 +3361,7 @@ gfc_resolve_fgetc_sub (gfc_code *c)
   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;
@@ -2928,8 +3370,8 @@ gfc_resolve_fgetc_sub (gfc_code *c)
     {
       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);
     }
 
@@ -2964,6 +3406,7 @@ gfc_resolve_fputc_sub (gfc_code *c)
   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;
@@ -2972,8 +3415,8 @@ gfc_resolve_fputc_sub (gfc_code *c)
     {
       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);
     }
 
@@ -3008,20 +3451,19 @@ gfc_resolve_fseek_sub (gfc_code *c)
   gfc_expr *unit;
   gfc_expr *offset;
   gfc_expr *whence;
-  gfc_expr *status;
   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;
-  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;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (unit, &ts, 2);
     }
 
@@ -3029,8 +3471,8 @@ gfc_resolve_fseek_sub (gfc_code *c)
     {
       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);
     }
 
@@ -3038,8 +3480,8 @@ gfc_resolve_fseek_sub (gfc_code *c)
     {
       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);
     }
 
@@ -3053,6 +3495,7 @@ gfc_resolve_ftell_sub (gfc_code *c)
   gfc_expr *unit;
   gfc_expr *offset;
   gfc_typespec ts;
+  gfc_clear_ts (&ts);
 
   unit = c->ext.actual->expr;
   offset = c->ext.actual->next->expr;
@@ -3061,8 +3504,8 @@ gfc_resolve_ftell_sub (gfc_code *c)
     {
       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);
     }
 
@@ -3075,13 +3518,14 @@ void
 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;
-      ts.derived = NULL;
-      ts.cl = NULL;
+      ts.u.derived = NULL;
+      ts.u.cl = NULL;
       gfc_convert_type (c->ext.actual->expr, &ts, 2);
     }