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