gcc/fortran/iresolve.c

   1 /* Intrinsic function resolution.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   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.cl == NULL)
  66     source->ts.cl = gfc_new_charlen (gfc_current_ns);
  67
  68   if (source->expr_type == EXPR_CONSTANT)
  69     {
  70       source->ts.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.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.cl = gfc_new_charlen (gfc_current_ns);
 165   f->ts.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.derived = NULL;
 655       ts.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 void
 810 gfc_resolve_fdate (gfc_expr *f)
 811 {
 812   f->ts.type = BT_CHARACTER;
 813   f->ts.kind = gfc_default_character_kind;
 814   f->value.function.name = gfc_get_string (PREFIX ("fdate"));
 815 }
 816
 817
 818 void
 819 gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 820 {
 821   f->ts.type = BT_INTEGER;
 822   f->ts.kind = (kind == NULL)
 823              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
 824   f->value.function.name
 825     = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
 826                       gfc_type_letter (a->ts.type), a->ts.kind);
 827 }
 828
 829
 830 void
 831 gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
 832 {
 833   f->ts.type = BT_INTEGER;
 834   f->ts.kind = gfc_default_integer_kind;
 835   if (n->ts.kind != f->ts.kind)
 836     gfc_convert_type (n, &f->ts, 2);
 837   f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
 838 }
 839
 840
 841 void
 842 gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
 843 {
 844   f->ts = x->ts;
 845   f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
 846 }
 847
 848
 849 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
 850
 851 void
 852 gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
 853 {
 854   f->ts = x->ts;
 855   f->value.function.name = gfc_get_string ("<intrinsic>");
 856 }
 857
 858
 859 void
 860 gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
 861 {
 862   f->ts = x->ts;
 863   f->value.function.name
 864     = gfc_get_string ("__gamma_%d", x->ts.kind);
 865 }
 866
 867
 868 void
 869 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
 870 {
 871   f->ts.type = BT_INTEGER;
 872   f->ts.kind = 4;
 873   f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
 874 }
 875
 876
 877 void
 878 gfc_resolve_getgid (gfc_expr *f)
 879 {
 880   f->ts.type = BT_INTEGER;
 881   f->ts.kind = 4;
 882   f->value.function.name = gfc_get_string (PREFIX ("getgid"));
 883 }
 884
 885
 886 void
 887 gfc_resolve_getpid (gfc_expr *f)
 888 {
 889   f->ts.type = BT_INTEGER;
 890   f->ts.kind = 4;
 891   f->value.function.name = gfc_get_string (PREFIX ("getpid"));
 892 }
 893
 894
 895 void
 896 gfc_resolve_getuid (gfc_expr *f)
 897 {
 898   f->ts.type = BT_INTEGER;
 899   f->ts.kind = 4;
 900   f->value.function.name = gfc_get_string (PREFIX ("getuid"));
 901 }
 902
 903
 904 void
 905 gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
 906 {
 907   f->ts.type = BT_INTEGER;
 908   f->ts.kind = 4;
 909   f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
 910 }
 911
 912
 913 void
 914 gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
 915 {
 916   f->ts = x->ts;
 917   f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind);
 918 }
 919
 920
 921 void
 922 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 923 {
 924   /* If the kind of i and j are different, then g77 cross-promoted the
 925      kinds to the largest value.  The Fortran 95 standard requires the
 926      kinds to match.  */
 927   if (i->ts.kind != j->ts.kind)
 928     {
 929       if (i->ts.kind == gfc_kind_max (i, j))
 930         gfc_convert_type (j, &i->ts, 2);
 931       else
 932         gfc_convert_type (i, &j->ts, 2);
 933     }
 934
 935   f->ts = i->ts;
 936   f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
 937 }
 938
 939
 940 void
 941 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 942 {
 943   f->ts = i->ts;
 944   f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
 945 }
 946
 947
 948 void
 949 gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
 950                    gfc_expr *len ATTRIBUTE_UNUSED)
 951 {
 952   f->ts = i->ts;
 953   f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
 954 }
 955
 956
 957 void
 958 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 959 {
 960   f->ts = i->ts;
 961   f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
 962 }
 963
 964
 965 void
 966 gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
 967 {
 968   f->ts.type = BT_INTEGER;
 969   if (kind)
 970     f->ts.kind = mpz_get_si (kind->value.integer);
 971   else
 972     f->ts.kind = gfc_default_integer_kind;
 973   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 974 }
 975
 976
 977 void
 978 gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
 979 {
 980   f->ts.type = BT_INTEGER;
 981   if (kind)
 982     f->ts.kind = mpz_get_si (kind->value.integer);
 983   else
 984     f->ts.kind = gfc_default_integer_kind;
 985   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 986 }
 987
 988
 989 void
 990 gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
 991 {
 992   gfc_resolve_nint (f, a, NULL);
 993 }
 994
 995
 996 void
 997 gfc_resolve_ierrno (gfc_expr *f)
 998 {
 999   f->ts.type = BT_INTEGER;
1000   f->ts.kind = gfc_default_integer_kind;
1001   f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
1002 }
1003
1004
1005 void
1006 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1007 {
1008   /* If the kind of i and j are different, then g77 cross-promoted the
1009      kinds to the largest value.  The Fortran 95 standard requires the
1010      kinds to match.  */
1011   if (i->ts.kind != j->ts.kind)
1012     {
1013       if (i->ts.kind == gfc_kind_max (i, j))
1014         gfc_convert_type (j, &i->ts, 2);
1015       else
1016         gfc_convert_type (i, &j->ts, 2);
1017     }
1018
1019   f->ts = i->ts;
1020   f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
1021 }
1022
1023
1024 void
1025 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1026 {
1027   /* If the kind of i and j are different, then g77 cross-promoted the
1028      kinds to the largest value.  The Fortran 95 standard requires the
1029      kinds to match.  */
1030   if (i->ts.kind != j->ts.kind)
1031     {
1032       if (i->ts.kind == gfc_kind_max (i, j))
1033         gfc_convert_type (j, &i->ts, 2);
1034       else
1035         gfc_convert_type (i, &j->ts, 2);
1036     }
1037
1038   f->ts = i->ts;
1039   f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
1040 }
1041
1042
1043 void
1044 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
1045                         gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
1046                         gfc_expr *kind)
1047 {
1048   gfc_typespec ts;
1049   gfc_clear_ts (&ts);
1050
1051   f->ts.type = BT_INTEGER;
1052   if (kind)
1053     f->ts.kind = mpz_get_si (kind->value.integer);
1054   else
1055     f->ts.kind = gfc_default_integer_kind;
1056
1057   if (back && back->ts.kind != gfc_default_integer_kind)
1058     {
1059       ts.type = BT_LOGICAL;
1060       ts.kind = gfc_default_integer_kind;
1061       ts.derived = NULL;
1062       ts.cl = NULL;
1063       gfc_convert_type (back, &ts, 2);
1064     }
1065
1066   f->value.function.name
1067     = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1068 }
1069
1070
1071 void
1072 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1073 {
1074   f->ts.type = BT_INTEGER;
1075   f->ts.kind = (kind == NULL)
1076              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1077   f->value.function.name
1078     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1079                       gfc_type_letter (a->ts.type), a->ts.kind);
1080 }
1081
1082
1083 void
1084 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1085 {
1086   f->ts.type = BT_INTEGER;
1087   f->ts.kind = 2;
1088   f->value.function.name
1089     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1090                       gfc_type_letter (a->ts.type), a->ts.kind);
1091 }
1092
1093
1094 void
1095 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1096 {
1097   f->ts.type = BT_INTEGER;
1098   f->ts.kind = 8;
1099   f->value.function.name
1100     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1101                       gfc_type_letter (a->ts.type), a->ts.kind);
1102 }
1103
1104
1105 void
1106 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1107 {
1108   f->ts.type = BT_INTEGER;
1109   f->ts.kind = 4;
1110   f->value.function.name
1111     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1112                       gfc_type_letter (a->ts.type), a->ts.kind);
1113 }
1114
1115
1116 void
1117 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1118 {
1119   gfc_typespec ts;
1120   gfc_clear_ts (&ts);
1121
1122   f->ts.type = BT_LOGICAL;
1123   f->ts.kind = gfc_default_integer_kind;
1124   if (u->ts.kind != gfc_c_int_kind)
1125     {
1126       ts.type = BT_INTEGER;
1127       ts.kind = gfc_c_int_kind;
1128       ts.derived = NULL;
1129       ts.cl = NULL;
1130       gfc_convert_type (u, &ts, 2);
1131     }
1132
1133   f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1134 }
1135
1136
1137 void
1138 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1139 {
1140   f->ts = i->ts;
1141   f->value.function.name
1142     = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1143 }
1144
1145
1146 void
1147 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1148 {
1149   f->ts = i->ts;
1150   f->value.function.name
1151     = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1152 }
1153
1154
1155 void
1156 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1157 {
1158   f->ts = i->ts;
1159   f->value.function.name
1160     = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1161 }
1162
1163
1164 void
1165 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1166 {
1167   int s_kind;
1168
1169   s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1170
1171   f->ts = i->ts;
1172   f->value.function.name
1173     = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1174 }
1175
1176
1177 void
1178 gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
1179                   gfc_expr *s ATTRIBUTE_UNUSED)
1180 {
1181   f->ts.type = BT_INTEGER;
1182   f->ts.kind = gfc_default_integer_kind;
1183   f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
1184 }
1185
1186
1187 void
1188 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1189 {
1190   static char lbound[] = "__lbound";
1191
1192   f->ts.type = BT_INTEGER;
1193   if (kind)
1194     f->ts.kind = mpz_get_si (kind->value.integer);
1195   else
1196     f->ts.kind = gfc_default_integer_kind;
1197
1198   if (dim == NULL)
1199     {
1200       f->rank = 1;
1201       f->shape = gfc_get_shape (1);
1202       mpz_init_set_ui (f->shape[0], array->rank);
1203     }
1204
1205   f->value.function.name = lbound;
1206 }
1207
1208
1209 void
1210 gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1211 {
1212   f->ts.type = BT_INTEGER;
1213   if (kind)
1214     f->ts.kind = mpz_get_si (kind->value.integer);
1215   else
1216     f->ts.kind = gfc_default_integer_kind;
1217   f->value.function.name
1218     = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1219                       gfc_default_integer_kind);
1220 }
1221
1222
1223 void
1224 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1225 {
1226   f->ts.type = BT_INTEGER;
1227   if (kind)
1228     f->ts.kind = mpz_get_si (kind->value.integer);
1229   else
1230     f->ts.kind = gfc_default_integer_kind;
1231   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1232 }
1233
1234
1235 void
1236 gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1237 {
1238   f->ts = x->ts;
1239   f->value.function.name
1240     = gfc_get_string ("__lgamma_%d", x->ts.kind);
1241 }
1242
1243
1244 void
1245 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1246                   gfc_expr *p2 ATTRIBUTE_UNUSED)
1247 {
1248   f->ts.type = BT_INTEGER;
1249   f->ts.kind = gfc_default_integer_kind;
1250   f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1251 }
1252
1253
1254 void
1255 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1256 {
1257   f->ts.type= BT_INTEGER;
1258   f->ts.kind = gfc_index_integer_kind;
1259   f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1260 }
1261
1262
1263 void
1264 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1265 {
1266   f->ts = x->ts;
1267   f->value.function.name
1268     = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1269 }
1270
1271
1272 void
1273 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1274 {
1275   f->ts = x->ts;
1276   f->value.function.name
1277     = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1278                       x->ts.kind);
1279 }
1280
1281
1282 void
1283 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1284 {
1285   f->ts.type = BT_LOGICAL;
1286   f->ts.kind = (kind == NULL)
1287              ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1288   f->rank = a->rank;
1289
1290   f->value.function.name
1291     = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1292                       gfc_type_letter (a->ts.type), a->ts.kind);
1293 }
1294
1295
1296 void
1297 gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
1298 {
1299   if (size->ts.kind < gfc_index_integer_kind)
1300     {
1301       gfc_typespec ts;
1302       gfc_clear_ts (&ts);
1303
1304       ts.type = BT_INTEGER;
1305       ts.kind = gfc_index_integer_kind;
1306       gfc_convert_type_warn (size, &ts, 2, 0);
1307     }
1308
1309   f->ts.type = BT_INTEGER;
1310   f->ts.kind = gfc_index_integer_kind;
1311   f->value.function.name = gfc_get_string (PREFIX ("malloc"));
1312 }
1313
1314
1315 void
1316 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1317 {
1318   gfc_expr temp;
1319
1320   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1321     {
1322       f->ts.type = BT_LOGICAL;
1323       f->ts.kind = gfc_default_logical_kind;
1324     }
1325   else
1326     {
1327       temp.expr_type = EXPR_OP;
1328       gfc_clear_ts (&temp.ts);
1329       temp.value.op.op = INTRINSIC_NONE;
1330       temp.value.op.op1 = a;
1331       temp.value.op.op2 = b;
1332       gfc_type_convert_binary (&temp);
1333       f->ts = temp.ts;
1334     }
1335
1336   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1337
1338   if (a->rank == 2 && b->rank == 2)
1339     {
1340       if (a->shape && b->shape)
1341         {
1342           f->shape = gfc_get_shape (f->rank);
1343           mpz_init_set (f->shape[0], a->shape[0]);
1344           mpz_init_set (f->shape[1], b->shape[1]);
1345         }
1346     }
1347   else if (a->rank == 1)
1348     {
1349       if (b->shape)
1350         {
1351           f->shape = gfc_get_shape (f->rank);
1352           mpz_init_set (f->shape[0], b->shape[1]);
1353         }
1354     }
1355   else
1356     {
1357       /* b->rank == 1 and a->rank == 2 here, all other cases have
1358          been caught in check.c.   */
1359       if (a->shape)
1360         {
1361           f->shape = gfc_get_shape (f->rank);
1362           mpz_init_set (f->shape[0], a->shape[0]);
1363         }
1364     }
1365
1366   f->value.function.name
1367     = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1368                       f->ts.kind);
1369 }
1370
1371
1372 static void
1373 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1374 {
1375   gfc_actual_arglist *a;
1376
1377   f->ts.type = args->expr->ts.type;
1378   f->ts.kind = args->expr->ts.kind;
1379   /* Find the largest type kind.  */
1380   for (a = args->next; a; a = a->next)
1381     {
1382       if (a->expr->ts.kind > f->ts.kind)
1383         f->ts.kind = a->expr->ts.kind;
1384     }
1385
1386   /* Convert all parameters to the required kind.  */
1387   for (a = args; a; a = a->next)
1388     {
1389       if (a->expr->ts.kind != f->ts.kind)
1390         gfc_convert_type (a->expr, &f->ts, 2);
1391     }
1392
1393   f->value.function.name
1394     = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1395 }
1396
1397
1398 void
1399 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1400 {
1401   gfc_resolve_minmax ("__max_%c%d", f, args);
1402 }
1403
1404
1405 void
1406 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1407                     gfc_expr *mask)
1408 {
1409   const char *name;
1410   int i, j, idim;
1411
1412   f->ts.type = BT_INTEGER;
1413   f->ts.kind = gfc_default_integer_kind;
1414
1415   if (dim == NULL)
1416     {
1417       f->rank = 1;
1418       f->shape = gfc_get_shape (1);
1419       mpz_init_set_si (f->shape[0], array->rank);
1420     }
1421   else
1422     {
1423       f->rank = array->rank - 1;
1424       gfc_resolve_dim_arg (dim);
1425       if (array->shape && dim->expr_type == EXPR_CONSTANT)
1426         {
1427           idim = (int) mpz_get_si (dim->value.integer);
1428           f->shape = gfc_get_shape (f->rank);
1429           for (i = 0, j = 0; i < f->rank; i++, j++)
1430             {
1431               if (i == (idim - 1))
1432                 j++;
1433               mpz_init_set (f->shape[i], array->shape[j]);
1434             }
1435         }
1436     }
1437
1438   if (mask)
1439     {
1440       if (mask->rank == 0)
1441         name = "smaxloc";
1442       else
1443         name = "mmaxloc";
1444
1445       resolve_mask_arg (mask);
1446     }
1447   else
1448     name = "maxloc";
1449
1450   f->value.function.name
1451     = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1452                       gfc_type_letter (array->ts.type), array->ts.kind);
1453 }
1454
1455
1456 void
1457 gfc_resolve_maxval (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 = array->ts;
1464
1465   if (dim != NULL)
1466     {
1467       f->rank = array->rank - 1;
1468       gfc_resolve_dim_arg (dim);
1469
1470       if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1471         {
1472           idim = (int) mpz_get_si (dim->value.integer);
1473           f->shape = gfc_get_shape (f->rank);
1474           for (i = 0, j = 0; i < f->rank; i++, j++)
1475             {
1476               if (i == (idim - 1))
1477                 j++;
1478               mpz_init_set (f->shape[i], array->shape[j]);
1479             }
1480         }
1481     }
1482
1483   if (mask)
1484     {
1485       if (mask->rank == 0)
1486         name = "smaxval";
1487       else
1488         name = "mmaxval";
1489
1490       resolve_mask_arg (mask);
1491     }
1492   else
1493     name = "maxval";
1494
1495   f->value.function.name
1496     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1497                       gfc_type_letter (array->ts.type), array->ts.kind);
1498 }
1499
1500
1501 void
1502 gfc_resolve_mclock (gfc_expr *f)
1503 {
1504   f->ts.type = BT_INTEGER;
1505   f->ts.kind = 4;
1506   f->value.function.name = PREFIX ("mclock");
1507 }
1508
1509
1510 void
1511 gfc_resolve_mclock8 (gfc_expr *f)
1512 {
1513   f->ts.type = BT_INTEGER;
1514   f->ts.kind = 8;
1515   f->value.function.name = PREFIX ("mclock8");
1516 }
1517
1518
1519 void
1520 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1521                    gfc_expr *fsource ATTRIBUTE_UNUSED,
1522                    gfc_expr *mask ATTRIBUTE_UNUSED)
1523 {
1524   if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1525     gfc_resolve_substring_charlen (tsource);
1526
1527   if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1528     gfc_resolve_substring_charlen (fsource);
1529
1530   if (tsource->ts.type == BT_CHARACTER)
1531     check_charlen_present (tsource);
1532
1533   f->ts = tsource->ts;
1534   f->value.function.name
1535     = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1536                       tsource->ts.kind);
1537 }
1538
1539
1540 void
1541 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1542 {
1543   gfc_resolve_minmax ("__min_%c%d", f, args);
1544 }
1545
1546
1547 void
1548 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1549                     gfc_expr *mask)
1550 {
1551   const char *name;
1552   int i, j, idim;
1553
1554   f->ts.type = BT_INTEGER;
1555   f->ts.kind = gfc_default_integer_kind;
1556
1557   if (dim == NULL)
1558     {
1559       f->rank = 1;
1560       f->shape = gfc_get_shape (1);
1561       mpz_init_set_si (f->shape[0], array->rank);
1562     }
1563   else
1564     {
1565       f->rank = array->rank - 1;
1566       gfc_resolve_dim_arg (dim);
1567       if (array->shape && dim->expr_type == EXPR_CONSTANT)
1568         {
1569           idim = (int) mpz_get_si (dim->value.integer);
1570           f->shape = gfc_get_shape (f->rank);
1571           for (i = 0, j = 0; i < f->rank; i++, j++)
1572             {
1573               if (i == (idim - 1))
1574                 j++;
1575               mpz_init_set (f->shape[i], array->shape[j]);
1576             }
1577         }
1578     }
1579
1580   if (mask)
1581     {
1582       if (mask->rank == 0)
1583         name = "sminloc";
1584       else
1585         name = "mminloc";
1586
1587       resolve_mask_arg (mask);
1588     }
1589   else
1590     name = "minloc";
1591
1592   f->value.function.name
1593     = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1594                       gfc_type_letter (array->ts.type), array->ts.kind);
1595 }
1596
1597
1598 void
1599 gfc_resolve_minval (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 = array->ts;
1606
1607   if (dim != NULL)
1608     {
1609       f->rank = array->rank - 1;
1610       gfc_resolve_dim_arg (dim);
1611
1612       if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1613         {
1614           idim = (int) mpz_get_si (dim->value.integer);
1615           f->shape = gfc_get_shape (f->rank);
1616           for (i = 0, j = 0; i < f->rank; i++, j++)
1617             {
1618               if (i == (idim - 1))
1619                 j++;
1620               mpz_init_set (f->shape[i], array->shape[j]);
1621             }
1622         }
1623     }
1624
1625   if (mask)
1626     {
1627       if (mask->rank == 0)
1628         name = "sminval";
1629       else
1630         name = "mminval";
1631
1632       resolve_mask_arg (mask);
1633     }
1634   else
1635     name = "minval";
1636
1637   f->value.function.name
1638     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1639                       gfc_type_letter (array->ts.type), array->ts.kind);
1640 }
1641
1642
1643 void
1644 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1645 {
1646   f->ts.type = a->ts.type;
1647   if (p != NULL)
1648     f->ts.kind = gfc_kind_max (a,p);
1649   else
1650     f->ts.kind = a->ts.kind;
1651
1652   if (p != NULL && a->ts.kind != p->ts.kind)
1653     {
1654       if (a->ts.kind == gfc_kind_max (a,p))
1655         gfc_convert_type (p, &a->ts, 2);
1656       else
1657         gfc_convert_type (a, &p->ts, 2);
1658     }
1659
1660   f->value.function.name
1661     = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1662 }
1663
1664
1665 void
1666 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1667 {
1668   f->ts.type = a->ts.type;
1669   if (p != NULL)
1670     f->ts.kind = gfc_kind_max (a,p);
1671   else
1672     f->ts.kind = a->ts.kind;
1673
1674   if (p != NULL && a->ts.kind != p->ts.kind)
1675     {
1676       if (a->ts.kind == gfc_kind_max (a,p))
1677         gfc_convert_type (p, &a->ts, 2);
1678       else
1679         gfc_convert_type (a, &p->ts, 2);
1680     }
1681
1682   f->value.function.name
1683     = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1684                       f->ts.kind);
1685 }
1686
1687 void
1688 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1689 {
1690   if (p->ts.kind != a->ts.kind)
1691     gfc_convert_type (p, &a->ts, 2);
1692
1693   f->ts = a->ts;
1694   f->value.function.name
1695     = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1696                       a->ts.kind);
1697 }
1698
1699 void
1700 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1701 {
1702   f->ts.type = BT_INTEGER;
1703   f->ts.kind = (kind == NULL)
1704              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1705   f->value.function.name
1706     = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1707 }
1708
1709
1710 void
1711 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
1712 {
1713   f->ts = i->ts;
1714   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1715 }
1716
1717
1718 void
1719 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1720 {
1721   f->ts.type = i->ts.type;
1722   f->ts.kind = gfc_kind_max (i, j);
1723
1724   if (i->ts.kind != j->ts.kind)
1725     {
1726       if (i->ts.kind == gfc_kind_max (i, j))
1727         gfc_convert_type (j, &i->ts, 2);
1728       else
1729         gfc_convert_type (i, &j->ts, 2);
1730     }
1731
1732   f->value.function.name
1733     = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
1734 }
1735
1736
1737 void
1738 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
1739                   gfc_expr *vector ATTRIBUTE_UNUSED)
1740 {
1741   if (array->ts.type == BT_CHARACTER && array->ref)
1742     gfc_resolve_substring_charlen (array);
1743
1744   f->ts = array->ts;
1745   f->rank = 1;
1746
1747   resolve_mask_arg (mask);
1748
1749   if (mask->rank != 0)
1750     {
1751       if (array->ts.type == BT_CHARACTER)
1752         f->value.function.name
1753           = array->ts.kind == 1 ? PREFIX ("pack_char")
1754                                 : gfc_get_string
1755                                         (PREFIX ("pack_char%d"),
1756                                          array->ts.kind);
1757       else
1758         f->value.function.name = PREFIX ("pack");
1759     }
1760   else
1761     {
1762       if (array->ts.type == BT_CHARACTER)
1763         f->value.function.name
1764           = array->ts.kind == 1 ? PREFIX ("pack_s_char")
1765                                 : gfc_get_string
1766                                         (PREFIX ("pack_s_char%d"),
1767                                          array->ts.kind);
1768       else
1769         f->value.function.name = PREFIX ("pack_s");
1770     }
1771 }
1772
1773
1774 void
1775 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1776                      gfc_expr *mask)
1777 {
1778   const char *name;
1779
1780   f->ts = array->ts;
1781
1782   if (dim != NULL)
1783     {
1784       f->rank = array->rank - 1;
1785       f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
1786       gfc_resolve_dim_arg (dim);
1787     }
1788
1789   if (mask)
1790     {
1791       if (mask->rank == 0)
1792         name = "sproduct";
1793       else
1794         name = "mproduct";
1795
1796       resolve_mask_arg (mask);
1797     }
1798   else
1799     name = "product";
1800
1801   f->value.function.name
1802     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1803                       gfc_type_letter (array->ts.type), array->ts.kind);
1804 }
1805
1806
1807 void
1808 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1809 {
1810   f->ts.type = BT_REAL;
1811
1812   if (kind != NULL)
1813     f->ts.kind = mpz_get_si (kind->value.integer);
1814   else
1815     f->ts.kind = (a->ts.type == BT_COMPLEX)
1816                ? a->ts.kind : gfc_default_real_kind;
1817
1818   f->value.function.name
1819     = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1820                       gfc_type_letter (a->ts.type), a->ts.kind);
1821 }
1822
1823
1824 void
1825 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
1826 {
1827   f->ts.type = BT_REAL;
1828   f->ts.kind = a->ts.kind;
1829   f->value.function.name
1830     = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1831                       gfc_type_letter (a->ts.type), a->ts.kind);
1832 }
1833
1834
1835 void
1836 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1837                     gfc_expr *p2 ATTRIBUTE_UNUSED)
1838 {
1839   f->ts.type = BT_INTEGER;
1840   f->ts.kind = gfc_default_integer_kind;
1841   f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
1842 }
1843
1844
1845 void
1846 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
1847                     gfc_expr *ncopies ATTRIBUTE_UNUSED)
1848 {
1849   f->ts.type = BT_CHARACTER;
1850   f->ts.kind = string->ts.kind;
1851   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1852 }
1853
1854
1855 void
1856 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
1857                      gfc_expr *pad ATTRIBUTE_UNUSED,
1858                      gfc_expr *order ATTRIBUTE_UNUSED)
1859 {
1860   mpz_t rank;
1861   int kind;
1862   int i;
1863
1864   if (source->ts.type == BT_CHARACTER && source->ref)
1865     gfc_resolve_substring_charlen (source);
1866
1867   f->ts = source->ts;
1868
1869   gfc_array_size (shape, &rank);
1870   f->rank = mpz_get_si (rank);
1871   mpz_clear (rank);
1872   switch (source->ts.type)
1873     {
1874     case BT_COMPLEX:
1875     case BT_REAL:
1876     case BT_INTEGER:
1877     case BT_LOGICAL:
1878     case BT_CHARACTER:
1879       kind = source->ts.kind;
1880       break;
1881
1882     default:
1883       kind = 0;
1884       break;
1885     }
1886
1887   switch (kind)
1888     {
1889     case 4:
1890     case 8:
1891     case 10:
1892     case 16:
1893       if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
1894         f->value.function.name
1895           = gfc_get_string (PREFIX ("reshape_%c%d"),
1896                             gfc_type_letter (source->ts.type),
1897                             source->ts.kind);
1898       else if (source->ts.type == BT_CHARACTER)
1899         f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
1900                                                  kind);
1901       else
1902         f->value.function.name
1903           = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
1904       break;
1905
1906     default:
1907       f->value.function.name = (source->ts.type == BT_CHARACTER
1908                                 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1909       break;
1910     }
1911
1912   /* TODO: Make this work with a constant ORDER parameter.  */
1913   if (shape->expr_type == EXPR_ARRAY
1914       && gfc_is_constant_expr (shape)
1915       && order == NULL)
1916     {
1917       gfc_constructor *c;
1918       f->shape = gfc_get_shape (f->rank);
1919       c = shape->value.constructor;
1920       for (i = 0; i < f->rank; i++)
1921         {
1922           mpz_init_set (f->shape[i], c->expr->value.integer);
1923           c = c->next;
1924         }
1925     }
1926
1927   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1928      so many runtime variations.  */
1929   if (shape->ts.kind != gfc_index_integer_kind)
1930     {
1931       gfc_typespec ts = shape->ts;
1932       ts.kind = gfc_index_integer_kind;
1933       gfc_convert_type_warn (shape, &ts, 2, 0);
1934     }
1935   if (order && order->ts.kind != gfc_index_integer_kind)
1936     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1937 }
1938
1939
1940 void
1941 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
1942 {
1943   f->ts = x->ts;
1944   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1945 }
1946
1947
1948 void
1949 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
1950 {
1951   f->ts = x->ts;
1952   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1953 }
1954
1955
1956 void
1957 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
1958                   gfc_expr *set ATTRIBUTE_UNUSED,
1959                   gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
1960 {
1961   f->ts.type = BT_INTEGER;
1962   if (kind)
1963     f->ts.kind = mpz_get_si (kind->value.integer);
1964   else
1965     f->ts.kind = gfc_default_integer_kind;
1966   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1967 }
1968
1969
1970 void
1971 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
1972 {
1973   t1->ts = t0->ts;
1974   t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
1975 }
1976
1977
1978 void
1979 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
1980                           gfc_expr *i ATTRIBUTE_UNUSED)
1981 {
1982   f->ts = x->ts;
1983   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1984 }
1985
1986
1987 void
1988 gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
1989 {
1990   f->ts.type = BT_INTEGER;
1991   f->ts.kind = gfc_default_integer_kind;
1992   f->rank = 1;
1993   f->shape = gfc_get_shape (1);
1994   mpz_init_set_ui (f->shape[0], array->rank);
1995   f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
1996 }
1997
1998
1999 void
2000 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2001 {
2002   f->ts = a->ts;
2003   f->value.function.name
2004     = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2005 }
2006
2007
2008 void
2009 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2010 {
2011   f->ts.type = BT_INTEGER;
2012   f->ts.kind = gfc_c_int_kind;
2013
2014   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2015   if (handler->ts.type == BT_INTEGER)
2016     {
2017       if (handler->ts.kind != gfc_c_int_kind)
2018         gfc_convert_type (handler, &f->ts, 2);
2019       f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2020     }
2021   else
2022     f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2023
2024   if (number->ts.kind != gfc_c_int_kind)
2025     gfc_convert_type (number, &f->ts, 2);
2026 }
2027
2028
2029 void
2030 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2031 {
2032   f->ts = x->ts;
2033   f->value.function.name
2034     = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2035 }
2036
2037
2038 void
2039 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2040 {
2041   f->ts = x->ts;
2042   f->value.function.name
2043     = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2044 }
2045
2046
2047 void
2048 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2049                   gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2050 {
2051   f->ts.type = BT_INTEGER;
2052   if (kind)
2053     f->ts.kind = mpz_get_si (kind->value.integer);
2054   else
2055     f->ts.kind = gfc_default_integer_kind;
2056 }
2057
2058
2059 void
2060 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2061 {
2062   f->ts = x->ts;
2063   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2064 }
2065
2066
2067 void
2068 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2069                     gfc_expr *ncopies)
2070 {
2071   if (source->ts.type == BT_CHARACTER && source->ref)
2072     gfc_resolve_substring_charlen (source);
2073
2074   if (source->ts.type == BT_CHARACTER)
2075     check_charlen_present (source);
2076
2077   f->ts = source->ts;
2078   f->rank = source->rank + 1;
2079   if (source->rank == 0)
2080     {
2081       if (source->ts.type == BT_CHARACTER)
2082         f->value.function.name
2083           = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2084                                  : gfc_get_string
2085                                         (PREFIX ("spread_char%d_scalar"),
2086                                          source->ts.kind);
2087       else
2088         f->value.function.name = PREFIX ("spread_scalar");
2089     }
2090   else
2091     {
2092       if (source->ts.type == BT_CHARACTER)
2093         f->value.function.name
2094           = source->ts.kind == 1 ? PREFIX ("spread_char")
2095                                  : gfc_get_string
2096                                         (PREFIX ("spread_char%d"),
2097                                          source->ts.kind);
2098       else
2099         f->value.function.name = PREFIX ("spread");
2100     }
2101
2102   if (dim && gfc_is_constant_expr (dim)
2103       && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2104     {
2105       int i, idim;
2106       idim = mpz_get_ui (dim->value.integer);
2107       f->shape = gfc_get_shape (f->rank);
2108       for (i = 0; i < (idim - 1); i++)
2109         mpz_init_set (f->shape[i], source->shape[i]);
2110
2111       mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2112
2113       for (i = idim; i < f->rank ; i++)
2114         mpz_init_set (f->shape[i], source->shape[i-1]);
2115     }
2116
2117
2118   gfc_resolve_dim_arg (dim);
2119   gfc_resolve_index (ncopies, 1);
2120 }
2121
2122
2123 void
2124 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2125 {
2126   f->ts = x->ts;
2127   f->value.function.name
2128     = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2129 }
2130
2131
2132 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
2133
2134 void
2135 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2136                   gfc_expr *a ATTRIBUTE_UNUSED)
2137 {
2138   f->ts.type = BT_INTEGER;
2139   f->ts.kind = gfc_default_integer_kind;
2140   f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2141 }
2142
2143
2144 void
2145 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2146                    gfc_expr *a ATTRIBUTE_UNUSED)
2147 {
2148   f->ts.type = BT_INTEGER;
2149   f->ts.kind = gfc_default_integer_kind;
2150   f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2151 }
2152
2153
2154 void
2155 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2156 {
2157   f->ts.type = BT_INTEGER;
2158   f->ts.kind = gfc_default_integer_kind;
2159   if (n->ts.kind != f->ts.kind)
2160     gfc_convert_type (n, &f->ts, 2);
2161
2162   f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2163 }
2164
2165
2166 void
2167 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2168 {
2169   gfc_typespec ts;
2170   gfc_clear_ts (&ts);
2171
2172   f->ts.type = BT_INTEGER;
2173   f->ts.kind = gfc_c_int_kind;
2174   if (u->ts.kind != gfc_c_int_kind)
2175     {
2176       ts.type = BT_INTEGER;
2177       ts.kind = gfc_c_int_kind;
2178       ts.derived = NULL;
2179       ts.cl = NULL;
2180       gfc_convert_type (u, &ts, 2);
2181     }
2182
2183   f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2184 }
2185
2186
2187 void
2188 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2189 {
2190   f->ts.type = BT_INTEGER;
2191   f->ts.kind = gfc_c_int_kind;
2192   f->value.function.name = gfc_get_string (PREFIX ("fget"));
2193 }
2194
2195
2196 void
2197 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2198 {
2199   gfc_typespec ts;
2200   gfc_clear_ts (&ts);
2201
2202   f->ts.type = BT_INTEGER;
2203   f->ts.kind = gfc_c_int_kind;
2204   if (u->ts.kind != gfc_c_int_kind)
2205     {
2206       ts.type = BT_INTEGER;
2207       ts.kind = gfc_c_int_kind;
2208       ts.derived = NULL;
2209       ts.cl = NULL;
2210       gfc_convert_type (u, &ts, 2);
2211     }
2212
2213   f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2214 }
2215
2216
2217 void
2218 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2219 {
2220   f->ts.type = BT_INTEGER;
2221   f->ts.kind = gfc_c_int_kind;
2222   f->value.function.name = gfc_get_string (PREFIX ("fput"));
2223 }
2224
2225
2226 void
2227 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2228 {
2229   gfc_typespec ts;
2230   gfc_clear_ts (&ts);
2231
2232   f->ts.type = BT_INTEGER;
2233   f->ts.kind = gfc_index_integer_kind;
2234   if (u->ts.kind != gfc_c_int_kind)
2235     {
2236       ts.type = BT_INTEGER;
2237       ts.kind = gfc_c_int_kind;
2238       ts.derived = NULL;
2239       ts.cl = NULL;
2240       gfc_convert_type (u, &ts, 2);
2241     }
2242
2243   f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2244 }
2245
2246
2247 void
2248 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2249 {
2250   const char *name;
2251
2252   f->ts = array->ts;
2253
2254   if (mask)
2255     {
2256       if (mask->rank == 0)
2257         name = "ssum";
2258       else
2259         name = "msum";
2260
2261       resolve_mask_arg (mask);
2262     }
2263   else
2264     name = "sum";
2265
2266   if (dim != NULL)
2267     {
2268       f->rank = array->rank - 1;
2269       f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
2270       gfc_resolve_dim_arg (dim);
2271     }
2272
2273   f->value.function.name
2274     = gfc_get_string (PREFIX ("%s_%c%d"), name,
2275                     gfc_type_letter (array->ts.type), array->ts.kind);
2276 }
2277
2278
2279 void
2280 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2281                     gfc_expr *p2 ATTRIBUTE_UNUSED)
2282 {
2283   f->ts.type = BT_INTEGER;
2284   f->ts.kind = gfc_default_integer_kind;
2285   f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2286 }
2287
2288
2289 /* Resolve the g77 compatibility function SYSTEM.  */
2290
2291 void
2292 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2293 {
2294   f->ts.type = BT_INTEGER;
2295   f->ts.kind = 4;
2296   f->value.function.name = gfc_get_string (PREFIX ("system"));
2297 }
2298
2299
2300 void
2301 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2302 {
2303   f->ts = x->ts;
2304   f->value.function.name
2305     = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2306 }
2307
2308
2309 void
2310 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2311 {
2312   f->ts = x->ts;
2313   f->value.function.name
2314     = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2315 }
2316
2317
2318 void
2319 gfc_resolve_time (gfc_expr *f)
2320 {
2321   f->ts.type = BT_INTEGER;
2322   f->ts.kind = 4;
2323   f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2324 }
2325
2326
2327 void
2328 gfc_resolve_time8 (gfc_expr *f)
2329 {
2330   f->ts.type = BT_INTEGER;
2331   f->ts.kind = 8;
2332   f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2333 }
2334
2335
2336 void
2337 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2338                       gfc_expr *mold, gfc_expr *size)
2339 {
2340   /* TODO: Make this do something meaningful.  */
2341   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2342
2343   if (mold->ts.type == BT_CHARACTER && !mold->ts.cl->length
2344         && !(mold->expr_type == EXPR_VARIABLE && mold->symtree->n.sym->attr.dummy))
2345     mold->ts.cl->length = gfc_int_expr (mold->value.character.length);
2346
2347   f->ts = mold->ts;
2348
2349   if (size == NULL && mold->rank == 0)
2350     {
2351       f->rank = 0;
2352       f->value.function.name = transfer0;
2353     }
2354   else
2355     {
2356       f->rank = 1;
2357       f->value.function.name = transfer1;
2358       if (size && gfc_is_constant_expr (size))
2359         {
2360           f->shape = gfc_get_shape (1);
2361           mpz_init_set (f->shape[0], size->value.integer);
2362         }
2363     }
2364 }
2365
2366
2367 void
2368 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2369 {
2370
2371   if (matrix->ts.type == BT_CHARACTER && matrix->ref)
2372     gfc_resolve_substring_charlen (matrix);
2373
2374   f->ts = matrix->ts;
2375   f->rank = 2;
2376   if (matrix->shape)
2377     {
2378       f->shape = gfc_get_shape (2);
2379       mpz_init_set (f->shape[0], matrix->shape[1]);
2380       mpz_init_set (f->shape[1], matrix->shape[0]);
2381     }
2382
2383   switch (matrix->ts.kind)
2384     {
2385     case 4:
2386     case 8:
2387     case 10:
2388     case 16:
2389       switch (matrix->ts.type)
2390         {
2391         case BT_REAL:
2392         case BT_COMPLEX:
2393           f->value.function.name
2394             = gfc_get_string (PREFIX ("transpose_%c%d"),
2395                               gfc_type_letter (matrix->ts.type),
2396                               matrix->ts.kind);
2397           break;
2398
2399         case BT_INTEGER:
2400         case BT_LOGICAL:
2401           /* Use the integer routines for real and logical cases.  This
2402              assumes they all have the same alignment requirements.  */
2403           f->value.function.name
2404             = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
2405           break;
2406
2407         default:
2408           if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
2409             f->value.function.name = PREFIX ("transpose_char4");
2410           else
2411             f->value.function.name = PREFIX ("transpose");
2412           break;
2413         }
2414       break;
2415
2416     default:
2417       f->value.function.name = (matrix->ts.type == BT_CHARACTER
2418                                 ? PREFIX ("transpose_char")
2419                                 : PREFIX ("transpose"));
2420       break;
2421     }
2422 }
2423
2424
2425 void
2426 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
2427 {
2428   f->ts.type = BT_CHARACTER;
2429   f->ts.kind = string->ts.kind;
2430   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2431 }
2432
2433
2434 void
2435 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2436 {
2437   static char ubound[] = "__ubound";
2438
2439   f->ts.type = BT_INTEGER;
2440   if (kind)
2441     f->ts.kind = mpz_get_si (kind->value.integer);
2442   else
2443     f->ts.kind = gfc_default_integer_kind;
2444
2445   if (dim == NULL)
2446     {
2447       f->rank = 1;
2448       f->shape = gfc_get_shape (1);
2449       mpz_init_set_ui (f->shape[0], array->rank);
2450     }
2451
2452   f->value.function.name = ubound;
2453 }
2454
2455
2456 /* Resolve the g77 compatibility function UMASK.  */
2457
2458 void
2459 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
2460 {
2461   f->ts.type = BT_INTEGER;
2462   f->ts.kind = n->ts.kind;
2463   f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
2464 }
2465
2466
2467 /* Resolve the g77 compatibility function UNLINK.  */
2468
2469 void
2470 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2471 {
2472   f->ts.type = BT_INTEGER;
2473   f->ts.kind = 4;
2474   f->value.function.name = gfc_get_string (PREFIX ("unlink"));
2475 }
2476
2477
2478 void
2479 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
2480 {
2481   gfc_typespec ts;
2482   gfc_clear_ts (&ts);
2483
2484   f->ts.type = BT_CHARACTER;
2485   f->ts.kind = gfc_default_character_kind;
2486
2487   if (unit->ts.kind != gfc_c_int_kind)
2488     {
2489       ts.type = BT_INTEGER;
2490       ts.kind = gfc_c_int_kind;
2491       ts.derived = NULL;
2492       ts.cl = NULL;
2493       gfc_convert_type (unit, &ts, 2);
2494     }
2495
2496   f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
2497 }
2498
2499
2500 void
2501 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
2502                     gfc_expr *field ATTRIBUTE_UNUSED)
2503 {
2504   if (vector->ts.type == BT_CHARACTER && vector->ref)
2505     gfc_resolve_substring_charlen (vector);
2506
2507   f->ts = vector->ts;
2508   f->rank = mask->rank;
2509   resolve_mask_arg (mask);
2510
2511   if (vector->ts.type == BT_CHARACTER)
2512     {
2513       if (vector->ts.kind == 1)
2514         f->value.function.name
2515           = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
2516       else
2517         f->value.function.name
2518           = gfc_get_string (PREFIX ("unpack%d_char%d"),
2519                             field->rank > 0 ? 1 : 0, vector->ts.kind);
2520     }
2521   else
2522     f->value.function.name
2523       = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
2524 }
2525
2526
2527 void
2528 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
2529                     gfc_expr *set ATTRIBUTE_UNUSED,
2530                     gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2531 {
2532   f->ts.type = BT_INTEGER;
2533   if (kind)
2534     f->ts.kind = mpz_get_si (kind->value.integer);
2535   else
2536     f->ts.kind = gfc_default_integer_kind;
2537   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2538 }
2539
2540
2541 void
2542 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2543 {
2544   f->ts.type = i->ts.type;
2545   f->ts.kind = gfc_kind_max (i, j);
2546
2547   if (i->ts.kind != j->ts.kind)
2548     {
2549       if (i->ts.kind == gfc_kind_max (i, j))
2550         gfc_convert_type (j, &i->ts, 2);
2551       else
2552         gfc_convert_type (i, &j->ts, 2);
2553     }
2554
2555   f->value.function.name
2556     = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2557 }
2558
2559
2560 /* Intrinsic subroutine resolution.  */
2561
2562 void
2563 gfc_resolve_alarm_sub (gfc_code *c)
2564 {
2565   const char *name;
2566   gfc_expr *seconds, *handler, *status;
2567   gfc_typespec ts;
2568   gfc_clear_ts (&ts);
2569
2570   seconds = c->ext.actual->expr;
2571   handler = c->ext.actual->next->expr;
2572   status = c->ext.actual->next->next->expr;
2573   ts.type = BT_INTEGER;
2574   ts.kind = gfc_c_int_kind;
2575
2576   /* handler can be either BT_INTEGER or BT_PROCEDURE.
2577      In all cases, the status argument is of default integer kind
2578      (enforced in check.c) so that the function suffix is fixed.  */
2579   if (handler->ts.type == BT_INTEGER)
2580     {
2581       if (handler->ts.kind != gfc_c_int_kind)
2582         gfc_convert_type (handler, &ts, 2);
2583       name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2584                              gfc_default_integer_kind);
2585     }
2586   else
2587     name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
2588                            gfc_default_integer_kind);
2589
2590   if (seconds->ts.kind != gfc_c_int_kind)
2591     gfc_convert_type (seconds, &ts, 2);
2592
2593   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2594 }
2595
2596 void
2597 gfc_resolve_cpu_time (gfc_code *c)
2598 {
2599   const char *name;
2600   name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2601   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2602 }
2603
2604
2605 /* Create a formal arglist based on an actual one and set the INTENTs given.  */
2606
2607 static gfc_formal_arglist*
2608 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
2609 {
2610   gfc_formal_arglist* head;
2611   gfc_formal_arglist* tail;
2612   int i;
2613
2614   if (!actual)
2615     return NULL;
2616
2617   head = tail = gfc_get_formal_arglist ();
2618   for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
2619     {
2620       gfc_symbol* sym;
2621
2622       sym = gfc_new_symbol ("dummyarg", NULL);
2623       sym->ts = actual->expr->ts;
2624
2625       sym->attr.intent = ints[i];
2626       tail->sym = sym;
2627
2628       if (actual->next)
2629         tail->next = gfc_get_formal_arglist ();
2630     }
2631
2632   return head;
2633 }
2634
2635
2636 void
2637 gfc_resolve_mvbits (gfc_code *c)
2638 {
2639   static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
2640                                        INTENT_INOUT, INTENT_IN};
2641
2642   const char *name;
2643   gfc_typespec ts;
2644   gfc_clear_ts (&ts);
2645
2646   /* FROMPOS, LEN and TOPOS are restricted to small values.  As such,
2647      they will be converted so that they fit into a C int.  */
2648   ts.type = BT_INTEGER;
2649   ts.kind = gfc_c_int_kind;
2650   if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
2651     gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
2652   if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
2653     gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
2654   if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
2655     gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
2656
2657   /* TO and FROM are guaranteed to have the same kind parameter.  */
2658   name = gfc_get_string (PREFIX ("mvbits_i%d"),
2659                          c->ext.actual->expr->ts.kind);
2660   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2661   /* Mark as elemental subroutine as this does not happen automatically.  */
2662   c->resolved_sym->attr.elemental = 1;
2663
2664   /* Create a dummy formal arglist so the INTENTs are known later for purpose
2665      of creating temporaries.  */
2666   c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
2667 }
2668
2669
2670 void
2671 gfc_resolve_random_number (gfc_code *c)
2672 {
2673   const char *name;
2674   int kind;
2675
2676   kind = c->ext.actual->expr->ts.kind;
2677   if (c->ext.actual->expr->rank == 0)
2678     name = gfc_get_string (PREFIX ("random_r%d"), kind);
2679   else
2680     name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2681
2682   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2683 }
2684
2685
2686 void
2687 gfc_resolve_random_seed (gfc_code *c)
2688 {
2689   const char *name;
2690
2691   name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
2692   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2693 }
2694
2695
2696 void
2697 gfc_resolve_rename_sub (gfc_code *c)
2698 {
2699   const char *name;
2700   int kind;
2701
2702   if (c->ext.actual->next->next->expr != NULL)
2703     kind = c->ext.actual->next->next->expr->ts.kind;
2704   else
2705     kind = gfc_default_integer_kind;
2706
2707   name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2708   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2709 }
2710
2711
2712 void
2713 gfc_resolve_kill_sub (gfc_code *c)
2714 {
2715   const char *name;
2716   int kind;
2717
2718   if (c->ext.actual->next->next->expr != NULL)
2719     kind = c->ext.actual->next->next->expr->ts.kind;
2720   else
2721     kind = gfc_default_integer_kind;
2722
2723   name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
2724   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2725 }
2726
2727
2728 void
2729 gfc_resolve_link_sub (gfc_code *c)
2730 {
2731   const char *name;
2732   int kind;
2733
2734   if (c->ext.actual->next->next->expr != NULL)
2735     kind = c->ext.actual->next->next->expr->ts.kind;
2736   else
2737     kind = gfc_default_integer_kind;
2738
2739   name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
2740   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2741 }
2742
2743
2744 void
2745 gfc_resolve_symlnk_sub (gfc_code *c)
2746 {
2747   const char *name;
2748   int kind;
2749
2750   if (c->ext.actual->next->next->expr != NULL)
2751     kind = c->ext.actual->next->next->expr->ts.kind;
2752   else
2753     kind = gfc_default_integer_kind;
2754
2755   name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
2756   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2757 }
2758
2759
2760 /* G77 compatibility subroutines dtime() and etime().  */
2761
2762 void
2763 gfc_resolve_dtime_sub (gfc_code *c)
2764 {
2765   const char *name;
2766   name = gfc_get_string (PREFIX ("dtime_sub"));
2767   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2768 }
2769
2770 void
2771 gfc_resolve_etime_sub (gfc_code *c)
2772 {
2773   const char *name;
2774   name = gfc_get_string (PREFIX ("etime_sub"));
2775   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2776 }
2777
2778
2779 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime().  */
2780
2781 void
2782 gfc_resolve_itime (gfc_code *c)
2783 {
2784   c->resolved_sym
2785     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2786                                                     gfc_default_integer_kind));
2787 }
2788
2789 void
2790 gfc_resolve_idate (gfc_code *c)
2791 {
2792   c->resolved_sym
2793     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2794                                                     gfc_default_integer_kind));
2795 }
2796
2797 void
2798 gfc_resolve_ltime (gfc_code *c)
2799 {
2800   c->resolved_sym
2801     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2802                                                     gfc_default_integer_kind));
2803 }
2804
2805 void
2806 gfc_resolve_gmtime (gfc_code *c)
2807 {
2808   c->resolved_sym
2809     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2810                                                     gfc_default_integer_kind));
2811 }
2812
2813
2814 /* G77 compatibility subroutine second().  */
2815
2816 void
2817 gfc_resolve_second_sub (gfc_code *c)
2818 {
2819   const char *name;
2820   name = gfc_get_string (PREFIX ("second_sub"));
2821   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2822 }
2823
2824
2825 void
2826 gfc_resolve_sleep_sub (gfc_code *c)
2827 {
2828   const char *name;
2829   int kind;
2830
2831   if (c->ext.actual->expr != NULL)
2832     kind = c->ext.actual->expr->ts.kind;
2833   else
2834     kind = gfc_default_integer_kind;
2835
2836   name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
2837   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2838 }
2839
2840
2841 /* G77 compatibility function srand().  */
2842
2843 void
2844 gfc_resolve_srand (gfc_code *c)
2845 {
2846   const char *name;
2847   name = gfc_get_string (PREFIX ("srand"));
2848   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2849 }
2850
2851
2852 /* Resolve the getarg intrinsic subroutine.  */
2853
2854 void
2855 gfc_resolve_getarg (gfc_code *c)
2856 {
2857   const char *name;
2858
2859   if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
2860     {
2861       gfc_typespec ts;
2862       gfc_clear_ts (&ts);
2863
2864       ts.type = BT_INTEGER;
2865       ts.kind = gfc_default_integer_kind;
2866
2867       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2868     }
2869
2870   name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
2871   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2872 }
2873
2874
2875 /* Resolve the getcwd intrinsic subroutine.  */
2876
2877 void
2878 gfc_resolve_getcwd_sub (gfc_code *c)
2879 {
2880   const char *name;
2881   int kind;
2882
2883   if (c->ext.actual->next->expr != NULL)
2884     kind = c->ext.actual->next->expr->ts.kind;
2885   else
2886     kind = gfc_default_integer_kind;
2887
2888   name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
2889   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2890 }
2891
2892
2893 /* Resolve the get_command intrinsic subroutine.  */
2894
2895 void
2896 gfc_resolve_get_command (gfc_code *c)
2897 {
2898   const char *name;
2899   int kind;
2900   kind = gfc_default_integer_kind;
2901   name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
2902   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2903 }
2904
2905
2906 /* Resolve the get_command_argument intrinsic subroutine.  */
2907
2908 void
2909 gfc_resolve_get_command_argument (gfc_code *c)
2910 {
2911   const char *name;
2912   int kind;
2913   kind = gfc_default_integer_kind;
2914   name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
2915   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2916 }
2917
2918
2919 /* Resolve the get_environment_variable intrinsic subroutine.  */
2920
2921 void
2922 gfc_resolve_get_environment_variable (gfc_code *code)
2923 {
2924   const char *name;
2925   int kind;
2926   kind = gfc_default_integer_kind;
2927   name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
2928   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2929 }
2930
2931
2932 void
2933 gfc_resolve_signal_sub (gfc_code *c)
2934 {
2935   const char *name;
2936   gfc_expr *number, *handler, *status;
2937   gfc_typespec ts;
2938   gfc_clear_ts (&ts);
2939
2940   number = c->ext.actual->expr;
2941   handler = c->ext.actual->next->expr;
2942   status = c->ext.actual->next->next->expr;
2943   ts.type = BT_INTEGER;
2944   ts.kind = gfc_c_int_kind;
2945
2946   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2947   if (handler->ts.type == BT_INTEGER)
2948     {
2949       if (handler->ts.kind != gfc_c_int_kind)
2950         gfc_convert_type (handler, &ts, 2);
2951       name = gfc_get_string (PREFIX ("signal_sub_int"));
2952     }
2953   else
2954     name = gfc_get_string (PREFIX ("signal_sub"));
2955
2956   if (number->ts.kind != gfc_c_int_kind)
2957     gfc_convert_type (number, &ts, 2);
2958   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2959     gfc_convert_type (status, &ts, 2);
2960
2961   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2962 }
2963
2964
2965 /* Resolve the SYSTEM intrinsic subroutine.  */
2966
2967 void
2968 gfc_resolve_system_sub (gfc_code *c)
2969 {
2970   const char *name;
2971   name = gfc_get_string (PREFIX ("system_sub"));
2972   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2973 }
2974
2975
2976 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2977
2978 void
2979 gfc_resolve_system_clock (gfc_code *c)
2980 {
2981   const char *name;
2982   int kind;
2983
2984   if (c->ext.actual->expr != NULL)
2985     kind = c->ext.actual->expr->ts.kind;
2986   else if (c->ext.actual->next->expr != NULL)
2987       kind = c->ext.actual->next->expr->ts.kind;
2988   else if (c->ext.actual->next->next->expr != NULL)
2989       kind = c->ext.actual->next->next->expr->ts.kind;
2990   else
2991     kind = gfc_default_integer_kind;
2992
2993   name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
2994   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2995 }
2996
2997
2998 /* Resolve the EXIT intrinsic subroutine.  */
2999
3000 void
3001 gfc_resolve_exit (gfc_code *c)
3002 {
3003   const char *name;
3004   gfc_typespec ts;
3005   gfc_expr *n;
3006   gfc_clear_ts (&ts);
3007
3008   /* The STATUS argument has to be of default kind.  If it is not,
3009      we convert it.  */
3010   ts.type = BT_INTEGER;
3011   ts.kind = gfc_default_integer_kind;
3012   n = c->ext.actual->expr;
3013   if (n != NULL && n->ts.kind != ts.kind)
3014     gfc_convert_type (n, &ts, 2);
3015
3016   name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3017   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3018 }
3019
3020
3021 /* Resolve the FLUSH intrinsic subroutine.  */
3022
3023 void
3024 gfc_resolve_flush (gfc_code *c)
3025 {
3026   const char *name;
3027   gfc_typespec ts;
3028   gfc_expr *n;
3029   gfc_clear_ts (&ts);
3030
3031   ts.type = BT_INTEGER;
3032   ts.kind = gfc_default_integer_kind;
3033   n = c->ext.actual->expr;
3034   if (n != NULL && n->ts.kind != ts.kind)
3035     gfc_convert_type (n, &ts, 2);
3036
3037   name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3038   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3039 }
3040
3041
3042 void
3043 gfc_resolve_free (gfc_code *c)
3044 {
3045   gfc_typespec ts;
3046   gfc_expr *n;
3047   gfc_clear_ts (&ts);
3048
3049   ts.type = BT_INTEGER;
3050   ts.kind = gfc_index_integer_kind;
3051   n = c->ext.actual->expr;
3052   if (n->ts.kind != ts.kind)
3053     gfc_convert_type (n, &ts, 2);
3054
3055   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3056 }
3057
3058
3059 void
3060 gfc_resolve_ctime_sub (gfc_code *c)
3061 {
3062   gfc_typespec ts;
3063   gfc_clear_ts (&ts);
3064
3065   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3066   if (c->ext.actual->expr->ts.kind != 8)
3067     {
3068       ts.type = BT_INTEGER;
3069       ts.kind = 8;
3070       ts.derived = NULL;
3071       ts.cl = NULL;
3072       gfc_convert_type (c->ext.actual->expr, &ts, 2);
3073     }
3074
3075   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3076 }
3077
3078
3079 void
3080 gfc_resolve_fdate_sub (gfc_code *c)
3081 {
3082   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3083 }
3084
3085
3086 void
3087 gfc_resolve_gerror (gfc_code *c)
3088 {
3089   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3090 }
3091
3092
3093 void
3094 gfc_resolve_getlog (gfc_code *c)
3095 {
3096   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3097 }
3098
3099
3100 void
3101 gfc_resolve_hostnm_sub (gfc_code *c)
3102 {
3103   const char *name;
3104   int kind;
3105
3106   if (c->ext.actual->next->expr != NULL)
3107     kind = c->ext.actual->next->expr->ts.kind;
3108   else
3109     kind = gfc_default_integer_kind;
3110
3111   name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3112   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3113 }
3114
3115
3116 void
3117 gfc_resolve_perror (gfc_code *c)
3118 {
3119   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3120 }
3121
3122 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
3123
3124 void
3125 gfc_resolve_stat_sub (gfc_code *c)
3126 {
3127   const char *name;
3128   name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3129   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3130 }
3131
3132
3133 void
3134 gfc_resolve_lstat_sub (gfc_code *c)
3135 {
3136   const char *name;
3137   name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3138   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3139 }
3140
3141
3142 void
3143 gfc_resolve_fstat_sub (gfc_code *c)
3144 {
3145   const char *name;
3146   gfc_expr *u;
3147   gfc_typespec *ts;
3148
3149   u = c->ext.actual->expr;
3150   ts = &c->ext.actual->next->expr->ts;
3151   if (u->ts.kind != ts->kind)
3152     gfc_convert_type (u, ts, 2);
3153   name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3154   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3155 }
3156
3157
3158 void
3159 gfc_resolve_fgetc_sub (gfc_code *c)
3160 {
3161   const char *name;
3162   gfc_typespec ts;
3163   gfc_expr *u, *st;
3164   gfc_clear_ts (&ts);
3165
3166   u = c->ext.actual->expr;
3167   st = c->ext.actual->next->next->expr;
3168
3169   if (u->ts.kind != gfc_c_int_kind)
3170     {
3171       ts.type = BT_INTEGER;
3172       ts.kind = gfc_c_int_kind;
3173       ts.derived = NULL;
3174       ts.cl = NULL;
3175       gfc_convert_type (u, &ts, 2);
3176     }
3177
3178   if (st != NULL)
3179     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3180   else
3181     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3182
3183   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3184 }
3185
3186
3187 void
3188 gfc_resolve_fget_sub (gfc_code *c)
3189 {
3190   const char *name;
3191   gfc_expr *st;
3192
3193   st = c->ext.actual->next->expr;
3194   if (st != NULL)
3195     name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3196   else
3197     name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3198
3199   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3200 }
3201
3202
3203 void
3204 gfc_resolve_fputc_sub (gfc_code *c)
3205 {
3206   const char *name;
3207   gfc_typespec ts;
3208   gfc_expr *u, *st;
3209   gfc_clear_ts (&ts);
3210
3211   u = c->ext.actual->expr;
3212   st = c->ext.actual->next->next->expr;
3213
3214   if (u->ts.kind != gfc_c_int_kind)
3215     {
3216       ts.type = BT_INTEGER;
3217       ts.kind = gfc_c_int_kind;
3218       ts.derived = NULL;
3219       ts.cl = NULL;
3220       gfc_convert_type (u, &ts, 2);
3221     }
3222
3223   if (st != NULL)
3224     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3225   else
3226     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3227
3228   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3229 }
3230
3231
3232 void
3233 gfc_resolve_fput_sub (gfc_code *c)
3234 {
3235   const char *name;
3236   gfc_expr *st;
3237
3238   st = c->ext.actual->next->expr;
3239   if (st != NULL)
3240     name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3241   else
3242     name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3243
3244   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3245 }
3246
3247
3248 void
3249 gfc_resolve_fseek_sub (gfc_code *c)
3250 {
3251   gfc_expr *unit;
3252   gfc_expr *offset;
3253   gfc_expr *whence;
3254   gfc_expr *status;
3255   gfc_typespec ts;
3256   gfc_clear_ts (&ts);
3257
3258   unit   = c->ext.actual->expr;
3259   offset = c->ext.actual->next->expr;
3260   whence = c->ext.actual->next->next->expr;
3261   status = c->ext.actual->next->next->next->expr;
3262
3263   if (unit->ts.kind != gfc_c_int_kind)
3264     {
3265       ts.type = BT_INTEGER;
3266       ts.kind = gfc_c_int_kind;
3267       ts.derived = NULL;
3268       ts.cl = NULL;
3269       gfc_convert_type (unit, &ts, 2);
3270     }
3271
3272   if (offset->ts.kind != gfc_intio_kind)
3273     {
3274       ts.type = BT_INTEGER;
3275       ts.kind = gfc_intio_kind;
3276       ts.derived = NULL;
3277       ts.cl = NULL;
3278       gfc_convert_type (offset, &ts, 2);
3279     }
3280
3281   if (whence->ts.kind != gfc_c_int_kind)
3282     {
3283       ts.type = BT_INTEGER;
3284       ts.kind = gfc_c_int_kind;
3285       ts.derived = NULL;
3286       ts.cl = NULL;
3287       gfc_convert_type (whence, &ts, 2);
3288     }
3289
3290   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3291 }
3292
3293 void
3294 gfc_resolve_ftell_sub (gfc_code *c)
3295 {
3296   const char *name;
3297   gfc_expr *unit;
3298   gfc_expr *offset;
3299   gfc_typespec ts;
3300   gfc_clear_ts (&ts);
3301
3302   unit = c->ext.actual->expr;
3303   offset = c->ext.actual->next->expr;
3304
3305   if (unit->ts.kind != gfc_c_int_kind)
3306     {
3307       ts.type = BT_INTEGER;
3308       ts.kind = gfc_c_int_kind;
3309       ts.derived = NULL;
3310       ts.cl = NULL;
3311       gfc_convert_type (unit, &ts, 2);
3312     }
3313
3314   name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3315   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3316 }
3317
3318
3319 void
3320 gfc_resolve_ttynam_sub (gfc_code *c)
3321 {
3322   gfc_typespec ts;
3323   gfc_clear_ts (&ts);
3324
3325   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3326     {
3327       ts.type = BT_INTEGER;
3328       ts.kind = gfc_c_int_kind;
3329       ts.derived = NULL;
3330       ts.cl = NULL;
3331       gfc_convert_type (c->ext.actual->expr, &ts, 2);
3332     }
3333
3334   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3335 }
3336
3337
3338 /* Resolve the UMASK intrinsic subroutine.  */
3339
3340 void
3341 gfc_resolve_umask_sub (gfc_code *c)
3342 {
3343   const char *name;
3344   int kind;
3345
3346   if (c->ext.actual->next->expr != NULL)
3347     kind = c->ext.actual->next->expr->ts.kind;
3348   else
3349     kind = gfc_default_integer_kind;
3350
3351   name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3352   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3353 }
3354
3355 /* Resolve the UNLINK intrinsic subroutine.  */
3356
3357 void
3358 gfc_resolve_unlink_sub (gfc_code *c)
3359 {
3360   const char *name;
3361   int kind;
3362
3363   if (c->ext.actual->next->expr != NULL)
3364     kind = c->ext.actual->next->expr->ts.kind;
3365   else
3366     kind = gfc_default_integer_kind;
3367
3368   name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3369   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3370 }