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 void
 886 gfc_resolve_minval (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 ? "mminval" : "minval",
 900                     gfc_type_letter (array->ts.type), array->ts.kind);
 901 }
 902
 903
 904 void
 905 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
 906                  gfc_expr * p ATTRIBUTE_UNUSED)
 907 {
 908
 909   f->ts = a->ts;
 910   f->value.function.name =
 911     gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 912 }
 913
 914
 915 void
 916 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
 917                     gfc_expr * p ATTRIBUTE_UNUSED)
 918 {
 919
 920   f->ts = a->ts;
 921   f->value.function.name =
 922     gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
 923                     a->ts.kind);
 924 }
 925
 926 void
 927 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a,
 928              gfc_expr *p ATTRIBUTE_UNUSED)
 929 {
 930
 931   f->ts = a->ts;
 932   f->value.function.name =
 933     gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
 934             a->ts.kind);
 935 }
 936
 937 void
 938 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 939 {
 940
 941   f->ts.type = BT_INTEGER;
 942   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind ()
 943     : mpz_get_si (kind->value.integer);
 944
 945   f->value.function.name =
 946     gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
 947 }
 948
 949
 950 void
 951 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
 952 {
 953
 954   f->ts = i->ts;
 955   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
 956 }
 957
 958
 959 void
 960 gfc_resolve_pack (gfc_expr * f,
 961                   gfc_expr * array ATTRIBUTE_UNUSED,
 962                   gfc_expr * mask ATTRIBUTE_UNUSED,
 963                   gfc_expr * vector ATTRIBUTE_UNUSED)
 964 {
 965   static char pack[] = "__pack";
 966
 967   f->ts = array->ts;
 968   f->rank = 1;
 969
 970   f->value.function.name = pack;
 971 }
 972
 973
 974 void
 975 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 976                      gfc_expr * mask)
 977 {
 978
 979   f->ts = array->ts;
 980
 981   if (dim != NULL)
 982     {
 983       f->rank = array->rank - 1;
 984       gfc_resolve_index (dim, 1);
 985     }
 986
 987   f->value.function.name =
 988     gfc_get_string ("__%s_%c%d", mask ? "mproduct" : "product",
 989                     gfc_type_letter (array->ts.type), array->ts.kind);
 990 }
 991
 992
 993 void
 994 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 995 {
 996
 997   f->ts.type = BT_REAL;
 998
 999   if (kind != NULL)
1000     f->ts.kind = mpz_get_si (kind->value.integer);
1001   else
1002     f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1003       a->ts.kind : gfc_default_real_kind ();
1004
1005   f->value.function.name =
1006     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1007                     gfc_type_letter (a->ts.type), a->ts.kind);
1008 }
1009
1010
1011 void
1012 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1013                    gfc_expr * ncopies ATTRIBUTE_UNUSED)
1014 {
1015
1016   f->ts.type = BT_CHARACTER;
1017   f->ts.kind = string->ts.kind;
1018   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1019 }
1020
1021
1022 void
1023 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1024                      gfc_expr * pad ATTRIBUTE_UNUSED,
1025                      gfc_expr * order ATTRIBUTE_UNUSED)
1026 {
1027   static char reshape0[] = "__reshape";
1028   mpz_t rank;
1029   int kind;
1030   int i;
1031
1032   f->ts = source->ts;
1033
1034   gfc_array_size (shape, &rank);
1035   f->rank = mpz_get_si (rank);
1036   mpz_clear (rank);
1037   switch (source->ts.type)
1038     {
1039     case BT_COMPLEX:
1040       kind = source->ts.kind * 2;
1041       break;
1042
1043     case BT_REAL:
1044     case BT_INTEGER:
1045     case BT_LOGICAL:
1046       kind = source->ts.kind;
1047       break;
1048
1049     default:
1050       kind = 0;
1051       break;
1052     }
1053
1054   switch (kind)
1055     {
1056     case 4:
1057     case 8:
1058     /* case 16: */
1059       f->value.function.name =
1060         gfc_get_string ("__reshape_%d", source->ts.kind);
1061       break;
1062
1063     default:
1064       f->value.function.name = reshape0;
1065       break;
1066     }
1067
1068   /* TODO: Make this work with a constant ORDER parameter.  */
1069   if (shape->expr_type == EXPR_ARRAY
1070       && gfc_is_constant_expr (shape)
1071       && order == NULL)
1072     {
1073       gfc_constructor *c;
1074       f->shape = gfc_get_shape (f->rank);
1075       c = shape->value.constructor;
1076       for (i = 0; i < f->rank; i++)
1077         {
1078           mpz_init_set (f->shape[i], c->expr->value.integer);
1079           c = c->next;
1080         }
1081     }
1082 }
1083
1084
1085 void
1086 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1087 {
1088
1089   f->ts = x->ts;
1090   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1091 }
1092
1093
1094 void
1095 gfc_resolve_scale (gfc_expr * f, gfc_expr * x,
1096                    gfc_expr * y ATTRIBUTE_UNUSED)
1097 {
1098
1099   f->ts = x->ts;
1100   f->value.function.name = gfc_get_string ("__scale_%d_%d", x->ts.kind,
1101                                            x->ts.kind);
1102 }
1103
1104
1105 void
1106 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1107                   gfc_expr * set ATTRIBUTE_UNUSED,
1108                   gfc_expr * back ATTRIBUTE_UNUSED)
1109 {
1110
1111   f->ts.type = BT_INTEGER;
1112   f->ts.kind = gfc_default_integer_kind ();
1113   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1114 }
1115
1116
1117 void
1118 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1119 {
1120
1121   f->ts = x->ts;
1122   f->value.function.name =
1123     gfc_get_string ("__set_exponent_%d_%d", x->ts.kind, i->ts.kind);
1124 }
1125
1126
1127 void
1128 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1129 {
1130
1131   f->ts.type = BT_INTEGER;
1132   f->ts.kind = gfc_default_integer_kind ();
1133   f->rank = 1;
1134   f->value.function.name = gfc_get_string ("__shape_%d", f->ts.kind);
1135   f->shape = gfc_get_shape (1);
1136   mpz_init_set_ui (f->shape[0], array->rank);
1137 }
1138
1139
1140 void
1141 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1142 {
1143
1144   f->ts = a->ts;
1145   f->value.function.name =
1146     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1147 }
1148
1149
1150 void
1151 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1152 {
1153
1154   f->ts = x->ts;
1155   f->value.function.name =
1156     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1157 }
1158
1159
1160 void
1161 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1162 {
1163
1164   f->ts = x->ts;
1165   f->value.function.name =
1166     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1167 }
1168
1169
1170 void
1171 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1172 {
1173
1174   f->ts = x->ts;
1175   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1176 }
1177
1178
1179 void
1180 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1181                     gfc_expr * dim,
1182                     gfc_expr * ncopies)
1183 {
1184   static char spread[] = "__spread";
1185
1186   f->ts = source->ts;
1187   f->rank = source->rank + 1;
1188   f->value.function.name = spread;
1189
1190   gfc_resolve_index (dim, 1);
1191   gfc_resolve_index (ncopies, 1);
1192 }
1193
1194
1195 void
1196 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1197 {
1198
1199   f->ts = x->ts;
1200   f->value.function.name =
1201     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1202 }
1203
1204
1205 void
1206 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1207                  gfc_expr * mask)
1208 {
1209
1210   f->ts = array->ts;
1211
1212   if (dim != NULL)
1213     {
1214       f->rank = array->rank - 1;
1215       gfc_resolve_index (dim, 1);
1216     }
1217
1218   f->value.function.name =
1219     gfc_get_string ("__%s_%c%d", mask ? "msum" : "sum",
1220                     gfc_type_letter (array->ts.type), array->ts.kind);
1221 }
1222
1223
1224 void
1225 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1226 {
1227
1228   f->ts = x->ts;
1229   f->value.function.name =
1230     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1231 }
1232
1233
1234 void
1235 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1236 {
1237
1238   f->ts = x->ts;
1239   f->value.function.name =
1240     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1241 }
1242
1243
1244 void
1245 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1246                       gfc_expr * mold, gfc_expr * size)
1247 {
1248   /* TODO: Make this do something meaningful.  */
1249   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1250
1251   f->ts = mold->ts;
1252
1253   if (size == NULL && mold->rank == 0)
1254     {
1255       f->rank = 0;
1256       f->value.function.name = transfer0;
1257     }
1258   else
1259     {
1260       f->rank = 1;
1261       f->value.function.name = transfer1;
1262     }
1263 }
1264
1265
1266 void
1267 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1268 {
1269   static char transpose0[] = "__transpose";
1270   int kind;
1271
1272   f->ts = matrix->ts;
1273   f->rank = 2;
1274   if (matrix->shape)
1275     {
1276       f->shape = gfc_get_shape (2);
1277       mpz_init_set (f->shape[0], matrix->shape[1]);
1278       mpz_init_set (f->shape[1], matrix->shape[0]);
1279     }
1280
1281   switch (matrix->ts.type)
1282     {
1283     case BT_COMPLEX:
1284       kind = matrix->ts.kind * 2;
1285       break;
1286
1287     case BT_REAL:
1288     case BT_INTEGER:
1289     case BT_LOGICAL:
1290       kind = matrix->ts.kind;
1291       break;
1292
1293     default:
1294       kind = 0;
1295       break;
1296
1297     }
1298
1299   switch (kind)
1300     {
1301     case 4:
1302     case 8:
1303     /* case 16: */
1304       f->value.function.name =
1305         gfc_get_string ("__transpose_%d", kind);
1306       break;
1307
1308     default:
1309       f->value.function.name = transpose0;
1310     }
1311 }
1312
1313
1314 void
1315 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1316 {
1317
1318   f->ts.type = BT_CHARACTER;
1319   f->ts.kind = string->ts.kind;
1320   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1321 }
1322
1323
1324 void
1325 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1326                     gfc_expr * dim)
1327 {
1328   static char ubound[] = "__ubound";
1329
1330   f->ts.type = BT_INTEGER;
1331   f->ts.kind = gfc_default_integer_kind ();
1332
1333   if (dim == NULL)
1334     {
1335       f->rank = 1;
1336       f->shape = gfc_get_shape (1);
1337       mpz_init_set_ui (f->shape[0], array->rank);
1338     }
1339
1340   f->value.function.name = ubound;
1341 }
1342
1343
1344 void
1345 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1346                     gfc_expr * field ATTRIBUTE_UNUSED)
1347 {
1348
1349   f->ts.type = vector->ts.type;
1350   f->ts.kind = vector->ts.kind;
1351   f->rank = mask->rank;
1352
1353   f->value.function.name =
1354     gfc_get_string ("__unpack%d", field->rank > 0 ? 1 : 0);
1355 }
1356
1357
1358 void
1359 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1360                     gfc_expr * set ATTRIBUTE_UNUSED,
1361                     gfc_expr * back ATTRIBUTE_UNUSED)
1362 {
1363
1364   f->ts.type = BT_INTEGER;
1365   f->ts.kind = gfc_default_integer_kind ();
1366   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1367 }
1368
1369
1370 /* Intrinsic subroutine resolution.  */
1371
1372 void
1373 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1374 {
1375   const char *name;
1376
1377   name = gfc_get_string (PREFIX("cpu_time_%d"),
1378                          c->ext.actual->expr->ts.kind);
1379   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1380 }
1381
1382
1383 void
1384 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1385 {
1386   const char *name;
1387   int kind;
1388
1389   kind = c->ext.actual->expr->ts.kind;
1390   if (c->ext.actual->expr->rank == 0)
1391     name = gfc_get_string (PREFIX("random_r%d"), kind);
1392   else
1393     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1394
1395   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1396
1397 }
1398
1399
1400 /* G77 compatibility subroutines etime() and dtime().  */
1401
1402 void
1403 gfc_resolve_etime_sub (gfc_code * c)
1404 {
1405   const char *name;
1406
1407   name = gfc_get_string (PREFIX("etime_sub"));
1408   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1409 }
1410
1411
1412 /* G77 compatibility subroutine second().  */
1413
1414 void
1415 gfc_resolve_second_sub (gfc_code * c)
1416 {
1417   const char *name;
1418
1419   name = gfc_get_string (PREFIX("second_sub"));
1420   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1421 }
1422
1423
1424 /* G77 compatibility function srand().  */
1425
1426 void
1427 gfc_resolve_srand (gfc_code * c)
1428 {
1429   const char *name;
1430   name = gfc_get_string (PREFIX("srand"));
1431   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1432 }
1433
1434
1435 /* Resolve the getarg intrinsic subroutine.  */
1436
1437 void
1438 gfc_resolve_getarg (gfc_code * c)
1439 {
1440   const char *name;
1441   int kind;
1442
1443   kind = gfc_default_integer_kind ();
1444   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1445   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1446 }
1447
1448
1449 /* Resolve the get_command intrinsic subroutine.  */
1450
1451 void
1452 gfc_resolve_get_command (gfc_code * c)
1453 {
1454   const char *name;
1455   int kind;
1456
1457   kind = gfc_default_integer_kind ();
1458   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1459   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1460 }
1461
1462
1463 /* Resolve the get_command_argument intrinsic subroutine.  */
1464
1465 void
1466 gfc_resolve_get_command_argument (gfc_code * c)
1467 {
1468   const char *name;
1469   int kind;
1470
1471   kind = gfc_default_integer_kind ();
1472   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1473   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1474 }
1475
1476 /* Resolve the get_environment_variable intrinsic subroutine. */
1477
1478 void
1479 gfc_resolve_get_environment_variable (gfc_code * code)
1480 {
1481   const char *name;
1482   int kind;
1483
1484   kind = gfc_default_integer_kind();
1485   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1486   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1487 }
1488
1489
1490 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1491
1492 void
1493 gfc_resolve_system_clock (gfc_code * c)
1494 {
1495   const char *name;
1496   int kind;
1497
1498   if (c->ext.actual->expr != NULL)
1499     kind = c->ext.actual->expr->ts.kind;
1500   else if (c->ext.actual->next->expr != NULL)
1501       kind = c->ext.actual->next->expr->ts.kind;
1502   else if (c->ext.actual->next->next->expr != NULL)
1503       kind = c->ext.actual->next->next->expr->ts.kind;
1504   else
1505     kind = gfc_default_integer_kind ();
1506
1507   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1508   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1509 }
1510
1511 void
1512 gfc_iresolve_init_1 (void)
1513 {
1514   int i;
1515
1516   for (i = 0; i < HASH_SIZE; i++)
1517     string_head[i] = NULL;
1518 }
1519
1520
1521 void
1522 gfc_iresolve_done_1 (void)
1523 {
1524
1525   free_strings ();
1526 }