gcc/fortran/iresolve.c

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