gcc/fortran/iresolve.c

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