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