gcc/fortran/iresolve.c

   1 /* Intrinsic function resolution.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
   3    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 2, 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 COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23
  24 /* Assign name and types to intrinsic procedures.  For functions, the
  25    first argument to a resolution function is an expression pointer to
  26    the original function node and the rest are pointers to the
  27    arguments of the function call.  For subroutines, a pointer to the
  28    code node is passed.  The result type and library subroutine name
  29    are generally set according to the function arguments.  */
  30
  31 #include "config.h"
  32 #include "system.h"
  33 #include "coretypes.h"
  34 #include "tree.h"
  35 #include "gfortran.h"
  36 #include "intrinsic.h"
  37
  38
  39 /* Given printf-like arguments, return a stable version of the result string.
  40
  41    We already have a working, optimized string hashing table in the form of
  42    the identifier table.  Reusing this table is likely not to be wasted,
  43    since if the function name makes it to the gimple output of the frontend,
  44    we'll have to create the identifier anyway.  */
  45
  46 const char *
  47 gfc_get_string (const char *format, ...)
  48 {
  49   char temp_name[128];
  50   va_list ap;
  51   tree ident;
  52
  53   va_start (ap, format);
  54   vsnprintf (temp_name, sizeof(temp_name), format, ap);
  55   va_end (ap);
  56   temp_name[sizeof(temp_name)-1] = 0;
  57
  58   ident = get_identifier (temp_name);
  59   return IDENTIFIER_POINTER (ident);
  60 }
  61
  62 /********************** Resolution functions **********************/
  63
  64
  65 void
  66 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
  67 {
  68   f->ts = a->ts;
  69   if (f->ts.type == BT_COMPLEX)
  70     f->ts.type = BT_REAL;
  71
  72   f->value.function.name =
  73     gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
  74 }
  75
  76
  77 void
  78 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
  79 {
  80   f->ts = x->ts;
  81   f->value.function.name =
  82     gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
  83 }
  84
  85
  86 void
  87 gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
  88 {
  89   f->ts = x->ts;
  90   f->value.function.name =
  91     gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
  92 }
  93
  94
  95 void
  96 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
  97 {
  98   f->ts.type = BT_REAL;
  99   f->ts.kind = x->ts.kind;
 100   f->value.function.name =
 101     gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 102 }
 103
 104
 105 void
 106 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 107 {
 108   f->ts.type = a->ts.type;
 109   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 110
 111   /* The resolved name is only used for specific intrinsics where
 112      the return kind is the same as the arg kind.  */
 113   f->value.function.name =
 114     gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 115 }
 116
 117
 118 void
 119 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
 120 {
 121   gfc_resolve_aint (f, a, NULL);
 122 }
 123
 124
 125 void
 126 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 127 {
 128   f->ts = mask->ts;
 129
 130   if (dim != NULL)
 131     {
 132       gfc_resolve_dim_arg (dim);
 133       f->rank = mask->rank - 1;
 134       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 135     }
 136
 137   f->value.function.name =
 138     gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
 139                     mask->ts.kind);
 140 }
 141
 142
 143 void
 144 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 145 {
 146   f->ts.type = a->ts.type;
 147   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 148
 149   /* The resolved name is only used for specific intrinsics where
 150      the return kind is the same as the arg kind.  */
 151   f->value.function.name =
 152     gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 153 }
 154
 155
 156 void
 157 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
 158 {
 159   gfc_resolve_anint (f, a, NULL);
 160 }
 161
 162
 163 void
 164 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 165 {
 166   f->ts = mask->ts;
 167
 168   if (dim != NULL)
 169     {
 170       gfc_resolve_dim_arg (dim);
 171       f->rank = mask->rank - 1;
 172       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 173     }
 174
 175   f->value.function.name =
 176     gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
 177                     mask->ts.kind);
 178 }
 179
 180
 181 void
 182 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
 183 {
 184   f->ts = x->ts;
 185   f->value.function.name =
 186     gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 187 }
 188
 189 void
 190 gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
 191 {
 192   f->ts = x->ts;
 193   f->value.function.name =
 194     gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 195 }
 196
 197 void
 198 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
 199 {
 200   f->ts = x->ts;
 201   f->value.function.name =
 202     gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 203 }
 204
 205 void
 206 gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
 207 {
 208   f->ts = x->ts;
 209   f->value.function.name =
 210     gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 211 }
 212
 213 void
 214 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
 215                    gfc_expr * y ATTRIBUTE_UNUSED)
 216 {
 217   f->ts = x->ts;
 218   f->value.function.name =
 219     gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 220 }
 221
 222
 223 /* Resolve the BESYN and BESJN intrinsics.  */
 224
 225 void
 226 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
 227 {
 228   gfc_typespec ts;
 229
 230   f->ts = x->ts;
 231   if (n->ts.kind != gfc_c_int_kind)
 232     {
 233       ts.type = BT_INTEGER;
 234       ts.kind = gfc_c_int_kind;
 235       gfc_convert_type (n, &ts, 2);
 236     }
 237   f->value.function.name = gfc_get_string ("<intrinsic>");
 238 }
 239
 240
 241 void
 242 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
 243 {
 244   f->ts.type = BT_LOGICAL;
 245   f->ts.kind = gfc_default_logical_kind;
 246
 247   f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
 248                                            pos->ts.kind);
 249 }
 250
 251
 252 void
 253 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 254 {
 255   f->ts.type = BT_INTEGER;
 256   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 257     : mpz_get_si (kind->value.integer);
 258
 259   f->value.function.name =
 260     gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
 261                     gfc_type_letter (a->ts.type), a->ts.kind);
 262 }
 263
 264
 265 void
 266 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 267 {
 268   f->ts.type = BT_CHARACTER;
 269   f->ts.kind = (kind == NULL) ? gfc_default_character_kind
 270     : mpz_get_si (kind->value.integer);
 271
 272   f->value.function.name =
 273     gfc_get_string ("__char_%d_%c%d", f->ts.kind,
 274                     gfc_type_letter (a->ts.type), a->ts.kind);
 275 }
 276
 277
 278 void
 279 gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
 280 {
 281   f->ts.type = BT_INTEGER;
 282   f->ts.kind = gfc_default_integer_kind;
 283   f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
 284 }
 285
 286
 287 void
 288 gfc_resolve_chdir_sub (gfc_code * c)
 289 {
 290   const char *name;
 291   int kind;
 292
 293   if (c->ext.actual->next->expr != NULL)
 294     kind = c->ext.actual->next->expr->ts.kind;
 295   else
 296     kind = gfc_default_integer_kind;
 297
 298   name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
 299   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 300 }
 301
 302
 303 void
 304 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 305 {
 306   f->ts.type = BT_COMPLEX;
 307   f->ts.kind = (kind == NULL) ? gfc_default_real_kind
 308     : mpz_get_si (kind->value.integer);
 309
 310   if (y == NULL)
 311     f->value.function.name =
 312       gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
 313                       gfc_type_letter (x->ts.type), x->ts.kind);
 314   else
 315     f->value.function.name =
 316       gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
 317                       gfc_type_letter (x->ts.type), x->ts.kind,
 318                       gfc_type_letter (y->ts.type), y->ts.kind);
 319 }
 320
 321 void
 322 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
 323 {
 324   gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
 325 }
 326
 327 void
 328 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
 329 {
 330   f->ts = x->ts;
 331   f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
 332 }
 333
 334
 335 void
 336 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
 337 {
 338   f->ts = x->ts;
 339   f->value.function.name =
 340     gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 341 }
 342
 343
 344 void
 345 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
 346 {
 347   f->ts = x->ts;
 348   f->value.function.name =
 349     gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 350 }
 351
 352
 353 void
 354 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 355 {
 356   f->ts.type = BT_INTEGER;
 357   f->ts.kind = gfc_default_integer_kind;
 358
 359   if (dim != NULL)
 360     {
 361       f->rank = mask->rank - 1;
 362       gfc_resolve_dim_arg (dim);
 363       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 364     }
 365
 366   f->value.function.name =
 367     gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
 368                     gfc_type_letter (mask->ts.type), mask->ts.kind);
 369 }
 370
 371
 372 void
 373 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
 374                     gfc_expr * shift,
 375                     gfc_expr * dim)
 376 {
 377   int n;
 378
 379   f->ts = array->ts;
 380   f->rank = array->rank;
 381   f->shape = gfc_copy_shape (array->shape, array->rank);
 382
 383   if (shift->rank > 0)
 384     n = 1;
 385   else
 386     n = 0;
 387
 388   /* Convert shift to at least gfc_default_integer_kind, so we don't need
 389      kind=1 and kind=2 versions of the library functions.  */
 390   if (shift->ts.kind < gfc_default_integer_kind)
 391     {
 392       gfc_typespec ts;
 393       ts.type = BT_INTEGER;
 394       ts.kind = gfc_default_integer_kind;
 395       gfc_convert_type_warn (shift, &ts, 2, 0);
 396     }
 397
 398   if (dim != NULL)
 399     {
 400       gfc_resolve_dim_arg (dim);
 401       /* Convert dim to shift's kind, so we don't need so many variations.  */
 402       if (dim->ts.kind != shift->ts.kind)
 403         gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 404     }
 405   f->value.function.name =
 406     gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
 407                     array->ts.type == BT_CHARACTER ? "_char" : "");
 408 }
 409
 410
 411 void
 412 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
 413 {
 414   f->ts.type = BT_REAL;
 415   f->ts.kind = gfc_default_double_kind;
 416   f->value.function.name =
 417     gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 418 }
 419
 420
 421 void
 422 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
 423                  gfc_expr * y ATTRIBUTE_UNUSED)
 424 {
 425   f->ts = x->ts;
 426   f->value.function.name =
 427     gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 428 }
 429
 430
 431 void
 432 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 433 {
 434   gfc_expr temp;
 435
 436   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 437     {
 438       f->ts.type = BT_LOGICAL;
 439       f->ts.kind = gfc_default_logical_kind;
 440     }
 441   else
 442     {
 443       temp.expr_type = EXPR_OP;
 444       gfc_clear_ts (&temp.ts);
 445       temp.value.op.operator = INTRINSIC_NONE;
 446       temp.value.op.op1 = a;
 447       temp.value.op.op2 = b;
 448       gfc_type_convert_binary (&temp);
 449       f->ts = temp.ts;
 450     }
 451
 452   f->value.function.name =
 453     gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
 454                     f->ts.kind);
 455 }
 456
 457
 458 void
 459 gfc_resolve_dprod (gfc_expr * f,
 460                    gfc_expr * a ATTRIBUTE_UNUSED,
 461                    gfc_expr * b ATTRIBUTE_UNUSED)
 462 {
 463   f->ts.kind = gfc_default_double_kind;
 464   f->ts.type = BT_REAL;
 465
 466   f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
 467 }
 468
 469
 470 void
 471 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
 472                      gfc_expr * shift,
 473                      gfc_expr * boundary,
 474                      gfc_expr * dim)
 475 {
 476   int n;
 477
 478   f->ts = array->ts;
 479   f->rank = array->rank;
 480   f->shape = gfc_copy_shape (array->shape, array->rank);
 481
 482   n = 0;
 483   if (shift->rank > 0)
 484     n = n | 1;
 485   if (boundary && boundary->rank > 0)
 486     n = n | 2;
 487
 488   /* Convert shift to at least gfc_default_integer_kind, so we don't need
 489      kind=1 and kind=2 versions of the library functions.  */
 490   if (shift->ts.kind < gfc_default_integer_kind)
 491     {
 492       gfc_typespec ts;
 493       ts.type = BT_INTEGER;
 494       ts.kind = gfc_default_integer_kind;
 495       gfc_convert_type_warn (shift, &ts, 2, 0);
 496     }
 497
 498   if (dim != NULL)
 499     {
 500       gfc_resolve_dim_arg (dim);
 501       /* Convert dim to shift's kind, so we don't need so many variations.  */
 502       if (dim->ts.kind != shift->ts.kind)
 503         gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 504     }
 505
 506   f->value.function.name =
 507     gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
 508                     array->ts.type == BT_CHARACTER ? "_char" : "");
 509 }
 510
 511
 512 void
 513 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
 514 {
 515   f->ts = x->ts;
 516   f->value.function.name =
 517     gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 518 }
 519
 520
 521 void
 522 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
 523 {
 524   f->ts.type = BT_INTEGER;
 525   f->ts.kind = gfc_default_integer_kind;
 526
 527   f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
 528 }
 529
 530
 531 void
 532 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 533 {
 534   f->ts.type = BT_INTEGER;
 535   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 536     : mpz_get_si (kind->value.integer);
 537
 538   f->value.function.name =
 539     gfc_get_string ("__floor%d_%c%d", f->ts.kind,
 540                     gfc_type_letter (a->ts.type), a->ts.kind);
 541 }
 542
 543
 544 void
 545 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
 546 {
 547   f->ts.type = BT_INTEGER;
 548   f->ts.kind = gfc_default_integer_kind;
 549   if (n->ts.kind != f->ts.kind)
 550     gfc_convert_type (n, &f->ts, 2);
 551   f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
 552 }
 553
 554
 555 void
 556 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
 557 {
 558   f->ts = x->ts;
 559   f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
 560 }
 561
 562
 563 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
 564
 565 void
 566 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
 567 {
 568   f->ts = x->ts;
 569   f->value.function.name = gfc_get_string ("<intrinsic>");
 570 }
 571
 572
 573 void
 574 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
 575 {
 576   f->ts.type = BT_INTEGER;
 577   f->ts.kind = 4;
 578   f->value.function.name = gfc_get_string (PREFIX("getcwd"));
 579 }
 580
 581
 582 void
 583 gfc_resolve_getgid (gfc_expr * f)
 584 {
 585   f->ts.type = BT_INTEGER;
 586   f->ts.kind = 4;
 587   f->value.function.name = gfc_get_string (PREFIX("getgid"));
 588 }
 589
 590
 591 void
 592 gfc_resolve_getpid (gfc_expr * f)
 593 {
 594   f->ts.type = BT_INTEGER;
 595   f->ts.kind = 4;
 596   f->value.function.name = gfc_get_string (PREFIX("getpid"));
 597 }
 598
 599
 600 void
 601 gfc_resolve_getuid (gfc_expr * f)
 602 {
 603   f->ts.type = BT_INTEGER;
 604   f->ts.kind = 4;
 605   f->value.function.name = gfc_get_string (PREFIX("getuid"));
 606 }
 607
 608 void
 609 gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
 610 {
 611   f->ts.type = BT_INTEGER;
 612   f->ts.kind = 4;
 613   f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
 614 }
 615
 616 void
 617 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 618 {
 619   /* If the kind of i and j are different, then g77 cross-promoted the
 620      kinds to the largest value.  The Fortran 95 standard requires the
 621      kinds to match.  */
 622   if (i->ts.kind != j->ts.kind)
 623     {
 624       if (i->ts.kind == gfc_kind_max (i,j))
 625         gfc_convert_type(j, &i->ts, 2);
 626       else
 627         gfc_convert_type(i, &j->ts, 2);
 628     }
 629
 630   f->ts = i->ts;
 631   f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
 632 }
 633
 634
 635 void
 636 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
 637 {
 638   f->ts = i->ts;
 639   f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
 640 }
 641
 642
 643 void
 644 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
 645                    gfc_expr * pos ATTRIBUTE_UNUSED,
 646                    gfc_expr * len ATTRIBUTE_UNUSED)
 647 {
 648   f->ts = i->ts;
 649   f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
 650 }
 651
 652
 653 void
 654 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
 655                    gfc_expr * pos ATTRIBUTE_UNUSED)
 656 {
 657   f->ts = i->ts;
 658   f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
 659 }
 660
 661
 662 void
 663 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
 664 {
 665   f->ts.type = BT_INTEGER;
 666   f->ts.kind = gfc_default_integer_kind;
 667
 668   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 669 }
 670
 671
 672 void
 673 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
 674 {
 675   gfc_resolve_nint (f, a, NULL);
 676 }
 677
 678
 679 void
 680 gfc_resolve_ierrno (gfc_expr * f)
 681 {
 682   f->ts.type = BT_INTEGER;
 683   f->ts.kind = gfc_default_integer_kind;
 684   f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
 685 }
 686
 687
 688 void
 689 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 690 {
 691   /* If the kind of i and j are different, then g77 cross-promoted the
 692      kinds to the largest value.  The Fortran 95 standard requires the
 693      kinds to match.  */
 694   if (i->ts.kind != j->ts.kind)
 695     {
 696       if (i->ts.kind == gfc_kind_max (i,j))
 697         gfc_convert_type(j, &i->ts, 2);
 698       else
 699         gfc_convert_type(i, &j->ts, 2);
 700     }
 701
 702   f->ts = i->ts;
 703   f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
 704 }
 705
 706
 707 void
 708 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 709 {
 710   /* If the kind of i and j are different, then g77 cross-promoted the
 711      kinds to the largest value.  The Fortran 95 standard requires the
 712      kinds to match.  */
 713   if (i->ts.kind != j->ts.kind)
 714     {
 715       if (i->ts.kind == gfc_kind_max (i,j))
 716         gfc_convert_type(j, &i->ts, 2);
 717       else
 718         gfc_convert_type(i, &j->ts, 2);
 719     }
 720
 721   f->ts = i->ts;
 722   f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
 723 }
 724
 725
 726 void
 727 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 728 {
 729   f->ts.type = BT_INTEGER;
 730   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 731     : mpz_get_si (kind->value.integer);
 732
 733   f->value.function.name =
 734     gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
 735                     a->ts.kind);
 736 }
 737
 738
 739 void
 740 gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
 741 {
 742   gfc_typespec ts;
 743
 744   f->ts.type = BT_LOGICAL;
 745   f->ts.kind = gfc_default_integer_kind;
 746   if (u->ts.kind != gfc_c_int_kind)
 747     {
 748       ts.type = BT_INTEGER;
 749       ts.kind = gfc_c_int_kind;
 750       ts.derived = NULL;
 751       ts.cl = NULL;
 752       gfc_convert_type (u, &ts, 2);
 753     }
 754
 755   f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
 756 }
 757
 758
 759 void
 760 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
 761 {
 762   f->ts = i->ts;
 763   f->value.function.name =
 764     gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
 765 }
 766
 767
 768 void
 769 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
 770                     gfc_expr * size)
 771 {
 772   int s_kind;
 773
 774   s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
 775
 776   f->ts = i->ts;
 777   f->value.function.name =
 778     gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
 779 }
 780
 781
 782 void
 783 gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
 784                   ATTRIBUTE_UNUSED gfc_expr * s)
 785 {
 786   f->ts.type = BT_INTEGER;
 787   f->ts.kind = gfc_default_integer_kind;
 788
 789   f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
 790 }
 791
 792
 793 void
 794 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
 795                     gfc_expr * dim)
 796 {
 797   static char lbound[] = "__lbound";
 798
 799   f->ts.type = BT_INTEGER;
 800   f->ts.kind = gfc_default_integer_kind;
 801
 802   if (dim == NULL)
 803     {
 804       f->rank = 1;
 805       f->shape = gfc_get_shape (1);
 806       mpz_init_set_ui (f->shape[0], array->rank);
 807     }
 808
 809   f->value.function.name = lbound;
 810 }
 811
 812
 813 void
 814 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
 815 {
 816   f->ts.type = BT_INTEGER;
 817   f->ts.kind = gfc_default_integer_kind;
 818   f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
 819 }
 820
 821
 822 void
 823 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
 824 {
 825   f->ts.type = BT_INTEGER;
 826   f->ts.kind = gfc_default_integer_kind;
 827   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
 828 }
 829
 830
 831 void
 832 gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
 833                   gfc_expr * p2 ATTRIBUTE_UNUSED)
 834 {
 835   f->ts.type = BT_INTEGER;
 836   f->ts.kind = gfc_default_integer_kind;
 837   f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
 838 }
 839
 840
 841 void
 842 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
 843 {
 844   f->ts = x->ts;
 845   f->value.function.name =
 846     gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 847 }
 848
 849
 850 void
 851 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
 852 {
 853   f->ts = x->ts;
 854   f->value.function.name =
 855     gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 856 }
 857
 858
 859 void
 860 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 861 {
 862   f->ts.type = BT_LOGICAL;
 863   f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
 864     : mpz_get_si (kind->value.integer);
 865   f->rank = a->rank;
 866
 867   f->value.function.name =
 868     gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
 869                     gfc_type_letter (a->ts.type), a->ts.kind);
 870 }
 871
 872
 873 void
 874 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 875 {
 876   gfc_expr temp;
 877
 878   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 879     {
 880       f->ts.type = BT_LOGICAL;
 881       f->ts.kind = gfc_default_logical_kind;
 882     }
 883   else
 884     {
 885       temp.expr_type = EXPR_OP;
 886       gfc_clear_ts (&temp.ts);
 887       temp.value.op.operator = INTRINSIC_NONE;
 888       temp.value.op.op1 = a;
 889       temp.value.op.op2 = b;
 890       gfc_type_convert_binary (&temp);
 891       f->ts = temp.ts;
 892     }
 893
 894   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
 895
 896   f->value.function.name =
 897     gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
 898                     f->ts.kind);
 899 }
 900
 901
 902 static void
 903 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
 904 {
 905   gfc_actual_arglist *a;
 906
 907   f->ts.type = args->expr->ts.type;
 908   f->ts.kind = args->expr->ts.kind;
 909   /* Find the largest type kind.  */
 910   for (a = args->next; a; a = a->next)
 911     {
 912       if (a->expr->ts.kind > f->ts.kind)
 913         f->ts.kind = a->expr->ts.kind;
 914     }
 915
 916   /* Convert all parameters to the required kind.  */
 917   for (a = args; a; a = a->next)
 918     {
 919       if (a->expr->ts.kind != f->ts.kind)
 920         gfc_convert_type (a->expr, &f->ts, 2);
 921     }
 922
 923   f->value.function.name =
 924     gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
 925 }
 926
 927
 928 void
 929 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
 930 {
 931   gfc_resolve_minmax ("__max_%c%d", f, args);
 932 }
 933
 934
 935 void
 936 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 937                     gfc_expr * mask)
 938 {
 939   const char *name;
 940
 941   f->ts.type = BT_INTEGER;
 942   f->ts.kind = gfc_default_integer_kind;
 943
 944   if (dim == NULL)
 945     f->rank = 1;
 946   else
 947     {
 948       f->rank = array->rank - 1;
 949       gfc_resolve_dim_arg (dim);
 950     }
 951
 952   name = mask ? "mmaxloc" : "maxloc";
 953   f->value.function.name =
 954     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
 955                     gfc_type_letter (array->ts.type), array->ts.kind);
 956 }
 957
 958
 959 void
 960 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 961                     gfc_expr * mask)
 962 {
 963   f->ts = array->ts;
 964
 965   if (dim != NULL)
 966     {
 967       f->rank = array->rank - 1;
 968       gfc_resolve_dim_arg (dim);
 969     }
 970
 971   f->value.function.name =
 972     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
 973                     gfc_type_letter (array->ts.type), array->ts.kind);
 974 }
 975
 976
 977 void
 978 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
 979                    gfc_expr * fsource ATTRIBUTE_UNUSED,
 980                    gfc_expr * mask ATTRIBUTE_UNUSED)
 981 {
 982   f->ts = tsource->ts;
 983   f->value.function.name =
 984     gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
 985                     tsource->ts.kind);
 986 }
 987
 988
 989 void
 990 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
 991 {
 992   gfc_resolve_minmax ("__min_%c%d", f, args);
 993 }
 994
 995
 996 void
 997 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 998                     gfc_expr * mask)
 999 {
1000   const char *name;
1001
1002   f->ts.type = BT_INTEGER;
1003   f->ts.kind = gfc_default_integer_kind;
1004
1005   if (dim == NULL)
1006     f->rank = 1;
1007   else
1008     {
1009       f->rank = array->rank - 1;
1010       gfc_resolve_dim_arg (dim);
1011     }
1012
1013   name = mask ? "mminloc" : "minloc";
1014   f->value.function.name =
1015     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1016                     gfc_type_letter (array->ts.type), array->ts.kind);
1017 }
1018
1019
1020 void
1021 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1022                     gfc_expr * mask)
1023 {
1024   f->ts = array->ts;
1025
1026   if (dim != NULL)
1027     {
1028       f->rank = array->rank - 1;
1029       gfc_resolve_dim_arg (dim);
1030     }
1031
1032   f->value.function.name =
1033     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
1034                     gfc_type_letter (array->ts.type), array->ts.kind);
1035 }
1036
1037
1038 void
1039 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
1040                  gfc_expr * p ATTRIBUTE_UNUSED)
1041 {
1042   f->ts = a->ts;
1043   f->value.function.name =
1044     gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1045 }
1046
1047
1048 void
1049 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
1050                     gfc_expr * p ATTRIBUTE_UNUSED)
1051 {
1052   f->ts = a->ts;
1053   f->value.function.name =
1054     gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
1055                     a->ts.kind);
1056 }
1057
1058 void
1059 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1060 {
1061   f->ts = a->ts;
1062   f->value.function.name =
1063     gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1064             a->ts.kind);
1065 }
1066
1067 void
1068 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1069 {
1070   f->ts.type = BT_INTEGER;
1071   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1072     : mpz_get_si (kind->value.integer);
1073
1074   f->value.function.name =
1075     gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1076 }
1077
1078
1079 void
1080 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1081 {
1082   f->ts = i->ts;
1083   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1084 }
1085
1086
1087 void
1088 gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
1089                   gfc_expr * vector ATTRIBUTE_UNUSED)
1090 {
1091   f->ts = array->ts;
1092   f->rank = 1;
1093
1094   if (mask->rank != 0)
1095     f->value.function.name = (array->ts.type == BT_CHARACTER
1096                               ? PREFIX("pack_char")
1097                               : PREFIX("pack"));
1098   else
1099     {
1100       /* We convert mask to default logical only in the scalar case.
1101          In the array case we can simply read the array as if it were
1102          of type default logical.  */
1103       if (mask->ts.kind != gfc_default_logical_kind)
1104         {
1105           gfc_typespec ts;
1106
1107           ts.type = BT_LOGICAL;
1108           ts.kind = gfc_default_logical_kind;
1109           gfc_convert_type (mask, &ts, 2);
1110         }
1111
1112       f->value.function.name = (array->ts.type == BT_CHARACTER
1113                                 ? PREFIX("pack_s_char")
1114                                 : PREFIX("pack_s"));
1115     }
1116 }
1117
1118
1119 void
1120 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1121                      gfc_expr * mask)
1122 {
1123   f->ts = array->ts;
1124
1125   if (dim != NULL)
1126     {
1127       f->rank = array->rank - 1;
1128       gfc_resolve_dim_arg (dim);
1129     }
1130
1131   f->value.function.name =
1132     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1133                     gfc_type_letter (array->ts.type), array->ts.kind);
1134 }
1135
1136
1137 void
1138 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1139 {
1140   f->ts.type = BT_REAL;
1141
1142   if (kind != NULL)
1143     f->ts.kind = mpz_get_si (kind->value.integer);
1144   else
1145     f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1146       a->ts.kind : gfc_default_real_kind;
1147
1148   f->value.function.name =
1149     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1150                     gfc_type_letter (a->ts.type), a->ts.kind);
1151 }
1152
1153
1154 void
1155 gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
1156 {
1157   f->ts.type = BT_REAL;
1158   f->ts.kind = a->ts.kind;
1159   f->value.function.name =
1160     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1161                     gfc_type_letter (a->ts.type), a->ts.kind);
1162 }
1163
1164
1165 void
1166 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1167                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1168 {
1169   f->ts.type = BT_INTEGER;
1170   f->ts.kind = gfc_default_integer_kind;
1171   f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1172 }
1173
1174
1175 void
1176 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1177                     gfc_expr * ncopies ATTRIBUTE_UNUSED)
1178 {
1179   f->ts.type = BT_CHARACTER;
1180   f->ts.kind = string->ts.kind;
1181   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1182 }
1183
1184
1185 void
1186 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1187                      gfc_expr * pad ATTRIBUTE_UNUSED,
1188                      gfc_expr * order ATTRIBUTE_UNUSED)
1189 {
1190   mpz_t rank;
1191   int kind;
1192   int i;
1193
1194   f->ts = source->ts;
1195
1196   gfc_array_size (shape, &rank);
1197   f->rank = mpz_get_si (rank);
1198   mpz_clear (rank);
1199   switch (source->ts.type)
1200     {
1201     case BT_COMPLEX:
1202       kind = source->ts.kind * 2;
1203       break;
1204
1205     case BT_REAL:
1206     case BT_INTEGER:
1207     case BT_LOGICAL:
1208       kind = source->ts.kind;
1209       break;
1210
1211     default:
1212       kind = 0;
1213       break;
1214     }
1215
1216   switch (kind)
1217     {
1218     case 4:
1219     case 8:
1220     case 10:
1221     case 16:
1222       if (source->ts.type == BT_COMPLEX)
1223         f->value.function.name =
1224           gfc_get_string (PREFIX("reshape_%c%d"),
1225                           gfc_type_letter (BT_COMPLEX), source->ts.kind);
1226       else
1227         f->value.function.name =
1228           gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1229
1230       break;
1231
1232     default:
1233       f->value.function.name = (source->ts.type == BT_CHARACTER
1234                                 ? PREFIX("reshape_char")
1235                                 : PREFIX("reshape"));
1236       break;
1237     }
1238
1239   /* TODO: Make this work with a constant ORDER parameter.  */
1240   if (shape->expr_type == EXPR_ARRAY
1241       && gfc_is_constant_expr (shape)
1242       && order == NULL)
1243     {
1244       gfc_constructor *c;
1245       f->shape = gfc_get_shape (f->rank);
1246       c = shape->value.constructor;
1247       for (i = 0; i < f->rank; i++)
1248         {
1249           mpz_init_set (f->shape[i], c->expr->value.integer);
1250           c = c->next;
1251         }
1252     }
1253
1254   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1255      so many runtime variations.  */
1256   if (shape->ts.kind != gfc_index_integer_kind)
1257     {
1258       gfc_typespec ts = shape->ts;
1259       ts.kind = gfc_index_integer_kind;
1260       gfc_convert_type_warn (shape, &ts, 2, 0);
1261     }
1262   if (order && order->ts.kind != gfc_index_integer_kind)
1263     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1264 }
1265
1266
1267 void
1268 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1269 {
1270   f->ts = x->ts;
1271   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1272 }
1273
1274
1275 void
1276 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1277 {
1278   f->ts = x->ts;
1279
1280   /* The implementation calls scalbn which takes an int as the
1281      second argument.  */
1282   if (i->ts.kind != gfc_c_int_kind)
1283     {
1284       gfc_typespec ts;
1285
1286       ts.type = BT_INTEGER;
1287       ts.kind = gfc_default_integer_kind;
1288
1289       gfc_convert_type_warn (i, &ts, 2, 0);
1290     }
1291
1292   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1293 }
1294
1295
1296 void
1297 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1298                   gfc_expr * set ATTRIBUTE_UNUSED,
1299                   gfc_expr * back ATTRIBUTE_UNUSED)
1300 {
1301   f->ts.type = BT_INTEGER;
1302   f->ts.kind = gfc_default_integer_kind;
1303   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1304 }
1305
1306
1307 void
1308 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1309 {
1310   f->ts = x->ts;
1311
1312   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1313      convert type so we don't have to implement all possible
1314      permutations.  */
1315   if (i->ts.kind != 4)
1316     {
1317       gfc_typespec ts;
1318
1319       ts.type = BT_INTEGER;
1320       ts.kind = gfc_default_integer_kind;
1321
1322       gfc_convert_type_warn (i, &ts, 2, 0);
1323     }
1324
1325   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1326 }
1327
1328
1329 void
1330 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1331 {
1332   f->ts.type = BT_INTEGER;
1333   f->ts.kind = gfc_default_integer_kind;
1334   f->rank = 1;
1335   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1336   f->shape = gfc_get_shape (1);
1337   mpz_init_set_ui (f->shape[0], array->rank);
1338 }
1339
1340
1341 void
1342 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1343 {
1344   f->ts = a->ts;
1345   f->value.function.name =
1346     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1347 }
1348
1349
1350 void
1351 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1352 {
1353   f->ts = x->ts;
1354   f->value.function.name =
1355     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1356 }
1357
1358
1359 void
1360 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1361 {
1362   f->ts = x->ts;
1363   f->value.function.name =
1364     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1365 }
1366
1367
1368 void
1369 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1370 {
1371   f->ts = x->ts;
1372   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1373 }
1374
1375
1376 void
1377 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1378                     gfc_expr * dim,
1379                     gfc_expr * ncopies)
1380 {
1381   f->ts = source->ts;
1382   f->rank = source->rank + 1;
1383   f->value.function.name = (source->ts.type == BT_CHARACTER
1384                             ? PREFIX("spread_char")
1385                             : PREFIX("spread"));
1386
1387   gfc_resolve_dim_arg (dim);
1388   gfc_resolve_index (ncopies, 1);
1389 }
1390
1391
1392 void
1393 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1394 {
1395   f->ts = x->ts;
1396   f->value.function.name =
1397     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1398 }
1399
1400
1401 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1402
1403 void
1404 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1405                   gfc_expr * a ATTRIBUTE_UNUSED)
1406 {
1407   f->ts.type = BT_INTEGER;
1408   f->ts.kind = gfc_default_integer_kind;
1409   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1410 }
1411
1412
1413 void
1414 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1415 {
1416   f->ts.type = BT_INTEGER;
1417   f->ts.kind = gfc_default_integer_kind;
1418   if (n->ts.kind != f->ts.kind)
1419     gfc_convert_type (n, &f->ts, 2);
1420
1421   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1422 }
1423
1424
1425 void
1426 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1427                  gfc_expr * mask)
1428 {
1429   f->ts = array->ts;
1430
1431   if (dim != NULL)
1432     {
1433       f->rank = array->rank - 1;
1434       gfc_resolve_dim_arg (dim);
1435     }
1436
1437   f->value.function.name =
1438     gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1439                     gfc_type_letter (array->ts.type), array->ts.kind);
1440 }
1441
1442
1443 void
1444 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1445                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1446 {
1447   f->ts.type = BT_INTEGER;
1448   f->ts.kind = gfc_default_integer_kind;
1449   f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1450 }
1451
1452
1453 /* Resolve the g77 compatibility function SYSTEM.  */
1454
1455 void
1456 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1457 {
1458   f->ts.type = BT_INTEGER;
1459   f->ts.kind = 4;
1460   f->value.function.name = gfc_get_string (PREFIX("system"));
1461 }
1462
1463
1464 void
1465 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1466 {
1467   f->ts = x->ts;
1468   f->value.function.name =
1469     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1470 }
1471
1472
1473 void
1474 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1475 {
1476   f->ts = x->ts;
1477   f->value.function.name =
1478     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1479 }
1480
1481
1482 void
1483 gfc_resolve_time (gfc_expr * f)
1484 {
1485   f->ts.type = BT_INTEGER;
1486   f->ts.kind = 4;
1487   f->value.function.name = gfc_get_string (PREFIX("time_func"));
1488 }
1489
1490
1491 void
1492 gfc_resolve_time8 (gfc_expr * f)
1493 {
1494   f->ts.type = BT_INTEGER;
1495   f->ts.kind = 8;
1496   f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1497 }
1498
1499
1500 void
1501 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1502                       gfc_expr * mold, gfc_expr * size)
1503 {
1504   /* TODO: Make this do something meaningful.  */
1505   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1506
1507   f->ts = mold->ts;
1508
1509   if (size == NULL && mold->rank == 0)
1510     {
1511       f->rank = 0;
1512       f->value.function.name = transfer0;
1513     }
1514   else
1515     {
1516       f->rank = 1;
1517       f->value.function.name = transfer1;
1518     }
1519 }
1520
1521
1522 void
1523 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1524 {
1525   int kind;
1526
1527   f->ts = matrix->ts;
1528   f->rank = 2;
1529   if (matrix->shape)
1530     {
1531       f->shape = gfc_get_shape (2);
1532       mpz_init_set (f->shape[0], matrix->shape[1]);
1533       mpz_init_set (f->shape[1], matrix->shape[0]);
1534     }
1535
1536   kind = matrix->ts.kind;
1537
1538   switch (kind)
1539     {
1540     case 4:
1541     case 8:
1542     case 10:
1543     case 16:
1544       switch (matrix->ts.type)
1545         {
1546         case BT_COMPLEX:
1547           f->value.function.name =
1548             gfc_get_string (PREFIX("transpose_c%d"), kind);
1549           break;
1550
1551         case BT_INTEGER:
1552         case BT_REAL:
1553         case BT_LOGICAL:
1554           /* Use the integer routines for real and logical cases.  This
1555              assumes they all have the same alignment requirements.  */
1556           f->value.function.name =
1557             gfc_get_string (PREFIX("transpose_i%d"), kind);
1558           break;
1559
1560         default:
1561           f->value.function.name = PREFIX("transpose");
1562           break;
1563         }
1564       break;
1565
1566     default:
1567       f->value.function.name = (matrix->ts.type == BT_CHARACTER
1568                                 ? PREFIX("transpose_char")
1569                                 : PREFIX("transpose"));
1570       break;
1571     }
1572 }
1573
1574
1575 void
1576 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1577 {
1578   f->ts.type = BT_CHARACTER;
1579   f->ts.kind = string->ts.kind;
1580   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1581 }
1582
1583
1584 void
1585 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1586                     gfc_expr * dim)
1587 {
1588   static char ubound[] = "__ubound";
1589
1590   f->ts.type = BT_INTEGER;
1591   f->ts.kind = gfc_default_integer_kind;
1592
1593   if (dim == NULL)
1594     {
1595       f->rank = 1;
1596       f->shape = gfc_get_shape (1);
1597       mpz_init_set_ui (f->shape[0], array->rank);
1598     }
1599
1600   f->value.function.name = ubound;
1601 }
1602
1603
1604 /* Resolve the g77 compatibility function UMASK.  */
1605
1606 void
1607 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1608 {
1609   f->ts.type = BT_INTEGER;
1610   f->ts.kind = n->ts.kind;
1611   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1612 }
1613
1614
1615 /* Resolve the g77 compatibility function UNLINK.  */
1616
1617 void
1618 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1619 {
1620   f->ts.type = BT_INTEGER;
1621   f->ts.kind = 4;
1622   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1623 }
1624
1625 void
1626 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1627                     gfc_expr * field ATTRIBUTE_UNUSED)
1628 {
1629   f->ts = vector->ts;
1630   f->rank = mask->rank;
1631
1632   f->value.function.name =
1633     gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
1634                     vector->ts.type == BT_CHARACTER ? "_char" : "");
1635 }
1636
1637
1638 void
1639 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1640                     gfc_expr * set ATTRIBUTE_UNUSED,
1641                     gfc_expr * back ATTRIBUTE_UNUSED)
1642 {
1643   f->ts.type = BT_INTEGER;
1644   f->ts.kind = gfc_default_integer_kind;
1645   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1646 }
1647
1648
1649 /* Intrinsic subroutine resolution.  */
1650
1651 void
1652 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1653 {
1654   const char *name;
1655
1656   name = gfc_get_string (PREFIX("cpu_time_%d"),
1657                          c->ext.actual->expr->ts.kind);
1658   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1659 }
1660
1661
1662 void
1663 gfc_resolve_mvbits (gfc_code * c)
1664 {
1665   const char *name;
1666   int kind;
1667
1668   kind = c->ext.actual->expr->ts.kind;
1669   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1670
1671   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1672 }
1673
1674
1675 void
1676 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1677 {
1678   const char *name;
1679   int kind;
1680
1681   kind = c->ext.actual->expr->ts.kind;
1682   if (c->ext.actual->expr->rank == 0)
1683     name = gfc_get_string (PREFIX("random_r%d"), kind);
1684   else
1685     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1686
1687   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1688 }
1689
1690
1691 void
1692 gfc_resolve_rename_sub (gfc_code * c)
1693 {
1694   const char *name;
1695   int kind;
1696
1697   if (c->ext.actual->next->next->expr != NULL)
1698     kind = c->ext.actual->next->next->expr->ts.kind;
1699   else
1700     kind = gfc_default_integer_kind;
1701
1702   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
1703   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1704 }
1705
1706
1707 void
1708 gfc_resolve_kill_sub (gfc_code * c)
1709 {
1710   const char *name;
1711   int kind;
1712
1713   if (c->ext.actual->next->next->expr != NULL)
1714     kind = c->ext.actual->next->next->expr->ts.kind;
1715   else
1716     kind = gfc_default_integer_kind;
1717
1718   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
1719   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1720 }
1721
1722
1723 void
1724 gfc_resolve_link_sub (gfc_code * c)
1725 {
1726   const char *name;
1727   int kind;
1728
1729   if (c->ext.actual->next->next->expr != NULL)
1730     kind = c->ext.actual->next->next->expr->ts.kind;
1731   else
1732     kind = gfc_default_integer_kind;
1733
1734   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
1735   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1736 }
1737
1738
1739 void
1740 gfc_resolve_symlnk_sub (gfc_code * c)
1741 {
1742   const char *name;
1743   int kind;
1744
1745   if (c->ext.actual->next->next->expr != NULL)
1746     kind = c->ext.actual->next->next->expr->ts.kind;
1747   else
1748     kind = gfc_default_integer_kind;
1749
1750   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
1751   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1752 }
1753
1754
1755 /* G77 compatibility subroutines etime() and dtime().  */
1756
1757 void
1758 gfc_resolve_etime_sub (gfc_code * c)
1759 {
1760   const char *name;
1761
1762   name = gfc_get_string (PREFIX("etime_sub"));
1763   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1764 }
1765
1766
1767 /* G77 compatibility subroutine second().  */
1768
1769 void
1770 gfc_resolve_second_sub (gfc_code * c)
1771 {
1772   const char *name;
1773
1774   name = gfc_get_string (PREFIX("second_sub"));
1775   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1776 }
1777
1778
1779 void
1780 gfc_resolve_sleep_sub (gfc_code * c)
1781 {
1782   const char *name;
1783   int kind;
1784
1785   if (c->ext.actual->expr != NULL)
1786     kind = c->ext.actual->expr->ts.kind;
1787   else
1788     kind = gfc_default_integer_kind;
1789
1790   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
1791   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1792 }
1793
1794
1795 /* G77 compatibility function srand().  */
1796
1797 void
1798 gfc_resolve_srand (gfc_code * c)
1799 {
1800   const char *name;
1801   name = gfc_get_string (PREFIX("srand"));
1802   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1803 }
1804
1805
1806 /* Resolve the getarg intrinsic subroutine.  */
1807
1808 void
1809 gfc_resolve_getarg (gfc_code * c)
1810 {
1811   const char *name;
1812   int kind;
1813
1814   kind = gfc_default_integer_kind;
1815   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1816   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1817 }
1818
1819 /* Resolve the getcwd intrinsic subroutine.  */
1820
1821 void
1822 gfc_resolve_getcwd_sub (gfc_code * c)
1823 {
1824   const char *name;
1825   int kind;
1826
1827   if (c->ext.actual->next->expr != NULL)
1828     kind = c->ext.actual->next->expr->ts.kind;
1829   else
1830     kind = gfc_default_integer_kind;
1831
1832   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1833   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1834 }
1835
1836
1837 /* Resolve the get_command intrinsic subroutine.  */
1838
1839 void
1840 gfc_resolve_get_command (gfc_code * c)
1841 {
1842   const char *name;
1843   int kind;
1844
1845   kind = gfc_default_integer_kind;
1846   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1847   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1848 }
1849
1850
1851 /* Resolve the get_command_argument intrinsic subroutine.  */
1852
1853 void
1854 gfc_resolve_get_command_argument (gfc_code * c)
1855 {
1856   const char *name;
1857   int kind;
1858
1859   kind = gfc_default_integer_kind;
1860   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1861   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1862 }
1863
1864 /* Resolve the get_environment_variable intrinsic subroutine.  */
1865
1866 void
1867 gfc_resolve_get_environment_variable (gfc_code * code)
1868 {
1869   const char *name;
1870   int kind;
1871
1872   kind = gfc_default_integer_kind;
1873   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1874   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1875 }
1876
1877 /* Resolve the SYSTEM intrinsic subroutine.  */
1878
1879 void
1880 gfc_resolve_system_sub (gfc_code * c)
1881 {
1882   const char *name;
1883
1884   name = gfc_get_string (PREFIX("system_sub"));
1885   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1886 }
1887
1888 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1889
1890 void
1891 gfc_resolve_system_clock (gfc_code * c)
1892 {
1893   const char *name;
1894   int kind;
1895
1896   if (c->ext.actual->expr != NULL)
1897     kind = c->ext.actual->expr->ts.kind;
1898   else if (c->ext.actual->next->expr != NULL)
1899       kind = c->ext.actual->next->expr->ts.kind;
1900   else if (c->ext.actual->next->next->expr != NULL)
1901       kind = c->ext.actual->next->next->expr->ts.kind;
1902   else
1903     kind = gfc_default_integer_kind;
1904
1905   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1906   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1907 }
1908
1909 /* Resolve the EXIT intrinsic subroutine.  */
1910
1911 void
1912 gfc_resolve_exit (gfc_code * c)
1913 {
1914   const char *name;
1915   int kind;
1916
1917   if (c->ext.actual->expr != NULL)
1918     kind = c->ext.actual->expr->ts.kind;
1919   else
1920     kind = gfc_default_integer_kind;
1921
1922   name = gfc_get_string (PREFIX("exit_i%d"), kind);
1923   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1924 }
1925
1926 /* Resolve the FLUSH intrinsic subroutine.  */
1927
1928 void
1929 gfc_resolve_flush (gfc_code * c)
1930 {
1931   const char *name;
1932   gfc_typespec ts;
1933   gfc_expr *n;
1934
1935   ts.type = BT_INTEGER;
1936   ts.kind = gfc_default_integer_kind;
1937   n = c->ext.actual->expr;
1938   if (n != NULL
1939       && n->ts.kind != ts.kind)
1940     gfc_convert_type (n, &ts, 2);
1941
1942   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1943   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1944 }
1945
1946
1947 void
1948 gfc_resolve_gerror (gfc_code * c)
1949 {
1950   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
1951 }
1952
1953
1954 void
1955 gfc_resolve_getlog (gfc_code * c)
1956 {
1957   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
1958 }
1959
1960
1961 void
1962 gfc_resolve_hostnm_sub (gfc_code * c)
1963 {
1964   const char *name;
1965   int kind;
1966
1967   if (c->ext.actual->next->expr != NULL)
1968     kind = c->ext.actual->next->expr->ts.kind;
1969   else
1970     kind = gfc_default_integer_kind;
1971
1972   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
1973   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1974 }
1975
1976
1977 void
1978 gfc_resolve_perror (gfc_code * c)
1979 {
1980   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
1981 }
1982
1983 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
1984
1985 void
1986 gfc_resolve_stat_sub (gfc_code * c)
1987 {
1988   const char *name;
1989
1990   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
1991   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1992 }
1993
1994
1995 void
1996 gfc_resolve_fstat_sub (gfc_code * c)
1997 {
1998   const char *name;
1999   gfc_expr *u;
2000   gfc_typespec *ts;
2001
2002   u = c->ext.actual->expr;
2003   ts = &c->ext.actual->next->expr->ts;
2004   if (u->ts.kind != ts->kind)
2005     gfc_convert_type (u, ts, 2);
2006   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2007   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2008 }
2009
2010
2011 void
2012 gfc_resolve_ttynam_sub (gfc_code * c)
2013 {
2014   gfc_typespec ts;
2015
2016   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2017     {
2018       ts.type = BT_INTEGER;
2019       ts.kind = gfc_c_int_kind;
2020       ts.derived = NULL;
2021       ts.cl = NULL;
2022       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2023     }
2024
2025   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2026 }
2027
2028
2029 /* Resolve the UMASK intrinsic subroutine.  */
2030
2031 void
2032 gfc_resolve_umask_sub (gfc_code * c)
2033 {
2034   const char *name;
2035   int kind;
2036
2037   if (c->ext.actual->next->expr != NULL)
2038     kind = c->ext.actual->next->expr->ts.kind;
2039   else
2040     kind = gfc_default_integer_kind;
2041
2042   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2043   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2044 }
2045
2046 /* Resolve the UNLINK intrinsic subroutine.  */
2047
2048 void
2049 gfc_resolve_unlink_sub (gfc_code * c)
2050 {
2051   const char *name;
2052   int kind;
2053
2054   if (c->ext.actual->next->expr != NULL)
2055     kind = c->ext.actual->next->expr->ts.kind;
2056   else
2057     kind = gfc_default_integer_kind;
2058
2059   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2060   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2061 }