gcc/fortran/iresolve.c

   1 /* Intrinsic function resolution.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
   3    Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.  */
  22
  23
  24 /* Assign name and types to intrinsic procedures.  For functions, the
  25    first argument to a resolution function is an expression pointer to
  26    the original function node and the rest are pointers to the
  27    arguments of the function call.  For subroutines, a pointer to the
  28    code node is passed.  The result type and library subroutine name
  29    are generally set according to the function arguments.  */
  30
  31 #include "config.h"
  32 #include "system.h"
  33 #include "coretypes.h"
  34 #include "tree.h"
  35 #include "gfortran.h"
  36 #include "intrinsic.h"
  37
  38
  39 /* Given printf-like arguments, return a stable version of the result string.
  40
  41    We already have a working, optimized string hashing table in the form of
  42    the identifier table.  Reusing this table is likely not to be wasted,
  43    since if the function name makes it to the gimple output of the frontend,
  44    we'll have to create the identifier anyway.  */
  45
  46 const char *
  47 gfc_get_string (const char *format, ...)
  48 {
  49   char temp_name[128];
  50   va_list ap;
  51   tree ident;
  52
  53   va_start (ap, format);
  54   vsnprintf (temp_name, sizeof(temp_name), format, ap);
  55   va_end (ap);
  56   temp_name[sizeof(temp_name)-1] = 0;
  57
  58   ident = get_identifier (temp_name);
  59   return IDENTIFIER_POINTER (ident);
  60 }
  61
  62 /********************** Resolution functions **********************/
  63
  64
  65 void
  66 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
  67 {
  68   f->ts = a->ts;
  69   if (f->ts.type == BT_COMPLEX)
  70     f->ts.type = BT_REAL;
  71
  72   f->value.function.name =
  73     gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
  74 }
  75
  76
  77 void
  78 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
  79 {
  80   f->ts = x->ts;
  81   f->value.function.name =
  82     gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
  83 }
  84
  85
  86 void
  87 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
  88 {
  89   f->ts.type = BT_REAL;
  90   f->ts.kind = x->ts.kind;
  91   f->value.function.name =
  92     gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
  93 }
  94
  95
  96 void
  97 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
  98 {
  99   f->ts.type = a->ts.type;
 100   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 101
 102   /* The resolved name is only used for specific intrinsics where
 103      the return kind is the same as the arg kind.  */
 104   f->value.function.name =
 105     gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 106 }
 107
 108
 109 void
 110 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
 111 {
 112   gfc_resolve_aint (f, a, NULL);
 113 }
 114
 115
 116 void
 117 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 118 {
 119   f->ts = mask->ts;
 120
 121   if (dim != NULL)
 122     {
 123       gfc_resolve_index (dim, 1);
 124       f->rank = mask->rank - 1;
 125       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 126     }
 127
 128   f->value.function.name =
 129     gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
 130                     mask->ts.kind);
 131 }
 132
 133
 134 void
 135 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 136 {
 137   f->ts.type = a->ts.type;
 138   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 139
 140   /* The resolved name is only used for specific intrinsics where
 141      the return kind is the same as the arg kind.  */
 142   f->value.function.name =
 143     gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 144 }
 145
 146
 147 void
 148 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
 149 {
 150   gfc_resolve_anint (f, a, NULL);
 151 }
 152
 153
 154 void
 155 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 156 {
 157   f->ts = mask->ts;
 158
 159   if (dim != NULL)
 160     {
 161       gfc_resolve_index (dim, 1);
 162       f->rank = mask->rank - 1;
 163       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 164     }
 165
 166   f->value.function.name =
 167     gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
 168                     mask->ts.kind);
 169 }
 170
 171
 172 void
 173 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
 174 {
 175   f->ts = x->ts;
 176   f->value.function.name =
 177     gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 178 }
 179
 180
 181 void
 182 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
 183 {
 184   f->ts = x->ts;
 185   f->value.function.name =
 186     gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 187 }
 188
 189
 190 void
 191 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
 192                    gfc_expr * y ATTRIBUTE_UNUSED)
 193 {
 194   f->ts = x->ts;
 195   f->value.function.name =
 196     gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 197 }
 198
 199
 200 /* Resolve the BESYN and BESJN intrinsics.  */
 201
 202 void
 203 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
 204 {
 205   gfc_typespec ts;
 206
 207   f->ts = x->ts;
 208   if (n->ts.kind != gfc_c_int_kind)
 209     {
 210       ts.type = BT_INTEGER;
 211       ts.kind = gfc_c_int_kind;
 212       gfc_convert_type (n, &ts, 2);
 213     }
 214   f->value.function.name = gfc_get_string ("<intrinsic>");
 215 }
 216
 217
 218 void
 219 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
 220 {
 221   f->ts.type = BT_LOGICAL;
 222   f->ts.kind = gfc_default_logical_kind;
 223
 224   f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
 225                                            pos->ts.kind);
 226 }
 227
 228
 229 void
 230 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 231 {
 232   f->ts.type = BT_INTEGER;
 233   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 234     : mpz_get_si (kind->value.integer);
 235
 236   f->value.function.name =
 237     gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
 238                     gfc_type_letter (a->ts.type), a->ts.kind);
 239 }
 240
 241
 242 void
 243 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 244 {
 245   f->ts.type = BT_CHARACTER;
 246   f->ts.kind = (kind == NULL) ? gfc_default_character_kind
 247     : mpz_get_si (kind->value.integer);
 248
 249   f->value.function.name =
 250     gfc_get_string ("__char_%d_%c%d", f->ts.kind,
 251                     gfc_type_letter (a->ts.type), a->ts.kind);
 252 }
 253
 254
 255 void
 256 gfc_resolve_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.value.op.operator = INTRINSIC_NONE;
 387       temp.value.op.op1 = a;
 388       temp.value.op.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.value.op.operator = INTRINSIC_NONE;
 757       temp.value.op.op1 = a;
 758       temp.value.op.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 implement 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   kind = matrix->ts.kind;
1344
1345   switch (kind)
1346     {
1347     case 4:
1348     case 8:
1349       switch (matrix->ts.type)
1350         {
1351         case BT_COMPLEX:
1352           f->value.function.name =
1353             gfc_get_string (PREFIX("transpose_c%d"), kind);
1354           break;
1355
1356         case BT_INTEGER:
1357         case BT_REAL:
1358         case BT_LOGICAL:
1359           /* Use the integer routines for real and logical cases.  This
1360              assumes they all have the same alignment requirements.  */
1361           f->value.function.name =
1362             gfc_get_string (PREFIX("transpose_i%d"), kind);
1363           break;
1364
1365         default:
1366           f->value.function.name = PREFIX("transpose");
1367           break;
1368         }
1369       break;
1370
1371     default:
1372       f->value.function.name = PREFIX("transpose");
1373     }
1374 }
1375
1376
1377 void
1378 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1379 {
1380   f->ts.type = BT_CHARACTER;
1381   f->ts.kind = string->ts.kind;
1382   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1383 }
1384
1385
1386 void
1387 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1388                     gfc_expr * dim)
1389 {
1390   static char ubound[] = "__ubound";
1391
1392   f->ts.type = BT_INTEGER;
1393   f->ts.kind = gfc_default_integer_kind;
1394
1395   if (dim == NULL)
1396     {
1397       f->rank = 1;
1398       f->shape = gfc_get_shape (1);
1399       mpz_init_set_ui (f->shape[0], array->rank);
1400     }
1401
1402   f->value.function.name = ubound;
1403 }
1404
1405
1406 /* Resolve the g77 compatibility function UMASK.  */
1407
1408 void
1409 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1410 {
1411   f->ts.type = BT_INTEGER;
1412   f->ts.kind = n->ts.kind;
1413   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1414 }
1415
1416
1417 /* Resolve the g77 compatibility function UNLINK.  */
1418
1419 void
1420 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1421 {
1422   f->ts.type = BT_INTEGER;
1423   f->ts.kind = 4;
1424   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1425 }
1426
1427 void
1428 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1429                     gfc_expr * field ATTRIBUTE_UNUSED)
1430 {
1431   f->ts.type = vector->ts.type;
1432   f->ts.kind = vector->ts.kind;
1433   f->rank = mask->rank;
1434
1435   f->value.function.name =
1436     gfc_get_string (PREFIX("unpack%d"), field->rank > 0 ? 1 : 0);
1437 }
1438
1439
1440 void
1441 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1442                     gfc_expr * set ATTRIBUTE_UNUSED,
1443                     gfc_expr * back ATTRIBUTE_UNUSED)
1444 {
1445   f->ts.type = BT_INTEGER;
1446   f->ts.kind = gfc_default_integer_kind;
1447   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1448 }
1449
1450
1451 /* Intrinsic subroutine resolution.  */
1452
1453 void
1454 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1455 {
1456   const char *name;
1457
1458   name = gfc_get_string (PREFIX("cpu_time_%d"),
1459                          c->ext.actual->expr->ts.kind);
1460   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1461 }
1462
1463
1464 void
1465 gfc_resolve_mvbits (gfc_code * c)
1466 {
1467   const char *name;
1468   int kind;
1469
1470   kind = c->ext.actual->expr->ts.kind;
1471   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1472
1473   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1474 }
1475
1476
1477 void
1478 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1479 {
1480   const char *name;
1481   int kind;
1482
1483   kind = c->ext.actual->expr->ts.kind;
1484   if (c->ext.actual->expr->rank == 0)
1485     name = gfc_get_string (PREFIX("random_r%d"), kind);
1486   else
1487     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1488
1489   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1490 }
1491
1492
1493 /* G77 compatibility subroutines etime() and dtime().  */
1494
1495 void
1496 gfc_resolve_etime_sub (gfc_code * c)
1497 {
1498   const char *name;
1499
1500   name = gfc_get_string (PREFIX("etime_sub"));
1501   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1502 }
1503
1504
1505 /* G77 compatibility subroutine second().  */
1506
1507 void
1508 gfc_resolve_second_sub (gfc_code * c)
1509 {
1510   const char *name;
1511
1512   name = gfc_get_string (PREFIX("second_sub"));
1513   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1514 }
1515
1516
1517 /* G77 compatibility function srand().  */
1518
1519 void
1520 gfc_resolve_srand (gfc_code * c)
1521 {
1522   const char *name;
1523   name = gfc_get_string (PREFIX("srand"));
1524   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1525 }
1526
1527
1528 /* Resolve the getarg intrinsic subroutine.  */
1529
1530 void
1531 gfc_resolve_getarg (gfc_code * c)
1532 {
1533   const char *name;
1534   int kind;
1535
1536   kind = gfc_default_integer_kind;
1537   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1538   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1539 }
1540
1541 /* Resolve the getcwd intrinsic subroutine.  */
1542
1543 void
1544 gfc_resolve_getcwd_sub (gfc_code * c)
1545 {
1546   const char *name;
1547   int kind;
1548
1549   if (c->ext.actual->next->expr != NULL)
1550     kind = c->ext.actual->next->expr->ts.kind;
1551   else
1552     kind = gfc_default_integer_kind;
1553
1554   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1555   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1556 }
1557
1558
1559 /* Resolve the get_command intrinsic subroutine.  */
1560
1561 void
1562 gfc_resolve_get_command (gfc_code * c)
1563 {
1564   const char *name;
1565   int kind;
1566
1567   kind = gfc_default_integer_kind;
1568   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1569   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1570 }
1571
1572
1573 /* Resolve the get_command_argument intrinsic subroutine.  */
1574
1575 void
1576 gfc_resolve_get_command_argument (gfc_code * c)
1577 {
1578   const char *name;
1579   int kind;
1580
1581   kind = gfc_default_integer_kind;
1582   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1583   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1584 }
1585
1586 /* Resolve the get_environment_variable intrinsic subroutine.  */
1587
1588 void
1589 gfc_resolve_get_environment_variable (gfc_code * code)
1590 {
1591   const char *name;
1592   int kind;
1593
1594   kind = gfc_default_integer_kind;
1595   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1596   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1597 }
1598
1599 /* Resolve the SYSTEM intrinsic subroutine.  */
1600
1601 void
1602 gfc_resolve_system_sub (gfc_code * c)
1603 {
1604   const char *name;
1605
1606   name = gfc_get_string (PREFIX("system_sub"));
1607   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1608 }
1609
1610 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1611
1612 void
1613 gfc_resolve_system_clock (gfc_code * c)
1614 {
1615   const char *name;
1616   int kind;
1617
1618   if (c->ext.actual->expr != NULL)
1619     kind = c->ext.actual->expr->ts.kind;
1620   else if (c->ext.actual->next->expr != NULL)
1621       kind = c->ext.actual->next->expr->ts.kind;
1622   else if (c->ext.actual->next->next->expr != NULL)
1623       kind = c->ext.actual->next->next->expr->ts.kind;
1624   else
1625     kind = gfc_default_integer_kind;
1626
1627   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1628   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1629 }
1630
1631 /* Resolve the EXIT intrinsic subroutine.  */
1632
1633 void
1634 gfc_resolve_exit (gfc_code * c)
1635 {
1636   const char *name;
1637   int kind;
1638
1639   if (c->ext.actual->expr != NULL)
1640     kind = c->ext.actual->expr->ts.kind;
1641   else
1642     kind = gfc_default_integer_kind;
1643
1644   name = gfc_get_string (PREFIX("exit_i%d"), kind);
1645   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1646 }
1647
1648 /* Resolve the FLUSH intrinsic subroutine.  */
1649
1650 void
1651 gfc_resolve_flush (gfc_code * c)
1652 {
1653   const char *name;
1654   gfc_typespec ts;
1655   gfc_expr *n;
1656
1657   ts.type = BT_INTEGER;
1658   ts.kind = gfc_default_integer_kind;
1659   n = c->ext.actual->expr;
1660   if (n != NULL
1661       && n->ts.kind != ts.kind)
1662     gfc_convert_type (n, &ts, 2);
1663
1664   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1665   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1666 }
1667
1668 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
1669
1670 void
1671 gfc_resolve_stat_sub (gfc_code * c)
1672 {
1673   const char *name;
1674
1675   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
1676   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1677 }
1678
1679
1680 void
1681 gfc_resolve_fstat_sub (gfc_code * c)
1682 {
1683   const char *name;
1684   gfc_expr *u;
1685   gfc_typespec *ts;
1686
1687   u = c->ext.actual->expr;
1688   ts = &c->ext.actual->next->expr->ts;
1689   if (u->ts.kind != ts->kind)
1690     gfc_convert_type (u, ts, 2);
1691   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
1692   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1693 }
1694
1695 /* Resolve the UMASK intrinsic subroutine.  */
1696
1697 void
1698 gfc_resolve_umask_sub (gfc_code * c)
1699 {
1700   const char *name;
1701   int kind;
1702
1703   if (c->ext.actual->next->expr != NULL)
1704     kind = c->ext.actual->next->expr->ts.kind;
1705   else
1706     kind = gfc_default_integer_kind;
1707
1708   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
1709   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1710 }
1711
1712 /* Resolve the UNLINK intrinsic subroutine.  */
1713
1714 void
1715 gfc_resolve_unlink_sub (gfc_code * c)
1716 {
1717   const char *name;
1718   int kind;
1719
1720   if (c->ext.actual->next->expr != NULL)
1721     kind = c->ext.actual->next->expr->ts.kind;
1722   else
1723     kind = gfc_default_integer_kind;
1724
1725   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
1726   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1727 }