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