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