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_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1156                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1157 {
1158   f->ts.type = BT_INTEGER;
1159   f->ts.kind = gfc_default_integer_kind;
1160   f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1161 }
1162
1163
1164 void
1165 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1166                     gfc_expr * ncopies ATTRIBUTE_UNUSED)
1167 {
1168   f->ts.type = BT_CHARACTER;
1169   f->ts.kind = string->ts.kind;
1170   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1171 }
1172
1173
1174 void
1175 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1176                      gfc_expr * pad ATTRIBUTE_UNUSED,
1177                      gfc_expr * order ATTRIBUTE_UNUSED)
1178 {
1179   mpz_t rank;
1180   int kind;
1181   int i;
1182
1183   f->ts = source->ts;
1184
1185   gfc_array_size (shape, &rank);
1186   f->rank = mpz_get_si (rank);
1187   mpz_clear (rank);
1188   switch (source->ts.type)
1189     {
1190     case BT_COMPLEX:
1191       kind = source->ts.kind * 2;
1192       break;
1193
1194     case BT_REAL:
1195     case BT_INTEGER:
1196     case BT_LOGICAL:
1197       kind = source->ts.kind;
1198       break;
1199
1200     default:
1201       kind = 0;
1202       break;
1203     }
1204
1205   switch (kind)
1206     {
1207     case 4:
1208     case 8:
1209     /* case 16: */
1210       if (source->ts.type == BT_COMPLEX)
1211         f->value.function.name =
1212           gfc_get_string (PREFIX("reshape_%c%d"),
1213                           gfc_type_letter (BT_COMPLEX), source->ts.kind);
1214       else
1215         f->value.function.name =
1216           gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1217
1218       break;
1219
1220     default:
1221       f->value.function.name = (source->ts.type == BT_CHARACTER
1222                                 ? PREFIX("reshape_char")
1223                                 : PREFIX("reshape"));
1224       break;
1225     }
1226
1227   /* TODO: Make this work with a constant ORDER parameter.  */
1228   if (shape->expr_type == EXPR_ARRAY
1229       && gfc_is_constant_expr (shape)
1230       && order == NULL)
1231     {
1232       gfc_constructor *c;
1233       f->shape = gfc_get_shape (f->rank);
1234       c = shape->value.constructor;
1235       for (i = 0; i < f->rank; i++)
1236         {
1237           mpz_init_set (f->shape[i], c->expr->value.integer);
1238           c = c->next;
1239         }
1240     }
1241
1242   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1243      so many runtime variations.  */
1244   if (shape->ts.kind != gfc_index_integer_kind)
1245     {
1246       gfc_typespec ts = shape->ts;
1247       ts.kind = gfc_index_integer_kind;
1248       gfc_convert_type_warn (shape, &ts, 2, 0);
1249     }
1250   if (order && order->ts.kind != gfc_index_integer_kind)
1251     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1252 }
1253
1254
1255 void
1256 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1257 {
1258   f->ts = x->ts;
1259   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1260 }
1261
1262
1263 void
1264 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1265 {
1266   f->ts = x->ts;
1267
1268   /* The implementation calls scalbn which takes an int as the
1269      second argument.  */
1270   if (i->ts.kind != gfc_c_int_kind)
1271     {
1272       gfc_typespec ts;
1273
1274       ts.type = BT_INTEGER;
1275       ts.kind = gfc_default_integer_kind;
1276
1277       gfc_convert_type_warn (i, &ts, 2, 0);
1278     }
1279
1280   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1281 }
1282
1283
1284 void
1285 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1286                   gfc_expr * set ATTRIBUTE_UNUSED,
1287                   gfc_expr * back ATTRIBUTE_UNUSED)
1288 {
1289   f->ts.type = BT_INTEGER;
1290   f->ts.kind = gfc_default_integer_kind;
1291   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1292 }
1293
1294
1295 void
1296 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1297 {
1298   f->ts = x->ts;
1299
1300   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1301      convert type so we don't have to implement all possible
1302      permutations.  */
1303   if (i->ts.kind != 4)
1304     {
1305       gfc_typespec ts;
1306
1307       ts.type = BT_INTEGER;
1308       ts.kind = gfc_default_integer_kind;
1309
1310       gfc_convert_type_warn (i, &ts, 2, 0);
1311     }
1312
1313   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1314 }
1315
1316
1317 void
1318 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1319 {
1320   f->ts.type = BT_INTEGER;
1321   f->ts.kind = gfc_default_integer_kind;
1322   f->rank = 1;
1323   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1324   f->shape = gfc_get_shape (1);
1325   mpz_init_set_ui (f->shape[0], array->rank);
1326 }
1327
1328
1329 void
1330 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1331 {
1332   f->ts = a->ts;
1333   f->value.function.name =
1334     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1335 }
1336
1337
1338 void
1339 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1340 {
1341   f->ts = x->ts;
1342   f->value.function.name =
1343     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1344 }
1345
1346
1347 void
1348 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1349 {
1350   f->ts = x->ts;
1351   f->value.function.name =
1352     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1353 }
1354
1355
1356 void
1357 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1358 {
1359   f->ts = x->ts;
1360   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1361 }
1362
1363
1364 void
1365 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1366                     gfc_expr * dim,
1367                     gfc_expr * ncopies)
1368 {
1369   f->ts = source->ts;
1370   f->rank = source->rank + 1;
1371   f->value.function.name = (source->ts.type == BT_CHARACTER
1372                             ? PREFIX("spread_char")
1373                             : PREFIX("spread"));
1374
1375   gfc_resolve_dim_arg (dim);
1376   gfc_resolve_index (ncopies, 1);
1377 }
1378
1379
1380 void
1381 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1382 {
1383   f->ts = x->ts;
1384   f->value.function.name =
1385     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1386 }
1387
1388
1389 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1390
1391 void
1392 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1393                   gfc_expr * a ATTRIBUTE_UNUSED)
1394 {
1395   f->ts.type = BT_INTEGER;
1396   f->ts.kind = gfc_default_integer_kind;
1397   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1398 }
1399
1400
1401 void
1402 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1403 {
1404   f->ts.type = BT_INTEGER;
1405   f->ts.kind = gfc_default_integer_kind;
1406   if (n->ts.kind != f->ts.kind)
1407     gfc_convert_type (n, &f->ts, 2);
1408
1409   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1410 }
1411
1412
1413 void
1414 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1415                  gfc_expr * mask)
1416 {
1417   f->ts = array->ts;
1418
1419   if (dim != NULL)
1420     {
1421       f->rank = array->rank - 1;
1422       gfc_resolve_dim_arg (dim);
1423     }
1424
1425   f->value.function.name =
1426     gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1427                     gfc_type_letter (array->ts.type), array->ts.kind);
1428 }
1429
1430
1431 void
1432 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1433                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1434 {
1435   f->ts.type = BT_INTEGER;
1436   f->ts.kind = gfc_default_integer_kind;
1437   f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1438 }
1439
1440
1441 /* Resolve the g77 compatibility function SYSTEM.  */
1442
1443 void
1444 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1445 {
1446   f->ts.type = BT_INTEGER;
1447   f->ts.kind = 4;
1448   f->value.function.name = gfc_get_string (PREFIX("system"));
1449 }
1450
1451
1452 void
1453 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1454 {
1455   f->ts = x->ts;
1456   f->value.function.name =
1457     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1458 }
1459
1460
1461 void
1462 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1463 {
1464   f->ts = x->ts;
1465   f->value.function.name =
1466     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1467 }
1468
1469
1470 void
1471 gfc_resolve_time (gfc_expr * f)
1472 {
1473   f->ts.type = BT_INTEGER;
1474   f->ts.kind = 4;
1475   f->value.function.name = gfc_get_string (PREFIX("time_func"));
1476 }
1477
1478
1479 void
1480 gfc_resolve_time8 (gfc_expr * f)
1481 {
1482   f->ts.type = BT_INTEGER;
1483   f->ts.kind = 8;
1484   f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1485 }
1486
1487
1488 void
1489 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1490                       gfc_expr * mold, gfc_expr * size)
1491 {
1492   /* TODO: Make this do something meaningful.  */
1493   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1494
1495   f->ts = mold->ts;
1496
1497   if (size == NULL && mold->rank == 0)
1498     {
1499       f->rank = 0;
1500       f->value.function.name = transfer0;
1501     }
1502   else
1503     {
1504       f->rank = 1;
1505       f->value.function.name = transfer1;
1506     }
1507 }
1508
1509
1510 void
1511 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1512 {
1513   int kind;
1514
1515   f->ts = matrix->ts;
1516   f->rank = 2;
1517   if (matrix->shape)
1518     {
1519       f->shape = gfc_get_shape (2);
1520       mpz_init_set (f->shape[0], matrix->shape[1]);
1521       mpz_init_set (f->shape[1], matrix->shape[0]);
1522     }
1523
1524   kind = matrix->ts.kind;
1525
1526   switch (kind)
1527     {
1528     case 4:
1529     case 8:
1530       switch (matrix->ts.type)
1531         {
1532         case BT_COMPLEX:
1533           f->value.function.name =
1534             gfc_get_string (PREFIX("transpose_c%d"), kind);
1535           break;
1536
1537         case BT_INTEGER:
1538         case BT_REAL:
1539         case BT_LOGICAL:
1540           /* Use the integer routines for real and logical cases.  This
1541              assumes they all have the same alignment requirements.  */
1542           f->value.function.name =
1543             gfc_get_string (PREFIX("transpose_i%d"), kind);
1544           break;
1545
1546         default:
1547           f->value.function.name = PREFIX("transpose");
1548           break;
1549         }
1550       break;
1551
1552     default:
1553       f->value.function.name = (matrix->ts.type == BT_CHARACTER
1554                                 ? PREFIX("transpose_char")
1555                                 : PREFIX("transpose"));
1556       break;
1557     }
1558 }
1559
1560
1561 void
1562 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1563 {
1564   f->ts.type = BT_CHARACTER;
1565   f->ts.kind = string->ts.kind;
1566   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1567 }
1568
1569
1570 void
1571 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1572                     gfc_expr * dim)
1573 {
1574   static char ubound[] = "__ubound";
1575
1576   f->ts.type = BT_INTEGER;
1577   f->ts.kind = gfc_default_integer_kind;
1578
1579   if (dim == NULL)
1580     {
1581       f->rank = 1;
1582       f->shape = gfc_get_shape (1);
1583       mpz_init_set_ui (f->shape[0], array->rank);
1584     }
1585
1586   f->value.function.name = ubound;
1587 }
1588
1589
1590 /* Resolve the g77 compatibility function UMASK.  */
1591
1592 void
1593 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1594 {
1595   f->ts.type = BT_INTEGER;
1596   f->ts.kind = n->ts.kind;
1597   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1598 }
1599
1600
1601 /* Resolve the g77 compatibility function UNLINK.  */
1602
1603 void
1604 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1605 {
1606   f->ts.type = BT_INTEGER;
1607   f->ts.kind = 4;
1608   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1609 }
1610
1611 void
1612 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1613                     gfc_expr * field ATTRIBUTE_UNUSED)
1614 {
1615   f->ts = vector->ts;
1616   f->rank = mask->rank;
1617
1618   f->value.function.name =
1619     gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
1620                     vector->ts.type == BT_CHARACTER ? "_char" : "");
1621 }
1622
1623
1624 void
1625 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1626                     gfc_expr * set ATTRIBUTE_UNUSED,
1627                     gfc_expr * back ATTRIBUTE_UNUSED)
1628 {
1629   f->ts.type = BT_INTEGER;
1630   f->ts.kind = gfc_default_integer_kind;
1631   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1632 }
1633
1634
1635 /* Intrinsic subroutine resolution.  */
1636
1637 void
1638 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1639 {
1640   const char *name;
1641
1642   name = gfc_get_string (PREFIX("cpu_time_%d"),
1643                          c->ext.actual->expr->ts.kind);
1644   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1645 }
1646
1647
1648 void
1649 gfc_resolve_mvbits (gfc_code * c)
1650 {
1651   const char *name;
1652   int kind;
1653
1654   kind = c->ext.actual->expr->ts.kind;
1655   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1656
1657   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1658 }
1659
1660
1661 void
1662 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1663 {
1664   const char *name;
1665   int kind;
1666
1667   kind = c->ext.actual->expr->ts.kind;
1668   if (c->ext.actual->expr->rank == 0)
1669     name = gfc_get_string (PREFIX("random_r%d"), kind);
1670   else
1671     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1672
1673   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1674 }
1675
1676
1677 void
1678 gfc_resolve_rename_sub (gfc_code * c)
1679 {
1680   const char *name;
1681   int kind;
1682
1683   if (c->ext.actual->next->next->expr != NULL)
1684     kind = c->ext.actual->next->next->expr->ts.kind;
1685   else
1686     kind = gfc_default_integer_kind;
1687
1688   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
1689   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1690 }
1691
1692
1693 void
1694 gfc_resolve_kill_sub (gfc_code * c)
1695 {
1696   const char *name;
1697   int kind;
1698
1699   if (c->ext.actual->next->next->expr != NULL)
1700     kind = c->ext.actual->next->next->expr->ts.kind;
1701   else
1702     kind = gfc_default_integer_kind;
1703
1704   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
1705   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1706 }
1707
1708
1709 void
1710 gfc_resolve_link_sub (gfc_code * c)
1711 {
1712   const char *name;
1713   int kind;
1714
1715   if (c->ext.actual->next->next->expr != NULL)
1716     kind = c->ext.actual->next->next->expr->ts.kind;
1717   else
1718     kind = gfc_default_integer_kind;
1719
1720   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
1721   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1722 }
1723
1724
1725 void
1726 gfc_resolve_symlnk_sub (gfc_code * c)
1727 {
1728   const char *name;
1729   int kind;
1730
1731   if (c->ext.actual->next->next->expr != NULL)
1732     kind = c->ext.actual->next->next->expr->ts.kind;
1733   else
1734     kind = gfc_default_integer_kind;
1735
1736   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
1737   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1738 }
1739
1740
1741 /* G77 compatibility subroutines etime() and dtime().  */
1742
1743 void
1744 gfc_resolve_etime_sub (gfc_code * c)
1745 {
1746   const char *name;
1747
1748   name = gfc_get_string (PREFIX("etime_sub"));
1749   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1750 }
1751
1752
1753 /* G77 compatibility subroutine second().  */
1754
1755 void
1756 gfc_resolve_second_sub (gfc_code * c)
1757 {
1758   const char *name;
1759
1760   name = gfc_get_string (PREFIX("second_sub"));
1761   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1762 }
1763
1764
1765 void
1766 gfc_resolve_sleep_sub (gfc_code * c)
1767 {
1768   const char *name;
1769   int kind;
1770
1771   if (c->ext.actual->expr != NULL)
1772     kind = c->ext.actual->expr->ts.kind;
1773   else
1774     kind = gfc_default_integer_kind;
1775
1776   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
1777   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1778 }
1779
1780
1781 /* G77 compatibility function srand().  */
1782
1783 void
1784 gfc_resolve_srand (gfc_code * c)
1785 {
1786   const char *name;
1787   name = gfc_get_string (PREFIX("srand"));
1788   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1789 }
1790
1791
1792 /* Resolve the getarg intrinsic subroutine.  */
1793
1794 void
1795 gfc_resolve_getarg (gfc_code * c)
1796 {
1797   const char *name;
1798   int kind;
1799
1800   kind = gfc_default_integer_kind;
1801   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1802   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1803 }
1804
1805 /* Resolve the getcwd intrinsic subroutine.  */
1806
1807 void
1808 gfc_resolve_getcwd_sub (gfc_code * c)
1809 {
1810   const char *name;
1811   int kind;
1812
1813   if (c->ext.actual->next->expr != NULL)
1814     kind = c->ext.actual->next->expr->ts.kind;
1815   else
1816     kind = gfc_default_integer_kind;
1817
1818   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1819   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1820 }
1821
1822
1823 /* Resolve the get_command intrinsic subroutine.  */
1824
1825 void
1826 gfc_resolve_get_command (gfc_code * c)
1827 {
1828   const char *name;
1829   int kind;
1830
1831   kind = gfc_default_integer_kind;
1832   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1833   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1834 }
1835
1836
1837 /* Resolve the get_command_argument intrinsic subroutine.  */
1838
1839 void
1840 gfc_resolve_get_command_argument (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_argument_i%d"), kind);
1847   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1848 }
1849
1850 /* Resolve the get_environment_variable intrinsic subroutine.  */
1851
1852 void
1853 gfc_resolve_get_environment_variable (gfc_code * code)
1854 {
1855   const char *name;
1856   int kind;
1857
1858   kind = gfc_default_integer_kind;
1859   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1860   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1861 }
1862
1863 /* Resolve the SYSTEM intrinsic subroutine.  */
1864
1865 void
1866 gfc_resolve_system_sub (gfc_code * c)
1867 {
1868   const char *name;
1869
1870   name = gfc_get_string (PREFIX("system_sub"));
1871   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1872 }
1873
1874 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1875
1876 void
1877 gfc_resolve_system_clock (gfc_code * c)
1878 {
1879   const char *name;
1880   int kind;
1881
1882   if (c->ext.actual->expr != NULL)
1883     kind = c->ext.actual->expr->ts.kind;
1884   else if (c->ext.actual->next->expr != NULL)
1885       kind = c->ext.actual->next->expr->ts.kind;
1886   else if (c->ext.actual->next->next->expr != NULL)
1887       kind = c->ext.actual->next->next->expr->ts.kind;
1888   else
1889     kind = gfc_default_integer_kind;
1890
1891   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1892   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1893 }
1894
1895 /* Resolve the EXIT intrinsic subroutine.  */
1896
1897 void
1898 gfc_resolve_exit (gfc_code * c)
1899 {
1900   const char *name;
1901   int kind;
1902
1903   if (c->ext.actual->expr != NULL)
1904     kind = c->ext.actual->expr->ts.kind;
1905   else
1906     kind = gfc_default_integer_kind;
1907
1908   name = gfc_get_string (PREFIX("exit_i%d"), kind);
1909   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1910 }
1911
1912 /* Resolve the FLUSH intrinsic subroutine.  */
1913
1914 void
1915 gfc_resolve_flush (gfc_code * c)
1916 {
1917   const char *name;
1918   gfc_typespec ts;
1919   gfc_expr *n;
1920
1921   ts.type = BT_INTEGER;
1922   ts.kind = gfc_default_integer_kind;
1923   n = c->ext.actual->expr;
1924   if (n != NULL
1925       && n->ts.kind != ts.kind)
1926     gfc_convert_type (n, &ts, 2);
1927
1928   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1929   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1930 }
1931
1932
1933 void
1934 gfc_resolve_gerror (gfc_code * c)
1935 {
1936   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
1937 }
1938
1939
1940 void
1941 gfc_resolve_getlog (gfc_code * c)
1942 {
1943   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
1944 }
1945
1946
1947 void
1948 gfc_resolve_hostnm_sub (gfc_code * c)
1949 {
1950   const char *name;
1951   int kind;
1952
1953   if (c->ext.actual->next->expr != NULL)
1954     kind = c->ext.actual->next->expr->ts.kind;
1955   else
1956     kind = gfc_default_integer_kind;
1957
1958   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
1959   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1960 }
1961
1962
1963 void
1964 gfc_resolve_perror (gfc_code * c)
1965 {
1966   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
1967 }
1968
1969 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
1970
1971 void
1972 gfc_resolve_stat_sub (gfc_code * c)
1973 {
1974   const char *name;
1975
1976   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
1977   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1978 }
1979
1980
1981 void
1982 gfc_resolve_fstat_sub (gfc_code * c)
1983 {
1984   const char *name;
1985   gfc_expr *u;
1986   gfc_typespec *ts;
1987
1988   u = c->ext.actual->expr;
1989   ts = &c->ext.actual->next->expr->ts;
1990   if (u->ts.kind != ts->kind)
1991     gfc_convert_type (u, ts, 2);
1992   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
1993   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1994 }
1995
1996
1997 void
1998 gfc_resolve_ttynam_sub (gfc_code * c)
1999 {
2000   gfc_typespec ts;
2001
2002   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2003     {
2004       ts.type = BT_INTEGER;
2005       ts.kind = gfc_c_int_kind;
2006       ts.derived = NULL;
2007       ts.cl = NULL;
2008       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2009     }
2010
2011   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2012 }
2013
2014
2015 /* Resolve the UMASK intrinsic subroutine.  */
2016
2017 void
2018 gfc_resolve_umask_sub (gfc_code * c)
2019 {
2020   const char *name;
2021   int kind;
2022
2023   if (c->ext.actual->next->expr != NULL)
2024     kind = c->ext.actual->next->expr->ts.kind;
2025   else
2026     kind = gfc_default_integer_kind;
2027
2028   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2029   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2030 }
2031
2032 /* Resolve the UNLINK intrinsic subroutine.  */
2033
2034 void
2035 gfc_resolve_unlink_sub (gfc_code * c)
2036 {
2037   const char *name;
2038   int kind;
2039
2040   if (c->ext.actual->next->expr != NULL)
2041     kind = c->ext.actual->next->expr->ts.kind;
2042   else
2043     kind = gfc_default_integer_kind;
2044
2045   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2046   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2047 }