gcc/fortran/iresolve.c

   1 /* Intrinsic function resolution.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004 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_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 257 {
 258   f->ts.type = BT_COMPLEX;
 259   f->ts.kind = (kind == NULL) ? gfc_default_real_kind
 260     : mpz_get_si (kind->value.integer);
 261
 262   if (y == NULL)
 263     f->value.function.name =
 264       gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
 265                       gfc_type_letter (x->ts.type), x->ts.kind);
 266   else
 267     f->value.function.name =
 268       gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
 269                       gfc_type_letter (x->ts.type), x->ts.kind,
 270                       gfc_type_letter (y->ts.type), y->ts.kind);
 271 }
 272
 273 void
 274 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
 275 {
 276   gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
 277 }
 278
 279 void
 280 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
 281 {
 282   f->ts = x->ts;
 283   f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
 284 }
 285
 286
 287 void
 288 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
 289 {
 290   f->ts = x->ts;
 291   f->value.function.name =
 292     gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 293 }
 294
 295
 296 void
 297 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
 298 {
 299   f->ts = x->ts;
 300   f->value.function.name =
 301     gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 302 }
 303
 304
 305 void
 306 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 307 {
 308   f->ts.type = BT_INTEGER;
 309   f->ts.kind = gfc_default_integer_kind;
 310
 311   if (dim != NULL)
 312     {
 313       f->rank = mask->rank - 1;
 314       gfc_resolve_index (dim, 1);
 315       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 316     }
 317
 318   f->value.function.name =
 319     gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
 320                     gfc_type_letter (mask->ts.type), mask->ts.kind);
 321 }
 322
 323
 324 void
 325 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
 326                     gfc_expr * shift,
 327                     gfc_expr * dim)
 328 {
 329   int n;
 330
 331   f->ts = array->ts;
 332   f->rank = array->rank;
 333   f->shape = gfc_copy_shape (array->shape, array->rank);
 334
 335   if (shift->rank > 0)
 336     n = 1;
 337   else
 338     n = 0;
 339
 340   if (dim != NULL)
 341     {
 342       gfc_resolve_index (dim, 1);
 343       /* Convert dim to shift's kind, so we don't need so many variations.  */
 344       if (dim->ts.kind != shift->ts.kind)
 345         gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 346     }
 347   f->value.function.name =
 348     gfc_get_string (PREFIX("cshift%d_%d"), n, shift->ts.kind);
 349 }
 350
 351
 352 void
 353 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
 354 {
 355   f->ts.type = BT_REAL;
 356   f->ts.kind = gfc_default_double_kind;
 357   f->value.function.name =
 358     gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 359 }
 360
 361
 362 void
 363 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
 364                  gfc_expr * y ATTRIBUTE_UNUSED)
 365 {
 366   f->ts = x->ts;
 367   f->value.function.name =
 368     gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 369 }
 370
 371
 372 void
 373 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 374 {
 375   gfc_expr temp;
 376
 377   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 378     {
 379       f->ts.type = BT_LOGICAL;
 380       f->ts.kind = gfc_default_logical_kind;
 381     }
 382   else
 383     {
 384       temp.expr_type = EXPR_OP;
 385       gfc_clear_ts (&temp.ts);
 386       temp.operator = INTRINSIC_NONE;
 387       temp.op1 = a;
 388       temp.op2 = b;
 389       gfc_type_convert_binary (&temp);
 390       f->ts = temp.ts;
 391     }
 392
 393   f->value.function.name =
 394     gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
 395                     f->ts.kind);
 396 }
 397
 398
 399 void
 400 gfc_resolve_dprod (gfc_expr * f,
 401                    gfc_expr * a ATTRIBUTE_UNUSED,
 402                    gfc_expr * b ATTRIBUTE_UNUSED)
 403 {
 404   f->ts.kind = gfc_default_double_kind;
 405   f->ts.type = BT_REAL;
 406
 407   f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
 408 }
 409
 410
 411 void
 412 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
 413                      gfc_expr * shift,
 414                      gfc_expr * boundary,
 415                      gfc_expr * dim)
 416 {
 417   int n;
 418
 419   f->ts = array->ts;
 420   f->rank = array->rank;
 421   f->shape = gfc_copy_shape (array->shape, array->rank);
 422
 423   n = 0;
 424   if (shift->rank > 0)
 425     n = n | 1;
 426   if (boundary && boundary->rank > 0)
 427     n = n | 2;
 428
 429   /* Convert dim to the same type as shift, so we don't need quite so many
 430      variations.  */
 431   if (dim != NULL && dim->ts.kind != shift->ts.kind)
 432     gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 433
 434   f->value.function.name =
 435     gfc_get_string (PREFIX("eoshift%d_%d"), n, shift->ts.kind);
 436 }
 437
 438
 439 void
 440 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
 441 {
 442   f->ts = x->ts;
 443   f->value.function.name =
 444     gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 445 }
 446
 447
 448 void
 449 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
 450 {
 451   f->ts.type = BT_INTEGER;
 452   f->ts.kind = gfc_default_integer_kind;
 453
 454   f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
 455 }
 456
 457
 458 void
 459 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 460 {
 461   f->ts.type = BT_INTEGER;
 462   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 463     : mpz_get_si (kind->value.integer);
 464
 465   f->value.function.name =
 466     gfc_get_string ("__floor%d_%c%d", f->ts.kind,
 467                     gfc_type_letter (a->ts.type), a->ts.kind);
 468 }
 469
 470
 471 void
 472 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
 473 {
 474   f->ts.type = BT_INTEGER;
 475   f->ts.kind = gfc_default_integer_kind;
 476   if (n->ts.kind != f->ts.kind)
 477     gfc_convert_type (n, &f->ts, 2);
 478   f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
 479 }
 480
 481
 482 void
 483 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
 484 {
 485   f->ts = x->ts;
 486   f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
 487 }
 488
 489
 490 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
 491
 492 void
 493 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
 494 {
 495   f->ts = x->ts;
 496   f->value.function.name = gfc_get_string ("<intrinsic>");
 497 }
 498
 499
 500 void
 501 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
 502 {
 503   f->ts.type = BT_INTEGER;
 504   f->ts.kind = 4;
 505   f->value.function.name = gfc_get_string (PREFIX("getcwd"));
 506 }
 507
 508
 509 void
 510 gfc_resolve_getgid (gfc_expr * f)
 511 {
 512   f->ts.type = BT_INTEGER;
 513   f->ts.kind = 4;
 514   f->value.function.name = gfc_get_string (PREFIX("getgid"));
 515 }
 516
 517
 518 void
 519 gfc_resolve_getpid (gfc_expr * f)
 520 {
 521   f->ts.type = BT_INTEGER;
 522   f->ts.kind = 4;
 523   f->value.function.name = gfc_get_string (PREFIX("getpid"));
 524 }
 525
 526
 527 void
 528 gfc_resolve_getuid (gfc_expr * f)
 529 {
 530   f->ts.type = BT_INTEGER;
 531   f->ts.kind = 4;
 532   f->value.function.name = gfc_get_string (PREFIX("getuid"));
 533 }
 534
 535 void
 536 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 537 {
 538   /* If the kind of i and j are different, then g77 cross-promoted the
 539      kinds to the largest value.  The Fortran 95 standard requires the
 540      kinds to match.  */
 541   if (i->ts.kind != j->ts.kind)
 542     {
 543       if (i->ts.kind == gfc_kind_max (i,j))
 544         gfc_convert_type(j, &i->ts, 2);
 545       else
 546         gfc_convert_type(i, &j->ts, 2);
 547     }
 548
 549   f->ts = i->ts;
 550   f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
 551 }
 552
 553
 554 void
 555 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
 556 {
 557   f->ts = i->ts;
 558   f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
 559 }
 560
 561
 562 void
 563 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
 564                    gfc_expr * pos ATTRIBUTE_UNUSED,
 565                    gfc_expr * len ATTRIBUTE_UNUSED)
 566 {
 567   f->ts = i->ts;
 568   f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
 569 }
 570
 571
 572 void
 573 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
 574                    gfc_expr * pos ATTRIBUTE_UNUSED)
 575 {
 576   f->ts = i->ts;
 577   f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
 578 }
 579
 580
 581 void
 582 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
 583 {
 584   f->ts.type = BT_INTEGER;
 585   f->ts.kind = gfc_default_integer_kind;
 586
 587   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 588 }
 589
 590
 591 void
 592 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
 593 {
 594   gfc_resolve_nint (f, a, NULL);
 595 }
 596
 597
 598 void
 599 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 600 {
 601   /* If the kind of i and j are different, then g77 cross-promoted the
 602      kinds to the largest value.  The Fortran 95 standard requires the
 603      kinds to match.  */
 604   if (i->ts.kind != j->ts.kind)
 605     {
 606       if (i->ts.kind == gfc_kind_max (i,j))
 607         gfc_convert_type(j, &i->ts, 2);
 608       else
 609         gfc_convert_type(i, &j->ts, 2);
 610     }
 611
 612   f->ts = i->ts;
 613   f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
 614 }
 615
 616
 617 void
 618 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 619 {
 620   /* If the kind of i and j are different, then g77 cross-promoted the
 621      kinds to the largest value.  The Fortran 95 standard requires the
 622      kinds to match.  */
 623   if (i->ts.kind != j->ts.kind)
 624     {
 625       if (i->ts.kind == gfc_kind_max (i,j))
 626         gfc_convert_type(j, &i->ts, 2);
 627       else
 628         gfc_convert_type(i, &j->ts, 2);
 629     }
 630
 631   f->ts = i->ts;
 632   f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
 633 }
 634
 635
 636 void
 637 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 638 {
 639   f->ts.type = BT_INTEGER;
 640   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 641     : mpz_get_si (kind->value.integer);
 642
 643   f->value.function.name =
 644     gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
 645                     a->ts.kind);
 646 }
 647
 648
 649 void
 650 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
 651 {
 652   f->ts = i->ts;
 653   f->value.function.name =
 654     gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
 655 }
 656
 657
 658 void
 659 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
 660                     gfc_expr * size)
 661 {
 662   int s_kind;
 663
 664   s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
 665
 666   f->ts = i->ts;
 667   f->value.function.name =
 668     gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
 669 }
 670
 671
 672 void
 673 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
 674                     gfc_expr * dim)
 675 {
 676   static char lbound[] = "__lbound";
 677
 678   f->ts.type = BT_INTEGER;
 679   f->ts.kind = gfc_default_integer_kind;
 680
 681   if (dim == NULL)
 682     {
 683       f->rank = 1;
 684       f->shape = gfc_get_shape (1);
 685       mpz_init_set_ui (f->shape[0], array->rank);
 686     }
 687
 688   f->value.function.name = lbound;
 689 }
 690
 691
 692 void
 693 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
 694 {
 695   f->ts.type = BT_INTEGER;
 696   f->ts.kind = gfc_default_integer_kind;
 697   f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
 698 }
 699
 700
 701 void
 702 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
 703 {
 704   f->ts.type = BT_INTEGER;
 705   f->ts.kind = gfc_default_integer_kind;
 706   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
 707 }
 708
 709
 710 void
 711 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
 712 {
 713   f->ts = x->ts;
 714   f->value.function.name =
 715     gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 716 }
 717
 718
 719 void
 720 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
 721 {
 722   f->ts = x->ts;
 723   f->value.function.name =
 724     gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 725 }
 726
 727
 728 void
 729 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 730 {
 731   f->ts.type = BT_LOGICAL;
 732   f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
 733     : mpz_get_si (kind->value.integer);
 734   f->rank = a->rank;
 735
 736   f->value.function.name =
 737     gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
 738                     gfc_type_letter (a->ts.type), a->ts.kind);
 739 }
 740
 741
 742 void
 743 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 744 {
 745   gfc_expr temp;
 746
 747   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 748     {
 749       f->ts.type = BT_LOGICAL;
 750       f->ts.kind = gfc_default_logical_kind;
 751     }
 752   else
 753     {
 754       temp.expr_type = EXPR_OP;
 755       gfc_clear_ts (&temp.ts);
 756       temp.operator = INTRINSIC_NONE;
 757       temp.op1 = a;
 758       temp.op2 = b;
 759       gfc_type_convert_binary (&temp);
 760       f->ts = temp.ts;
 761     }
 762
 763   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
 764
 765   f->value.function.name =
 766     gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
 767                     f->ts.kind);
 768 }
 769
 770
 771 static void
 772 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
 773 {
 774   gfc_actual_arglist *a;
 775
 776   f->ts.type = args->expr->ts.type;
 777   f->ts.kind = args->expr->ts.kind;
 778   /* Find the largest type kind.  */
 779   for (a = args->next; a; a = a->next)
 780     {
 781       if (a->expr->ts.kind > f->ts.kind)
 782         f->ts.kind = a->expr->ts.kind;
 783     }
 784
 785   /* Convert all parameters to the required kind.  */
 786   for (a = args; a; a = a->next)
 787     {
 788       if (a->expr->ts.kind != f->ts.kind)
 789         gfc_convert_type (a->expr, &f->ts, 2);
 790     }
 791
 792   f->value.function.name =
 793     gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
 794 }
 795
 796
 797 void
 798 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
 799 {
 800   gfc_resolve_minmax ("__max_%c%d", f, args);
 801 }
 802
 803
 804 void
 805 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 806                     gfc_expr * mask)
 807 {
 808   const char *name;
 809
 810   f->ts.type = BT_INTEGER;
 811   f->ts.kind = gfc_default_integer_kind;
 812
 813   if (dim == NULL)
 814     f->rank = 1;
 815   else
 816     {
 817       f->rank = array->rank - 1;
 818       gfc_resolve_index (dim, 1);
 819     }
 820
 821   name = mask ? "mmaxloc" : "maxloc";
 822   f->value.function.name =
 823     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
 824                     gfc_type_letter (array->ts.type), array->ts.kind);
 825 }
 826
 827
 828 void
 829 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 830                     gfc_expr * mask)
 831 {
 832   f->ts = array->ts;
 833
 834   if (dim != NULL)
 835     {
 836       f->rank = array->rank - 1;
 837       gfc_resolve_index (dim, 1);
 838     }
 839
 840   f->value.function.name =
 841     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
 842                     gfc_type_letter (array->ts.type), array->ts.kind);
 843 }
 844
 845
 846 void
 847 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
 848                    gfc_expr * fsource ATTRIBUTE_UNUSED,
 849                    gfc_expr * mask ATTRIBUTE_UNUSED)
 850 {
 851   f->ts = tsource->ts;
 852   f->value.function.name =
 853     gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
 854                     tsource->ts.kind);
 855 }
 856
 857
 858 void
 859 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
 860 {
 861   gfc_resolve_minmax ("__min_%c%d", f, args);
 862 }
 863
 864
 865 void
 866 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 867                     gfc_expr * mask)
 868 {
 869   const char *name;
 870
 871   f->ts.type = BT_INTEGER;
 872   f->ts.kind = gfc_default_integer_kind;
 873
 874   if (dim == NULL)
 875     f->rank = 1;
 876   else
 877     {
 878       f->rank = array->rank - 1;
 879       gfc_resolve_index (dim, 1);
 880     }
 881
 882   name = mask ? "mminloc" : "minloc";
 883   f->value.function.name =
 884     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
 885                     gfc_type_letter (array->ts.type), array->ts.kind);
 886 }
 887
 888
 889 void
 890 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 891                     gfc_expr * mask)
 892 {
 893   f->ts = array->ts;
 894
 895   if (dim != NULL)
 896     {
 897       f->rank = array->rank - 1;
 898       gfc_resolve_index (dim, 1);
 899     }
 900
 901   f->value.function.name =
 902     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
 903                     gfc_type_letter (array->ts.type), array->ts.kind);
 904 }
 905
 906
 907 void
 908 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
 909                  gfc_expr * p ATTRIBUTE_UNUSED)
 910 {
 911   f->ts = a->ts;
 912   f->value.function.name =
 913     gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 914 }
 915
 916
 917 void
 918 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
 919                     gfc_expr * p ATTRIBUTE_UNUSED)
 920 {
 921   f->ts = a->ts;
 922   f->value.function.name =
 923     gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
 924                     a->ts.kind);
 925 }
 926
 927 void
 928 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
 929 {
 930   f->ts = a->ts;
 931   f->value.function.name =
 932     gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
 933             a->ts.kind);
 934 }
 935
 936 void
 937 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 938 {
 939   f->ts.type = BT_INTEGER;
 940   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 941     : mpz_get_si (kind->value.integer);
 942
 943   f->value.function.name =
 944     gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
 945 }
 946
 947
 948 void
 949 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
 950 {
 951   f->ts = i->ts;
 952   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
 953 }
 954
 955
 956 void
 957 gfc_resolve_pack (gfc_expr * f,
 958                   gfc_expr * array ATTRIBUTE_UNUSED,
 959                   gfc_expr * mask,
 960                   gfc_expr * vector ATTRIBUTE_UNUSED)
 961 {
 962   f->ts = array->ts;
 963   f->rank = 1;
 964
 965   if (mask->rank != 0)
 966     f->value.function.name = PREFIX("pack");
 967   else
 968     {
 969       /* We convert mask to default logical only in the scalar case.
 970          In the array case we can simply read the array as if it were
 971          of type default logical.  */
 972       if (mask->ts.kind != gfc_default_logical_kind)
 973         {
 974           gfc_typespec ts;
 975
 976           ts.type = BT_LOGICAL;
 977           ts.kind = gfc_default_logical_kind;
 978           gfc_convert_type (mask, &ts, 2);
 979         }
 980
 981       f->value.function.name = PREFIX("pack_s");
 982     }
 983 }
 984
 985
 986 void
 987 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 988                      gfc_expr * mask)
 989 {
 990   f->ts = array->ts;
 991
 992   if (dim != NULL)
 993     {
 994       f->rank = array->rank - 1;
 995       gfc_resolve_index (dim, 1);
 996     }
 997
 998   f->value.function.name =
 999     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1000                     gfc_type_letter (array->ts.type), array->ts.kind);
1001 }
1002
1003
1004 void
1005 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1006 {
1007   f->ts.type = BT_REAL;
1008
1009   if (kind != NULL)
1010     f->ts.kind = mpz_get_si (kind->value.integer);
1011   else
1012     f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1013       a->ts.kind : gfc_default_real_kind;
1014
1015   f->value.function.name =
1016     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1017                     gfc_type_letter (a->ts.type), a->ts.kind);
1018 }
1019
1020
1021 void
1022 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1023                     gfc_expr * ncopies ATTRIBUTE_UNUSED)
1024 {
1025   f->ts.type = BT_CHARACTER;
1026   f->ts.kind = string->ts.kind;
1027   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1028 }
1029
1030
1031 void
1032 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1033                      gfc_expr * pad ATTRIBUTE_UNUSED,
1034                      gfc_expr * order ATTRIBUTE_UNUSED)
1035 {
1036   mpz_t rank;
1037   int kind;
1038   int i;
1039
1040   f->ts = source->ts;
1041
1042   gfc_array_size (shape, &rank);
1043   f->rank = mpz_get_si (rank);
1044   mpz_clear (rank);
1045   switch (source->ts.type)
1046     {
1047     case BT_COMPLEX:
1048       kind = source->ts.kind * 2;
1049       break;
1050
1051     case BT_REAL:
1052     case BT_INTEGER:
1053     case BT_LOGICAL:
1054       kind = source->ts.kind;
1055       break;
1056
1057     default:
1058       kind = 0;
1059       break;
1060     }
1061
1062   switch (kind)
1063     {
1064     case 4:
1065     case 8:
1066     /* case 16: */
1067       f->value.function.name =
1068         gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1069       break;
1070
1071     default:
1072       f->value.function.name = PREFIX("reshape");
1073       break;
1074     }
1075
1076   /* TODO: Make this work with a constant ORDER parameter.  */
1077   if (shape->expr_type == EXPR_ARRAY
1078       && gfc_is_constant_expr (shape)
1079       && order == NULL)
1080     {
1081       gfc_constructor *c;
1082       f->shape = gfc_get_shape (f->rank);
1083       c = shape->value.constructor;
1084       for (i = 0; i < f->rank; i++)
1085         {
1086           mpz_init_set (f->shape[i], c->expr->value.integer);
1087           c = c->next;
1088         }
1089     }
1090
1091   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1092      so many runtime variations.  */
1093   if (shape->ts.kind != gfc_index_integer_kind)
1094     {
1095       gfc_typespec ts = shape->ts;
1096       ts.kind = gfc_index_integer_kind;
1097       gfc_convert_type_warn (shape, &ts, 2, 0);
1098     }
1099   if (order && order->ts.kind != gfc_index_integer_kind)
1100     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1101 }
1102
1103
1104 void
1105 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1106 {
1107   f->ts = x->ts;
1108   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1109 }
1110
1111
1112 void
1113 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1114 {
1115   f->ts = x->ts;
1116
1117   /* The implementation calls scalbn which takes an int as the
1118      second argument.  */
1119   if (i->ts.kind != gfc_c_int_kind)
1120     {
1121       gfc_typespec ts;
1122
1123       ts.type = BT_INTEGER;
1124       ts.kind = gfc_default_integer_kind;
1125
1126       gfc_convert_type_warn (i, &ts, 2, 0);
1127     }
1128
1129   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1130 }
1131
1132
1133 void
1134 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1135                   gfc_expr * set ATTRIBUTE_UNUSED,
1136                   gfc_expr * back ATTRIBUTE_UNUSED)
1137 {
1138   f->ts.type = BT_INTEGER;
1139   f->ts.kind = gfc_default_integer_kind;
1140   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1141 }
1142
1143
1144 void
1145 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1146 {
1147   f->ts = x->ts;
1148
1149   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1150      convert type so we don't have to implment all possible
1151      permutations.  */
1152   if (i->ts.kind != 4)
1153     {
1154       gfc_typespec ts;
1155
1156       ts.type = BT_INTEGER;
1157       ts.kind = gfc_default_integer_kind;
1158
1159       gfc_convert_type_warn (i, &ts, 2, 0);
1160     }
1161
1162   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1163 }
1164
1165
1166 void
1167 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1168 {
1169   f->ts.type = BT_INTEGER;
1170   f->ts.kind = gfc_default_integer_kind;
1171   f->rank = 1;
1172   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1173   f->shape = gfc_get_shape (1);
1174   mpz_init_set_ui (f->shape[0], array->rank);
1175 }
1176
1177
1178 void
1179 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1180 {
1181   f->ts = a->ts;
1182   f->value.function.name =
1183     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1184 }
1185
1186
1187 void
1188 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1189 {
1190   f->ts = x->ts;
1191   f->value.function.name =
1192     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1193 }
1194
1195
1196 void
1197 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1198 {
1199   f->ts = x->ts;
1200   f->value.function.name =
1201     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1202 }
1203
1204
1205 void
1206 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1207 {
1208   f->ts = x->ts;
1209   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1210 }
1211
1212
1213 void
1214 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1215                     gfc_expr * dim,
1216                     gfc_expr * ncopies)
1217 {
1218   f->ts = source->ts;
1219   f->rank = source->rank + 1;
1220   f->value.function.name = PREFIX("spread");
1221
1222   gfc_resolve_index (dim, 1);
1223   gfc_resolve_index (ncopies, 1);
1224 }
1225
1226
1227 void
1228 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1229 {
1230   f->ts = x->ts;
1231   f->value.function.name =
1232     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1233 }
1234
1235
1236 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1237
1238 void
1239 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1240                   gfc_expr * a ATTRIBUTE_UNUSED)
1241 {
1242   f->ts.type = BT_INTEGER;
1243   f->ts.kind = gfc_default_integer_kind;
1244   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1245 }
1246
1247
1248 void
1249 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1250 {
1251   f->ts.type = BT_INTEGER;
1252   f->ts.kind = gfc_default_integer_kind;
1253   if (n->ts.kind != f->ts.kind)
1254     gfc_convert_type (n, &f->ts, 2);
1255
1256   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1257 }
1258
1259
1260 void
1261 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1262                  gfc_expr * mask)
1263 {
1264   f->ts = array->ts;
1265
1266   if (dim != NULL)
1267     {
1268       f->rank = array->rank - 1;
1269       gfc_resolve_index (dim, 1);
1270     }
1271
1272   f->value.function.name =
1273     gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1274                     gfc_type_letter (array->ts.type), array->ts.kind);
1275 }
1276
1277
1278 /* Resolve the g77 compatibility function SYSTEM.  */
1279
1280 void
1281 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1282 {
1283   f->ts.type = BT_INTEGER;
1284   f->ts.kind = 4;
1285   f->value.function.name = gfc_get_string (PREFIX("system"));
1286 }
1287
1288
1289 void
1290 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1291 {
1292   f->ts = x->ts;
1293   f->value.function.name =
1294     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1295 }
1296
1297
1298 void
1299 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1300 {
1301   f->ts = x->ts;
1302   f->value.function.name =
1303     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1304 }
1305
1306
1307 void
1308 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1309                       gfc_expr * mold, gfc_expr * size)
1310 {
1311   /* TODO: Make this do something meaningful.  */
1312   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1313
1314   f->ts = mold->ts;
1315
1316   if (size == NULL && mold->rank == 0)
1317     {
1318       f->rank = 0;
1319       f->value.function.name = transfer0;
1320     }
1321   else
1322     {
1323       f->rank = 1;
1324       f->value.function.name = transfer1;
1325     }
1326 }
1327
1328
1329 void
1330 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1331 {
1332   int kind;
1333
1334   f->ts = matrix->ts;
1335   f->rank = 2;
1336   if (matrix->shape)
1337     {
1338       f->shape = gfc_get_shape (2);
1339       mpz_init_set (f->shape[0], matrix->shape[1]);
1340       mpz_init_set (f->shape[1], matrix->shape[0]);
1341     }
1342
1343   switch (matrix->ts.type)
1344     {
1345     case BT_COMPLEX:
1346       kind = matrix->ts.kind * 2;
1347       break;
1348
1349     case BT_REAL:
1350     case BT_INTEGER:
1351     case BT_LOGICAL:
1352       kind = matrix->ts.kind;
1353       break;
1354
1355     default:
1356       kind = 0;
1357       break;
1358
1359     }
1360
1361   switch (kind)
1362     {
1363     case 4:
1364     case 8:
1365     /* case 16: */
1366       f->value.function.name =
1367         gfc_get_string (PREFIX("transpose_%d"), kind);
1368       break;
1369
1370     default:
1371       f->value.function.name = PREFIX("transpose");
1372     }
1373 }
1374
1375
1376 void
1377 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1378 {
1379   f->ts.type = BT_CHARACTER;
1380   f->ts.kind = string->ts.kind;
1381   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1382 }
1383
1384
1385 void
1386 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1387                     gfc_expr * dim)
1388 {
1389   static char ubound[] = "__ubound";
1390
1391   f->ts.type = BT_INTEGER;
1392   f->ts.kind = gfc_default_integer_kind;
1393
1394   if (dim == NULL)
1395     {
1396       f->rank = 1;
1397       f->shape = gfc_get_shape (1);
1398       mpz_init_set_ui (f->shape[0], array->rank);
1399     }
1400
1401   f->value.function.name = ubound;
1402 }
1403
1404
1405 /* Resolve the g77 compatibility function UMASK.  */
1406
1407 void
1408 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1409 {
1410   f->ts.type = BT_INTEGER;
1411   f->ts.kind = n->ts.kind;
1412   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1413 }
1414
1415
1416 /* Resolve the g77 compatibility function UNLINK.  */
1417
1418 void
1419 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1420 {
1421   f->ts.type = BT_INTEGER;
1422   f->ts.kind = 4;
1423   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1424 }
1425
1426 void
1427 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1428                     gfc_expr * field ATTRIBUTE_UNUSED)
1429 {
1430   f->ts.type = vector->ts.type;
1431   f->ts.kind = vector->ts.kind;
1432   f->rank = mask->rank;
1433
1434   f->value.function.name =
1435     gfc_get_string (PREFIX("unpack%d"), field->rank > 0 ? 1 : 0);
1436 }
1437
1438
1439 void
1440 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1441                     gfc_expr * set ATTRIBUTE_UNUSED,
1442                     gfc_expr * back ATTRIBUTE_UNUSED)
1443 {
1444   f->ts.type = BT_INTEGER;
1445   f->ts.kind = gfc_default_integer_kind;
1446   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1447 }
1448
1449
1450 /* Intrinsic subroutine resolution.  */
1451
1452 void
1453 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1454 {
1455   const char *name;
1456
1457   name = gfc_get_string (PREFIX("cpu_time_%d"),
1458                          c->ext.actual->expr->ts.kind);
1459   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1460 }
1461
1462
1463 void
1464 gfc_resolve_mvbits (gfc_code * c)
1465 {
1466   const char *name;
1467   int kind;
1468
1469   kind = c->ext.actual->expr->ts.kind;
1470   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1471
1472   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1473 }
1474
1475
1476 void
1477 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1478 {
1479   const char *name;
1480   int kind;
1481
1482   kind = c->ext.actual->expr->ts.kind;
1483   if (c->ext.actual->expr->rank == 0)
1484     name = gfc_get_string (PREFIX("random_r%d"), kind);
1485   else
1486     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1487
1488   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1489 }
1490
1491
1492 /* G77 compatibility subroutines etime() and dtime().  */
1493
1494 void
1495 gfc_resolve_etime_sub (gfc_code * c)
1496 {
1497   const char *name;
1498
1499   name = gfc_get_string (PREFIX("etime_sub"));
1500   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1501 }
1502
1503
1504 /* G77 compatibility subroutine second().  */
1505
1506 void
1507 gfc_resolve_second_sub (gfc_code * c)
1508 {
1509   const char *name;
1510
1511   name = gfc_get_string (PREFIX("second_sub"));
1512   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1513 }
1514
1515
1516 /* G77 compatibility function srand().  */
1517
1518 void
1519 gfc_resolve_srand (gfc_code * c)
1520 {
1521   const char *name;
1522   name = gfc_get_string (PREFIX("srand"));
1523   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1524 }
1525
1526
1527 /* Resolve the getarg intrinsic subroutine.  */
1528
1529 void
1530 gfc_resolve_getarg (gfc_code * c)
1531 {
1532   const char *name;
1533   int kind;
1534
1535   kind = gfc_default_integer_kind;
1536   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1537   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1538 }
1539
1540 /* Resolve the getcwd intrinsic subroutine.  */
1541
1542 void
1543 gfc_resolve_getcwd_sub (gfc_code * c)
1544 {
1545   const char *name;
1546   int kind;
1547
1548   if (c->ext.actual->next->expr != NULL)
1549     kind = c->ext.actual->next->expr->ts.kind;
1550   else
1551     kind = gfc_default_integer_kind;
1552
1553   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1554   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1555 }
1556
1557
1558 /* Resolve the get_command intrinsic subroutine.  */
1559
1560 void
1561 gfc_resolve_get_command (gfc_code * c)
1562 {
1563   const char *name;
1564   int kind;
1565
1566   kind = gfc_default_integer_kind;
1567   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1568   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1569 }
1570
1571
1572 /* Resolve the get_command_argument intrinsic subroutine.  */
1573
1574 void
1575 gfc_resolve_get_command_argument (gfc_code * c)
1576 {
1577   const char *name;
1578   int kind;
1579
1580   kind = gfc_default_integer_kind;
1581   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1582   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1583 }
1584
1585 /* Resolve the get_environment_variable intrinsic subroutine.  */
1586
1587 void
1588 gfc_resolve_get_environment_variable (gfc_code * code)
1589 {
1590   const char *name;
1591   int kind;
1592
1593   kind = gfc_default_integer_kind;
1594   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1595   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1596 }
1597
1598 /* Resolve the SYSTEM intrinsic subroutine.  */
1599
1600 void
1601 gfc_resolve_system_sub (gfc_code * c)
1602 {
1603   const char *name;
1604
1605   name = gfc_get_string (PREFIX("system_sub"));
1606   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1607 }
1608
1609 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1610
1611 void
1612 gfc_resolve_system_clock (gfc_code * c)
1613 {
1614   const char *name;
1615   int kind;
1616
1617   if (c->ext.actual->expr != NULL)
1618     kind = c->ext.actual->expr->ts.kind;
1619   else if (c->ext.actual->next->expr != NULL)
1620       kind = c->ext.actual->next->expr->ts.kind;
1621   else if (c->ext.actual->next->next->expr != NULL)
1622       kind = c->ext.actual->next->next->expr->ts.kind;
1623   else
1624     kind = gfc_default_integer_kind;
1625
1626   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1627   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1628 }
1629
1630 /* Resolve the EXIT intrinsic subroutine.  */
1631
1632 void
1633 gfc_resolve_exit (gfc_code * c)
1634 {
1635   const char *name;
1636   int kind;
1637
1638   if (c->ext.actual->expr != NULL)
1639     kind = c->ext.actual->expr->ts.kind;
1640   else
1641     kind = gfc_default_integer_kind;
1642
1643   name = gfc_get_string (PREFIX("exit_i%d"), kind);
1644   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1645 }
1646
1647 /* Resolve the FLUSH intrinsic subroutine.  */
1648
1649 void
1650 gfc_resolve_flush (gfc_code * c)
1651 {
1652   const char *name;
1653   gfc_typespec ts;
1654   gfc_expr *n;
1655
1656   ts.type = BT_INTEGER;
1657   ts.kind = gfc_default_integer_kind;
1658   n = c->ext.actual->expr;
1659   if (n != NULL
1660       && n->ts.kind != ts.kind)
1661     gfc_convert_type (n, &ts, 2);
1662
1663   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1664   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1665 }
1666
1667 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
1668
1669 void
1670 gfc_resolve_stat_sub (gfc_code * c)
1671 {
1672   const char *name;
1673
1674   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
1675   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1676 }
1677
1678
1679 void
1680 gfc_resolve_fstat_sub (gfc_code * c)
1681 {
1682   const char *name;
1683   gfc_expr *u;
1684   gfc_typespec *ts;
1685
1686   u = c->ext.actual->expr;
1687   ts = &c->ext.actual->next->expr->ts;
1688   if (u->ts.kind != ts->kind)
1689     gfc_convert_type (u, ts, 2);
1690   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
1691   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1692 }
1693
1694 /* Resolve the UMASK intrinsic subroutine.  */
1695
1696 void
1697 gfc_resolve_umask_sub (gfc_code * c)
1698 {
1699   const char *name;
1700   int kind;
1701
1702   if (c->ext.actual->next->expr != NULL)
1703     kind = c->ext.actual->next->expr->ts.kind;
1704   else
1705     kind = gfc_default_integer_kind;
1706
1707   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
1708   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1709 }
1710
1711 /* Resolve the UNLINK intrinsic subroutine.  */
1712
1713 void
1714 gfc_resolve_unlink_sub (gfc_code * c)
1715 {
1716   const char *name;
1717   int kind;
1718
1719   if (c->ext.actual->next->expr != NULL)
1720     kind = c->ext.actual->next->expr->ts.kind;
1721   else
1722     kind = gfc_default_integer_kind;
1723
1724   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
1725   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1726 }