gcc/fortran/iresolve.c

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