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 (dim, &shift->ts, 2);
 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 (dim, &shift->ts, 2);
 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_fraction (gfc_expr * f, gfc_expr * x)
 557 {
 558
 559   f->ts = x->ts;
 560   f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
 561 }
 562
 563
 564 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
 565
 566 void
 567 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
 568 {
 569   f->ts = x->ts;
 570   f->value.function.name = gfc_get_string ("<intrinsic>");
 571 }
 572
 573
 574 void
 575 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
 576 {
 577   f->ts.type = BT_INTEGER;
 578   f->ts.kind = 4;
 579   f->value.function.name = gfc_get_string (PREFIX("getcwd"));
 580 }
 581
 582
 583 void
 584 gfc_resolve_getgid (gfc_expr * f)
 585 {
 586   f->ts.type = BT_INTEGER;
 587   f->ts.kind = 4;
 588   f->value.function.name = gfc_get_string (PREFIX("getgid"));
 589 }
 590
 591
 592 void
 593 gfc_resolve_getpid (gfc_expr * f)
 594 {
 595   f->ts.type = BT_INTEGER;
 596   f->ts.kind = 4;
 597   f->value.function.name = gfc_get_string (PREFIX("getpid"));
 598 }
 599
 600
 601 void
 602 gfc_resolve_getuid (gfc_expr * f)
 603 {
 604   f->ts.type = BT_INTEGER;
 605   f->ts.kind = 4;
 606   f->value.function.name = gfc_get_string (PREFIX("getuid"));
 607 }
 608
 609 void
 610 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j ATTRIBUTE_UNUSED)
 611 {
 612
 613   f->ts = i->ts;
 614   f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
 615 }
 616
 617
 618 void
 619 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
 620 {
 621
 622   f->ts = i->ts;
 623   f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
 624 }
 625
 626
 627 void
 628 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
 629                    gfc_expr * pos ATTRIBUTE_UNUSED,
 630                    gfc_expr * len ATTRIBUTE_UNUSED)
 631 {
 632
 633   f->ts = i->ts;
 634   f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
 635 }
 636
 637
 638 void
 639 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
 640                    gfc_expr * pos ATTRIBUTE_UNUSED)
 641 {
 642
 643   f->ts = i->ts;
 644   f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
 645 }
 646
 647
 648 void
 649 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
 650 {
 651
 652   f->ts.type = BT_INTEGER;
 653   f->ts.kind = gfc_default_integer_kind;
 654
 655   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 656 }
 657
 658
 659 void
 660 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
 661 {
 662   gfc_resolve_nint (f, a, NULL);
 663 }
 664
 665
 666 void
 667 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i,
 668                   gfc_expr * j ATTRIBUTE_UNUSED)
 669 {
 670
 671   f->ts = i->ts;
 672   f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
 673 }
 674
 675
 676 void
 677 gfc_resolve_ior (gfc_expr * f, gfc_expr * i,
 678                  gfc_expr * j ATTRIBUTE_UNUSED)
 679 {
 680
 681   f->ts = i->ts;
 682   f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
 683 }
 684
 685
 686 void
 687 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 688 {
 689
 690   f->ts.type = BT_INTEGER;
 691   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 692     : mpz_get_si (kind->value.integer);
 693
 694   f->value.function.name =
 695     gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
 696                     a->ts.kind);
 697 }
 698
 699
 700 void
 701 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
 702 {
 703
 704   f->ts = i->ts;
 705   f->value.function.name =
 706     gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
 707 }
 708
 709
 710 void
 711 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
 712                     gfc_expr * size)
 713 {
 714   int s_kind;
 715
 716   s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
 717
 718   f->ts = i->ts;
 719   f->value.function.name =
 720     gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
 721 }
 722
 723
 724 void
 725 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
 726                     gfc_expr * dim)
 727 {
 728   static char lbound[] = "__lbound";
 729
 730   f->ts.type = BT_INTEGER;
 731   f->ts.kind = gfc_default_integer_kind;
 732
 733   if (dim == NULL)
 734     {
 735       f->rank = 1;
 736       f->shape = gfc_get_shape (1);
 737       mpz_init_set_ui (f->shape[0], array->rank);
 738     }
 739
 740   f->value.function.name = lbound;
 741 }
 742
 743
 744 void
 745 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
 746 {
 747
 748   f->ts.type = BT_INTEGER;
 749   f->ts.kind = gfc_default_integer_kind;
 750   f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
 751 }
 752
 753
 754 void
 755 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
 756 {
 757
 758   f->ts.type = BT_INTEGER;
 759   f->ts.kind = gfc_default_integer_kind;
 760   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
 761 }
 762
 763
 764 void
 765 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
 766 {
 767
 768   f->ts = x->ts;
 769   f->value.function.name =
 770     gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 771 }
 772
 773
 774 void
 775 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
 776 {
 777
 778   f->ts = x->ts;
 779   f->value.function.name =
 780     gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 781 }
 782
 783
 784 void
 785 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 786 {
 787
 788   f->ts.type = BT_LOGICAL;
 789   f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
 790     : mpz_get_si (kind->value.integer);
 791   f->rank = a->rank;
 792
 793   f->value.function.name =
 794     gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
 795                     gfc_type_letter (a->ts.type), a->ts.kind);
 796 }
 797
 798
 799 void
 800 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 801 {
 802   gfc_expr temp;
 803
 804   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 805     {
 806       f->ts.type = BT_LOGICAL;
 807       f->ts.kind = gfc_default_logical_kind;
 808     }
 809   else
 810     {
 811       temp.expr_type = EXPR_OP;
 812       gfc_clear_ts (&temp.ts);
 813       temp.operator = INTRINSIC_NONE;
 814       temp.op1 = a;
 815       temp.op2 = b;
 816       gfc_type_convert_binary (&temp);
 817       f->ts = temp.ts;
 818     }
 819
 820   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
 821
 822   f->value.function.name =
 823     gfc_get_string ("__matmul_%c%d", gfc_type_letter (f->ts.type),
 824                     f->ts.kind);
 825 }
 826
 827
 828 static void
 829 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
 830 {
 831   gfc_actual_arglist *a;
 832
 833   f->ts.type = args->expr->ts.type;
 834   f->ts.kind = args->expr->ts.kind;
 835   /* Find the largest type kind.  */
 836   for (a = args->next; a; a = a->next)
 837     {
 838       if (a->expr->ts.kind > f->ts.kind)
 839         f->ts.kind = a->expr->ts.kind;
 840     }
 841
 842   /* Convert all parameters to the required kind.  */
 843   for (a = args; a; a = a->next)
 844     {
 845       if (a->expr->ts.kind != f->ts.kind)
 846         gfc_convert_type (a->expr, &f->ts, 2);
 847     }
 848
 849   f->value.function.name =
 850     gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
 851 }
 852
 853
 854 void
 855 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
 856 {
 857   gfc_resolve_minmax ("__max_%c%d", f, args);
 858 }
 859
 860
 861 void
 862 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 863                     gfc_expr * mask)
 864 {
 865   const char *name;
 866
 867   f->ts.type = BT_INTEGER;
 868   f->ts.kind = gfc_default_integer_kind;
 869
 870   if (dim == NULL)
 871     f->rank = 1;
 872   else
 873     {
 874       f->rank = array->rank - 1;
 875       gfc_resolve_index (dim, 1);
 876     }
 877
 878   name = mask ? "mmaxloc" : "maxloc";
 879   f->value.function.name =
 880     gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
 881                     gfc_type_letter (array->ts.type), array->ts.kind);
 882 }
 883
 884
 885 void
 886 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 887                     gfc_expr * mask)
 888 {
 889
 890   f->ts = array->ts;
 891
 892   if (dim != NULL)
 893     {
 894       f->rank = array->rank - 1;
 895       gfc_resolve_index (dim, 1);
 896     }
 897
 898   f->value.function.name =
 899     gfc_get_string ("__%s_%c%d", mask ? "mmaxval" : "maxval",
 900                     gfc_type_letter (array->ts.type), array->ts.kind);
 901 }
 902
 903
 904 void
 905 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
 906                    gfc_expr * fsource ATTRIBUTE_UNUSED,
 907                    gfc_expr * mask ATTRIBUTE_UNUSED)
 908 {
 909
 910   f->ts = tsource->ts;
 911   f->value.function.name =
 912     gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
 913                     tsource->ts.kind);
 914 }
 915
 916
 917 void
 918 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
 919 {
 920   gfc_resolve_minmax ("__min_%c%d", f, args);
 921 }
 922
 923
 924 void
 925 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 926                     gfc_expr * mask)
 927 {
 928   const char *name;
 929
 930   f->ts.type = BT_INTEGER;
 931   f->ts.kind = gfc_default_integer_kind;
 932
 933   if (dim == NULL)
 934     f->rank = 1;
 935   else
 936     {
 937       f->rank = array->rank - 1;
 938       gfc_resolve_index (dim, 1);
 939     }
 940
 941   name = mask ? "mminloc" : "minloc";
 942   f->value.function.name =
 943     gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
 944                     gfc_type_letter (array->ts.type), array->ts.kind);
 945 }
 946
 947
 948 void
 949 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 950                     gfc_expr * mask)
 951 {
 952
 953   f->ts = array->ts;
 954
 955   if (dim != NULL)
 956     {
 957       f->rank = array->rank - 1;
 958       gfc_resolve_index (dim, 1);
 959     }
 960
 961   f->value.function.name =
 962     gfc_get_string ("__%s_%c%d", mask ? "mminval" : "minval",
 963                     gfc_type_letter (array->ts.type), array->ts.kind);
 964 }
 965
 966
 967 void
 968 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
 969                  gfc_expr * p ATTRIBUTE_UNUSED)
 970 {
 971
 972   f->ts = a->ts;
 973   f->value.function.name =
 974     gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 975 }
 976
 977
 978 void
 979 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
 980                     gfc_expr * p ATTRIBUTE_UNUSED)
 981 {
 982
 983   f->ts = a->ts;
 984   f->value.function.name =
 985     gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
 986                     a->ts.kind);
 987 }
 988
 989 void
 990 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a,
 991              gfc_expr *p ATTRIBUTE_UNUSED)
 992 {
 993
 994   f->ts = a->ts;
 995   f->value.function.name =
 996     gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
 997             a->ts.kind);
 998 }
 999
1000 void
1001 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1002 {
1003
1004   f->ts.type = BT_INTEGER;
1005   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1006     : mpz_get_si (kind->value.integer);
1007
1008   f->value.function.name =
1009     gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1010 }
1011
1012
1013 void
1014 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1015 {
1016
1017   f->ts = i->ts;
1018   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1019 }
1020
1021
1022 void
1023 gfc_resolve_pack (gfc_expr * f,
1024                   gfc_expr * array ATTRIBUTE_UNUSED,
1025                   gfc_expr * mask,
1026                   gfc_expr * vector ATTRIBUTE_UNUSED)
1027 {
1028   static char pack[] = "__pack",
1029     pack_s[] = "__pack_s";
1030
1031   f->ts = array->ts;
1032   f->rank = 1;
1033
1034   if (mask->rank != 0)
1035     f->value.function.name = pack;
1036   else
1037     {
1038       /* We convert mask to default logical only in the scalar case.
1039          In the array case we can simply read the array as if it were
1040          of type default logical.  */
1041       if (mask->ts.kind != gfc_default_logical_kind)
1042         {
1043           gfc_typespec ts;
1044
1045           ts.type = BT_LOGICAL;
1046           ts.kind = gfc_default_logical_kind;
1047           gfc_convert_type (mask, &ts, 2);
1048         }
1049
1050       f->value.function.name = pack_s;
1051     }
1052 }
1053
1054
1055 void
1056 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1057                      gfc_expr * mask)
1058 {
1059
1060   f->ts = array->ts;
1061
1062   if (dim != NULL)
1063     {
1064       f->rank = array->rank - 1;
1065       gfc_resolve_index (dim, 1);
1066     }
1067
1068   f->value.function.name =
1069     gfc_get_string ("__%s_%c%d", mask ? "mproduct" : "product",
1070                     gfc_type_letter (array->ts.type), array->ts.kind);
1071 }
1072
1073
1074 void
1075 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1076 {
1077
1078   f->ts.type = BT_REAL;
1079
1080   if (kind != NULL)
1081     f->ts.kind = mpz_get_si (kind->value.integer);
1082   else
1083     f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1084       a->ts.kind : gfc_default_real_kind;
1085
1086   f->value.function.name =
1087     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1088                     gfc_type_letter (a->ts.type), a->ts.kind);
1089 }
1090
1091
1092 void
1093 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1094                    gfc_expr * ncopies ATTRIBUTE_UNUSED)
1095 {
1096
1097   f->ts.type = BT_CHARACTER;
1098   f->ts.kind = string->ts.kind;
1099   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1100 }
1101
1102
1103 void
1104 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1105                      gfc_expr * pad ATTRIBUTE_UNUSED,
1106                      gfc_expr * order ATTRIBUTE_UNUSED)
1107 {
1108   static char reshape0[] = "__reshape";
1109   mpz_t rank;
1110   int kind;
1111   int i;
1112
1113   f->ts = source->ts;
1114
1115   gfc_array_size (shape, &rank);
1116   f->rank = mpz_get_si (rank);
1117   mpz_clear (rank);
1118   switch (source->ts.type)
1119     {
1120     case BT_COMPLEX:
1121       kind = source->ts.kind * 2;
1122       break;
1123
1124     case BT_REAL:
1125     case BT_INTEGER:
1126     case BT_LOGICAL:
1127       kind = source->ts.kind;
1128       break;
1129
1130     default:
1131       kind = 0;
1132       break;
1133     }
1134
1135   switch (kind)
1136     {
1137     case 4:
1138     case 8:
1139     /* case 16: */
1140       f->value.function.name =
1141         gfc_get_string ("__reshape_%d", source->ts.kind);
1142       break;
1143
1144     default:
1145       f->value.function.name = reshape0;
1146       break;
1147     }
1148
1149   /* TODO: Make this work with a constant ORDER parameter.  */
1150   if (shape->expr_type == EXPR_ARRAY
1151       && gfc_is_constant_expr (shape)
1152       && order == NULL)
1153     {
1154       gfc_constructor *c;
1155       f->shape = gfc_get_shape (f->rank);
1156       c = shape->value.constructor;
1157       for (i = 0; i < f->rank; i++)
1158         {
1159           mpz_init_set (f->shape[i], c->expr->value.integer);
1160           c = c->next;
1161         }
1162     }
1163 }
1164
1165
1166 void
1167 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1168 {
1169
1170   f->ts = x->ts;
1171   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1172 }
1173
1174
1175 void
1176 gfc_resolve_scale (gfc_expr * f, gfc_expr * x,
1177                    gfc_expr * y ATTRIBUTE_UNUSED)
1178 {
1179
1180   f->ts = x->ts;
1181   f->value.function.name = gfc_get_string ("__scale_%d_%d", x->ts.kind,
1182                                            x->ts.kind);
1183 }
1184
1185
1186 void
1187 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1188                   gfc_expr * set ATTRIBUTE_UNUSED,
1189                   gfc_expr * back ATTRIBUTE_UNUSED)
1190 {
1191
1192   f->ts.type = BT_INTEGER;
1193   f->ts.kind = gfc_default_integer_kind;
1194   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1195 }
1196
1197
1198 void
1199 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1200 {
1201
1202   f->ts = x->ts;
1203   f->value.function.name =
1204     gfc_get_string ("__set_exponent_%d_%d", x->ts.kind, i->ts.kind);
1205 }
1206
1207
1208 void
1209 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1210 {
1211
1212   f->ts.type = BT_INTEGER;
1213   f->ts.kind = gfc_default_integer_kind;
1214   f->rank = 1;
1215   f->value.function.name = gfc_get_string ("__shape_%d", f->ts.kind);
1216   f->shape = gfc_get_shape (1);
1217   mpz_init_set_ui (f->shape[0], array->rank);
1218 }
1219
1220
1221 void
1222 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1223 {
1224
1225   f->ts = a->ts;
1226   f->value.function.name =
1227     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1228 }
1229
1230
1231 void
1232 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1233 {
1234
1235   f->ts = x->ts;
1236   f->value.function.name =
1237     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1238 }
1239
1240
1241 void
1242 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1243 {
1244
1245   f->ts = x->ts;
1246   f->value.function.name =
1247     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1248 }
1249
1250
1251 void
1252 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1253 {
1254
1255   f->ts = x->ts;
1256   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1257 }
1258
1259
1260 void
1261 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1262                     gfc_expr * dim,
1263                     gfc_expr * ncopies)
1264 {
1265   static char spread[] = "__spread";
1266
1267   f->ts = source->ts;
1268   f->rank = source->rank + 1;
1269   f->value.function.name = spread;
1270
1271   gfc_resolve_index (dim, 1);
1272   gfc_resolve_index (ncopies, 1);
1273 }
1274
1275
1276 void
1277 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1278 {
1279
1280   f->ts = x->ts;
1281   f->value.function.name =
1282     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1283 }
1284
1285
1286 void
1287 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1288                  gfc_expr * mask)
1289 {
1290
1291   f->ts = array->ts;
1292
1293   if (dim != NULL)
1294     {
1295       f->rank = array->rank - 1;
1296       gfc_resolve_index (dim, 1);
1297     }
1298
1299   f->value.function.name =
1300     gfc_get_string ("__%s_%c%d", mask ? "msum" : "sum",
1301                     gfc_type_letter (array->ts.type), array->ts.kind);
1302 }
1303
1304
1305 void
1306 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1307 {
1308
1309   f->ts = x->ts;
1310   f->value.function.name =
1311     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1312 }
1313
1314
1315 void
1316 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1317 {
1318
1319   f->ts = x->ts;
1320   f->value.function.name =
1321     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1322 }
1323
1324
1325 void
1326 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1327                       gfc_expr * mold, gfc_expr * size)
1328 {
1329   /* TODO: Make this do something meaningful.  */
1330   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1331
1332   f->ts = mold->ts;
1333
1334   if (size == NULL && mold->rank == 0)
1335     {
1336       f->rank = 0;
1337       f->value.function.name = transfer0;
1338     }
1339   else
1340     {
1341       f->rank = 1;
1342       f->value.function.name = transfer1;
1343     }
1344 }
1345
1346
1347 void
1348 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1349 {
1350   static char transpose0[] = "__transpose";
1351   int kind;
1352
1353   f->ts = matrix->ts;
1354   f->rank = 2;
1355   if (matrix->shape)
1356     {
1357       f->shape = gfc_get_shape (2);
1358       mpz_init_set (f->shape[0], matrix->shape[1]);
1359       mpz_init_set (f->shape[1], matrix->shape[0]);
1360     }
1361
1362   switch (matrix->ts.type)
1363     {
1364     case BT_COMPLEX:
1365       kind = matrix->ts.kind * 2;
1366       break;
1367
1368     case BT_REAL:
1369     case BT_INTEGER:
1370     case BT_LOGICAL:
1371       kind = matrix->ts.kind;
1372       break;
1373
1374     default:
1375       kind = 0;
1376       break;
1377
1378     }
1379
1380   switch (kind)
1381     {
1382     case 4:
1383     case 8:
1384     /* case 16: */
1385       f->value.function.name =
1386         gfc_get_string ("__transpose_%d", kind);
1387       break;
1388
1389     default:
1390       f->value.function.name = transpose0;
1391     }
1392 }
1393
1394
1395 void
1396 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1397 {
1398
1399   f->ts.type = BT_CHARACTER;
1400   f->ts.kind = string->ts.kind;
1401   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1402 }
1403
1404
1405 void
1406 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1407                     gfc_expr * dim)
1408 {
1409   static char ubound[] = "__ubound";
1410
1411   f->ts.type = BT_INTEGER;
1412   f->ts.kind = gfc_default_integer_kind;
1413
1414   if (dim == NULL)
1415     {
1416       f->rank = 1;
1417       f->shape = gfc_get_shape (1);
1418       mpz_init_set_ui (f->shape[0], array->rank);
1419     }
1420
1421   f->value.function.name = ubound;
1422 }
1423
1424
1425 void
1426 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1427                     gfc_expr * field ATTRIBUTE_UNUSED)
1428 {
1429
1430   f->ts.type = vector->ts.type;
1431   f->ts.kind = vector->ts.kind;
1432   f->rank = mask->rank;
1433
1434   f->value.function.name =
1435     gfc_get_string ("__unpack%d", field->rank > 0 ? 1 : 0);
1436 }
1437
1438
1439 void
1440 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1441                     gfc_expr * set ATTRIBUTE_UNUSED,
1442                     gfc_expr * back ATTRIBUTE_UNUSED)
1443 {
1444
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_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1466 {
1467   const char *name;
1468   int kind;
1469
1470   kind = c->ext.actual->expr->ts.kind;
1471   if (c->ext.actual->expr->rank == 0)
1472     name = gfc_get_string (PREFIX("random_r%d"), kind);
1473   else
1474     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1475
1476   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1477
1478 }
1479
1480
1481 /* G77 compatibility subroutines etime() and dtime().  */
1482
1483 void
1484 gfc_resolve_etime_sub (gfc_code * c)
1485 {
1486   const char *name;
1487
1488   name = gfc_get_string (PREFIX("etime_sub"));
1489   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1490 }
1491
1492
1493 /* G77 compatibility subroutine second().  */
1494
1495 void
1496 gfc_resolve_second_sub (gfc_code * c)
1497 {
1498   const char *name;
1499
1500   name = gfc_get_string (PREFIX("second_sub"));
1501   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1502 }
1503
1504
1505 /* G77 compatibility function srand().  */
1506
1507 void
1508 gfc_resolve_srand (gfc_code * c)
1509 {
1510   const char *name;
1511   name = gfc_get_string (PREFIX("srand"));
1512   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1513 }
1514
1515
1516 /* Resolve the getarg intrinsic subroutine.  */
1517
1518 void
1519 gfc_resolve_getarg (gfc_code * c)
1520 {
1521   const char *name;
1522   int kind;
1523
1524   kind = gfc_default_integer_kind;
1525   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1526   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1527 }
1528
1529 /* Resolve the getcwd intrinsic subroutine.  */
1530
1531 void
1532 gfc_resolve_getcwd_sub (gfc_code * c)
1533 {
1534   const char *name;
1535   int kind;
1536
1537   if (c->ext.actual->next->expr != NULL)
1538     kind = c->ext.actual->next->expr->ts.kind;
1539   else
1540     kind = gfc_default_integer_kind;
1541
1542   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1543   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1544 }
1545
1546
1547 /* Resolve the get_command intrinsic subroutine.  */
1548
1549 void
1550 gfc_resolve_get_command (gfc_code * c)
1551 {
1552   const char *name;
1553   int kind;
1554
1555   kind = gfc_default_integer_kind;
1556   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1557   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1558 }
1559
1560
1561 /* Resolve the get_command_argument intrinsic subroutine.  */
1562
1563 void
1564 gfc_resolve_get_command_argument (gfc_code * c)
1565 {
1566   const char *name;
1567   int kind;
1568
1569   kind = gfc_default_integer_kind;
1570   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1571   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1572 }
1573
1574 /* Resolve the get_environment_variable intrinsic subroutine. */
1575
1576 void
1577 gfc_resolve_get_environment_variable (gfc_code * code)
1578 {
1579   const char *name;
1580   int kind;
1581
1582   kind = gfc_default_integer_kind;
1583   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1584   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1585 }
1586
1587
1588 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1589
1590 void
1591 gfc_resolve_system_clock (gfc_code * c)
1592 {
1593   const char *name;
1594   int kind;
1595
1596   if (c->ext.actual->expr != NULL)
1597     kind = c->ext.actual->expr->ts.kind;
1598   else if (c->ext.actual->next->expr != NULL)
1599       kind = c->ext.actual->next->expr->ts.kind;
1600   else if (c->ext.actual->next->next->expr != NULL)
1601       kind = c->ext.actual->next->next->expr->ts.kind;
1602   else
1603     kind = gfc_default_integer_kind;
1604
1605   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1606   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1607 }
1608
1609 void
1610 gfc_iresolve_init_1 (void)
1611 {
1612   int i;
1613
1614   for (i = 0; i < HASH_SIZE; i++)
1615     string_head[i] = NULL;
1616 }
1617
1618
1619 void
1620 gfc_iresolve_done_1 (void)
1621 {
1622
1623   free_strings ();
1624 }