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