gcc/fortran/iresolve.c

   1 /* Intrinsic function resolution.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22
  23 /* Assign name and types to intrinsic procedures.  For functions, the
  24    first argument to a resolution function is an expression pointer to
  25    the original function node and the rest are pointers to the
  26    arguments of the function call.  For subroutines, a pointer to the
  27    code node is passed.  The result type and library subroutine name
  28    are generally set according to the function arguments.  */
  29
  30 #include "config.h"
  31 #include "system.h"
  32 #include "coretypes.h"
  33 #include "tree.h"
  34 #include "gfortran.h"
  35 #include "intrinsic.h"
  36
  37 /* Given printf-like arguments, return a stable version of the result string.
  38
  39    We already have a working, optimized string hashing table in the form of
  40    the identifier table.  Reusing this table is likely not to be wasted,
  41    since if the function name makes it to the gimple output of the frontend,
  42    we'll have to create the identifier anyway.  */
  43
  44 const char *
  45 gfc_get_string (const char *format, ...)
  46 {
  47   char temp_name[128];
  48   va_list ap;
  49   tree ident;
  50
  51   va_start (ap, format);
  52   vsnprintf (temp_name, sizeof (temp_name), format, ap);
  53   va_end (ap);
  54   temp_name[sizeof (temp_name) - 1] = 0;
  55
  56   ident = get_identifier (temp_name);
  57   return IDENTIFIER_POINTER (ident);
  58 }
  59
  60 /* MERGE and SPREAD need to have source charlen's present for passing
  61    to the result expression.  */
  62 static void
  63 check_charlen_present (gfc_expr *source)
  64 {
  65   if (source->ts.u.cl == NULL)
  66     source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
  67
  68   if (source->expr_type == EXPR_CONSTANT)
  69     {
  70       source->ts.u.cl->length = gfc_int_expr (source->value.character.length);
  71       source->rank = 0;
  72     }
  73   else if (source->expr_type == EXPR_ARRAY)
  74     source->ts.u.cl->length =
  75         gfc_int_expr (source->value.constructor->expr->value.character.length);
  76 }
  77
  78 /* Helper function for resolving the "mask" argument.  */
  79
  80 static void
  81 resolve_mask_arg (gfc_expr *mask)
  82 {
  83
  84   gfc_typespec ts;
  85   gfc_clear_ts (&ts);
  86
  87   if (mask->rank == 0)
  88     {
  89       /* For the scalar case, coerce the mask to kind=4 unconditionally
  90          (because this is the only kind we have a library function
  91          for).  */
  92
  93       if (mask->ts.kind != 4)
  94         {
  95           ts.type = BT_LOGICAL;
  96           ts.kind = 4;
  97           gfc_convert_type (mask, &ts, 2);
  98         }
  99     }
 100   else
 101     {
 102       /* In the library, we access the mask with a GFC_LOGICAL_1
 103          argument.  No need to waste memory if we are about to create
 104          a temporary array.  */
 105       if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
 106         {
 107           ts.type = BT_LOGICAL;
 108           ts.kind = 1;
 109           gfc_convert_type (mask, &ts, 2);
 110         }
 111     }
 112 }
 113
 114 /********************** Resolution functions **********************/
 115
 116
 117 void
 118 gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
 119 {
 120   f->ts = a->ts;
 121   if (f->ts.type == BT_COMPLEX)
 122     f->ts.type = BT_REAL;
 123
 124   f->value.function.name
 125     = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 126 }
 127
 128
 129 void
 130 gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
 131                     gfc_expr *mode ATTRIBUTE_UNUSED)
 132 {
 133   f->ts.type = BT_INTEGER;
 134   f->ts.kind = gfc_c_int_kind;
 135   f->value.function.name = PREFIX ("access_func");
 136 }
 137
 138
 139 void
 140 gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
 141 {
 142   f->ts.type = BT_CHARACTER;
 143   f->ts.kind = string->ts.kind;
 144   f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
 145 }
 146
 147
 148 void
 149 gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
 150 {
 151   f->ts.type = BT_CHARACTER;
 152   f->ts.kind = string->ts.kind;
 153   f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
 154 }
 155
 156
 157 static void
 158 gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
 159                         const char *name)
 160 {
 161   f->ts.type = BT_CHARACTER;
 162   f->ts.kind = (kind == NULL)
 163              ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
 164   f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 165   f->ts.u.cl->length = gfc_int_expr (1);
 166
 167   f->value.function.name = gfc_get_string (name, f->ts.kind,
 168                                            gfc_type_letter (x->ts.type),
 169                                            x->ts.kind);
 170 }
 171
 172
 173 void
 174 gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
 175 {
 176   gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
 177 }
 178
 179
 180 void
 181 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
 182 {
 183   f->ts = x->ts;
 184   f->value.function.name
 185     = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 186 }
 187
 188
 189 void
 190 gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
 191 {
 192   f->ts = x->ts;
 193   f->value.function.name
 194     = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
 195                       x->ts.kind);
 196 }
 197
 198
 199 void
 200 gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
 201 {
 202   f->ts.type = BT_REAL;
 203   f->ts.kind = x->ts.kind;
 204   f->value.function.name
 205     = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
 206                       x->ts.kind);
 207 }
 208
 209
 210 void
 211 gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 212 {
 213   f->ts.type = i->ts.type;
 214   f->ts.kind = gfc_kind_max (i, j);
 215
 216   if (i->ts.kind != j->ts.kind)
 217     {
 218       if (i->ts.kind == gfc_kind_max (i, j))
 219         gfc_convert_type (j, &i->ts, 2);
 220       else
 221         gfc_convert_type (i, &j->ts, 2);
 222     }
 223
 224   f->value.function.name
 225     = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
 226 }
 227
 228
 229 void
 230 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 231 {
 232   gfc_typespec ts;
 233   gfc_clear_ts (&ts);
 234
 235   f->ts.type = a->ts.type;
 236   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 237
 238   if (a->ts.kind != f->ts.kind)
 239     {
 240       ts.type = f->ts.type;
 241       ts.kind = f->ts.kind;
 242       gfc_convert_type (a, &ts, 2);
 243     }
 244   /* The resolved name is only used for specific intrinsics where
 245      the return kind is the same as the arg kind.  */
 246   f->value.function.name
 247     = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 248 }
 249
 250
 251 void
 252 gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
 253 {
 254   gfc_resolve_aint (f, a, NULL);
 255 }
 256
 257
 258 void
 259 gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
 260 {
 261   f->ts = mask->ts;
 262
 263   if (dim != NULL)
 264     {
 265       gfc_resolve_dim_arg (dim);
 266       f->rank = mask->rank - 1;
 267       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 268     }
 269
 270   f->value.function.name
 271     = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
 272                       mask->ts.kind);
 273 }
 274
 275
 276 void
 277 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 278 {
 279   gfc_typespec ts;
 280   gfc_clear_ts (&ts);
 281
 282   f->ts.type = a->ts.type;
 283   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 284
 285   if (a->ts.kind != f->ts.kind)
 286     {
 287       ts.type = f->ts.type;
 288       ts.kind = f->ts.kind;
 289       gfc_convert_type (a, &ts, 2);
 290     }
 291
 292   /* The resolved name is only used for specific intrinsics where
 293      the return kind is the same as the arg kind.  */
 294   f->value.function.name
 295     = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
 296                       a->ts.kind);
 297 }
 298
 299
 300 void
 301 gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
 302 {
 303   gfc_resolve_anint (f, a, NULL);
 304 }
 305
 306
 307 void
 308 gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
 309 {
 310   f->ts = mask->ts;
 311
 312   if (dim != NULL)
 313     {
 314       gfc_resolve_dim_arg (dim);
 315       f->rank = mask->rank - 1;
 316       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 317     }
 318
 319   f->value.function.name
 320     = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
 321                       mask->ts.kind);
 322 }
 323
 324
 325 void
 326 gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
 327 {
 328   f->ts = x->ts;
 329   f->value.function.name
 330     = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 331 }
 332
 333 void
 334 gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
 335 {
 336   f->ts = x->ts;
 337   f->value.function.name
 338     = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
 339                       x->ts.kind);
 340 }
 341
 342 void
 343 gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
 344 {
 345   f->ts = x->ts;
 346   f->value.function.name
 347     = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 348 }
 349
 350 void
 351 gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
 352 {
 353   f->ts = x->ts;
 354   f->value.function.name
 355     = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
 356                       x->ts.kind);
 357 }
 358
 359 void
 360 gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
 361 {
 362   f->ts = x->ts;
 363   f->value.function.name
 364     = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
 365                       x->ts.kind);
 366 }
 367
 368
 369 /* Resolve the BESYN and BESJN intrinsics.  */
 370
 371 void
 372 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
 373 {
 374   gfc_typespec ts;
 375   gfc_clear_ts (&ts);
 376
 377   f->ts = x->ts;
 378   if (n->ts.kind != gfc_c_int_kind)
 379     {
 380       ts.type = BT_INTEGER;
 381       ts.kind = gfc_c_int_kind;
 382       gfc_convert_type (n, &ts, 2);
 383     }
 384   f->value.function.name = gfc_get_string ("<intrinsic>");
 385 }
 386
 387
 388 void
 389 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
 390 {
 391   f->ts.type = BT_LOGICAL;
 392   f->ts.kind = gfc_default_logical_kind;
 393   f->value.function.name
 394     = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
 395 }
 396
 397
 398 void
 399 gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 400 {
 401   f->ts.type = BT_INTEGER;
 402   f->ts.kind = (kind == NULL)
 403              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
 404   f->value.function.name
 405     = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
 406                       gfc_type_letter (a->ts.type), a->ts.kind);
 407 }
 408
 409
 410 void
 411 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 412 {
 413   gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
 414 }
 415
 416
 417 void
 418 gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
 419 {
 420   f->ts.type = BT_INTEGER;
 421   f->ts.kind = gfc_default_integer_kind;
 422   f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
 423 }
 424
 425
 426 void
 427 gfc_resolve_chdir_sub (gfc_code *c)
 428 {
 429   const char *name;
 430   int kind;
 431
 432   if (c->ext.actual->next->expr != NULL)
 433     kind = c->ext.actual->next->expr->ts.kind;
 434   else
 435     kind = gfc_default_integer_kind;
 436
 437   name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
 438   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 439 }
 440
 441
 442 void
 443 gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
 444                    gfc_expr *mode ATTRIBUTE_UNUSED)
 445 {
 446   f->ts.type = BT_INTEGER;
 447   f->ts.kind = gfc_c_int_kind;
 448   f->value.function.name = PREFIX ("chmod_func");
 449 }
 450
 451
 452 void
 453 gfc_resolve_chmod_sub (gfc_code *c)
 454 {
 455   const char *name;
 456   int kind;
 457
 458   if (c->ext.actual->next->next->expr != NULL)
 459     kind = c->ext.actual->next->next->expr->ts.kind;
 460   else
 461     kind = gfc_default_integer_kind;
 462
 463   name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
 464   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 465 }
 466
 467
 468 void
 469 gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
 470 {
 471   f->ts.type = BT_COMPLEX;
 472   f->ts.kind = (kind == NULL)
 473              ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
 474
 475   if (y == NULL)
 476     f->value.function.name
 477       = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
 478                         gfc_type_letter (x->ts.type), x->ts.kind);
 479   else
 480     f->value.function.name
 481       = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
 482                         gfc_type_letter (x->ts.type), x->ts.kind,
 483                         gfc_type_letter (y->ts.type), y->ts.kind);
 484 }
 485
 486
 487 void
 488 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
 489 {
 490   gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
 491 }
 492
 493
 494 void
 495 gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
 496 {
 497   int kind;
 498
 499   if (x->ts.type == BT_INTEGER)
 500     {
 501       if (y->ts.type == BT_INTEGER)
 502         kind = gfc_default_real_kind;
 503       else
 504         kind = y->ts.kind;
 505     }
 506   else
 507     {
 508       if (y->ts.type == BT_REAL)
 509         kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
 510       else
 511         kind = x->ts.kind;
 512     }
 513
 514   f->ts.type = BT_COMPLEX;
 515   f->ts.kind = kind;
 516   f->value.function.name
 517     = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
 518                       gfc_type_letter (x->ts.type), x->ts.kind,
 519                       gfc_type_letter (y->ts.type), y->ts.kind);
 520 }
 521
 522
 523 void
 524 gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
 525 {
 526   f->ts = x->ts;
 527   f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
 528 }
 529
 530
 531 void
 532 gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
 533 {
 534   f->ts = x->ts;
 535   f->value.function.name
 536     = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 537 }
 538
 539
 540 void
 541 gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
 542 {
 543   f->ts = x->ts;
 544   f->value.function.name
 545     = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 546 }
 547
 548
 549 void
 550 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
 551 {
 552   f->ts.type = BT_INTEGER;
 553   if (kind)
 554     f->ts.kind = mpz_get_si (kind->value.integer);
 555   else
 556     f->ts.kind = gfc_default_integer_kind;
 557
 558   if (dim != NULL)
 559     {
 560       f->rank = mask->rank - 1;
 561       gfc_resolve_dim_arg (dim);
 562       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 563     }
 564
 565   resolve_mask_arg (mask);
 566
 567   f->value.function.name
 568     = gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind,
 569                       gfc_type_letter (mask->ts.type));
 570 }
 571
 572
 573 void
 574 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
 575                     gfc_expr *dim)
 576 {
 577   int n, m;
 578
 579   if (array->ts.type == BT_CHARACTER && array->ref)
 580     gfc_resolve_substring_charlen (array);
 581
 582   f->ts = array->ts;
 583   f->rank = array->rank;
 584   f->shape = gfc_copy_shape (array->shape, array->rank);
 585
 586   if (shift->rank > 0)
 587     n = 1;
 588   else
 589     n = 0;
 590
 591   /* If dim kind is greater than default integer we need to use the larger.  */
 592   m = gfc_default_integer_kind;
 593   if (dim != NULL)
 594     m = m < dim->ts.kind ? dim->ts.kind : m;
 595
 596   /* Convert shift to at least m, so we don't need
 597       kind=1 and kind=2 versions of the library functions.  */
 598   if (shift->ts.kind < m)
 599     {
 600       gfc_typespec ts;
 601       gfc_clear_ts (&ts);
 602       ts.type = BT_INTEGER;
 603       ts.kind = m;
 604       gfc_convert_type_warn (shift, &ts, 2, 0);
 605     }
 606
 607   if (dim != NULL)
 608     {
 609       if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
 610           && dim->symtree->n.sym->attr.optional)
 611         {
 612           /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
 613           dim->representation.length = shift->ts.kind;
 614         }
 615       else
 616         {
 617           gfc_resolve_dim_arg (dim);
 618           /* Convert dim to shift's kind to reduce variations.  */
 619           if (dim->ts.kind != shift->ts.kind)
 620             gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 621         }
 622     }
 623
 624   if (array->ts.type == BT_CHARACTER)
 625     {
 626       if (array->ts.kind == gfc_default_character_kind)
 627         f->value.function.name
 628           = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
 629       else
 630         f->value.function.name
 631           = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
 632                             array->ts.kind);
 633     }
 634   else
 635     f->value.function.name
 636         = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
 637 }
 638
 639
 640 void
 641 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
 642 {
 643   gfc_typespec ts;
 644   gfc_clear_ts (&ts);
 645
 646   f->ts.type = BT_CHARACTER;
 647   f->ts.kind = gfc_default_character_kind;
 648
 649   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
 650   if (time->ts.kind != 8)
 651     {
 652       ts.type = BT_INTEGER;
 653       ts.kind = 8;
 654       ts.u.derived = NULL;
 655       ts.u.cl = NULL;
 656       gfc_convert_type (time, &ts, 2);
 657     }
 658
 659   f->value.function.name = gfc_get_string (PREFIX ("ctime"));
 660 }
 661
 662
 663 void
 664 gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
 665 {
 666   f->ts.type = BT_REAL;
 667   f->ts.kind = gfc_default_double_kind;
 668   f->value.function.name
 669     = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 670 }
 671
 672
 673 void
 674 gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
 675 {
 676   f->ts.type = a->ts.type;
 677   if (p != NULL)
 678     f->ts.kind = gfc_kind_max (a,p);
 679   else
 680     f->ts.kind = a->ts.kind;
 681
 682   if (p != NULL && a->ts.kind != p->ts.kind)
 683     {
 684       if (a->ts.kind == gfc_kind_max (a,p))
 685         gfc_convert_type (p, &a->ts, 2);
 686       else
 687         gfc_convert_type (a, &p->ts, 2);
 688     }
 689
 690   f->value.function.name
 691     = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
 692 }
 693
 694
 695 void
 696 gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
 697 {
 698   gfc_expr temp;
 699
 700   temp.expr_type = EXPR_OP;
 701   gfc_clear_ts (&temp.ts);
 702   temp.value.op.op = INTRINSIC_NONE;
 703   temp.value.op.op1 = a;
 704   temp.value.op.op2 = b;
 705   gfc_type_convert_binary (&temp);
 706   f->ts = temp.ts;
 707   f->value.function.name
 708     = gfc_get_string (PREFIX ("dot_product_%c%d"),
 709                       gfc_type_letter (f->ts.type), f->ts.kind);
 710 }
 711
 712
 713 void
 714 gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
 715                    gfc_expr *b ATTRIBUTE_UNUSED)
 716 {
 717   f->ts.kind = gfc_default_double_kind;
 718   f->ts.type = BT_REAL;
 719   f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
 720 }
 721
 722
 723 void
 724 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
 725                      gfc_expr *boundary, gfc_expr *dim)
 726 {
 727   int n, m;
 728
 729   if (array->ts.type == BT_CHARACTER && array->ref)
 730     gfc_resolve_substring_charlen (array);
 731
 732   f->ts = array->ts;
 733   f->rank = array->rank;
 734   f->shape = gfc_copy_shape (array->shape, array->rank);
 735
 736   n = 0;
 737   if (shift->rank > 0)
 738     n = n | 1;
 739   if (boundary && boundary->rank > 0)
 740     n = n | 2;
 741
 742   /* If dim kind is greater than default integer we need to use the larger.  */
 743   m = gfc_default_integer_kind;
 744   if (dim != NULL)
 745     m = m < dim->ts.kind ? dim->ts.kind : m;
 746
 747   /* Convert shift to at least m, so we don't need
 748       kind=1 and kind=2 versions of the library functions.  */
 749   if (shift->ts.kind < m)
 750     {
 751       gfc_typespec ts;
 752       gfc_clear_ts (&ts);
 753       ts.type = BT_INTEGER;
 754       ts.kind = m;
 755       gfc_convert_type_warn (shift, &ts, 2, 0);
 756     }
 757
 758   if (dim != NULL)
 759     {
 760       if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
 761           && dim->symtree->n.sym->attr.optional)
 762         {
 763           /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
 764           dim->representation.length = shift->ts.kind;
 765         }
 766       else
 767         {
 768           gfc_resolve_dim_arg (dim);
 769           /* Convert dim to shift's kind to reduce variations.  */
 770           if (dim->ts.kind != shift->ts.kind)
 771             gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 772         }
 773     }
 774
 775   if (array->ts.type == BT_CHARACTER)
 776     {
 777       if (array->ts.kind == gfc_default_character_kind)
 778         f->value.function.name
 779           = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
 780       else
 781         f->value.function.name
 782           = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
 783                             array->ts.kind);
 784     }
 785   else
 786     f->value.function.name
 787         = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
 788 }
 789
 790
 791 void
 792 gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
 793 {
 794   f->ts = x->ts;
 795   f->value.function.name
 796     = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 797 }
 798
 799
 800 void
 801 gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
 802 {
 803   f->ts.type = BT_INTEGER;
 804   f->ts.kind = gfc_default_integer_kind;
 805   f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
 806 }
 807
 808
 809 /* Resolve the EXTENDS_TYPE_OF intrinsic function.  */
 810
 811 void
 812 gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
 813 {
 814   gfc_symbol *vtab;
 815   gfc_symtree *st;
 816
 817   /* Prevent double resolution.  */
 818   if (f->ts.type == BT_LOGICAL)
 819     return;
 820
 821   /* Replace the first argument with the corresponding vtab.  */
 822   if (a->ts.type == BT_CLASS)
 823     gfc_add_component_ref (a, "$vptr");
 824   else if (a->ts.type == BT_DERIVED)
 825     {
 826       vtab = gfc_find_derived_vtab (a->ts.u.derived);
 827       /* Clear the old expr.  */
 828       gfc_free_ref_list (a->ref);
 829       memset (a, '\0', sizeof (gfc_expr));
 830       /* Construct a new one.  */
 831       a->expr_type = EXPR_VARIABLE;
 832       st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
 833       a->symtree = st;
 834       a->ts = vtab->ts;
 835     }
 836
 837   /* Replace the second argument with the corresponding vtab.  */
 838   if (mo->ts.type == BT_CLASS)
 839     gfc_add_component_ref (mo, "$vptr");
 840   else if (mo->ts.type == BT_DERIVED)
 841     {
 842       vtab = gfc_find_derived_vtab (mo->ts.u.derived);
 843       /* Clear the old expr.  */
 844       gfc_free_ref_list (mo->ref);
 845       memset (mo, '\0', sizeof (gfc_expr));
 846       /* Construct a new one.  */
 847       mo->expr_type = EXPR_VARIABLE;
 848       st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
 849       mo->symtree = st;
 850       mo->ts = vtab->ts;
 851     }
 852
 853   f->ts.type = BT_LOGICAL;
 854   f->ts.kind = 4;
 855   /* Call library function.  */
 856   f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
 857 }
 858
 859
 860 void
 861 gfc_resolve_fdate (gfc_expr *f)
 862 {
 863   f->ts.type = BT_CHARACTER;
 864   f->ts.kind = gfc_default_character_kind;
 865   f->value.function.name = gfc_get_string (PREFIX ("fdate"));
 866 }
 867
 868
 869 void
 870 gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 871 {
 872   f->ts.type = BT_INTEGER;
 873   f->ts.kind = (kind == NULL)
 874              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
 875   f->value.function.name
 876     = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
 877                       gfc_type_letter (a->ts.type), a->ts.kind);
 878 }
 879
 880
 881 void
 882 gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
 883 {
 884   f->ts.type = BT_INTEGER;
 885   f->ts.kind = gfc_default_integer_kind;
 886   if (n->ts.kind != f->ts.kind)
 887     gfc_convert_type (n, &f->ts, 2);
 888   f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
 889 }
 890
 891
 892 void
 893 gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
 894 {
 895   f->ts = x->ts;
 896   f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
 897 }
 898
 899
 900 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
 901
 902 void
 903 gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
 904 {
 905   f->ts = x->ts;
 906   f->value.function.name = gfc_get_string ("<intrinsic>");
 907 }
 908
 909
 910 void
 911 gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
 912 {
 913   f->ts = x->ts;
 914   f->value.function.name
 915     = gfc_get_string ("__gamma_%d", x->ts.kind);
 916 }
 917
 918
 919 void
 920 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
 921 {
 922   f->ts.type = BT_INTEGER;
 923   f->ts.kind = 4;
 924   f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
 925 }
 926
 927
 928 void
 929 gfc_resolve_getgid (gfc_expr *f)
 930 {
 931   f->ts.type = BT_INTEGER;
 932   f->ts.kind = 4;
 933   f->value.function.name = gfc_get_string (PREFIX ("getgid"));
 934 }
 935
 936
 937 void
 938 gfc_resolve_getpid (gfc_expr *f)
 939 {
 940   f->ts.type = BT_INTEGER;
 941   f->ts.kind = 4;
 942   f->value.function.name = gfc_get_string (PREFIX ("getpid"));
 943 }
 944
 945
 946 void
 947 gfc_resolve_getuid (gfc_expr *f)
 948 {
 949   f->ts.type = BT_INTEGER;
 950   f->ts.kind = 4;
 951   f->value.function.name = gfc_get_string (PREFIX ("getuid"));
 952 }
 953
 954
 955 void
 956 gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
 957 {
 958   f->ts.type = BT_INTEGER;
 959   f->ts.kind = 4;
 960   f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
 961 }
 962
 963
 964 void
 965 gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
 966 {
 967   f->ts = x->ts;
 968   f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind);
 969 }
 970
 971
 972 void
 973 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 974 {
 975   /* If the kind of i and j are different, then g77 cross-promoted the
 976      kinds to the largest value.  The Fortran 95 standard requires the
 977      kinds to match.  */
 978   if (i->ts.kind != j->ts.kind)
 979     {
 980       if (i->ts.kind == gfc_kind_max (i, j))
 981         gfc_convert_type (j, &i->ts, 2);
 982       else
 983         gfc_convert_type (i, &j->ts, 2);
 984     }
 985
 986   f->ts = i->ts;
 987   f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
 988 }
 989
 990
 991 void
 992 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 993 {
 994   f->ts = i->ts;
 995   f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
 996 }
 997
 998
 999 void
1000 gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
1001                    gfc_expr *len ATTRIBUTE_UNUSED)
1002 {
1003   f->ts = i->ts;
1004   f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
1005 }
1006
1007
1008 void
1009 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1010 {
1011   f->ts = i->ts;
1012   f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
1013 }
1014
1015
1016 void
1017 gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1018 {
1019   f->ts.type = BT_INTEGER;
1020   if (kind)
1021     f->ts.kind = mpz_get_si (kind->value.integer);
1022   else
1023     f->ts.kind = gfc_default_integer_kind;
1024   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1025 }
1026
1027
1028 void
1029 gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1030 {
1031   f->ts.type = BT_INTEGER;
1032   if (kind)
1033     f->ts.kind = mpz_get_si (kind->value.integer);
1034   else
1035     f->ts.kind = gfc_default_integer_kind;
1036   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1037 }
1038
1039
1040 void
1041 gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
1042 {
1043   gfc_resolve_nint (f, a, NULL);
1044 }
1045
1046
1047 void
1048 gfc_resolve_ierrno (gfc_expr *f)
1049 {
1050   f->ts.type = BT_INTEGER;
1051   f->ts.kind = gfc_default_integer_kind;
1052   f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
1053 }
1054
1055
1056 void
1057 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1058 {
1059   /* If the kind of i and j are different, then g77 cross-promoted the
1060      kinds to the largest value.  The Fortran 95 standard requires the
1061      kinds to match.  */
1062   if (i->ts.kind != j->ts.kind)
1063     {
1064       if (i->ts.kind == gfc_kind_max (i, j))
1065         gfc_convert_type (j, &i->ts, 2);
1066       else
1067         gfc_convert_type (i, &j->ts, 2);
1068     }
1069
1070   f->ts = i->ts;
1071   f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
1072 }
1073
1074
1075 void
1076 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1077 {
1078   /* If the kind of i and j are different, then g77 cross-promoted the
1079      kinds to the largest value.  The Fortran 95 standard requires the
1080      kinds to match.  */
1081   if (i->ts.kind != j->ts.kind)
1082     {
1083       if (i->ts.kind == gfc_kind_max (i, j))
1084         gfc_convert_type (j, &i->ts, 2);
1085       else
1086         gfc_convert_type (i, &j->ts, 2);
1087     }
1088
1089   f->ts = i->ts;
1090   f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
1091 }
1092
1093
1094 void
1095 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
1096                         gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
1097                         gfc_expr *kind)
1098 {
1099   gfc_typespec ts;
1100   gfc_clear_ts (&ts);
1101
1102   f->ts.type = BT_INTEGER;
1103   if (kind)
1104     f->ts.kind = mpz_get_si (kind->value.integer);
1105   else
1106     f->ts.kind = gfc_default_integer_kind;
1107
1108   if (back && back->ts.kind != gfc_default_integer_kind)
1109     {
1110       ts.type = BT_LOGICAL;
1111       ts.kind = gfc_default_integer_kind;
1112       ts.u.derived = NULL;
1113       ts.u.cl = NULL;
1114       gfc_convert_type (back, &ts, 2);
1115     }
1116
1117   f->value.function.name
1118     = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1119 }
1120
1121
1122 void
1123 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1124 {
1125   f->ts.type = BT_INTEGER;
1126   f->ts.kind = (kind == NULL)
1127              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1128   f->value.function.name
1129     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1130                       gfc_type_letter (a->ts.type), a->ts.kind);
1131 }
1132
1133
1134 void
1135 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1136 {
1137   f->ts.type = BT_INTEGER;
1138   f->ts.kind = 2;
1139   f->value.function.name
1140     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1141                       gfc_type_letter (a->ts.type), a->ts.kind);
1142 }
1143
1144
1145 void
1146 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1147 {
1148   f->ts.type = BT_INTEGER;
1149   f->ts.kind = 8;
1150   f->value.function.name
1151     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1152                       gfc_type_letter (a->ts.type), a->ts.kind);
1153 }
1154
1155
1156 void
1157 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1158 {
1159   f->ts.type = BT_INTEGER;
1160   f->ts.kind = 4;
1161   f->value.function.name
1162     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1163                       gfc_type_letter (a->ts.type), a->ts.kind);
1164 }
1165
1166
1167 void
1168 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1169 {
1170   gfc_typespec ts;
1171   gfc_clear_ts (&ts);
1172
1173   f->ts.type = BT_LOGICAL;
1174   f->ts.kind = gfc_default_integer_kind;
1175   if (u->ts.kind != gfc_c_int_kind)
1176     {
1177       ts.type = BT_INTEGER;
1178       ts.kind = gfc_c_int_kind;
1179       ts.u.derived = NULL;
1180       ts.u.cl = NULL;
1181       gfc_convert_type (u, &ts, 2);
1182     }
1183
1184   f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1185 }
1186
1187
1188 void
1189 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1190 {
1191   f->ts = i->ts;
1192   f->value.function.name
1193     = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1194 }
1195
1196
1197 void
1198 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1199 {
1200   f->ts = i->ts;
1201   f->value.function.name
1202     = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1203 }
1204
1205
1206 void
1207 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1208 {
1209   f->ts = i->ts;
1210   f->value.function.name
1211     = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1212 }
1213
1214
1215 void
1216 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1217 {
1218   int s_kind;
1219
1220   s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1221
1222   f->ts = i->ts;
1223   f->value.function.name
1224     = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1225 }
1226
1227
1228 void
1229 gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
1230                   gfc_expr *s ATTRIBUTE_UNUSED)
1231 {
1232   f->ts.type = BT_INTEGER;
1233   f->ts.kind = gfc_default_integer_kind;
1234   f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
1235 }
1236
1237
1238 void
1239 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1240 {
1241   static char lbound[] = "__lbound";
1242
1243   f->ts.type = BT_INTEGER;
1244   if (kind)
1245     f->ts.kind = mpz_get_si (kind->value.integer);
1246   else
1247     f->ts.kind = gfc_default_integer_kind;
1248
1249   if (dim == NULL)
1250     {
1251       f->rank = 1;
1252       f->shape = gfc_get_shape (1);
1253       mpz_init_set_ui (f->shape[0], array->rank);
1254     }
1255
1256   f->value.function.name = lbound;
1257 }
1258
1259
1260 void
1261 gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1262 {
1263   f->ts.type = BT_INTEGER;
1264   if (kind)
1265     f->ts.kind = mpz_get_si (kind->value.integer);
1266   else
1267     f->ts.kind = gfc_default_integer_kind;
1268   f->value.function.name
1269     = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1270                       gfc_default_integer_kind);
1271 }
1272
1273
1274 void
1275 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1276 {
1277   f->ts.type = BT_INTEGER;
1278   if (kind)
1279     f->ts.kind = mpz_get_si (kind->value.integer);
1280   else
1281     f->ts.kind = gfc_default_integer_kind;
1282   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1283 }
1284
1285
1286 void
1287 gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1288 {
1289   f->ts = x->ts;
1290   f->value.function.name
1291     = gfc_get_string ("__lgamma_%d", x->ts.kind);
1292 }
1293
1294
1295 void
1296 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1297                   gfc_expr *p2 ATTRIBUTE_UNUSED)
1298 {
1299   f->ts.type = BT_INTEGER;
1300   f->ts.kind = gfc_default_integer_kind;
1301   f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1302 }
1303
1304
1305 void
1306 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1307 {
1308   f->ts.type= BT_INTEGER;
1309   f->ts.kind = gfc_index_integer_kind;
1310   f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1311 }
1312
1313
1314 void
1315 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1316 {
1317   f->ts = x->ts;
1318   f->value.function.name
1319     = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1320 }
1321
1322
1323 void
1324 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1325 {
1326   f->ts = x->ts;
1327   f->value.function.name
1328     = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1329                       x->ts.kind);
1330 }
1331
1332
1333 void
1334 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1335 {
1336   f->ts.type = BT_LOGICAL;
1337   f->ts.kind = (kind == NULL)
1338              ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1339   f->rank = a->rank;
1340
1341   f->value.function.name
1342     = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1343                       gfc_type_letter (a->ts.type), a->ts.kind);
1344 }
1345
1346
1347 void
1348 gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
1349 {
1350   if (size->ts.kind < gfc_index_integer_kind)
1351     {
1352       gfc_typespec ts;
1353       gfc_clear_ts (&ts);
1354
1355       ts.type = BT_INTEGER;
1356       ts.kind = gfc_index_integer_kind;
1357       gfc_convert_type_warn (size, &ts, 2, 0);
1358     }
1359
1360   f->ts.type = BT_INTEGER;
1361   f->ts.kind = gfc_index_integer_kind;
1362   f->value.function.name = gfc_get_string (PREFIX ("malloc"));
1363 }
1364
1365
1366 void
1367 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1368 {
1369   gfc_expr temp;
1370
1371   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1372     {
1373       f->ts.type = BT_LOGICAL;
1374       f->ts.kind = gfc_default_logical_kind;
1375     }
1376   else
1377     {
1378       temp.expr_type = EXPR_OP;
1379       gfc_clear_ts (&temp.ts);
1380       temp.value.op.op = INTRINSIC_NONE;
1381       temp.value.op.op1 = a;
1382       temp.value.op.op2 = b;
1383       gfc_type_convert_binary (&temp);
1384       f->ts = temp.ts;
1385     }
1386
1387   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1388
1389   if (a->rank == 2 && b->rank == 2)
1390     {
1391       if (a->shape && b->shape)
1392         {
1393           f->shape = gfc_get_shape (f->rank);
1394           mpz_init_set (f->shape[0], a->shape[0]);
1395           mpz_init_set (f->shape[1], b->shape[1]);
1396         }
1397     }
1398   else if (a->rank == 1)
1399     {
1400       if (b->shape)
1401         {
1402           f->shape = gfc_get_shape (f->rank);
1403           mpz_init_set (f->shape[0], b->shape[1]);
1404         }
1405     }
1406   else
1407     {
1408       /* b->rank == 1 and a->rank == 2 here, all other cases have
1409          been caught in check.c.   */
1410       if (a->shape)
1411         {
1412           f->shape = gfc_get_shape (f->rank);
1413           mpz_init_set (f->shape[0], a->shape[0]);
1414         }
1415     }
1416
1417   f->value.function.name
1418     = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1419                       f->ts.kind);
1420 }
1421
1422
1423 static void
1424 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1425 {
1426   gfc_actual_arglist *a;
1427
1428   f->ts.type = args->expr->ts.type;
1429   f->ts.kind = args->expr->ts.kind;
1430   /* Find the largest type kind.  */
1431   for (a = args->next; a; a = a->next)
1432     {
1433       if (a->expr->ts.kind > f->ts.kind)
1434         f->ts.kind = a->expr->ts.kind;
1435     }
1436
1437   /* Convert all parameters to the required kind.  */
1438   for (a = args; a; a = a->next)
1439     {
1440       if (a->expr->ts.kind != f->ts.kind)
1441         gfc_convert_type (a->expr, &f->ts, 2);
1442     }
1443
1444   f->value.function.name
1445     = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1446 }
1447
1448
1449 void
1450 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1451 {
1452   gfc_resolve_minmax ("__max_%c%d", f, args);
1453 }
1454
1455
1456 void
1457 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1458                     gfc_expr *mask)
1459 {
1460   const char *name;
1461   int i, j, idim;
1462
1463   f->ts.type = BT_INTEGER;
1464   f->ts.kind = gfc_default_integer_kind;
1465
1466   if (dim == NULL)
1467     {
1468       f->rank = 1;
1469       f->shape = gfc_get_shape (1);
1470       mpz_init_set_si (f->shape[0], array->rank);
1471     }
1472   else
1473     {
1474       f->rank = array->rank - 1;
1475       gfc_resolve_dim_arg (dim);
1476       if (array->shape && dim->expr_type == EXPR_CONSTANT)
1477         {
1478           idim = (int) mpz_get_si (dim->value.integer);
1479           f->shape = gfc_get_shape (f->rank);
1480           for (i = 0, j = 0; i < f->rank; i++, j++)
1481             {
1482               if (i == (idim - 1))
1483                 j++;
1484               mpz_init_set (f->shape[i], array->shape[j]);
1485             }
1486         }
1487     }
1488
1489   if (mask)
1490     {
1491       if (mask->rank == 0)
1492         name = "smaxloc";
1493       else
1494         name = "mmaxloc";
1495
1496       resolve_mask_arg (mask);
1497     }
1498   else
1499     name = "maxloc";
1500
1501   f->value.function.name
1502     = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1503                       gfc_type_letter (array->ts.type), array->ts.kind);
1504 }
1505
1506
1507 void
1508 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1509                     gfc_expr *mask)
1510 {
1511   const char *name;
1512   int i, j, idim;
1513
1514   f->ts = array->ts;
1515
1516   if (dim != NULL)
1517     {
1518       f->rank = array->rank - 1;
1519       gfc_resolve_dim_arg (dim);
1520
1521       if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1522         {
1523           idim = (int) mpz_get_si (dim->value.integer);
1524           f->shape = gfc_get_shape (f->rank);
1525           for (i = 0, j = 0; i < f->rank; i++, j++)
1526             {
1527               if (i == (idim - 1))
1528                 j++;
1529               mpz_init_set (f->shape[i], array->shape[j]);
1530             }
1531         }
1532     }
1533
1534   if (mask)
1535     {
1536       if (mask->rank == 0)
1537         name = "smaxval";
1538       else
1539         name = "mmaxval";
1540
1541       resolve_mask_arg (mask);
1542     }
1543   else
1544     name = "maxval";
1545
1546   f->value.function.name
1547     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1548                       gfc_type_letter (array->ts.type), array->ts.kind);
1549 }
1550
1551
1552 void
1553 gfc_resolve_mclock (gfc_expr *f)
1554 {
1555   f->ts.type = BT_INTEGER;
1556   f->ts.kind = 4;
1557   f->value.function.name = PREFIX ("mclock");
1558 }
1559
1560
1561 void
1562 gfc_resolve_mclock8 (gfc_expr *f)
1563 {
1564   f->ts.type = BT_INTEGER;
1565   f->ts.kind = 8;
1566   f->value.function.name = PREFIX ("mclock8");
1567 }
1568
1569
1570 void
1571 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1572                    gfc_expr *fsource ATTRIBUTE_UNUSED,
1573                    gfc_expr *mask ATTRIBUTE_UNUSED)
1574 {
1575   if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1576     gfc_resolve_substring_charlen (tsource);
1577
1578   if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1579     gfc_resolve_substring_charlen (fsource);
1580
1581   if (tsource->ts.type == BT_CHARACTER)
1582     check_charlen_present (tsource);
1583
1584   f->ts = tsource->ts;
1585   f->value.function.name
1586     = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1587                       tsource->ts.kind);
1588 }
1589
1590
1591 void
1592 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1593 {
1594   gfc_resolve_minmax ("__min_%c%d", f, args);
1595 }
1596
1597
1598 void
1599 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1600                     gfc_expr *mask)
1601 {
1602   const char *name;
1603   int i, j, idim;
1604
1605   f->ts.type = BT_INTEGER;
1606   f->ts.kind = gfc_default_integer_kind;
1607
1608   if (dim == NULL)
1609     {
1610       f->rank = 1;
1611       f->shape = gfc_get_shape (1);
1612       mpz_init_set_si (f->shape[0], array->rank);
1613     }
1614   else
1615     {
1616       f->rank = array->rank - 1;
1617       gfc_resolve_dim_arg (dim);
1618       if (array->shape && dim->expr_type == EXPR_CONSTANT)
1619         {
1620           idim = (int) mpz_get_si (dim->value.integer);
1621           f->shape = gfc_get_shape (f->rank);
1622           for (i = 0, j = 0; i < f->rank; i++, j++)
1623             {
1624               if (i == (idim - 1))
1625                 j++;
1626               mpz_init_set (f->shape[i], array->shape[j]);
1627             }
1628         }
1629     }
1630
1631   if (mask)
1632     {
1633       if (mask->rank == 0)
1634         name = "sminloc";
1635       else
1636         name = "mminloc";
1637
1638       resolve_mask_arg (mask);
1639     }
1640   else
1641     name = "minloc";
1642
1643   f->value.function.name
1644     = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1645                       gfc_type_letter (array->ts.type), array->ts.kind);
1646 }
1647
1648
1649 void
1650 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1651                     gfc_expr *mask)
1652 {
1653   const char *name;
1654   int i, j, idim;
1655
1656   f->ts = array->ts;
1657
1658   if (dim != NULL)
1659     {
1660       f->rank = array->rank - 1;
1661       gfc_resolve_dim_arg (dim);
1662
1663       if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1664         {
1665           idim = (int) mpz_get_si (dim->value.integer);
1666           f->shape = gfc_get_shape (f->rank);
1667           for (i = 0, j = 0; i < f->rank; i++, j++)
1668             {
1669               if (i == (idim - 1))
1670                 j++;
1671               mpz_init_set (f->shape[i], array->shape[j]);
1672             }
1673         }
1674     }
1675
1676   if (mask)
1677     {
1678       if (mask->rank == 0)
1679         name = "sminval";
1680       else
1681         name = "mminval";
1682
1683       resolve_mask_arg (mask);
1684     }
1685   else
1686     name = "minval";
1687
1688   f->value.function.name
1689     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1690                       gfc_type_letter (array->ts.type), array->ts.kind);
1691 }
1692
1693
1694 void
1695 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1696 {
1697   f->ts.type = a->ts.type;
1698   if (p != NULL)
1699     f->ts.kind = gfc_kind_max (a,p);
1700   else
1701     f->ts.kind = a->ts.kind;
1702
1703   if (p != NULL && a->ts.kind != p->ts.kind)
1704     {
1705       if (a->ts.kind == gfc_kind_max (a,p))
1706         gfc_convert_type (p, &a->ts, 2);
1707       else
1708         gfc_convert_type (a, &p->ts, 2);
1709     }
1710
1711   f->value.function.name
1712     = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1713 }
1714
1715
1716 void
1717 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1718 {
1719   f->ts.type = a->ts.type;
1720   if (p != NULL)
1721     f->ts.kind = gfc_kind_max (a,p);
1722   else
1723     f->ts.kind = a->ts.kind;
1724
1725   if (p != NULL && a->ts.kind != p->ts.kind)
1726     {
1727       if (a->ts.kind == gfc_kind_max (a,p))
1728         gfc_convert_type (p, &a->ts, 2);
1729       else
1730         gfc_convert_type (a, &p->ts, 2);
1731     }
1732
1733   f->value.function.name
1734     = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1735                       f->ts.kind);
1736 }
1737
1738 void
1739 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1740 {
1741   if (p->ts.kind != a->ts.kind)
1742     gfc_convert_type (p, &a->ts, 2);
1743
1744   f->ts = a->ts;
1745   f->value.function.name
1746     = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1747                       a->ts.kind);
1748 }
1749
1750 void
1751 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1752 {
1753   f->ts.type = BT_INTEGER;
1754   f->ts.kind = (kind == NULL)
1755              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1756   f->value.function.name
1757     = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1758 }
1759
1760
1761 void
1762 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
1763 {
1764   f->ts = i->ts;
1765   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1766 }
1767
1768
1769 void
1770 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1771 {
1772   f->ts.type = i->ts.type;
1773   f->ts.kind = gfc_kind_max (i, j);
1774
1775   if (i->ts.kind != j->ts.kind)
1776     {
1777       if (i->ts.kind == gfc_kind_max (i, j))
1778         gfc_convert_type (j, &i->ts, 2);
1779       else
1780         gfc_convert_type (i, &j->ts, 2);
1781     }
1782
1783   f->value.function.name
1784     = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
1785 }
1786
1787
1788 void
1789 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
1790                   gfc_expr *vector ATTRIBUTE_UNUSED)
1791 {
1792   if (array->ts.type == BT_CHARACTER && array->ref)
1793     gfc_resolve_substring_charlen (array);
1794
1795   f->ts = array->ts;
1796   f->rank = 1;
1797
1798   resolve_mask_arg (mask);
1799
1800   if (mask->rank != 0)
1801     {
1802       if (array->ts.type == BT_CHARACTER)
1803         f->value.function.name
1804           = array->ts.kind == 1 ? PREFIX ("pack_char")
1805                                 : gfc_get_string
1806                                         (PREFIX ("pack_char%d"),
1807                                          array->ts.kind);
1808       else
1809         f->value.function.name = PREFIX ("pack");
1810     }
1811   else
1812     {
1813       if (array->ts.type == BT_CHARACTER)
1814         f->value.function.name
1815           = array->ts.kind == 1 ? PREFIX ("pack_s_char")
1816                                 : gfc_get_string
1817                                         (PREFIX ("pack_s_char%d"),
1818                                          array->ts.kind);
1819       else
1820         f->value.function.name = PREFIX ("pack_s");
1821     }
1822 }
1823
1824
1825 void
1826 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1827                      gfc_expr *mask)
1828 {
1829   const char *name;
1830
1831   f->ts = array->ts;
1832
1833   if (dim != NULL)
1834     {
1835       f->rank = array->rank - 1;
1836       f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
1837       gfc_resolve_dim_arg (dim);
1838     }
1839
1840   if (mask)
1841     {
1842       if (mask->rank == 0)
1843         name = "sproduct";
1844       else
1845         name = "mproduct";
1846
1847       resolve_mask_arg (mask);
1848     }
1849   else
1850     name = "product";
1851
1852   f->value.function.name
1853     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1854                       gfc_type_letter (array->ts.type), array->ts.kind);
1855 }
1856
1857
1858 void
1859 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1860 {
1861   f->ts.type = BT_REAL;
1862
1863   if (kind != NULL)
1864     f->ts.kind = mpz_get_si (kind->value.integer);
1865   else
1866     f->ts.kind = (a->ts.type == BT_COMPLEX)
1867                ? a->ts.kind : gfc_default_real_kind;
1868
1869   f->value.function.name
1870     = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1871                       gfc_type_letter (a->ts.type), a->ts.kind);
1872 }
1873
1874
1875 void
1876 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
1877 {
1878   f->ts.type = BT_REAL;
1879   f->ts.kind = a->ts.kind;
1880   f->value.function.name
1881     = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1882                       gfc_type_letter (a->ts.type), a->ts.kind);
1883 }
1884
1885
1886 void
1887 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1888                     gfc_expr *p2 ATTRIBUTE_UNUSED)
1889 {
1890   f->ts.type = BT_INTEGER;
1891   f->ts.kind = gfc_default_integer_kind;
1892   f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
1893 }
1894
1895
1896 void
1897 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
1898                     gfc_expr *ncopies ATTRIBUTE_UNUSED)
1899 {
1900   f->ts.type = BT_CHARACTER;
1901   f->ts.kind = string->ts.kind;
1902   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1903 }
1904
1905
1906 void
1907 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
1908                      gfc_expr *pad ATTRIBUTE_UNUSED,
1909                      gfc_expr *order ATTRIBUTE_UNUSED)
1910 {
1911   mpz_t rank;
1912   int kind;
1913   int i;
1914
1915   if (source->ts.type == BT_CHARACTER && source->ref)
1916     gfc_resolve_substring_charlen (source);
1917
1918   f->ts = source->ts;
1919
1920   gfc_array_size (shape, &rank);
1921   f->rank = mpz_get_si (rank);
1922   mpz_clear (rank);
1923   switch (source->ts.type)
1924     {
1925     case BT_COMPLEX:
1926     case BT_REAL:
1927     case BT_INTEGER:
1928     case BT_LOGICAL:
1929     case BT_CHARACTER:
1930       kind = source->ts.kind;
1931       break;
1932
1933     default:
1934       kind = 0;
1935       break;
1936     }
1937
1938   switch (kind)
1939     {
1940     case 4:
1941     case 8:
1942     case 10:
1943     case 16:
1944       if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
1945         f->value.function.name
1946           = gfc_get_string (PREFIX ("reshape_%c%d"),
1947                             gfc_type_letter (source->ts.type),
1948                             source->ts.kind);
1949       else if (source->ts.type == BT_CHARACTER)
1950         f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
1951                                                  kind);
1952       else
1953         f->value.function.name
1954           = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
1955       break;
1956
1957     default:
1958       f->value.function.name = (source->ts.type == BT_CHARACTER
1959                                 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1960       break;
1961     }
1962
1963   /* TODO: Make this work with a constant ORDER parameter.  */
1964   if (shape->expr_type == EXPR_ARRAY
1965       && gfc_is_constant_expr (shape)
1966       && order == NULL)
1967     {
1968       gfc_constructor *c;
1969       f->shape = gfc_get_shape (f->rank);
1970       c = shape->value.constructor;
1971       for (i = 0; i < f->rank; i++)
1972         {
1973           mpz_init_set (f->shape[i], c->expr->value.integer);
1974           c = c->next;
1975         }
1976     }
1977
1978   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1979      so many runtime variations.  */
1980   if (shape->ts.kind != gfc_index_integer_kind)
1981     {
1982       gfc_typespec ts = shape->ts;
1983       ts.kind = gfc_index_integer_kind;
1984       gfc_convert_type_warn (shape, &ts, 2, 0);
1985     }
1986   if (order && order->ts.kind != gfc_index_integer_kind)
1987     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1988 }
1989
1990
1991 void
1992 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
1993 {
1994   f->ts = x->ts;
1995   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1996 }
1997
1998
1999 void
2000 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2001 {
2002   f->ts = x->ts;
2003   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2004 }
2005
2006
2007 void
2008 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2009                   gfc_expr *set ATTRIBUTE_UNUSED,
2010                   gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2011 {
2012   f->ts.type = BT_INTEGER;
2013   if (kind)
2014     f->ts.kind = mpz_get_si (kind->value.integer);
2015   else
2016     f->ts.kind = gfc_default_integer_kind;
2017   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2018 }
2019
2020
2021 void
2022 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2023 {
2024   t1->ts = t0->ts;
2025   t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2026 }
2027
2028
2029 void
2030 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2031                           gfc_expr *i ATTRIBUTE_UNUSED)
2032 {
2033   f->ts = x->ts;
2034   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2035 }
2036
2037
2038 void
2039 gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
2040 {
2041   f->ts.type = BT_INTEGER;
2042   f->ts.kind = gfc_default_integer_kind;
2043   f->rank = 1;
2044   f->shape = gfc_get_shape (1);
2045   mpz_init_set_ui (f->shape[0], array->rank);
2046   f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2047 }
2048
2049
2050 void
2051 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2052 {
2053   f->ts = a->ts;
2054   f->value.function.name
2055     = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2056 }
2057
2058
2059 void
2060 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2061 {
2062   f->ts.type = BT_INTEGER;
2063   f->ts.kind = gfc_c_int_kind;
2064
2065   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2066   if (handler->ts.type == BT_INTEGER)
2067     {
2068       if (handler->ts.kind != gfc_c_int_kind)
2069         gfc_convert_type (handler, &f->ts, 2);
2070       f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2071     }
2072   else
2073     f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2074
2075   if (number->ts.kind != gfc_c_int_kind)
2076     gfc_convert_type (number, &f->ts, 2);
2077 }
2078
2079
2080 void
2081 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2082 {
2083   f->ts = x->ts;
2084   f->value.function.name
2085     = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2086 }
2087
2088
2089 void
2090 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2091 {
2092   f->ts = x->ts;
2093   f->value.function.name
2094     = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2095 }
2096
2097
2098 void
2099 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2100                   gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2101 {
2102   f->ts.type = BT_INTEGER;
2103   if (kind)
2104     f->ts.kind = mpz_get_si (kind->value.integer);
2105   else
2106     f->ts.kind = gfc_default_integer_kind;
2107 }
2108
2109
2110 void
2111 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2112 {
2113   f->ts = x->ts;
2114   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2115 }
2116
2117
2118 void
2119 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2120                     gfc_expr *ncopies)
2121 {
2122   if (source->ts.type == BT_CHARACTER && source->ref)
2123     gfc_resolve_substring_charlen (source);
2124
2125   if (source->ts.type == BT_CHARACTER)
2126     check_charlen_present (source);
2127
2128   f->ts = source->ts;
2129   f->rank = source->rank + 1;
2130   if (source->rank == 0)
2131     {
2132       if (source->ts.type == BT_CHARACTER)
2133         f->value.function.name
2134           = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2135                                  : gfc_get_string
2136                                         (PREFIX ("spread_char%d_scalar"),
2137                                          source->ts.kind);
2138       else
2139         f->value.function.name = PREFIX ("spread_scalar");
2140     }
2141   else
2142     {
2143       if (source->ts.type == BT_CHARACTER)
2144         f->value.function.name
2145           = source->ts.kind == 1 ? PREFIX ("spread_char")
2146                                  : gfc_get_string
2147                                         (PREFIX ("spread_char%d"),
2148                                          source->ts.kind);
2149       else
2150         f->value.function.name = PREFIX ("spread");
2151     }
2152
2153   if (dim && gfc_is_constant_expr (dim)
2154       && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2155     {
2156       int i, idim;
2157       idim = mpz_get_ui (dim->value.integer);
2158       f->shape = gfc_get_shape (f->rank);
2159       for (i = 0; i < (idim - 1); i++)
2160         mpz_init_set (f->shape[i], source->shape[i]);
2161
2162       mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2163
2164       for (i = idim; i < f->rank ; i++)
2165         mpz_init_set (f->shape[i], source->shape[i-1]);
2166     }
2167
2168
2169   gfc_resolve_dim_arg (dim);
2170   gfc_resolve_index (ncopies, 1);
2171 }
2172
2173
2174 void
2175 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2176 {
2177   f->ts = x->ts;
2178   f->value.function.name
2179     = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2180 }
2181
2182
2183 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
2184
2185 void
2186 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2187                   gfc_expr *a ATTRIBUTE_UNUSED)
2188 {
2189   f->ts.type = BT_INTEGER;
2190   f->ts.kind = gfc_default_integer_kind;
2191   f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2192 }
2193
2194
2195 void
2196 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2197                    gfc_expr *a ATTRIBUTE_UNUSED)
2198 {
2199   f->ts.type = BT_INTEGER;
2200   f->ts.kind = gfc_default_integer_kind;
2201   f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2202 }
2203
2204
2205 void
2206 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2207 {
2208   f->ts.type = BT_INTEGER;
2209   f->ts.kind = gfc_default_integer_kind;
2210   if (n->ts.kind != f->ts.kind)
2211     gfc_convert_type (n, &f->ts, 2);
2212
2213   f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2214 }
2215
2216
2217 void
2218 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2219 {
2220   gfc_typespec ts;
2221   gfc_clear_ts (&ts);
2222
2223   f->ts.type = BT_INTEGER;
2224   f->ts.kind = gfc_c_int_kind;
2225   if (u->ts.kind != gfc_c_int_kind)
2226     {
2227       ts.type = BT_INTEGER;
2228       ts.kind = gfc_c_int_kind;
2229       ts.u.derived = NULL;
2230       ts.u.cl = NULL;
2231       gfc_convert_type (u, &ts, 2);
2232     }
2233
2234   f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2235 }
2236
2237
2238 void
2239 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2240 {
2241   f->ts.type = BT_INTEGER;
2242   f->ts.kind = gfc_c_int_kind;
2243   f->value.function.name = gfc_get_string (PREFIX ("fget"));
2244 }
2245
2246
2247 void
2248 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2249 {
2250   gfc_typespec ts;
2251   gfc_clear_ts (&ts);
2252
2253   f->ts.type = BT_INTEGER;
2254   f->ts.kind = gfc_c_int_kind;
2255   if (u->ts.kind != gfc_c_int_kind)
2256     {
2257       ts.type = BT_INTEGER;
2258       ts.kind = gfc_c_int_kind;
2259       ts.u.derived = NULL;
2260       ts.u.cl = NULL;
2261       gfc_convert_type (u, &ts, 2);
2262     }
2263
2264   f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2265 }
2266
2267
2268 void
2269 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2270 {
2271   f->ts.type = BT_INTEGER;
2272   f->ts.kind = gfc_c_int_kind;
2273   f->value.function.name = gfc_get_string (PREFIX ("fput"));
2274 }
2275
2276
2277 void
2278 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2279 {
2280   gfc_typespec ts;
2281   gfc_clear_ts (&ts);
2282
2283   f->ts.type = BT_INTEGER;
2284   f->ts.kind = gfc_index_integer_kind;
2285   if (u->ts.kind != gfc_c_int_kind)
2286     {
2287       ts.type = BT_INTEGER;
2288       ts.kind = gfc_c_int_kind;
2289       ts.u.derived = NULL;
2290       ts.u.cl = NULL;
2291       gfc_convert_type (u, &ts, 2);
2292     }
2293
2294   f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2295 }
2296
2297
2298 void
2299 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2300 {
2301   const char *name;
2302
2303   f->ts = array->ts;
2304
2305   if (mask)
2306     {
2307       if (mask->rank == 0)
2308         name = "ssum";
2309       else
2310         name = "msum";
2311
2312       resolve_mask_arg (mask);
2313     }
2314   else
2315     name = "sum";
2316
2317   if (dim != NULL)
2318     {
2319       f->rank = array->rank - 1;
2320       f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
2321       gfc_resolve_dim_arg (dim);
2322     }
2323
2324   f->value.function.name
2325     = gfc_get_string (PREFIX ("%s_%c%d"), name,
2326                     gfc_type_letter (array->ts.type), array->ts.kind);
2327 }
2328
2329
2330 void
2331 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2332                     gfc_expr *p2 ATTRIBUTE_UNUSED)
2333 {
2334   f->ts.type = BT_INTEGER;
2335   f->ts.kind = gfc_default_integer_kind;
2336   f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2337 }
2338
2339
2340 /* Resolve the g77 compatibility function SYSTEM.  */
2341
2342 void
2343 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2344 {
2345   f->ts.type = BT_INTEGER;
2346   f->ts.kind = 4;
2347   f->value.function.name = gfc_get_string (PREFIX ("system"));
2348 }
2349
2350
2351 void
2352 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2353 {
2354   f->ts = x->ts;
2355   f->value.function.name
2356     = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2357 }
2358
2359
2360 void
2361 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2362 {
2363   f->ts = x->ts;
2364   f->value.function.name
2365     = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2366 }
2367
2368
2369 void
2370 gfc_resolve_time (gfc_expr *f)
2371 {
2372   f->ts.type = BT_INTEGER;
2373   f->ts.kind = 4;
2374   f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2375 }
2376
2377
2378 void
2379 gfc_resolve_time8 (gfc_expr *f)
2380 {
2381   f->ts.type = BT_INTEGER;
2382   f->ts.kind = 8;
2383   f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2384 }
2385
2386
2387 void
2388 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2389                       gfc_expr *mold, gfc_expr *size)
2390 {
2391   /* TODO: Make this do something meaningful.  */
2392   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2393
2394   if (mold->ts.type == BT_CHARACTER
2395         && !mold->ts.u.cl->length
2396         && gfc_is_constant_expr (mold))
2397     {
2398       int len;
2399       if (mold->expr_type == EXPR_CONSTANT)
2400         mold->ts.u.cl->length = gfc_int_expr (mold->value.character.length);
2401       else
2402         {
2403           len = mold->value.constructor->expr->value.character.length;
2404           mold->ts.u.cl->length = gfc_int_expr (len);
2405         }
2406     }
2407
2408   f->ts = mold->ts;
2409
2410   if (size == NULL && mold->rank == 0)
2411     {
2412       f->rank = 0;
2413       f->value.function.name = transfer0;
2414     }
2415   else
2416     {
2417       f->rank = 1;
2418       f->value.function.name = transfer1;
2419       if (size && gfc_is_constant_expr (size))
2420         {
2421           f->shape = gfc_get_shape (1);
2422           mpz_init_set (f->shape[0], size->value.integer);
2423         }
2424     }
2425 }
2426
2427
2428 void
2429 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2430 {
2431
2432   if (matrix->ts.type == BT_CHARACTER && matrix->ref)
2433     gfc_resolve_substring_charlen (matrix);
2434
2435   f->ts = matrix->ts;
2436   f->rank = 2;
2437   if (matrix->shape)
2438     {
2439       f->shape = gfc_get_shape (2);
2440       mpz_init_set (f->shape[0], matrix->shape[1]);
2441       mpz_init_set (f->shape[1], matrix->shape[0]);
2442     }
2443
2444   switch (matrix->ts.kind)
2445     {
2446     case 4:
2447     case 8:
2448     case 10:
2449     case 16:
2450       switch (matrix->ts.type)
2451         {
2452         case BT_REAL:
2453         case BT_COMPLEX:
2454           f->value.function.name
2455             = gfc_get_string (PREFIX ("transpose_%c%d"),
2456                               gfc_type_letter (matrix->ts.type),
2457                               matrix->ts.kind);
2458           break;
2459
2460         case BT_INTEGER:
2461         case BT_LOGICAL:
2462           /* Use the integer routines for real and logical cases.  This
2463              assumes they all have the same alignment requirements.  */
2464           f->value.function.name
2465             = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
2466           break;
2467
2468         default:
2469           if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
2470             f->value.function.name = PREFIX ("transpose_char4");
2471           else
2472             f->value.function.name = PREFIX ("transpose");
2473           break;
2474         }
2475       break;
2476
2477     default:
2478       f->value.function.name = (matrix->ts.type == BT_CHARACTER
2479                                 ? PREFIX ("transpose_char")
2480                                 : PREFIX ("transpose"));
2481       break;
2482     }
2483 }
2484
2485
2486 void
2487 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
2488 {
2489   f->ts.type = BT_CHARACTER;
2490   f->ts.kind = string->ts.kind;
2491   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2492 }
2493
2494
2495 void
2496 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2497 {
2498   static char ubound[] = "__ubound";
2499
2500   f->ts.type = BT_INTEGER;
2501   if (kind)
2502     f->ts.kind = mpz_get_si (kind->value.integer);
2503   else
2504     f->ts.kind = gfc_default_integer_kind;
2505
2506   if (dim == NULL)
2507     {
2508       f->rank = 1;
2509       f->shape = gfc_get_shape (1);
2510       mpz_init_set_ui (f->shape[0], array->rank);
2511     }
2512
2513   f->value.function.name = ubound;
2514 }
2515
2516
2517 /* Resolve the g77 compatibility function UMASK.  */
2518
2519 void
2520 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
2521 {
2522   f->ts.type = BT_INTEGER;
2523   f->ts.kind = n->ts.kind;
2524   f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
2525 }
2526
2527
2528 /* Resolve the g77 compatibility function UNLINK.  */
2529
2530 void
2531 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2532 {
2533   f->ts.type = BT_INTEGER;
2534   f->ts.kind = 4;
2535   f->value.function.name = gfc_get_string (PREFIX ("unlink"));
2536 }
2537
2538
2539 void
2540 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
2541 {
2542   gfc_typespec ts;
2543   gfc_clear_ts (&ts);
2544
2545   f->ts.type = BT_CHARACTER;
2546   f->ts.kind = gfc_default_character_kind;
2547
2548   if (unit->ts.kind != gfc_c_int_kind)
2549     {
2550       ts.type = BT_INTEGER;
2551       ts.kind = gfc_c_int_kind;
2552       ts.u.derived = NULL;
2553       ts.u.cl = NULL;
2554       gfc_convert_type (unit, &ts, 2);
2555     }
2556
2557   f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
2558 }
2559
2560
2561 void
2562 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
2563                     gfc_expr *field ATTRIBUTE_UNUSED)
2564 {
2565   if (vector->ts.type == BT_CHARACTER && vector->ref)
2566     gfc_resolve_substring_charlen (vector);
2567
2568   f->ts = vector->ts;
2569   f->rank = mask->rank;
2570   resolve_mask_arg (mask);
2571
2572   if (vector->ts.type == BT_CHARACTER)
2573     {
2574       if (vector->ts.kind == 1)
2575         f->value.function.name
2576           = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
2577       else
2578         f->value.function.name
2579           = gfc_get_string (PREFIX ("unpack%d_char%d"),
2580                             field->rank > 0 ? 1 : 0, vector->ts.kind);
2581     }
2582   else
2583     f->value.function.name
2584       = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
2585 }
2586
2587
2588 void
2589 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
2590                     gfc_expr *set ATTRIBUTE_UNUSED,
2591                     gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2592 {
2593   f->ts.type = BT_INTEGER;
2594   if (kind)
2595     f->ts.kind = mpz_get_si (kind->value.integer);
2596   else
2597     f->ts.kind = gfc_default_integer_kind;
2598   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2599 }
2600
2601
2602 void
2603 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2604 {
2605   f->ts.type = i->ts.type;
2606   f->ts.kind = gfc_kind_max (i, j);
2607
2608   if (i->ts.kind != j->ts.kind)
2609     {
2610       if (i->ts.kind == gfc_kind_max (i, j))
2611         gfc_convert_type (j, &i->ts, 2);
2612       else
2613         gfc_convert_type (i, &j->ts, 2);
2614     }
2615
2616   f->value.function.name
2617     = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2618 }
2619
2620
2621 /* Intrinsic subroutine resolution.  */
2622
2623 void
2624 gfc_resolve_alarm_sub (gfc_code *c)
2625 {
2626   const char *name;
2627   gfc_expr *seconds, *handler;
2628   gfc_typespec ts;
2629   gfc_clear_ts (&ts);
2630
2631   seconds = c->ext.actual->expr;
2632   handler = c->ext.actual->next->expr;
2633   ts.type = BT_INTEGER;
2634   ts.kind = gfc_c_int_kind;
2635
2636   /* handler can be either BT_INTEGER or BT_PROCEDURE.
2637      In all cases, the status argument is of default integer kind
2638      (enforced in check.c) so that the function suffix is fixed.  */
2639   if (handler->ts.type == BT_INTEGER)
2640     {
2641       if (handler->ts.kind != gfc_c_int_kind)
2642         gfc_convert_type (handler, &ts, 2);
2643       name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2644                              gfc_default_integer_kind);
2645     }
2646   else
2647     name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
2648                            gfc_default_integer_kind);
2649
2650   if (seconds->ts.kind != gfc_c_int_kind)
2651     gfc_convert_type (seconds, &ts, 2);
2652
2653   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2654 }
2655
2656 void
2657 gfc_resolve_cpu_time (gfc_code *c)
2658 {
2659   const char *name;
2660   name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2661   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2662 }
2663
2664
2665 /* Create a formal arglist based on an actual one and set the INTENTs given.  */
2666
2667 static gfc_formal_arglist*
2668 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
2669 {
2670   gfc_formal_arglist* head;
2671   gfc_formal_arglist* tail;
2672   int i;
2673
2674   if (!actual)
2675     return NULL;
2676
2677   head = tail = gfc_get_formal_arglist ();
2678   for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
2679     {
2680       gfc_symbol* sym;
2681
2682       sym = gfc_new_symbol ("dummyarg", NULL);
2683       sym->ts = actual->expr->ts;
2684
2685       sym->attr.intent = ints[i];
2686       tail->sym = sym;
2687
2688       if (actual->next)
2689         tail->next = gfc_get_formal_arglist ();
2690     }
2691
2692   return head;
2693 }
2694
2695
2696 void
2697 gfc_resolve_mvbits (gfc_code *c)
2698 {
2699   static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
2700                                        INTENT_INOUT, INTENT_IN};
2701
2702   const char *name;
2703   gfc_typespec ts;
2704   gfc_clear_ts (&ts);
2705
2706   /* FROMPOS, LEN and TOPOS are restricted to small values.  As such,
2707      they will be converted so that they fit into a C int.  */
2708   ts.type = BT_INTEGER;
2709   ts.kind = gfc_c_int_kind;
2710   if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
2711     gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
2712   if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
2713     gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
2714   if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
2715     gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
2716
2717   /* TO and FROM are guaranteed to have the same kind parameter.  */
2718   name = gfc_get_string (PREFIX ("mvbits_i%d"),
2719                          c->ext.actual->expr->ts.kind);
2720   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2721   /* Mark as elemental subroutine as this does not happen automatically.  */
2722   c->resolved_sym->attr.elemental = 1;
2723
2724   /* Create a dummy formal arglist so the INTENTs are known later for purpose
2725      of creating temporaries.  */
2726   c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
2727 }
2728
2729
2730 void
2731 gfc_resolve_random_number (gfc_code *c)
2732 {
2733   const char *name;
2734   int kind;
2735
2736   kind = c->ext.actual->expr->ts.kind;
2737   if (c->ext.actual->expr->rank == 0)
2738     name = gfc_get_string (PREFIX ("random_r%d"), kind);
2739   else
2740     name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2741
2742   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2743 }
2744
2745
2746 void
2747 gfc_resolve_random_seed (gfc_code *c)
2748 {
2749   const char *name;
2750
2751   name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
2752   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2753 }
2754
2755
2756 void
2757 gfc_resolve_rename_sub (gfc_code *c)
2758 {
2759   const char *name;
2760   int kind;
2761
2762   if (c->ext.actual->next->next->expr != NULL)
2763     kind = c->ext.actual->next->next->expr->ts.kind;
2764   else
2765     kind = gfc_default_integer_kind;
2766
2767   name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2768   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2769 }
2770
2771
2772 void
2773 gfc_resolve_kill_sub (gfc_code *c)
2774 {
2775   const char *name;
2776   int kind;
2777
2778   if (c->ext.actual->next->next->expr != NULL)
2779     kind = c->ext.actual->next->next->expr->ts.kind;
2780   else
2781     kind = gfc_default_integer_kind;
2782
2783   name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
2784   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2785 }
2786
2787
2788 void
2789 gfc_resolve_link_sub (gfc_code *c)
2790 {
2791   const char *name;
2792   int kind;
2793
2794   if (c->ext.actual->next->next->expr != NULL)
2795     kind = c->ext.actual->next->next->expr->ts.kind;
2796   else
2797     kind = gfc_default_integer_kind;
2798
2799   name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
2800   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2801 }
2802
2803
2804 void
2805 gfc_resolve_symlnk_sub (gfc_code *c)
2806 {
2807   const char *name;
2808   int kind;
2809
2810   if (c->ext.actual->next->next->expr != NULL)
2811     kind = c->ext.actual->next->next->expr->ts.kind;
2812   else
2813     kind = gfc_default_integer_kind;
2814
2815   name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
2816   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2817 }
2818
2819
2820 /* G77 compatibility subroutines dtime() and etime().  */
2821
2822 void
2823 gfc_resolve_dtime_sub (gfc_code *c)
2824 {
2825   const char *name;
2826   name = gfc_get_string (PREFIX ("dtime_sub"));
2827   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2828 }
2829
2830 void
2831 gfc_resolve_etime_sub (gfc_code *c)
2832 {
2833   const char *name;
2834   name = gfc_get_string (PREFIX ("etime_sub"));
2835   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2836 }
2837
2838
2839 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime().  */
2840
2841 void
2842 gfc_resolve_itime (gfc_code *c)
2843 {
2844   c->resolved_sym
2845     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2846                                                     gfc_default_integer_kind));
2847 }
2848
2849 void
2850 gfc_resolve_idate (gfc_code *c)
2851 {
2852   c->resolved_sym
2853     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2854                                                     gfc_default_integer_kind));
2855 }
2856
2857 void
2858 gfc_resolve_ltime (gfc_code *c)
2859 {
2860   c->resolved_sym
2861     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2862                                                     gfc_default_integer_kind));
2863 }
2864
2865 void
2866 gfc_resolve_gmtime (gfc_code *c)
2867 {
2868   c->resolved_sym
2869     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2870                                                     gfc_default_integer_kind));
2871 }
2872
2873
2874 /* G77 compatibility subroutine second().  */
2875
2876 void
2877 gfc_resolve_second_sub (gfc_code *c)
2878 {
2879   const char *name;
2880   name = gfc_get_string (PREFIX ("second_sub"));
2881   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2882 }
2883
2884
2885 void
2886 gfc_resolve_sleep_sub (gfc_code *c)
2887 {
2888   const char *name;
2889   int kind;
2890
2891   if (c->ext.actual->expr != NULL)
2892     kind = c->ext.actual->expr->ts.kind;
2893   else
2894     kind = gfc_default_integer_kind;
2895
2896   name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
2897   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2898 }
2899
2900
2901 /* G77 compatibility function srand().  */
2902
2903 void
2904 gfc_resolve_srand (gfc_code *c)
2905 {
2906   const char *name;
2907   name = gfc_get_string (PREFIX ("srand"));
2908   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2909 }
2910
2911
2912 /* Resolve the getarg intrinsic subroutine.  */
2913
2914 void
2915 gfc_resolve_getarg (gfc_code *c)
2916 {
2917   const char *name;
2918
2919   if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
2920     {
2921       gfc_typespec ts;
2922       gfc_clear_ts (&ts);
2923
2924       ts.type = BT_INTEGER;
2925       ts.kind = gfc_default_integer_kind;
2926
2927       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2928     }
2929
2930   name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
2931   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2932 }
2933
2934
2935 /* Resolve the getcwd intrinsic subroutine.  */
2936
2937 void
2938 gfc_resolve_getcwd_sub (gfc_code *c)
2939 {
2940   const char *name;
2941   int kind;
2942
2943   if (c->ext.actual->next->expr != NULL)
2944     kind = c->ext.actual->next->expr->ts.kind;
2945   else
2946     kind = gfc_default_integer_kind;
2947
2948   name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
2949   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2950 }
2951
2952
2953 /* Resolve the get_command intrinsic subroutine.  */
2954
2955 void
2956 gfc_resolve_get_command (gfc_code *c)
2957 {
2958   const char *name;
2959   int kind;
2960   kind = gfc_default_integer_kind;
2961   name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
2962   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2963 }
2964
2965
2966 /* Resolve the get_command_argument intrinsic subroutine.  */
2967
2968 void
2969 gfc_resolve_get_command_argument (gfc_code *c)
2970 {
2971   const char *name;
2972   int kind;
2973   kind = gfc_default_integer_kind;
2974   name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
2975   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2976 }
2977
2978
2979 /* Resolve the get_environment_variable intrinsic subroutine.  */
2980
2981 void
2982 gfc_resolve_get_environment_variable (gfc_code *code)
2983 {
2984   const char *name;
2985   int kind;
2986   kind = gfc_default_integer_kind;
2987   name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
2988   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2989 }
2990
2991
2992 void
2993 gfc_resolve_signal_sub (gfc_code *c)
2994 {
2995   const char *name;
2996   gfc_expr *number, *handler, *status;
2997   gfc_typespec ts;
2998   gfc_clear_ts (&ts);
2999
3000   number = c->ext.actual->expr;
3001   handler = c->ext.actual->next->expr;
3002   status = c->ext.actual->next->next->expr;
3003   ts.type = BT_INTEGER;
3004   ts.kind = gfc_c_int_kind;
3005
3006   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
3007   if (handler->ts.type == BT_INTEGER)
3008     {
3009       if (handler->ts.kind != gfc_c_int_kind)
3010         gfc_convert_type (handler, &ts, 2);
3011       name = gfc_get_string (PREFIX ("signal_sub_int"));
3012     }
3013   else
3014     name = gfc_get_string (PREFIX ("signal_sub"));
3015
3016   if (number->ts.kind != gfc_c_int_kind)
3017     gfc_convert_type (number, &ts, 2);
3018   if (status != NULL && status->ts.kind != gfc_c_int_kind)
3019     gfc_convert_type (status, &ts, 2);
3020
3021   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3022 }
3023
3024
3025 /* Resolve the SYSTEM intrinsic subroutine.  */
3026
3027 void
3028 gfc_resolve_system_sub (gfc_code *c)
3029 {
3030   const char *name;
3031   name = gfc_get_string (PREFIX ("system_sub"));
3032   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3033 }
3034
3035
3036 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3037
3038 void
3039 gfc_resolve_system_clock (gfc_code *c)
3040 {
3041   const char *name;
3042   int kind;
3043
3044   if (c->ext.actual->expr != NULL)
3045     kind = c->ext.actual->expr->ts.kind;
3046   else if (c->ext.actual->next->expr != NULL)
3047       kind = c->ext.actual->next->expr->ts.kind;
3048   else if (c->ext.actual->next->next->expr != NULL)
3049       kind = c->ext.actual->next->next->expr->ts.kind;
3050   else
3051     kind = gfc_default_integer_kind;
3052
3053   name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3054   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3055 }
3056
3057
3058 /* Resolve the EXIT intrinsic subroutine.  */
3059
3060 void
3061 gfc_resolve_exit (gfc_code *c)
3062 {
3063   const char *name;
3064   gfc_typespec ts;
3065   gfc_expr *n;
3066   gfc_clear_ts (&ts);
3067
3068   /* The STATUS argument has to be of default kind.  If it is not,
3069      we convert it.  */
3070   ts.type = BT_INTEGER;
3071   ts.kind = gfc_default_integer_kind;
3072   n = c->ext.actual->expr;
3073   if (n != NULL && n->ts.kind != ts.kind)
3074     gfc_convert_type (n, &ts, 2);
3075
3076   name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3077   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3078 }
3079
3080
3081 /* Resolve the FLUSH intrinsic subroutine.  */
3082
3083 void
3084 gfc_resolve_flush (gfc_code *c)
3085 {
3086   const char *name;
3087   gfc_typespec ts;
3088   gfc_expr *n;
3089   gfc_clear_ts (&ts);
3090
3091   ts.type = BT_INTEGER;
3092   ts.kind = gfc_default_integer_kind;
3093   n = c->ext.actual->expr;
3094   if (n != NULL && n->ts.kind != ts.kind)
3095     gfc_convert_type (n, &ts, 2);
3096
3097   name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3098   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3099 }
3100
3101
3102 void
3103 gfc_resolve_free (gfc_code *c)
3104 {
3105   gfc_typespec ts;
3106   gfc_expr *n;
3107   gfc_clear_ts (&ts);
3108
3109   ts.type = BT_INTEGER;
3110   ts.kind = gfc_index_integer_kind;
3111   n = c->ext.actual->expr;
3112   if (n->ts.kind != ts.kind)
3113     gfc_convert_type (n, &ts, 2);
3114
3115   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3116 }
3117
3118
3119 void
3120 gfc_resolve_ctime_sub (gfc_code *c)
3121 {
3122   gfc_typespec ts;
3123   gfc_clear_ts (&ts);
3124
3125   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3126   if (c->ext.actual->expr->ts.kind != 8)
3127     {
3128       ts.type = BT_INTEGER;
3129       ts.kind = 8;
3130       ts.u.derived = NULL;
3131       ts.u.cl = NULL;
3132       gfc_convert_type (c->ext.actual->expr, &ts, 2);
3133     }
3134
3135   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3136 }
3137
3138
3139 void
3140 gfc_resolve_fdate_sub (gfc_code *c)
3141 {
3142   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3143 }
3144
3145
3146 void
3147 gfc_resolve_gerror (gfc_code *c)
3148 {
3149   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3150 }
3151
3152
3153 void
3154 gfc_resolve_getlog (gfc_code *c)
3155 {
3156   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3157 }
3158
3159
3160 void
3161 gfc_resolve_hostnm_sub (gfc_code *c)
3162 {
3163   const char *name;
3164   int kind;
3165
3166   if (c->ext.actual->next->expr != NULL)
3167     kind = c->ext.actual->next->expr->ts.kind;
3168   else
3169     kind = gfc_default_integer_kind;
3170
3171   name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3172   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3173 }
3174
3175
3176 void
3177 gfc_resolve_perror (gfc_code *c)
3178 {
3179   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3180 }
3181
3182 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
3183
3184 void
3185 gfc_resolve_stat_sub (gfc_code *c)
3186 {
3187   const char *name;
3188   name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3189   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3190 }
3191
3192
3193 void
3194 gfc_resolve_lstat_sub (gfc_code *c)
3195 {
3196   const char *name;
3197   name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3198   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3199 }
3200
3201
3202 void
3203 gfc_resolve_fstat_sub (gfc_code *c)
3204 {
3205   const char *name;
3206   gfc_expr *u;
3207   gfc_typespec *ts;
3208
3209   u = c->ext.actual->expr;
3210   ts = &c->ext.actual->next->expr->ts;
3211   if (u->ts.kind != ts->kind)
3212     gfc_convert_type (u, ts, 2);
3213   name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3214   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3215 }
3216
3217
3218 void
3219 gfc_resolve_fgetc_sub (gfc_code *c)
3220 {
3221   const char *name;
3222   gfc_typespec ts;
3223   gfc_expr *u, *st;
3224   gfc_clear_ts (&ts);
3225
3226   u = c->ext.actual->expr;
3227   st = c->ext.actual->next->next->expr;
3228
3229   if (u->ts.kind != gfc_c_int_kind)
3230     {
3231       ts.type = BT_INTEGER;
3232       ts.kind = gfc_c_int_kind;
3233       ts.u.derived = NULL;
3234       ts.u.cl = NULL;
3235       gfc_convert_type (u, &ts, 2);
3236     }
3237
3238   if (st != NULL)
3239     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3240   else
3241     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3242
3243   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3244 }
3245
3246
3247 void
3248 gfc_resolve_fget_sub (gfc_code *c)
3249 {
3250   const char *name;
3251   gfc_expr *st;
3252
3253   st = c->ext.actual->next->expr;
3254   if (st != NULL)
3255     name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3256   else
3257     name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3258
3259   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3260 }
3261
3262
3263 void
3264 gfc_resolve_fputc_sub (gfc_code *c)
3265 {
3266   const char *name;
3267   gfc_typespec ts;
3268   gfc_expr *u, *st;
3269   gfc_clear_ts (&ts);
3270
3271   u = c->ext.actual->expr;
3272   st = c->ext.actual->next->next->expr;
3273
3274   if (u->ts.kind != gfc_c_int_kind)
3275     {
3276       ts.type = BT_INTEGER;
3277       ts.kind = gfc_c_int_kind;
3278       ts.u.derived = NULL;
3279       ts.u.cl = NULL;
3280       gfc_convert_type (u, &ts, 2);
3281     }
3282
3283   if (st != NULL)
3284     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3285   else
3286     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3287
3288   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3289 }
3290
3291
3292 void
3293 gfc_resolve_fput_sub (gfc_code *c)
3294 {
3295   const char *name;
3296   gfc_expr *st;
3297
3298   st = c->ext.actual->next->expr;
3299   if (st != NULL)
3300     name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3301   else
3302     name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3303
3304   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3305 }
3306
3307
3308 void
3309 gfc_resolve_fseek_sub (gfc_code *c)
3310 {
3311   gfc_expr *unit;
3312   gfc_expr *offset;
3313   gfc_expr *whence;
3314   gfc_typespec ts;
3315   gfc_clear_ts (&ts);
3316
3317   unit   = c->ext.actual->expr;
3318   offset = c->ext.actual->next->expr;
3319   whence = c->ext.actual->next->next->expr;
3320
3321   if (unit->ts.kind != gfc_c_int_kind)
3322     {
3323       ts.type = BT_INTEGER;
3324       ts.kind = gfc_c_int_kind;
3325       ts.u.derived = NULL;
3326       ts.u.cl = NULL;
3327       gfc_convert_type (unit, &ts, 2);
3328     }
3329
3330   if (offset->ts.kind != gfc_intio_kind)
3331     {
3332       ts.type = BT_INTEGER;
3333       ts.kind = gfc_intio_kind;
3334       ts.u.derived = NULL;
3335       ts.u.cl = NULL;
3336       gfc_convert_type (offset, &ts, 2);
3337     }
3338
3339   if (whence->ts.kind != gfc_c_int_kind)
3340     {
3341       ts.type = BT_INTEGER;
3342       ts.kind = gfc_c_int_kind;
3343       ts.u.derived = NULL;
3344       ts.u.cl = NULL;
3345       gfc_convert_type (whence, &ts, 2);
3346     }
3347
3348   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3349 }
3350
3351 void
3352 gfc_resolve_ftell_sub (gfc_code *c)
3353 {
3354   const char *name;
3355   gfc_expr *unit;
3356   gfc_expr *offset;
3357   gfc_typespec ts;
3358   gfc_clear_ts (&ts);
3359
3360   unit = c->ext.actual->expr;
3361   offset = c->ext.actual->next->expr;
3362
3363   if (unit->ts.kind != gfc_c_int_kind)
3364     {
3365       ts.type = BT_INTEGER;
3366       ts.kind = gfc_c_int_kind;
3367       ts.u.derived = NULL;
3368       ts.u.cl = NULL;
3369       gfc_convert_type (unit, &ts, 2);
3370     }
3371
3372   name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3373   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3374 }
3375
3376
3377 void
3378 gfc_resolve_ttynam_sub (gfc_code *c)
3379 {
3380   gfc_typespec ts;
3381   gfc_clear_ts (&ts);
3382
3383   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3384     {
3385       ts.type = BT_INTEGER;
3386       ts.kind = gfc_c_int_kind;
3387       ts.u.derived = NULL;
3388       ts.u.cl = NULL;
3389       gfc_convert_type (c->ext.actual->expr, &ts, 2);
3390     }
3391
3392   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3393 }
3394
3395
3396 /* Resolve the UMASK intrinsic subroutine.  */
3397
3398 void
3399 gfc_resolve_umask_sub (gfc_code *c)
3400 {
3401   const char *name;
3402   int kind;
3403
3404   if (c->ext.actual->next->expr != NULL)
3405     kind = c->ext.actual->next->expr->ts.kind;
3406   else
3407     kind = gfc_default_integer_kind;
3408
3409   name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3410   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3411 }
3412
3413 /* Resolve the UNLINK intrinsic subroutine.  */
3414
3415 void
3416 gfc_resolve_unlink_sub (gfc_code *c)
3417 {
3418   const char *name;
3419   int kind;
3420
3421   if (c->ext.actual->next->expr != NULL)
3422     kind = c->ext.actual->next->expr->ts.kind;
3423   else
3424     kind = gfc_default_integer_kind;
3425
3426   name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3427   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3428 }