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