gcc/fortran/iresolve.c

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