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