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