PR fortran/30964

[pf3gnuchains/gcc-fork.git] / gcc / fortran / iresolve.c

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 32ed6da..6232374 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -520,10 +520,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)
     {
@@ -856,10 +859,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);
 }
 
@@ -920,12 +938,16 @@ 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;
 
   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)
     {
@@ -1057,12 +1079,15 @@ 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;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
 
   if (dim == NULL)
     {
@@ -1076,10 +1101,13 @@ gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
 
 
 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);
@@ -1087,10 +1115,13 @@ 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);
 }
 
@@ -1742,6 +1773,14 @@ gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
   prec = gfc_get_actual_arglist ();
   prec->name = "p";
   prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
+  /* The library routine expects INTEGER(4).  */
+  if (prec->expr->ts.kind != gfc_c_int_kind)
+    {
+      gfc_typespec ts;
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      gfc_convert_type (prec->expr, &ts, 2);
+    }
   f->value.function.actual->next = prec;
 }
 
@@ -1757,7 +1796,7 @@ gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
     {
       gfc_typespec ts;
       ts.type = BT_INTEGER;
-      ts.kind = gfc_default_integer_kind;
+      ts.kind = gfc_c_int_kind;
       gfc_convert_type_warn (i, &ts, 2, 0);
     }
 
@@ -1768,10 +1807,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);
 }
 
@@ -1792,11 +1834,11 @@ gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, gfc_expr *i)
   /* 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)
+  if (i->ts.kind != gfc_c_int_kind)
     {
       gfc_typespec ts;
       ts.type = BT_INTEGER;
-      ts.kind = gfc_default_integer_kind;
+      ts.kind = gfc_c_int_kind;
       gfc_convert_type_warn (i, &ts, 2, 0);
     }
 
@@ -1865,6 +1907,18 @@ 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; 
@@ -1892,11 +1946,29 @@ gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
   emin_1 = gfc_get_actual_arglist ();
   emin_1->name = "emin";
   emin_1->expr = gfc_int_expr (gfc_real_kinds[k].min_exponent - 1);
+
+  /* The library routine expects INTEGER(4).  */
+  if (emin_1->expr->ts.kind != gfc_c_int_kind)
+    {
+      gfc_typespec ts;
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      gfc_convert_type (emin_1->expr, &ts, 2);
+    }
   emin_1->next = tiny;
 
   prec = gfc_get_actual_arglist ();
   prec->name = "prec";
   prec->expr = gfc_int_expr (gfc_real_kinds[k].digits);
+
+  /* The library routine expects INTEGER(4).  */
+  if (prec->expr->ts.kind != gfc_c_int_kind)
+    {
+      gfc_typespec ts;
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      gfc_convert_type (prec->expr, &ts, 2);
+    }
   prec->next = emin_1;
 
   f->value.function.actual->next = prec;
@@ -2239,12 +2311,15 @@ 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;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
 
   if (dim == NULL)
     {
@@ -2317,10 +2392,13 @@ gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
 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);
 }
 
@@ -2359,15 +2437,19 @@ gfc_resolve_alarm_sub (gfc_code *c)
   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);
@@ -2425,6 +2507,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;
@@ -2713,14 +2805,18 @@ void
 gfc_resolve_exit (gfc_code *c)
 {
   const char *name;
-  int kind;
+  gfc_typespec ts;
+  gfc_expr *n;
 
-  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);
 }