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