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_and (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 122 {
 123   f->ts.type = i->ts.type;
 124   f->ts.kind = gfc_kind_max (i,j);
 125
 126   if (i->ts.kind != j->ts.kind)
 127     {
 128       if (i->ts.kind == gfc_kind_max (i,j))
 129         gfc_convert_type(j, &i->ts, 2);
 130       else
 131         gfc_convert_type(i, &j->ts, 2);
 132     }
 133
 134   f->value.function.name = gfc_get_string ("__and_%c%d",
 135                                            gfc_type_letter (i->ts.type),
 136                                            f->ts.kind);
 137 }
 138
 139
 140 void
 141 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 142 {
 143   gfc_typespec ts;
 144
 145   f->ts.type = a->ts.type;
 146   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 147
 148   if (a->ts.kind != f->ts.kind)
 149     {
 150       ts.type = f->ts.type;
 151       ts.kind = f->ts.kind;
 152       gfc_convert_type (a, &ts, 2);
 153     }
 154   /* The resolved name is only used for specific intrinsics where
 155      the return kind is the same as the arg kind.  */
 156   f->value.function.name =
 157     gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 158 }
 159
 160
 161 void
 162 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
 163 {
 164   gfc_resolve_aint (f, a, NULL);
 165 }
 166
 167
 168 void
 169 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 170 {
 171   f->ts = mask->ts;
 172
 173   if (dim != NULL)
 174     {
 175       gfc_resolve_dim_arg (dim);
 176       f->rank = mask->rank - 1;
 177       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 178     }
 179
 180   f->value.function.name =
 181     gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
 182                     mask->ts.kind);
 183 }
 184
 185
 186 void
 187 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 188 {
 189   gfc_typespec ts;
 190
 191   f->ts.type = a->ts.type;
 192   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 193
 194   if (a->ts.kind != f->ts.kind)
 195     {
 196       ts.type = f->ts.type;
 197       ts.kind = f->ts.kind;
 198       gfc_convert_type (a, &ts, 2);
 199     }
 200
 201   /* The resolved name is only used for specific intrinsics where
 202      the return kind is the same as the arg kind.  */
 203   f->value.function.name =
 204     gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 205 }
 206
 207
 208 void
 209 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
 210 {
 211   gfc_resolve_anint (f, a, NULL);
 212 }
 213
 214
 215 void
 216 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 217 {
 218   f->ts = mask->ts;
 219
 220   if (dim != NULL)
 221     {
 222       gfc_resolve_dim_arg (dim);
 223       f->rank = mask->rank - 1;
 224       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 225     }
 226
 227   f->value.function.name =
 228     gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
 229                     mask->ts.kind);
 230 }
 231
 232
 233 void
 234 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
 235 {
 236   f->ts = x->ts;
 237   f->value.function.name =
 238     gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 239 }
 240
 241 void
 242 gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
 243 {
 244   f->ts = x->ts;
 245   f->value.function.name =
 246     gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 247 }
 248
 249 void
 250 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
 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 void
 258 gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
 259 {
 260   f->ts = x->ts;
 261   f->value.function.name =
 262     gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 263 }
 264
 265 void
 266 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
 267                    gfc_expr * y ATTRIBUTE_UNUSED)
 268 {
 269   f->ts = x->ts;
 270   f->value.function.name =
 271     gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 272 }
 273
 274
 275 /* Resolve the BESYN and BESJN intrinsics.  */
 276
 277 void
 278 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
 279 {
 280   gfc_typespec ts;
 281
 282   f->ts = x->ts;
 283   if (n->ts.kind != gfc_c_int_kind)
 284     {
 285       ts.type = BT_INTEGER;
 286       ts.kind = gfc_c_int_kind;
 287       gfc_convert_type (n, &ts, 2);
 288     }
 289   f->value.function.name = gfc_get_string ("<intrinsic>");
 290 }
 291
 292
 293 void
 294 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
 295 {
 296   f->ts.type = BT_LOGICAL;
 297   f->ts.kind = gfc_default_logical_kind;
 298
 299   f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
 300                                            pos->ts.kind);
 301 }
 302
 303
 304 void
 305 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 306 {
 307   f->ts.type = BT_INTEGER;
 308   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 309     : mpz_get_si (kind->value.integer);
 310
 311   f->value.function.name =
 312     gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
 313                     gfc_type_letter (a->ts.type), a->ts.kind);
 314 }
 315
 316
 317 void
 318 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 319 {
 320   f->ts.type = BT_CHARACTER;
 321   f->ts.kind = (kind == NULL) ? gfc_default_character_kind
 322     : mpz_get_si (kind->value.integer);
 323
 324   f->value.function.name =
 325     gfc_get_string ("__char_%d_%c%d", f->ts.kind,
 326                     gfc_type_letter (a->ts.type), a->ts.kind);
 327 }
 328
 329
 330 void
 331 gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
 332 {
 333   f->ts.type = BT_INTEGER;
 334   f->ts.kind = gfc_default_integer_kind;
 335   f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
 336 }
 337
 338
 339 void
 340 gfc_resolve_chdir_sub (gfc_code * c)
 341 {
 342   const char *name;
 343   int kind;
 344
 345   if (c->ext.actual->next->expr != NULL)
 346     kind = c->ext.actual->next->expr->ts.kind;
 347   else
 348     kind = gfc_default_integer_kind;
 349
 350   name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
 351   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 352 }
 353
 354
 355 void
 356 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 357 {
 358   f->ts.type = BT_COMPLEX;
 359   f->ts.kind = (kind == NULL) ? gfc_default_real_kind
 360     : mpz_get_si (kind->value.integer);
 361
 362   if (y == NULL)
 363     f->value.function.name =
 364       gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
 365                       gfc_type_letter (x->ts.type), x->ts.kind);
 366   else
 367     f->value.function.name =
 368       gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
 369                       gfc_type_letter (x->ts.type), x->ts.kind,
 370                       gfc_type_letter (y->ts.type), y->ts.kind);
 371 }
 372
 373 void
 374 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
 375 {
 376   gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
 377 }
 378
 379 void
 380 gfc_resolve_complex (gfc_expr * f, gfc_expr * x, gfc_expr * y)
 381 {
 382   int kind;
 383
 384   if (x->ts.type == BT_INTEGER)
 385     {
 386       if (y->ts.type == BT_INTEGER)
 387         kind = gfc_default_real_kind;
 388       else
 389         kind = y->ts.kind;
 390     }
 391   else
 392     {
 393       if (y->ts.type == BT_REAL)
 394         kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
 395       else
 396         kind = x->ts.kind;
 397     }
 398
 399   f->ts.type = BT_COMPLEX;
 400   f->ts.kind = kind;
 401
 402   f->value.function.name =
 403     gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
 404                     gfc_type_letter (x->ts.type), x->ts.kind,
 405                     gfc_type_letter (y->ts.type), y->ts.kind);
 406 }
 407
 408
 409 void
 410 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
 411 {
 412   f->ts = x->ts;
 413   f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
 414 }
 415
 416
 417 void
 418 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
 419 {
 420   f->ts = x->ts;
 421   f->value.function.name =
 422     gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 423 }
 424
 425
 426 void
 427 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
 428 {
 429   f->ts = x->ts;
 430   f->value.function.name =
 431     gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 432 }
 433
 434
 435 void
 436 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 437 {
 438   f->ts.type = BT_INTEGER;
 439   f->ts.kind = gfc_default_integer_kind;
 440
 441   if (dim != NULL)
 442     {
 443       f->rank = mask->rank - 1;
 444       gfc_resolve_dim_arg (dim);
 445       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 446     }
 447
 448   f->value.function.name =
 449     gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
 450                     gfc_type_letter (mask->ts.type), mask->ts.kind);
 451 }
 452
 453
 454 void
 455 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
 456                     gfc_expr * shift,
 457                     gfc_expr * dim)
 458 {
 459   int n;
 460
 461   f->ts = array->ts;
 462   f->rank = array->rank;
 463   f->shape = gfc_copy_shape (array->shape, array->rank);
 464
 465   if (shift->rank > 0)
 466     n = 1;
 467   else
 468     n = 0;
 469
 470   /* Convert shift to at least gfc_default_integer_kind, so we don't need
 471      kind=1 and kind=2 versions of the library functions.  */
 472   if (shift->ts.kind < gfc_default_integer_kind)
 473     {
 474       gfc_typespec ts;
 475       ts.type = BT_INTEGER;
 476       ts.kind = gfc_default_integer_kind;
 477       gfc_convert_type_warn (shift, &ts, 2, 0);
 478     }
 479
 480   if (dim != NULL)
 481     {
 482       gfc_resolve_dim_arg (dim);
 483       /* Convert dim to shift's kind, so we don't need so many variations.  */
 484       if (dim->ts.kind != shift->ts.kind)
 485         gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 486     }
 487   f->value.function.name =
 488     gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
 489                     array->ts.type == BT_CHARACTER ? "_char" : "");
 490 }
 491
 492
 493 void
 494 gfc_resolve_ctime (gfc_expr * f, gfc_expr * time)
 495 {
 496   gfc_typespec ts;
 497
 498   f->ts.type = BT_CHARACTER;
 499   f->ts.kind = gfc_default_character_kind;
 500
 501   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
 502   if (time->ts.kind != 8)
 503     {
 504       ts.type = BT_INTEGER;
 505       ts.kind = 8;
 506       ts.derived = NULL;
 507       ts.cl = NULL;
 508       gfc_convert_type (time, &ts, 2);
 509     }
 510
 511   f->value.function.name = gfc_get_string (PREFIX("ctime"));
 512 }
 513
 514
 515 void
 516 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
 517 {
 518   f->ts.type = BT_REAL;
 519   f->ts.kind = gfc_default_double_kind;
 520   f->value.function.name =
 521     gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 522 }
 523
 524
 525 void
 526 gfc_resolve_dim (gfc_expr * f, gfc_expr * a, gfc_expr * p)
 527 {
 528   f->ts.type = a->ts.type;
 529   if (p != NULL)
 530     f->ts.kind = gfc_kind_max (a,p);
 531   else
 532     f->ts.kind = a->ts.kind;
 533
 534   if (p != NULL && a->ts.kind != p->ts.kind)
 535     {
 536       if (a->ts.kind == gfc_kind_max (a,p))
 537         gfc_convert_type(p, &a->ts, 2);
 538       else
 539         gfc_convert_type(a, &p->ts, 2);
 540     }
 541
 542   f->value.function.name =
 543     gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
 544 }
 545
 546
 547 void
 548 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 549 {
 550   gfc_expr temp;
 551
 552   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 553     {
 554       f->ts.type = BT_LOGICAL;
 555       f->ts.kind = gfc_default_logical_kind;
 556     }
 557   else
 558     {
 559       temp.expr_type = EXPR_OP;
 560       gfc_clear_ts (&temp.ts);
 561       temp.value.op.operator = INTRINSIC_NONE;
 562       temp.value.op.op1 = a;
 563       temp.value.op.op2 = b;
 564       gfc_type_convert_binary (&temp);
 565       f->ts = temp.ts;
 566     }
 567
 568   f->value.function.name =
 569     gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
 570                     f->ts.kind);
 571 }
 572
 573
 574 void
 575 gfc_resolve_dprod (gfc_expr * f,
 576                    gfc_expr * a ATTRIBUTE_UNUSED,
 577                    gfc_expr * b ATTRIBUTE_UNUSED)
 578 {
 579   f->ts.kind = gfc_default_double_kind;
 580   f->ts.type = BT_REAL;
 581
 582   f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
 583 }
 584
 585
 586 void
 587 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
 588                      gfc_expr * shift,
 589                      gfc_expr * boundary,
 590                      gfc_expr * dim)
 591 {
 592   int n;
 593
 594   f->ts = array->ts;
 595   f->rank = array->rank;
 596   f->shape = gfc_copy_shape (array->shape, array->rank);
 597
 598   n = 0;
 599   if (shift->rank > 0)
 600     n = n | 1;
 601   if (boundary && boundary->rank > 0)
 602     n = n | 2;
 603
 604   /* Convert shift to at least gfc_default_integer_kind, so we don't need
 605      kind=1 and kind=2 versions of the library functions.  */
 606   if (shift->ts.kind < gfc_default_integer_kind)
 607     {
 608       gfc_typespec ts;
 609       ts.type = BT_INTEGER;
 610       ts.kind = gfc_default_integer_kind;
 611       gfc_convert_type_warn (shift, &ts, 2, 0);
 612     }
 613
 614   if (dim != NULL)
 615     {
 616       gfc_resolve_dim_arg (dim);
 617       /* Convert dim to shift's kind, so we don't need so many variations.  */
 618       if (dim->ts.kind != shift->ts.kind)
 619         gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 620     }
 621
 622   f->value.function.name =
 623     gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
 624                     array->ts.type == BT_CHARACTER ? "_char" : "");
 625 }
 626
 627
 628 void
 629 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
 630 {
 631   f->ts = x->ts;
 632   f->value.function.name =
 633     gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 634 }
 635
 636
 637 void
 638 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
 639 {
 640   f->ts.type = BT_INTEGER;
 641   f->ts.kind = gfc_default_integer_kind;
 642
 643   f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
 644 }
 645
 646
 647 void
 648 gfc_resolve_fdate (gfc_expr * f)
 649 {
 650   f->ts.type = BT_CHARACTER;
 651   f->ts.kind = gfc_default_character_kind;
 652   f->value.function.name = gfc_get_string (PREFIX("fdate"));
 653 }
 654
 655
 656 void
 657 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 658 {
 659   f->ts.type = BT_INTEGER;
 660   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 661     : mpz_get_si (kind->value.integer);
 662
 663   f->value.function.name =
 664     gfc_get_string ("__floor%d_%c%d", f->ts.kind,
 665                     gfc_type_letter (a->ts.type), a->ts.kind);
 666 }
 667
 668
 669 void
 670 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
 671 {
 672   f->ts.type = BT_INTEGER;
 673   f->ts.kind = gfc_default_integer_kind;
 674   if (n->ts.kind != f->ts.kind)
 675     gfc_convert_type (n, &f->ts, 2);
 676   f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
 677 }
 678
 679
 680 void
 681 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
 682 {
 683   f->ts = x->ts;
 684   f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
 685 }
 686
 687
 688 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
 689
 690 void
 691 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
 692 {
 693   f->ts = x->ts;
 694   f->value.function.name = gfc_get_string ("<intrinsic>");
 695 }
 696
 697
 698 void
 699 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
 700 {
 701   f->ts.type = BT_INTEGER;
 702   f->ts.kind = 4;
 703   f->value.function.name = gfc_get_string (PREFIX("getcwd"));
 704 }
 705
 706
 707 void
 708 gfc_resolve_getgid (gfc_expr * f)
 709 {
 710   f->ts.type = BT_INTEGER;
 711   f->ts.kind = 4;
 712   f->value.function.name = gfc_get_string (PREFIX("getgid"));
 713 }
 714
 715
 716 void
 717 gfc_resolve_getpid (gfc_expr * f)
 718 {
 719   f->ts.type = BT_INTEGER;
 720   f->ts.kind = 4;
 721   f->value.function.name = gfc_get_string (PREFIX("getpid"));
 722 }
 723
 724
 725 void
 726 gfc_resolve_getuid (gfc_expr * f)
 727 {
 728   f->ts.type = BT_INTEGER;
 729   f->ts.kind = 4;
 730   f->value.function.name = gfc_get_string (PREFIX("getuid"));
 731 }
 732
 733 void
 734 gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
 735 {
 736   f->ts.type = BT_INTEGER;
 737   f->ts.kind = 4;
 738   f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
 739 }
 740
 741 void
 742 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 743 {
 744   /* If the kind of i and j are different, then g77 cross-promoted the
 745      kinds to the largest value.  The Fortran 95 standard requires the
 746      kinds to match.  */
 747   if (i->ts.kind != j->ts.kind)
 748     {
 749       if (i->ts.kind == gfc_kind_max (i,j))
 750         gfc_convert_type(j, &i->ts, 2);
 751       else
 752         gfc_convert_type(i, &j->ts, 2);
 753     }
 754
 755   f->ts = i->ts;
 756   f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
 757 }
 758
 759
 760 void
 761 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
 762 {
 763   f->ts = i->ts;
 764   f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
 765 }
 766
 767
 768 void
 769 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
 770                    gfc_expr * pos ATTRIBUTE_UNUSED,
 771                    gfc_expr * len ATTRIBUTE_UNUSED)
 772 {
 773   f->ts = i->ts;
 774   f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
 775 }
 776
 777
 778 void
 779 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
 780                    gfc_expr * pos ATTRIBUTE_UNUSED)
 781 {
 782   f->ts = i->ts;
 783   f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
 784 }
 785
 786
 787 void
 788 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
 789 {
 790   f->ts.type = BT_INTEGER;
 791   f->ts.kind = gfc_default_integer_kind;
 792
 793   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 794 }
 795
 796
 797 void
 798 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
 799 {
 800   gfc_resolve_nint (f, a, NULL);
 801 }
 802
 803
 804 void
 805 gfc_resolve_ierrno (gfc_expr * f)
 806 {
 807   f->ts.type = BT_INTEGER;
 808   f->ts.kind = gfc_default_integer_kind;
 809   f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
 810 }
 811
 812
 813 void
 814 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 815 {
 816   /* If the kind of i and j are different, then g77 cross-promoted the
 817      kinds to the largest value.  The Fortran 95 standard requires the
 818      kinds to match.  */
 819   if (i->ts.kind != j->ts.kind)
 820     {
 821       if (i->ts.kind == gfc_kind_max (i,j))
 822         gfc_convert_type(j, &i->ts, 2);
 823       else
 824         gfc_convert_type(i, &j->ts, 2);
 825     }
 826
 827   f->ts = i->ts;
 828   f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
 829 }
 830
 831
 832 void
 833 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 834 {
 835   /* If the kind of i and j are different, then g77 cross-promoted the
 836      kinds to the largest value.  The Fortran 95 standard requires the
 837      kinds to match.  */
 838   if (i->ts.kind != j->ts.kind)
 839     {
 840       if (i->ts.kind == gfc_kind_max (i,j))
 841         gfc_convert_type(j, &i->ts, 2);
 842       else
 843         gfc_convert_type(i, &j->ts, 2);
 844     }
 845
 846   f->ts = i->ts;
 847   f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
 848 }
 849
 850
 851 void
 852 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 853 {
 854   f->ts.type = BT_INTEGER;
 855   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 856     : mpz_get_si (kind->value.integer);
 857
 858   f->value.function.name =
 859     gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
 860                     a->ts.kind);
 861 }
 862
 863
 864 void
 865 gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
 866 {
 867   gfc_typespec ts;
 868
 869   f->ts.type = BT_LOGICAL;
 870   f->ts.kind = gfc_default_integer_kind;
 871   if (u->ts.kind != gfc_c_int_kind)
 872     {
 873       ts.type = BT_INTEGER;
 874       ts.kind = gfc_c_int_kind;
 875       ts.derived = NULL;
 876       ts.cl = NULL;
 877       gfc_convert_type (u, &ts, 2);
 878     }
 879
 880   f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
 881 }
 882
 883
 884 void
 885 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
 886 {
 887   f->ts = i->ts;
 888   f->value.function.name =
 889     gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
 890 }
 891
 892
 893 void
 894 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
 895                     gfc_expr * size)
 896 {
 897   int s_kind;
 898
 899   s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
 900
 901   f->ts = i->ts;
 902   f->value.function.name =
 903     gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
 904 }
 905
 906
 907 void
 908 gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
 909                   ATTRIBUTE_UNUSED gfc_expr * s)
 910 {
 911   f->ts.type = BT_INTEGER;
 912   f->ts.kind = gfc_default_integer_kind;
 913
 914   f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
 915 }
 916
 917
 918 void
 919 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
 920                     gfc_expr * dim)
 921 {
 922   static char lbound[] = "__lbound";
 923
 924   f->ts.type = BT_INTEGER;
 925   f->ts.kind = gfc_default_integer_kind;
 926
 927   if (dim == NULL)
 928     {
 929       f->rank = 1;
 930       f->shape = gfc_get_shape (1);
 931       mpz_init_set_ui (f->shape[0], array->rank);
 932     }
 933
 934   f->value.function.name = lbound;
 935 }
 936
 937
 938 void
 939 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
 940 {
 941   f->ts.type = BT_INTEGER;
 942   f->ts.kind = gfc_default_integer_kind;
 943   f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
 944 }
 945
 946
 947 void
 948 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
 949 {
 950   f->ts.type = BT_INTEGER;
 951   f->ts.kind = gfc_default_integer_kind;
 952   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
 953 }
 954
 955
 956 void
 957 gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
 958                   gfc_expr * p2 ATTRIBUTE_UNUSED)
 959 {
 960   f->ts.type = BT_INTEGER;
 961   f->ts.kind = gfc_default_integer_kind;
 962   f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
 963 }
 964
 965
 966 void
 967 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
 968 {
 969   f->ts.type= BT_INTEGER;
 970   f->ts.kind = gfc_index_integer_kind;
 971   f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
 972 }
 973
 974
 975 void
 976 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
 977 {
 978   f->ts = x->ts;
 979   f->value.function.name =
 980     gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 981 }
 982
 983
 984 void
 985 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
 986 {
 987   f->ts = x->ts;
 988   f->value.function.name =
 989     gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 990 }
 991
 992
 993 void
 994 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 995 {
 996   f->ts.type = BT_LOGICAL;
 997   f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
 998     : mpz_get_si (kind->value.integer);
 999   f->rank = a->rank;
1000
1001   f->value.function.name =
1002     gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1003                     gfc_type_letter (a->ts.type), a->ts.kind);
1004 }
1005
1006
1007 void
1008 gfc_resolve_malloc (gfc_expr * f, gfc_expr * size)
1009 {
1010   if (size->ts.kind < gfc_index_integer_kind)
1011     {
1012       gfc_typespec ts;
1013
1014       ts.type = BT_INTEGER;
1015       ts.kind = gfc_index_integer_kind;
1016       gfc_convert_type_warn (size, &ts, 2, 0);
1017     }
1018
1019   f->ts.type = BT_INTEGER;
1020   f->ts.kind = gfc_index_integer_kind;
1021   f->value.function.name = gfc_get_string (PREFIX("malloc"));
1022 }
1023
1024
1025 void
1026 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
1027 {
1028   gfc_expr temp;
1029
1030   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1031     {
1032       f->ts.type = BT_LOGICAL;
1033       f->ts.kind = gfc_default_logical_kind;
1034     }
1035   else
1036     {
1037       temp.expr_type = EXPR_OP;
1038       gfc_clear_ts (&temp.ts);
1039       temp.value.op.operator = INTRINSIC_NONE;
1040       temp.value.op.op1 = a;
1041       temp.value.op.op2 = b;
1042       gfc_type_convert_binary (&temp);
1043       f->ts = temp.ts;
1044     }
1045
1046   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1047
1048   f->value.function.name =
1049     gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
1050                     f->ts.kind);
1051 }
1052
1053
1054 static void
1055 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
1056 {
1057   gfc_actual_arglist *a;
1058
1059   f->ts.type = args->expr->ts.type;
1060   f->ts.kind = args->expr->ts.kind;
1061   /* Find the largest type kind.  */
1062   for (a = args->next; a; a = a->next)
1063     {
1064       if (a->expr->ts.kind > f->ts.kind)
1065         f->ts.kind = a->expr->ts.kind;
1066     }
1067
1068   /* Convert all parameters to the required kind.  */
1069   for (a = args; a; a = a->next)
1070     {
1071       if (a->expr->ts.kind != f->ts.kind)
1072         gfc_convert_type (a->expr, &f->ts, 2);
1073     }
1074
1075   f->value.function.name =
1076     gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1077 }
1078
1079
1080 void
1081 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
1082 {
1083   gfc_resolve_minmax ("__max_%c%d", f, args);
1084 }
1085
1086
1087 void
1088 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1089                     gfc_expr * mask)
1090 {
1091   const char *name;
1092
1093   f->ts.type = BT_INTEGER;
1094   f->ts.kind = gfc_default_integer_kind;
1095
1096   if (dim == NULL)
1097     f->rank = 1;
1098   else
1099     {
1100       f->rank = array->rank - 1;
1101       gfc_resolve_dim_arg (dim);
1102     }
1103
1104   name = mask ? "mmaxloc" : "maxloc";
1105   f->value.function.name =
1106     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1107                     gfc_type_letter (array->ts.type), array->ts.kind);
1108 }
1109
1110
1111 void
1112 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1113                     gfc_expr * mask)
1114 {
1115   f->ts = array->ts;
1116
1117   if (dim != NULL)
1118     {
1119       f->rank = array->rank - 1;
1120       gfc_resolve_dim_arg (dim);
1121     }
1122
1123   f->value.function.name =
1124     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
1125                     gfc_type_letter (array->ts.type), array->ts.kind);
1126 }
1127
1128
1129 void
1130 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
1131                    gfc_expr * fsource ATTRIBUTE_UNUSED,
1132                    gfc_expr * mask ATTRIBUTE_UNUSED)
1133 {
1134   if (tsource->ts.type == BT_CHARACTER)
1135     check_charlen_present (tsource);
1136
1137   f->ts = tsource->ts;
1138   f->value.function.name =
1139     gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1140                     tsource->ts.kind);
1141 }
1142
1143
1144 void
1145 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
1146 {
1147   gfc_resolve_minmax ("__min_%c%d", f, args);
1148 }
1149
1150
1151 void
1152 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1153                     gfc_expr * mask)
1154 {
1155   const char *name;
1156
1157   f->ts.type = BT_INTEGER;
1158   f->ts.kind = gfc_default_integer_kind;
1159
1160   if (dim == NULL)
1161     f->rank = 1;
1162   else
1163     {
1164       f->rank = array->rank - 1;
1165       gfc_resolve_dim_arg (dim);
1166     }
1167
1168   name = mask ? "mminloc" : "minloc";
1169   f->value.function.name =
1170     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1171                     gfc_type_letter (array->ts.type), array->ts.kind);
1172 }
1173
1174
1175 void
1176 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1177                     gfc_expr * mask)
1178 {
1179   f->ts = array->ts;
1180
1181   if (dim != NULL)
1182     {
1183       f->rank = array->rank - 1;
1184       gfc_resolve_dim_arg (dim);
1185     }
1186
1187   f->value.function.name =
1188     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
1189                     gfc_type_letter (array->ts.type), array->ts.kind);
1190 }
1191
1192
1193 void
1194 gfc_resolve_mod (gfc_expr * f, gfc_expr * a, gfc_expr * p)
1195 {
1196   f->ts.type = a->ts.type;
1197   if (p != NULL)
1198     f->ts.kind = gfc_kind_max (a,p);
1199   else
1200     f->ts.kind = a->ts.kind;
1201
1202   if (p != NULL && a->ts.kind != p->ts.kind)
1203     {
1204       if (a->ts.kind == gfc_kind_max (a,p))
1205         gfc_convert_type(p, &a->ts, 2);
1206       else
1207         gfc_convert_type(a, &p->ts, 2);
1208     }
1209
1210   f->value.function.name =
1211     gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1212 }
1213
1214
1215 void
1216 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, gfc_expr * p)
1217 {
1218   f->ts.type = a->ts.type;
1219   if (p != NULL)
1220     f->ts.kind = gfc_kind_max (a,p);
1221   else
1222     f->ts.kind = a->ts.kind;
1223
1224   if (p != NULL && a->ts.kind != p->ts.kind)
1225     {
1226       if (a->ts.kind == gfc_kind_max (a,p))
1227         gfc_convert_type(p, &a->ts, 2);
1228       else
1229         gfc_convert_type(a, &p->ts, 2);
1230     }
1231
1232   f->value.function.name =
1233     gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1234                     f->ts.kind);
1235 }
1236
1237 void
1238 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1239 {
1240   f->ts = a->ts;
1241   f->value.function.name =
1242     gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1243             a->ts.kind);
1244 }
1245
1246 void
1247 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1248 {
1249   f->ts.type = BT_INTEGER;
1250   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1251     : mpz_get_si (kind->value.integer);
1252
1253   f->value.function.name =
1254     gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1255 }
1256
1257
1258 void
1259 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1260 {
1261   f->ts = i->ts;
1262   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1263 }
1264
1265
1266 void
1267 gfc_resolve_or (gfc_expr * f, gfc_expr * i, gfc_expr * j)
1268 {
1269   f->ts.type = i->ts.type;
1270   f->ts.kind = gfc_kind_max (i,j);
1271
1272   if (i->ts.kind != j->ts.kind)
1273     {
1274       if (i->ts.kind == gfc_kind_max (i,j))
1275         gfc_convert_type(j, &i->ts, 2);
1276       else
1277         gfc_convert_type(i, &j->ts, 2);
1278     }
1279
1280   f->value.function.name = gfc_get_string ("__or_%c%d",
1281                                            gfc_type_letter (i->ts.type),
1282                                            f->ts.kind);
1283 }
1284
1285
1286 void
1287 gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
1288                   gfc_expr * vector ATTRIBUTE_UNUSED)
1289 {
1290   f->ts = array->ts;
1291   f->rank = 1;
1292
1293   if (mask->rank != 0)
1294     f->value.function.name = (array->ts.type == BT_CHARACTER
1295                               ? PREFIX("pack_char")
1296                               : PREFIX("pack"));
1297   else
1298     {
1299       /* We convert mask to default logical only in the scalar case.
1300          In the array case we can simply read the array as if it were
1301          of type default logical.  */
1302       if (mask->ts.kind != gfc_default_logical_kind)
1303         {
1304           gfc_typespec ts;
1305
1306           ts.type = BT_LOGICAL;
1307           ts.kind = gfc_default_logical_kind;
1308           gfc_convert_type (mask, &ts, 2);
1309         }
1310
1311       f->value.function.name = (array->ts.type == BT_CHARACTER
1312                                 ? PREFIX("pack_s_char")
1313                                 : PREFIX("pack_s"));
1314     }
1315 }
1316
1317
1318 void
1319 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1320                      gfc_expr * mask)
1321 {
1322   f->ts = array->ts;
1323
1324   if (dim != NULL)
1325     {
1326       f->rank = array->rank - 1;
1327       gfc_resolve_dim_arg (dim);
1328     }
1329
1330   f->value.function.name =
1331     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1332                     gfc_type_letter (array->ts.type), array->ts.kind);
1333 }
1334
1335
1336 void
1337 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1338 {
1339   f->ts.type = BT_REAL;
1340
1341   if (kind != NULL)
1342     f->ts.kind = mpz_get_si (kind->value.integer);
1343   else
1344     f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1345       a->ts.kind : gfc_default_real_kind;
1346
1347   f->value.function.name =
1348     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1349                     gfc_type_letter (a->ts.type), a->ts.kind);
1350 }
1351
1352
1353 void
1354 gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
1355 {
1356   f->ts.type = BT_REAL;
1357   f->ts.kind = a->ts.kind;
1358   f->value.function.name =
1359     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1360                     gfc_type_letter (a->ts.type), a->ts.kind);
1361 }
1362
1363
1364 void
1365 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1366                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1367 {
1368   f->ts.type = BT_INTEGER;
1369   f->ts.kind = gfc_default_integer_kind;
1370   f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1371 }
1372
1373
1374 void
1375 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1376                     gfc_expr * ncopies ATTRIBUTE_UNUSED)
1377 {
1378   f->ts.type = BT_CHARACTER;
1379   f->ts.kind = string->ts.kind;
1380   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1381 }
1382
1383
1384 void
1385 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1386                      gfc_expr * pad ATTRIBUTE_UNUSED,
1387                      gfc_expr * order ATTRIBUTE_UNUSED)
1388 {
1389   mpz_t rank;
1390   int kind;
1391   int i;
1392
1393   f->ts = source->ts;
1394
1395   gfc_array_size (shape, &rank);
1396   f->rank = mpz_get_si (rank);
1397   mpz_clear (rank);
1398   switch (source->ts.type)
1399     {
1400     case BT_COMPLEX:
1401       kind = source->ts.kind * 2;
1402       break;
1403
1404     case BT_REAL:
1405     case BT_INTEGER:
1406     case BT_LOGICAL:
1407       kind = source->ts.kind;
1408       break;
1409
1410     default:
1411       kind = 0;
1412       break;
1413     }
1414
1415   switch (kind)
1416     {
1417     case 4:
1418     case 8:
1419     case 10:
1420     case 16:
1421       if (source->ts.type == BT_COMPLEX)
1422         f->value.function.name =
1423           gfc_get_string (PREFIX("reshape_%c%d"),
1424                           gfc_type_letter (BT_COMPLEX), source->ts.kind);
1425       else
1426         f->value.function.name =
1427           gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1428
1429       break;
1430
1431     default:
1432       f->value.function.name = (source->ts.type == BT_CHARACTER
1433                                 ? PREFIX("reshape_char")
1434                                 : PREFIX("reshape"));
1435       break;
1436     }
1437
1438   /* TODO: Make this work with a constant ORDER parameter.  */
1439   if (shape->expr_type == EXPR_ARRAY
1440       && gfc_is_constant_expr (shape)
1441       && order == NULL)
1442     {
1443       gfc_constructor *c;
1444       f->shape = gfc_get_shape (f->rank);
1445       c = shape->value.constructor;
1446       for (i = 0; i < f->rank; i++)
1447         {
1448           mpz_init_set (f->shape[i], c->expr->value.integer);
1449           c = c->next;
1450         }
1451     }
1452
1453   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1454      so many runtime variations.  */
1455   if (shape->ts.kind != gfc_index_integer_kind)
1456     {
1457       gfc_typespec ts = shape->ts;
1458       ts.kind = gfc_index_integer_kind;
1459       gfc_convert_type_warn (shape, &ts, 2, 0);
1460     }
1461   if (order && order->ts.kind != gfc_index_integer_kind)
1462     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1463 }
1464
1465
1466 void
1467 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1468 {
1469   f->ts = x->ts;
1470   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1471 }
1472
1473
1474 void
1475 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1476 {
1477   f->ts = x->ts;
1478
1479   /* The implementation calls scalbn which takes an int as the
1480      second argument.  */
1481   if (i->ts.kind != gfc_c_int_kind)
1482     {
1483       gfc_typespec ts;
1484
1485       ts.type = BT_INTEGER;
1486       ts.kind = gfc_default_integer_kind;
1487
1488       gfc_convert_type_warn (i, &ts, 2, 0);
1489     }
1490
1491   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1492 }
1493
1494
1495 void
1496 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1497                   gfc_expr * set ATTRIBUTE_UNUSED,
1498                   gfc_expr * back ATTRIBUTE_UNUSED)
1499 {
1500   f->ts.type = BT_INTEGER;
1501   f->ts.kind = gfc_default_integer_kind;
1502   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1503 }
1504
1505
1506 void
1507 gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0)
1508 {
1509   t1->ts = t0->ts;
1510   t1->value.function.name =
1511     gfc_get_string (PREFIX("secnds"));
1512 }
1513
1514
1515 void
1516 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1517 {
1518   f->ts = x->ts;
1519
1520   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1521      convert type so we don't have to implement all possible
1522      permutations.  */
1523   if (i->ts.kind != 4)
1524     {
1525       gfc_typespec ts;
1526
1527       ts.type = BT_INTEGER;
1528       ts.kind = gfc_default_integer_kind;
1529
1530       gfc_convert_type_warn (i, &ts, 2, 0);
1531     }
1532
1533   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1534 }
1535
1536
1537 void
1538 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1539 {
1540   f->ts.type = BT_INTEGER;
1541   f->ts.kind = gfc_default_integer_kind;
1542   f->rank = 1;
1543   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1544   f->shape = gfc_get_shape (1);
1545   mpz_init_set_ui (f->shape[0], array->rank);
1546 }
1547
1548
1549 void
1550 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1551 {
1552   f->ts = a->ts;
1553   f->value.function.name =
1554     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1555 }
1556
1557
1558 void
1559 gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
1560 {
1561   f->ts.type = BT_INTEGER;
1562   f->ts.kind = gfc_c_int_kind;
1563
1564   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
1565   if (handler->ts.type == BT_INTEGER)
1566     {
1567       if (handler->ts.kind != gfc_c_int_kind)
1568         gfc_convert_type (handler, &f->ts, 2);
1569       f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
1570     }
1571   else
1572     f->value.function.name = gfc_get_string (PREFIX("signal_func"));
1573
1574   if (number->ts.kind != gfc_c_int_kind)
1575     gfc_convert_type (number, &f->ts, 2);
1576 }
1577
1578
1579 void
1580 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1581 {
1582   f->ts = x->ts;
1583   f->value.function.name =
1584     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1585 }
1586
1587
1588 void
1589 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1590 {
1591   f->ts = x->ts;
1592   f->value.function.name =
1593     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1594 }
1595
1596
1597 void
1598 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1599 {
1600   f->ts = x->ts;
1601   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1602 }
1603
1604
1605 void
1606 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1607                     gfc_expr * dim,
1608                     gfc_expr * ncopies)
1609 {
1610   if (source->ts.type == BT_CHARACTER)
1611     check_charlen_present (source);
1612
1613   f->ts = source->ts;
1614   f->rank = source->rank + 1;
1615   if (source->rank == 0)
1616     f->value.function.name = (source->ts.type == BT_CHARACTER
1617                               ? PREFIX("spread_char_scalar")
1618                               : PREFIX("spread_scalar"));
1619   else
1620     f->value.function.name = (source->ts.type == BT_CHARACTER
1621                               ? PREFIX("spread_char")
1622                               : PREFIX("spread"));
1623
1624   gfc_resolve_dim_arg (dim);
1625   gfc_resolve_index (ncopies, 1);
1626 }
1627
1628
1629 void
1630 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1631 {
1632   f->ts = x->ts;
1633   f->value.function.name =
1634     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1635 }
1636
1637
1638 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1639
1640 void
1641 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1642                   gfc_expr * a ATTRIBUTE_UNUSED)
1643 {
1644   f->ts.type = BT_INTEGER;
1645   f->ts.kind = gfc_default_integer_kind;
1646   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1647 }
1648
1649
1650 void
1651 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1652 {
1653   f->ts.type = BT_INTEGER;
1654   f->ts.kind = gfc_default_integer_kind;
1655   if (n->ts.kind != f->ts.kind)
1656     gfc_convert_type (n, &f->ts, 2);
1657
1658   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1659 }
1660
1661
1662 void
1663 gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
1664 {
1665   gfc_typespec ts;
1666
1667   f->ts.type = BT_INTEGER;
1668   f->ts.kind = gfc_c_int_kind;
1669   if (u->ts.kind != gfc_c_int_kind)
1670     {
1671       ts.type = BT_INTEGER;
1672       ts.kind = gfc_c_int_kind;
1673       ts.derived = NULL;
1674       ts.cl = NULL;
1675       gfc_convert_type (u, &ts, 2);
1676     }
1677
1678   f->value.function.name = gfc_get_string (PREFIX("fgetc"));
1679 }
1680
1681
1682 void
1683 gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
1684 {
1685   f->ts.type = BT_INTEGER;
1686   f->ts.kind = gfc_c_int_kind;
1687   f->value.function.name = gfc_get_string (PREFIX("fget"));
1688 }
1689
1690
1691 void
1692 gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
1693 {
1694   gfc_typespec ts;
1695
1696   f->ts.type = BT_INTEGER;
1697   f->ts.kind = gfc_c_int_kind;
1698   if (u->ts.kind != gfc_c_int_kind)
1699     {
1700       ts.type = BT_INTEGER;
1701       ts.kind = gfc_c_int_kind;
1702       ts.derived = NULL;
1703       ts.cl = NULL;
1704       gfc_convert_type (u, &ts, 2);
1705     }
1706
1707   f->value.function.name = gfc_get_string (PREFIX("fputc"));
1708 }
1709
1710
1711 void
1712 gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
1713 {
1714   f->ts.type = BT_INTEGER;
1715   f->ts.kind = gfc_c_int_kind;
1716   f->value.function.name = gfc_get_string (PREFIX("fput"));
1717 }
1718
1719
1720 void
1721 gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
1722 {
1723   gfc_typespec ts;
1724
1725   f->ts.type = BT_INTEGER;
1726   f->ts.kind = gfc_index_integer_kind;
1727   if (u->ts.kind != gfc_c_int_kind)
1728     {
1729       ts.type = BT_INTEGER;
1730       ts.kind = gfc_c_int_kind;
1731       ts.derived = NULL;
1732       ts.cl = NULL;
1733       gfc_convert_type (u, &ts, 2);
1734     }
1735
1736   f->value.function.name = gfc_get_string (PREFIX("ftell"));
1737 }
1738
1739
1740 void
1741 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1742                  gfc_expr * mask)
1743 {
1744   f->ts = array->ts;
1745
1746   if (dim != NULL)
1747     {
1748       f->rank = array->rank - 1;
1749       gfc_resolve_dim_arg (dim);
1750     }
1751
1752   f->value.function.name =
1753     gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1754                     gfc_type_letter (array->ts.type), array->ts.kind);
1755 }
1756
1757
1758 void
1759 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1760                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1761 {
1762   f->ts.type = BT_INTEGER;
1763   f->ts.kind = gfc_default_integer_kind;
1764   f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1765 }
1766
1767
1768 /* Resolve the g77 compatibility function SYSTEM.  */
1769
1770 void
1771 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1772 {
1773   f->ts.type = BT_INTEGER;
1774   f->ts.kind = 4;
1775   f->value.function.name = gfc_get_string (PREFIX("system"));
1776 }
1777
1778
1779 void
1780 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1781 {
1782   f->ts = x->ts;
1783   f->value.function.name =
1784     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1785 }
1786
1787
1788 void
1789 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1790 {
1791   f->ts = x->ts;
1792   f->value.function.name =
1793     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1794 }
1795
1796
1797 void
1798 gfc_resolve_time (gfc_expr * f)
1799 {
1800   f->ts.type = BT_INTEGER;
1801   f->ts.kind = 4;
1802   f->value.function.name = gfc_get_string (PREFIX("time_func"));
1803 }
1804
1805
1806 void
1807 gfc_resolve_time8 (gfc_expr * f)
1808 {
1809   f->ts.type = BT_INTEGER;
1810   f->ts.kind = 8;
1811   f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1812 }
1813
1814
1815 void
1816 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1817                       gfc_expr * mold, gfc_expr * size)
1818 {
1819   /* TODO: Make this do something meaningful.  */
1820   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1821
1822   f->ts = mold->ts;
1823
1824   if (size == NULL && mold->rank == 0)
1825     {
1826       f->rank = 0;
1827       f->value.function.name = transfer0;
1828     }
1829   else
1830     {
1831       f->rank = 1;
1832       f->value.function.name = transfer1;
1833     }
1834 }
1835
1836
1837 void
1838 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1839 {
1840   int kind;
1841
1842   f->ts = matrix->ts;
1843   f->rank = 2;
1844   if (matrix->shape)
1845     {
1846       f->shape = gfc_get_shape (2);
1847       mpz_init_set (f->shape[0], matrix->shape[1]);
1848       mpz_init_set (f->shape[1], matrix->shape[0]);
1849     }
1850
1851   kind = matrix->ts.kind;
1852
1853   switch (kind)
1854     {
1855     case 4:
1856     case 8:
1857     case 10:
1858     case 16:
1859       switch (matrix->ts.type)
1860         {
1861         case BT_COMPLEX:
1862           f->value.function.name =
1863             gfc_get_string (PREFIX("transpose_c%d"), kind);
1864           break;
1865
1866         case BT_INTEGER:
1867         case BT_REAL:
1868         case BT_LOGICAL:
1869           /* Use the integer routines for real and logical cases.  This
1870              assumes they all have the same alignment requirements.  */
1871           f->value.function.name =
1872             gfc_get_string (PREFIX("transpose_i%d"), kind);
1873           break;
1874
1875         default:
1876           f->value.function.name = PREFIX("transpose");
1877           break;
1878         }
1879       break;
1880
1881     default:
1882       f->value.function.name = (matrix->ts.type == BT_CHARACTER
1883                                 ? PREFIX("transpose_char")
1884                                 : PREFIX("transpose"));
1885       break;
1886     }
1887 }
1888
1889
1890 void
1891 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1892 {
1893   f->ts.type = BT_CHARACTER;
1894   f->ts.kind = string->ts.kind;
1895   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1896 }
1897
1898
1899 void
1900 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1901                     gfc_expr * dim)
1902 {
1903   static char ubound[] = "__ubound";
1904
1905   f->ts.type = BT_INTEGER;
1906   f->ts.kind = gfc_default_integer_kind;
1907
1908   if (dim == NULL)
1909     {
1910       f->rank = 1;
1911       f->shape = gfc_get_shape (1);
1912       mpz_init_set_ui (f->shape[0], array->rank);
1913     }
1914
1915   f->value.function.name = ubound;
1916 }
1917
1918
1919 /* Resolve the g77 compatibility function UMASK.  */
1920
1921 void
1922 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1923 {
1924   f->ts.type = BT_INTEGER;
1925   f->ts.kind = n->ts.kind;
1926   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1927 }
1928
1929
1930 /* Resolve the g77 compatibility function UNLINK.  */
1931
1932 void
1933 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1934 {
1935   f->ts.type = BT_INTEGER;
1936   f->ts.kind = 4;
1937   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1938 }
1939
1940
1941 void
1942 gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
1943 {
1944   gfc_typespec ts;
1945
1946   f->ts.type = BT_CHARACTER;
1947   f->ts.kind = gfc_default_character_kind;
1948
1949   if (unit->ts.kind != gfc_c_int_kind)
1950     {
1951       ts.type = BT_INTEGER;
1952       ts.kind = gfc_c_int_kind;
1953       ts.derived = NULL;
1954       ts.cl = NULL;
1955       gfc_convert_type (unit, &ts, 2);
1956     }
1957
1958   f->value.function.name = gfc_get_string (PREFIX("ttynam"));
1959 }
1960
1961
1962 void
1963 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1964                     gfc_expr * field ATTRIBUTE_UNUSED)
1965 {
1966   f->ts = vector->ts;
1967   f->rank = mask->rank;
1968
1969   f->value.function.name =
1970     gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
1971                     vector->ts.type == BT_CHARACTER ? "_char" : "");
1972 }
1973
1974
1975 void
1976 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1977                     gfc_expr * set ATTRIBUTE_UNUSED,
1978                     gfc_expr * back ATTRIBUTE_UNUSED)
1979 {
1980   f->ts.type = BT_INTEGER;
1981   f->ts.kind = gfc_default_integer_kind;
1982   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1983 }
1984
1985
1986 void
1987 gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
1988 {
1989   f->ts.type = i->ts.type;
1990   f->ts.kind = gfc_kind_max (i,j);
1991
1992   if (i->ts.kind != j->ts.kind)
1993     {
1994       if (i->ts.kind == gfc_kind_max (i,j))
1995         gfc_convert_type(j, &i->ts, 2);
1996       else
1997         gfc_convert_type(i, &j->ts, 2);
1998     }
1999
2000   f->value.function.name = gfc_get_string ("__xor_%c%d",
2001                                            gfc_type_letter (i->ts.type),
2002                                            f->ts.kind);
2003 }
2004
2005
2006 /* Intrinsic subroutine resolution.  */
2007
2008 void
2009 gfc_resolve_alarm_sub (gfc_code * c)
2010 {
2011   const char *name;
2012   gfc_expr *seconds, *handler, *status;
2013   gfc_typespec ts;
2014
2015   seconds = c->ext.actual->expr;
2016   handler = c->ext.actual->next->expr;
2017   status = c->ext.actual->next->next->expr;
2018   ts.type = BT_INTEGER;
2019   ts.kind = gfc_c_int_kind;
2020
2021   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2022   if (handler->ts.type == BT_INTEGER)
2023     {
2024       if (handler->ts.kind != gfc_c_int_kind)
2025         gfc_convert_type (handler, &ts, 2);
2026       name = gfc_get_string (PREFIX("alarm_sub_int"));
2027     }
2028   else
2029     name = gfc_get_string (PREFIX("alarm_sub"));
2030
2031   if (seconds->ts.kind != gfc_c_int_kind)
2032     gfc_convert_type (seconds, &ts, 2);
2033   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2034     gfc_convert_type (status, &ts, 2);
2035
2036   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2037 }
2038
2039 void
2040 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
2041 {
2042   const char *name;
2043
2044   name = gfc_get_string (PREFIX("cpu_time_%d"),
2045                          c->ext.actual->expr->ts.kind);
2046   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2047 }
2048
2049
2050 void
2051 gfc_resolve_mvbits (gfc_code * c)
2052 {
2053   const char *name;
2054   int kind;
2055
2056   kind = c->ext.actual->expr->ts.kind;
2057   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
2058
2059   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2060 }
2061
2062
2063 void
2064 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
2065 {
2066   const char *name;
2067   int kind;
2068
2069   kind = c->ext.actual->expr->ts.kind;
2070   if (c->ext.actual->expr->rank == 0)
2071     name = gfc_get_string (PREFIX("random_r%d"), kind);
2072   else
2073     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
2074
2075   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2076 }
2077
2078
2079 void
2080 gfc_resolve_rename_sub (gfc_code * c)
2081 {
2082   const char *name;
2083   int kind;
2084
2085   if (c->ext.actual->next->next->expr != NULL)
2086     kind = c->ext.actual->next->next->expr->ts.kind;
2087   else
2088     kind = gfc_default_integer_kind;
2089
2090   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
2091   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2092 }
2093
2094
2095 void
2096 gfc_resolve_kill_sub (gfc_code * c)
2097 {
2098   const char *name;
2099   int kind;
2100
2101   if (c->ext.actual->next->next->expr != NULL)
2102     kind = c->ext.actual->next->next->expr->ts.kind;
2103   else
2104     kind = gfc_default_integer_kind;
2105
2106   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
2107   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2108 }
2109
2110
2111 void
2112 gfc_resolve_link_sub (gfc_code * c)
2113 {
2114   const char *name;
2115   int kind;
2116
2117   if (c->ext.actual->next->next->expr != NULL)
2118     kind = c->ext.actual->next->next->expr->ts.kind;
2119   else
2120     kind = gfc_default_integer_kind;
2121
2122   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
2123   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2124 }
2125
2126
2127 void
2128 gfc_resolve_symlnk_sub (gfc_code * c)
2129 {
2130   const char *name;
2131   int kind;
2132
2133   if (c->ext.actual->next->next->expr != NULL)
2134     kind = c->ext.actual->next->next->expr->ts.kind;
2135   else
2136     kind = gfc_default_integer_kind;
2137
2138   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
2139   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2140 }
2141
2142
2143 /* G77 compatibility subroutines etime() and dtime().  */
2144
2145 void
2146 gfc_resolve_etime_sub (gfc_code * c)
2147 {
2148   const char *name;
2149
2150   name = gfc_get_string (PREFIX("etime_sub"));
2151   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2152 }
2153
2154
2155 /* G77 compatibility subroutine second().  */
2156
2157 void
2158 gfc_resolve_second_sub (gfc_code * c)
2159 {
2160   const char *name;
2161
2162   name = gfc_get_string (PREFIX("second_sub"));
2163   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2164 }
2165
2166
2167 void
2168 gfc_resolve_sleep_sub (gfc_code * c)
2169 {
2170   const char *name;
2171   int kind;
2172
2173   if (c->ext.actual->expr != NULL)
2174     kind = c->ext.actual->expr->ts.kind;
2175   else
2176     kind = gfc_default_integer_kind;
2177
2178   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
2179   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2180 }
2181
2182
2183 /* G77 compatibility function srand().  */
2184
2185 void
2186 gfc_resolve_srand (gfc_code * c)
2187 {
2188   const char *name;
2189   name = gfc_get_string (PREFIX("srand"));
2190   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2191 }
2192
2193
2194 /* Resolve the getarg intrinsic subroutine.  */
2195
2196 void
2197 gfc_resolve_getarg (gfc_code * c)
2198 {
2199   const char *name;
2200   int kind;
2201
2202   kind = gfc_default_integer_kind;
2203   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
2204   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2205 }
2206
2207 /* Resolve the getcwd intrinsic subroutine.  */
2208
2209 void
2210 gfc_resolve_getcwd_sub (gfc_code * c)
2211 {
2212   const char *name;
2213   int kind;
2214
2215   if (c->ext.actual->next->expr != NULL)
2216     kind = c->ext.actual->next->expr->ts.kind;
2217   else
2218     kind = gfc_default_integer_kind;
2219
2220   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
2221   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2222 }
2223
2224
2225 /* Resolve the get_command intrinsic subroutine.  */
2226
2227 void
2228 gfc_resolve_get_command (gfc_code * c)
2229 {
2230   const char *name;
2231   int kind;
2232
2233   kind = gfc_default_integer_kind;
2234   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
2235   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2236 }
2237
2238
2239 /* Resolve the get_command_argument intrinsic subroutine.  */
2240
2241 void
2242 gfc_resolve_get_command_argument (gfc_code * c)
2243 {
2244   const char *name;
2245   int kind;
2246
2247   kind = gfc_default_integer_kind;
2248   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
2249   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2250 }
2251
2252 /* Resolve the get_environment_variable intrinsic subroutine.  */
2253
2254 void
2255 gfc_resolve_get_environment_variable (gfc_code * code)
2256 {
2257   const char *name;
2258   int kind;
2259
2260   kind = gfc_default_integer_kind;
2261   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
2262   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2263 }
2264
2265 void
2266 gfc_resolve_signal_sub (gfc_code * c)
2267 {
2268   const char *name;
2269   gfc_expr *number, *handler, *status;
2270   gfc_typespec ts;
2271
2272   number = c->ext.actual->expr;
2273   handler = c->ext.actual->next->expr;
2274   status = c->ext.actual->next->next->expr;
2275   ts.type = BT_INTEGER;
2276   ts.kind = gfc_c_int_kind;
2277
2278   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2279   if (handler->ts.type == BT_INTEGER)
2280     {
2281       if (handler->ts.kind != gfc_c_int_kind)
2282         gfc_convert_type (handler, &ts, 2);
2283       name = gfc_get_string (PREFIX("signal_sub_int"));
2284     }
2285   else
2286     name = gfc_get_string (PREFIX("signal_sub"));
2287
2288   if (number->ts.kind != gfc_c_int_kind)
2289     gfc_convert_type (number, &ts, 2);
2290   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2291     gfc_convert_type (status, &ts, 2);
2292
2293   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2294 }
2295
2296 /* Resolve the SYSTEM intrinsic subroutine.  */
2297
2298 void
2299 gfc_resolve_system_sub (gfc_code * c)
2300 {
2301   const char *name;
2302
2303   name = gfc_get_string (PREFIX("system_sub"));
2304   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2305 }
2306
2307 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2308
2309 void
2310 gfc_resolve_system_clock (gfc_code * c)
2311 {
2312   const char *name;
2313   int kind;
2314
2315   if (c->ext.actual->expr != NULL)
2316     kind = c->ext.actual->expr->ts.kind;
2317   else if (c->ext.actual->next->expr != NULL)
2318       kind = c->ext.actual->next->expr->ts.kind;
2319   else if (c->ext.actual->next->next->expr != NULL)
2320       kind = c->ext.actual->next->next->expr->ts.kind;
2321   else
2322     kind = gfc_default_integer_kind;
2323
2324   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
2325   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2326 }
2327
2328 /* Resolve the EXIT intrinsic subroutine.  */
2329
2330 void
2331 gfc_resolve_exit (gfc_code * c)
2332 {
2333   const char *name;
2334   int kind;
2335
2336   if (c->ext.actual->expr != NULL)
2337     kind = c->ext.actual->expr->ts.kind;
2338   else
2339     kind = gfc_default_integer_kind;
2340
2341   name = gfc_get_string (PREFIX("exit_i%d"), kind);
2342   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2343 }
2344
2345 /* Resolve the FLUSH intrinsic subroutine.  */
2346
2347 void
2348 gfc_resolve_flush (gfc_code * c)
2349 {
2350   const char *name;
2351   gfc_typespec ts;
2352   gfc_expr *n;
2353
2354   ts.type = BT_INTEGER;
2355   ts.kind = gfc_default_integer_kind;
2356   n = c->ext.actual->expr;
2357   if (n != NULL
2358       && n->ts.kind != ts.kind)
2359     gfc_convert_type (n, &ts, 2);
2360
2361   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
2362   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2363 }
2364
2365
2366 void
2367 gfc_resolve_free (gfc_code * c)
2368 {
2369   gfc_typespec ts;
2370   gfc_expr *n;
2371
2372   ts.type = BT_INTEGER;
2373   ts.kind = gfc_index_integer_kind;
2374   n = c->ext.actual->expr;
2375   if (n->ts.kind != ts.kind)
2376     gfc_convert_type (n, &ts, 2);
2377
2378   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
2379 }
2380
2381
2382 void
2383 gfc_resolve_ctime_sub (gfc_code * c)
2384 {
2385   gfc_typespec ts;
2386
2387   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2388   if (c->ext.actual->expr->ts.kind != 8)
2389     {
2390       ts.type = BT_INTEGER;
2391       ts.kind = 8;
2392       ts.derived = NULL;
2393       ts.cl = NULL;
2394       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2395     }
2396
2397   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
2398 }
2399
2400
2401 void
2402 gfc_resolve_fdate_sub (gfc_code * c)
2403 {
2404   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2405 }
2406
2407
2408 void
2409 gfc_resolve_gerror (gfc_code * c)
2410 {
2411   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2412 }
2413
2414
2415 void
2416 gfc_resolve_getlog (gfc_code * c)
2417 {
2418   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2419 }
2420
2421
2422 void
2423 gfc_resolve_hostnm_sub (gfc_code * c)
2424 {
2425   const char *name;
2426   int kind;
2427
2428   if (c->ext.actual->next->expr != NULL)
2429     kind = c->ext.actual->next->expr->ts.kind;
2430   else
2431     kind = gfc_default_integer_kind;
2432
2433   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2434   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2435 }
2436
2437
2438 void
2439 gfc_resolve_perror (gfc_code * c)
2440 {
2441   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2442 }
2443
2444 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
2445
2446 void
2447 gfc_resolve_stat_sub (gfc_code * c)
2448 {
2449   const char *name;
2450
2451   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2452   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2453 }
2454
2455
2456 void
2457 gfc_resolve_fstat_sub (gfc_code * c)
2458 {
2459   const char *name;
2460   gfc_expr *u;
2461   gfc_typespec *ts;
2462
2463   u = c->ext.actual->expr;
2464   ts = &c->ext.actual->next->expr->ts;
2465   if (u->ts.kind != ts->kind)
2466     gfc_convert_type (u, ts, 2);
2467   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2468   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2469 }
2470
2471
2472 void
2473 gfc_resolve_fgetc_sub (gfc_code * c)
2474 {
2475   const char *name;
2476   gfc_typespec ts;
2477   gfc_expr *u, *st;
2478
2479   u = c->ext.actual->expr;
2480   st = c->ext.actual->next->next->expr;
2481
2482   if (u->ts.kind != gfc_c_int_kind)
2483     {
2484       ts.type = BT_INTEGER;
2485       ts.kind = gfc_c_int_kind;
2486       ts.derived = NULL;
2487       ts.cl = NULL;
2488       gfc_convert_type (u, &ts, 2);
2489     }
2490
2491   if (st != NULL)
2492     name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
2493   else
2494     name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
2495
2496   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2497 }
2498
2499
2500 void
2501 gfc_resolve_fget_sub (gfc_code * c)
2502 {
2503   const char *name;
2504   gfc_expr *st;
2505
2506   st = c->ext.actual->next->expr;
2507   if (st != NULL)
2508     name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
2509   else
2510     name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
2511
2512   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2513 }
2514
2515
2516 void
2517 gfc_resolve_fputc_sub (gfc_code * c)
2518 {
2519   const char *name;
2520   gfc_typespec ts;
2521   gfc_expr *u, *st;
2522
2523   u = c->ext.actual->expr;
2524   st = c->ext.actual->next->next->expr;
2525
2526   if (u->ts.kind != gfc_c_int_kind)
2527     {
2528       ts.type = BT_INTEGER;
2529       ts.kind = gfc_c_int_kind;
2530       ts.derived = NULL;
2531       ts.cl = NULL;
2532       gfc_convert_type (u, &ts, 2);
2533     }
2534
2535   if (st != NULL)
2536     name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
2537   else
2538     name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
2539
2540   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2541 }
2542
2543
2544 void
2545 gfc_resolve_fput_sub (gfc_code * c)
2546 {
2547   const char *name;
2548   gfc_expr *st;
2549
2550   st = c->ext.actual->next->expr;
2551   if (st != NULL)
2552     name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
2553   else
2554     name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
2555
2556   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2557 }
2558
2559
2560 void
2561 gfc_resolve_ftell_sub (gfc_code * c)
2562 {
2563   const char *name;
2564   gfc_expr *unit;
2565   gfc_expr *offset;
2566   gfc_typespec ts;
2567
2568   unit = c->ext.actual->expr;
2569   offset = c->ext.actual->next->expr;
2570
2571   if (unit->ts.kind != gfc_c_int_kind)
2572     {
2573       ts.type = BT_INTEGER;
2574       ts.kind = gfc_c_int_kind;
2575       ts.derived = NULL;
2576       ts.cl = NULL;
2577       gfc_convert_type (unit, &ts, 2);
2578     }
2579
2580   name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
2581   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2582 }
2583
2584
2585 void
2586 gfc_resolve_ttynam_sub (gfc_code * c)
2587 {
2588   gfc_typespec ts;
2589
2590   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2591     {
2592       ts.type = BT_INTEGER;
2593       ts.kind = gfc_c_int_kind;
2594       ts.derived = NULL;
2595       ts.cl = NULL;
2596       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2597     }
2598
2599   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2600 }
2601
2602
2603 /* Resolve the UMASK intrinsic subroutine.  */
2604
2605 void
2606 gfc_resolve_umask_sub (gfc_code * c)
2607 {
2608   const char *name;
2609   int kind;
2610
2611   if (c->ext.actual->next->expr != NULL)
2612     kind = c->ext.actual->next->expr->ts.kind;
2613   else
2614     kind = gfc_default_integer_kind;
2615
2616   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2617   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2618 }
2619
2620 /* Resolve the UNLINK intrinsic subroutine.  */
2621
2622 void
2623 gfc_resolve_unlink_sub (gfc_code * c)
2624 {
2625   const char *name;
2626   int kind;
2627
2628   if (c->ext.actual->next->expr != NULL)
2629     kind = c->ext.actual->next->expr->ts.kind;
2630   else
2631     kind = gfc_default_integer_kind;
2632
2633   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2634   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2635 }