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