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 && mask->ts.kind != 1)
 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   if (a->rank == 2 && b->rank == 2)
1345     {
1346       if (a->shape && b->shape)
1347         {
1348           f->shape = gfc_get_shape (f->rank);
1349           mpz_init_set (f->shape[0], a->shape[0]);
1350           mpz_init_set (f->shape[1], b->shape[1]);
1351         }
1352     }
1353   else if (a->rank == 1)
1354     {
1355       if (b->shape)
1356         {
1357           f->shape = gfc_get_shape (f->rank);
1358           mpz_init_set (f->shape[0], b->shape[1]);
1359         }
1360     }
1361   else
1362     {
1363       /* b->rank == 1 and a->rank == 2 here, all other cases have
1364          been caught in check.c.   */
1365       if (a->shape)
1366         {
1367           f->shape = gfc_get_shape (f->rank);
1368           mpz_init_set (f->shape[0], a->shape[0]);
1369         }
1370     }
1371
1372   f->value.function.name
1373     = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1374                       f->ts.kind);
1375 }
1376
1377
1378 static void
1379 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1380 {
1381   gfc_actual_arglist *a;
1382
1383   f->ts.type = args->expr->ts.type;
1384   f->ts.kind = args->expr->ts.kind;
1385   /* Find the largest type kind.  */
1386   for (a = args->next; a; a = a->next)
1387     {
1388       if (a->expr->ts.kind > f->ts.kind)
1389         f->ts.kind = a->expr->ts.kind;
1390     }
1391
1392   /* Convert all parameters to the required kind.  */
1393   for (a = args; a; a = a->next)
1394     {
1395       if (a->expr->ts.kind != f->ts.kind)
1396         gfc_convert_type (a->expr, &f->ts, 2);
1397     }
1398
1399   f->value.function.name
1400     = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1401 }
1402
1403
1404 void
1405 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1406 {
1407   gfc_resolve_minmax ("__max_%c%d", f, args);
1408 }
1409
1410
1411 void
1412 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1413                     gfc_expr *mask)
1414 {
1415   const char *name;
1416   int i, j, idim;
1417
1418   f->ts.type = BT_INTEGER;
1419   f->ts.kind = gfc_default_integer_kind;
1420
1421   if (dim == NULL)
1422     {
1423       f->rank = 1;
1424       f->shape = gfc_get_shape (1);
1425       mpz_init_set_si (f->shape[0], array->rank);
1426     }
1427   else
1428     {
1429       f->rank = array->rank - 1;
1430       gfc_resolve_dim_arg (dim);
1431       if (array->shape && dim->expr_type == EXPR_CONSTANT)
1432         {
1433           idim = (int) mpz_get_si (dim->value.integer);
1434           f->shape = gfc_get_shape (f->rank);
1435           for (i = 0, j = 0; i < f->rank; i++, j++)
1436             {
1437               if (i == (idim - 1))
1438                 j++;
1439               mpz_init_set (f->shape[i], array->shape[j]);
1440             }
1441         }
1442     }
1443
1444   if (mask)
1445     {
1446       if (mask->rank == 0)
1447         name = "smaxloc";
1448       else
1449         name = "mmaxloc";
1450
1451       resolve_mask_arg (mask);
1452     }
1453   else
1454     name = "maxloc";
1455
1456   f->value.function.name
1457     = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1458                       gfc_type_letter (array->ts.type), array->ts.kind);
1459 }
1460
1461
1462 void
1463 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1464                     gfc_expr *mask)
1465 {
1466   const char *name;
1467   int i, j, idim;
1468
1469   f->ts = array->ts;
1470
1471   if (dim != NULL)
1472     {
1473       f->rank = array->rank - 1;
1474       gfc_resolve_dim_arg (dim);
1475
1476       if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1477         {
1478           idim = (int) mpz_get_si (dim->value.integer);
1479           f->shape = gfc_get_shape (f->rank);
1480           for (i = 0, j = 0; i < f->rank; i++, j++)
1481             {
1482               if (i == (idim - 1))
1483                 j++;
1484               mpz_init_set (f->shape[i], array->shape[j]);
1485             }
1486         }
1487     }
1488
1489   if (mask)
1490     {
1491       if (mask->rank == 0)
1492         name = "smaxval";
1493       else
1494         name = "mmaxval";
1495
1496       resolve_mask_arg (mask);
1497     }
1498   else
1499     name = "maxval";
1500
1501   f->value.function.name
1502     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1503                       gfc_type_letter (array->ts.type), array->ts.kind);
1504 }
1505
1506
1507 void
1508 gfc_resolve_mclock (gfc_expr *f)
1509 {
1510   f->ts.type = BT_INTEGER;
1511   f->ts.kind = 4;
1512   f->value.function.name = PREFIX ("mclock");
1513 }
1514
1515
1516 void
1517 gfc_resolve_mclock8 (gfc_expr *f)
1518 {
1519   f->ts.type = BT_INTEGER;
1520   f->ts.kind = 8;
1521   f->value.function.name = PREFIX ("mclock8");
1522 }
1523
1524
1525 void
1526 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1527                    gfc_expr *fsource ATTRIBUTE_UNUSED,
1528                    gfc_expr *mask ATTRIBUTE_UNUSED)
1529 {
1530   if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1531     gfc_resolve_substring_charlen (tsource);
1532
1533   if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1534     gfc_resolve_substring_charlen (fsource);
1535
1536   if (tsource->ts.type == BT_CHARACTER)
1537     check_charlen_present (tsource);
1538
1539   f->ts = tsource->ts;
1540   f->value.function.name
1541     = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1542                       tsource->ts.kind);
1543 }
1544
1545
1546 void
1547 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1548 {
1549   gfc_resolve_minmax ("__min_%c%d", f, args);
1550 }
1551
1552
1553 void
1554 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1555                     gfc_expr *mask)
1556 {
1557   const char *name;
1558   int i, j, idim;
1559
1560   f->ts.type = BT_INTEGER;
1561   f->ts.kind = gfc_default_integer_kind;
1562
1563   if (dim == NULL)
1564     {
1565       f->rank = 1;
1566       f->shape = gfc_get_shape (1);
1567       mpz_init_set_si (f->shape[0], array->rank);
1568     }
1569   else
1570     {
1571       f->rank = array->rank - 1;
1572       gfc_resolve_dim_arg (dim);
1573       if (array->shape && dim->expr_type == EXPR_CONSTANT)
1574         {
1575           idim = (int) mpz_get_si (dim->value.integer);
1576           f->shape = gfc_get_shape (f->rank);
1577           for (i = 0, j = 0; i < f->rank; i++, j++)
1578             {
1579               if (i == (idim - 1))
1580                 j++;
1581               mpz_init_set (f->shape[i], array->shape[j]);
1582             }
1583         }
1584     }
1585
1586   if (mask)
1587     {
1588       if (mask->rank == 0)
1589         name = "sminloc";
1590       else
1591         name = "mminloc";
1592
1593       resolve_mask_arg (mask);
1594     }
1595   else
1596     name = "minloc";
1597
1598   f->value.function.name
1599     = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1600                       gfc_type_letter (array->ts.type), array->ts.kind);
1601 }
1602
1603
1604 void
1605 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1606                     gfc_expr *mask)
1607 {
1608   const char *name;
1609   int i, j, idim;
1610
1611   f->ts = array->ts;
1612
1613   if (dim != NULL)
1614     {
1615       f->rank = array->rank - 1;
1616       gfc_resolve_dim_arg (dim);
1617
1618       if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1619         {
1620           idim = (int) mpz_get_si (dim->value.integer);
1621           f->shape = gfc_get_shape (f->rank);
1622           for (i = 0, j = 0; i < f->rank; i++, j++)
1623             {
1624               if (i == (idim - 1))
1625                 j++;
1626               mpz_init_set (f->shape[i], array->shape[j]);
1627             }
1628         }
1629     }
1630
1631   if (mask)
1632     {
1633       if (mask->rank == 0)
1634         name = "sminval";
1635       else
1636         name = "mminval";
1637
1638       resolve_mask_arg (mask);
1639     }
1640   else
1641     name = "minval";
1642
1643   f->value.function.name
1644     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1645                       gfc_type_letter (array->ts.type), array->ts.kind);
1646 }
1647
1648
1649 void
1650 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1651 {
1652   f->ts.type = a->ts.type;
1653   if (p != NULL)
1654     f->ts.kind = gfc_kind_max (a,p);
1655   else
1656     f->ts.kind = a->ts.kind;
1657
1658   if (p != NULL && a->ts.kind != p->ts.kind)
1659     {
1660       if (a->ts.kind == gfc_kind_max (a,p))
1661         gfc_convert_type (p, &a->ts, 2);
1662       else
1663         gfc_convert_type (a, &p->ts, 2);
1664     }
1665
1666   f->value.function.name
1667     = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1668 }
1669
1670
1671 void
1672 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1673 {
1674   f->ts.type = a->ts.type;
1675   if (p != NULL)
1676     f->ts.kind = gfc_kind_max (a,p);
1677   else
1678     f->ts.kind = a->ts.kind;
1679
1680   if (p != NULL && a->ts.kind != p->ts.kind)
1681     {
1682       if (a->ts.kind == gfc_kind_max (a,p))
1683         gfc_convert_type (p, &a->ts, 2);
1684       else
1685         gfc_convert_type (a, &p->ts, 2);
1686     }
1687
1688   f->value.function.name
1689     = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1690                       f->ts.kind);
1691 }
1692
1693 void
1694 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1695 {
1696   if (p->ts.kind != a->ts.kind)
1697     gfc_convert_type (p, &a->ts, 2);
1698
1699   f->ts = a->ts;
1700   f->value.function.name
1701     = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1702                       a->ts.kind);
1703 }
1704
1705 void
1706 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1707 {
1708   f->ts.type = BT_INTEGER;
1709   f->ts.kind = (kind == NULL)
1710              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1711   f->value.function.name
1712     = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1713 }
1714
1715
1716 void
1717 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
1718 {
1719   f->ts = i->ts;
1720   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1721 }
1722
1723
1724 void
1725 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1726 {
1727   f->ts.type = i->ts.type;
1728   f->ts.kind = gfc_kind_max (i, j);
1729
1730   if (i->ts.kind != j->ts.kind)
1731     {
1732       if (i->ts.kind == gfc_kind_max (i, j))
1733         gfc_convert_type (j, &i->ts, 2);
1734       else
1735         gfc_convert_type (i, &j->ts, 2);
1736     }
1737
1738   f->value.function.name
1739     = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
1740 }
1741
1742
1743 void
1744 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
1745                   gfc_expr *vector ATTRIBUTE_UNUSED)
1746 {
1747   if (array->ts.type == BT_CHARACTER && array->ref)
1748     gfc_resolve_substring_charlen (array);
1749
1750   f->ts = array->ts;
1751   f->rank = 1;
1752
1753   resolve_mask_arg (mask);
1754
1755   if (mask->rank != 0)
1756     {
1757       if (array->ts.type == BT_CHARACTER)
1758         f->value.function.name
1759           = array->ts.kind == 1 ? PREFIX ("pack_char")
1760                                 : gfc_get_string
1761                                         (PREFIX ("pack_char%d"),
1762                                          array->ts.kind);
1763       else
1764         f->value.function.name = PREFIX ("pack");
1765     }
1766   else
1767     {
1768       if (array->ts.type == BT_CHARACTER)
1769         f->value.function.name
1770           = array->ts.kind == 1 ? PREFIX ("pack_s_char")
1771                                 : gfc_get_string
1772                                         (PREFIX ("pack_s_char%d"),
1773                                          array->ts.kind);
1774       else
1775         f->value.function.name = PREFIX ("pack_s");
1776     }
1777 }
1778
1779
1780 void
1781 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1782                      gfc_expr *mask)
1783 {
1784   const char *name;
1785
1786   f->ts = array->ts;
1787
1788   if (dim != NULL)
1789     {
1790       f->rank = array->rank - 1;
1791       f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
1792       gfc_resolve_dim_arg (dim);
1793     }
1794
1795   if (mask)
1796     {
1797       if (mask->rank == 0)
1798         name = "sproduct";
1799       else
1800         name = "mproduct";
1801
1802       resolve_mask_arg (mask);
1803     }
1804   else
1805     name = "product";
1806
1807   f->value.function.name
1808     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1809                       gfc_type_letter (array->ts.type), array->ts.kind);
1810 }
1811
1812
1813 void
1814 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1815 {
1816   f->ts.type = BT_REAL;
1817
1818   if (kind != NULL)
1819     f->ts.kind = mpz_get_si (kind->value.integer);
1820   else
1821     f->ts.kind = (a->ts.type == BT_COMPLEX)
1822                ? a->ts.kind : gfc_default_real_kind;
1823
1824   f->value.function.name
1825     = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1826                       gfc_type_letter (a->ts.type), a->ts.kind);
1827 }
1828
1829
1830 void
1831 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
1832 {
1833   f->ts.type = BT_REAL;
1834   f->ts.kind = a->ts.kind;
1835   f->value.function.name
1836     = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1837                       gfc_type_letter (a->ts.type), a->ts.kind);
1838 }
1839
1840
1841 void
1842 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1843                     gfc_expr *p2 ATTRIBUTE_UNUSED)
1844 {
1845   f->ts.type = BT_INTEGER;
1846   f->ts.kind = gfc_default_integer_kind;
1847   f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
1848 }
1849
1850
1851 void
1852 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
1853                     gfc_expr *ncopies ATTRIBUTE_UNUSED)
1854 {
1855   f->ts.type = BT_CHARACTER;
1856   f->ts.kind = string->ts.kind;
1857   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1858 }
1859
1860
1861 void
1862 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
1863                      gfc_expr *pad ATTRIBUTE_UNUSED,
1864                      gfc_expr *order ATTRIBUTE_UNUSED)
1865 {
1866   mpz_t rank;
1867   int kind;
1868   int i;
1869
1870   if (source->ts.type == BT_CHARACTER && source->ref)
1871     gfc_resolve_substring_charlen (source);
1872
1873   f->ts = source->ts;
1874
1875   gfc_array_size (shape, &rank);
1876   f->rank = mpz_get_si (rank);
1877   mpz_clear (rank);
1878   switch (source->ts.type)
1879     {
1880     case BT_COMPLEX:
1881     case BT_REAL:
1882     case BT_INTEGER:
1883     case BT_LOGICAL:
1884     case BT_CHARACTER:
1885       kind = source->ts.kind;
1886       break;
1887
1888     default:
1889       kind = 0;
1890       break;
1891     }
1892
1893   switch (kind)
1894     {
1895     case 4:
1896     case 8:
1897     case 10:
1898     case 16:
1899       if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
1900         f->value.function.name
1901           = gfc_get_string (PREFIX ("reshape_%c%d"),
1902                             gfc_type_letter (source->ts.type),
1903                             source->ts.kind);
1904       else if (source->ts.type == BT_CHARACTER)
1905         f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
1906                                                  kind);
1907       else
1908         f->value.function.name
1909           = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
1910       break;
1911
1912     default:
1913       f->value.function.name = (source->ts.type == BT_CHARACTER
1914                                 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
1915       break;
1916     }
1917
1918   /* TODO: Make this work with a constant ORDER parameter.  */
1919   if (shape->expr_type == EXPR_ARRAY
1920       && gfc_is_constant_expr (shape)
1921       && order == NULL)
1922     {
1923       gfc_constructor *c;
1924       f->shape = gfc_get_shape (f->rank);
1925       c = shape->value.constructor;
1926       for (i = 0; i < f->rank; i++)
1927         {
1928           mpz_init_set (f->shape[i], c->expr->value.integer);
1929           c = c->next;
1930         }
1931     }
1932
1933   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1934      so many runtime variations.  */
1935   if (shape->ts.kind != gfc_index_integer_kind)
1936     {
1937       gfc_typespec ts = shape->ts;
1938       ts.kind = gfc_index_integer_kind;
1939       gfc_convert_type_warn (shape, &ts, 2, 0);
1940     }
1941   if (order && order->ts.kind != gfc_index_integer_kind)
1942     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1943 }
1944
1945
1946 void
1947 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
1948 {
1949   f->ts = x->ts;
1950   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1951 }
1952
1953
1954 void
1955 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
1956 {
1957   f->ts = x->ts;
1958   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1959 }
1960
1961
1962 void
1963 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
1964                   gfc_expr *set ATTRIBUTE_UNUSED,
1965                   gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
1966 {
1967   f->ts.type = BT_INTEGER;
1968   if (kind)
1969     f->ts.kind = mpz_get_si (kind->value.integer);
1970   else
1971     f->ts.kind = gfc_default_integer_kind;
1972   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1973 }
1974
1975
1976 void
1977 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
1978 {
1979   t1->ts = t0->ts;
1980   t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
1981 }
1982
1983
1984 void
1985 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
1986                           gfc_expr *i ATTRIBUTE_UNUSED)
1987 {
1988   f->ts = x->ts;
1989   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1990 }
1991
1992
1993 void
1994 gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
1995 {
1996   f->ts.type = BT_INTEGER;
1997   f->ts.kind = gfc_default_integer_kind;
1998   f->rank = 1;
1999   f->shape = gfc_get_shape (1);
2000   mpz_init_set_ui (f->shape[0], array->rank);
2001   f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2002 }
2003
2004
2005 void
2006 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2007 {
2008   f->ts = a->ts;
2009   f->value.function.name
2010     = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2011 }
2012
2013
2014 void
2015 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2016 {
2017   f->ts.type = BT_INTEGER;
2018   f->ts.kind = gfc_c_int_kind;
2019
2020   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2021   if (handler->ts.type == BT_INTEGER)
2022     {
2023       if (handler->ts.kind != gfc_c_int_kind)
2024         gfc_convert_type (handler, &f->ts, 2);
2025       f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2026     }
2027   else
2028     f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2029
2030   if (number->ts.kind != gfc_c_int_kind)
2031     gfc_convert_type (number, &f->ts, 2);
2032 }
2033
2034
2035 void
2036 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2037 {
2038   f->ts = x->ts;
2039   f->value.function.name
2040     = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2041 }
2042
2043
2044 void
2045 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2046 {
2047   f->ts = x->ts;
2048   f->value.function.name
2049     = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2050 }
2051
2052
2053 void
2054 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2055                   gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2056 {
2057   f->ts.type = BT_INTEGER;
2058   if (kind)
2059     f->ts.kind = mpz_get_si (kind->value.integer);
2060   else
2061     f->ts.kind = gfc_default_integer_kind;
2062 }
2063
2064
2065 void
2066 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2067 {
2068   f->ts = x->ts;
2069   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2070 }
2071
2072
2073 void
2074 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2075                     gfc_expr *ncopies)
2076 {
2077   if (source->ts.type == BT_CHARACTER && source->ref)
2078     gfc_resolve_substring_charlen (source);
2079
2080   if (source->ts.type == BT_CHARACTER)
2081     check_charlen_present (source);
2082
2083   f->ts = source->ts;
2084   f->rank = source->rank + 1;
2085   if (source->rank == 0)
2086     {
2087       if (source->ts.type == BT_CHARACTER)
2088         f->value.function.name
2089           = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2090                                  : gfc_get_string
2091                                         (PREFIX ("spread_char%d_scalar"),
2092                                          source->ts.kind);
2093       else
2094         f->value.function.name = PREFIX ("spread_scalar");
2095     }
2096   else
2097     {
2098       if (source->ts.type == BT_CHARACTER)
2099         f->value.function.name
2100           = source->ts.kind == 1 ? PREFIX ("spread_char")
2101                                  : gfc_get_string
2102                                         (PREFIX ("spread_char%d"),
2103                                          source->ts.kind);
2104       else
2105         f->value.function.name = PREFIX ("spread");
2106     }
2107
2108   if (dim && gfc_is_constant_expr (dim)
2109       && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2110     {
2111       int i, idim;
2112       idim = mpz_get_ui (dim->value.integer);
2113       f->shape = gfc_get_shape (f->rank);
2114       for (i = 0; i < (idim - 1); i++)
2115         mpz_init_set (f->shape[i], source->shape[i]);
2116
2117       mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2118
2119       for (i = idim; i < f->rank ; i++)
2120         mpz_init_set (f->shape[i], source->shape[i-1]);
2121     }
2122
2123
2124   gfc_resolve_dim_arg (dim);
2125   gfc_resolve_index (ncopies, 1);
2126 }
2127
2128
2129 void
2130 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2131 {
2132   f->ts = x->ts;
2133   f->value.function.name
2134     = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2135 }
2136
2137
2138 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
2139
2140 void
2141 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2142                   gfc_expr *a ATTRIBUTE_UNUSED)
2143 {
2144   f->ts.type = BT_INTEGER;
2145   f->ts.kind = gfc_default_integer_kind;
2146   f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2147 }
2148
2149
2150 void
2151 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2152                    gfc_expr *a ATTRIBUTE_UNUSED)
2153 {
2154   f->ts.type = BT_INTEGER;
2155   f->ts.kind = gfc_default_integer_kind;
2156   f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2157 }
2158
2159
2160 void
2161 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2162 {
2163   f->ts.type = BT_INTEGER;
2164   f->ts.kind = gfc_default_integer_kind;
2165   if (n->ts.kind != f->ts.kind)
2166     gfc_convert_type (n, &f->ts, 2);
2167
2168   f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2169 }
2170
2171
2172 void
2173 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2174 {
2175   gfc_typespec ts;
2176   gfc_clear_ts (&ts);
2177
2178   f->ts.type = BT_INTEGER;
2179   f->ts.kind = gfc_c_int_kind;
2180   if (u->ts.kind != gfc_c_int_kind)
2181     {
2182       ts.type = BT_INTEGER;
2183       ts.kind = gfc_c_int_kind;
2184       ts.derived = NULL;
2185       ts.cl = NULL;
2186       gfc_convert_type (u, &ts, 2);
2187     }
2188
2189   f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2190 }
2191
2192
2193 void
2194 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2195 {
2196   f->ts.type = BT_INTEGER;
2197   f->ts.kind = gfc_c_int_kind;
2198   f->value.function.name = gfc_get_string (PREFIX ("fget"));
2199 }
2200
2201
2202 void
2203 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2204 {
2205   gfc_typespec ts;
2206   gfc_clear_ts (&ts);
2207
2208   f->ts.type = BT_INTEGER;
2209   f->ts.kind = gfc_c_int_kind;
2210   if (u->ts.kind != gfc_c_int_kind)
2211     {
2212       ts.type = BT_INTEGER;
2213       ts.kind = gfc_c_int_kind;
2214       ts.derived = NULL;
2215       ts.cl = NULL;
2216       gfc_convert_type (u, &ts, 2);
2217     }
2218
2219   f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2220 }
2221
2222
2223 void
2224 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2225 {
2226   f->ts.type = BT_INTEGER;
2227   f->ts.kind = gfc_c_int_kind;
2228   f->value.function.name = gfc_get_string (PREFIX ("fput"));
2229 }
2230
2231
2232 void
2233 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2234 {
2235   gfc_typespec ts;
2236   gfc_clear_ts (&ts);
2237
2238   f->ts.type = BT_INTEGER;
2239   f->ts.kind = gfc_index_integer_kind;
2240   if (u->ts.kind != gfc_c_int_kind)
2241     {
2242       ts.type = BT_INTEGER;
2243       ts.kind = gfc_c_int_kind;
2244       ts.derived = NULL;
2245       ts.cl = NULL;
2246       gfc_convert_type (u, &ts, 2);
2247     }
2248
2249   f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2250 }
2251
2252
2253 void
2254 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2255 {
2256   const char *name;
2257
2258   f->ts = array->ts;
2259
2260   if (mask)
2261     {
2262       if (mask->rank == 0)
2263         name = "ssum";
2264       else
2265         name = "msum";
2266
2267       resolve_mask_arg (mask);
2268     }
2269   else
2270     name = "sum";
2271
2272   if (dim != NULL)
2273     {
2274       f->rank = array->rank - 1;
2275       f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
2276       gfc_resolve_dim_arg (dim);
2277     }
2278
2279   f->value.function.name
2280     = gfc_get_string (PREFIX ("%s_%c%d"), name,
2281                     gfc_type_letter (array->ts.type), array->ts.kind);
2282 }
2283
2284
2285 void
2286 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2287                     gfc_expr *p2 ATTRIBUTE_UNUSED)
2288 {
2289   f->ts.type = BT_INTEGER;
2290   f->ts.kind = gfc_default_integer_kind;
2291   f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2292 }
2293
2294
2295 /* Resolve the g77 compatibility function SYSTEM.  */
2296
2297 void
2298 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2299 {
2300   f->ts.type = BT_INTEGER;
2301   f->ts.kind = 4;
2302   f->value.function.name = gfc_get_string (PREFIX ("system"));
2303 }
2304
2305
2306 void
2307 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2308 {
2309   f->ts = x->ts;
2310   f->value.function.name
2311     = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2312 }
2313
2314
2315 void
2316 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2317 {
2318   f->ts = x->ts;
2319   f->value.function.name
2320     = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2321 }
2322
2323
2324 void
2325 gfc_resolve_time (gfc_expr *f)
2326 {
2327   f->ts.type = BT_INTEGER;
2328   f->ts.kind = 4;
2329   f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2330 }
2331
2332
2333 void
2334 gfc_resolve_time8 (gfc_expr *f)
2335 {
2336   f->ts.type = BT_INTEGER;
2337   f->ts.kind = 8;
2338   f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2339 }
2340
2341
2342 void
2343 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2344                       gfc_expr *mold, gfc_expr *size)
2345 {
2346   /* TODO: Make this do something meaningful.  */
2347   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2348
2349   if (mold->ts.type == BT_CHARACTER && !mold->ts.cl->length
2350         && !(mold->expr_type == EXPR_VARIABLE && mold->symtree->n.sym->attr.dummy))
2351     mold->ts.cl->length = gfc_int_expr (mold->value.character.length);
2352
2353   f->ts = mold->ts;
2354
2355   if (size == NULL && mold->rank == 0)
2356     {
2357       f->rank = 0;
2358       f->value.function.name = transfer0;
2359     }
2360   else
2361     {
2362       f->rank = 1;
2363       f->value.function.name = transfer1;
2364       if (size && gfc_is_constant_expr (size))
2365         {
2366           f->shape = gfc_get_shape (1);
2367           mpz_init_set (f->shape[0], size->value.integer);
2368         }
2369     }
2370 }
2371
2372
2373 void
2374 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2375 {
2376
2377   if (matrix->ts.type == BT_CHARACTER && matrix->ref)
2378     gfc_resolve_substring_charlen (matrix);
2379
2380   f->ts = matrix->ts;
2381   f->rank = 2;
2382   if (matrix->shape)
2383     {
2384       f->shape = gfc_get_shape (2);
2385       mpz_init_set (f->shape[0], matrix->shape[1]);
2386       mpz_init_set (f->shape[1], matrix->shape[0]);
2387     }
2388
2389   switch (matrix->ts.kind)
2390     {
2391     case 4:
2392     case 8:
2393     case 10:
2394     case 16:
2395       switch (matrix->ts.type)
2396         {
2397         case BT_REAL:
2398         case BT_COMPLEX:
2399           f->value.function.name
2400             = gfc_get_string (PREFIX ("transpose_%c%d"),
2401                               gfc_type_letter (matrix->ts.type),
2402                               matrix->ts.kind);
2403           break;
2404
2405         case BT_INTEGER:
2406         case BT_LOGICAL:
2407           /* Use the integer routines for real and logical cases.  This
2408              assumes they all have the same alignment requirements.  */
2409           f->value.function.name
2410             = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
2411           break;
2412
2413         default:
2414           if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
2415             f->value.function.name = PREFIX ("transpose_char4");
2416           else
2417             f->value.function.name = PREFIX ("transpose");
2418           break;
2419         }
2420       break;
2421
2422     default:
2423       f->value.function.name = (matrix->ts.type == BT_CHARACTER
2424                                 ? PREFIX ("transpose_char")
2425                                 : PREFIX ("transpose"));
2426       break;
2427     }
2428 }
2429
2430
2431 void
2432 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
2433 {
2434   f->ts.type = BT_CHARACTER;
2435   f->ts.kind = string->ts.kind;
2436   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2437 }
2438
2439
2440 void
2441 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2442 {
2443   static char ubound[] = "__ubound";
2444
2445   f->ts.type = BT_INTEGER;
2446   if (kind)
2447     f->ts.kind = mpz_get_si (kind->value.integer);
2448   else
2449     f->ts.kind = gfc_default_integer_kind;
2450
2451   if (dim == NULL)
2452     {
2453       f->rank = 1;
2454       f->shape = gfc_get_shape (1);
2455       mpz_init_set_ui (f->shape[0], array->rank);
2456     }
2457
2458   f->value.function.name = ubound;
2459 }
2460
2461
2462 /* Resolve the g77 compatibility function UMASK.  */
2463
2464 void
2465 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
2466 {
2467   f->ts.type = BT_INTEGER;
2468   f->ts.kind = n->ts.kind;
2469   f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
2470 }
2471
2472
2473 /* Resolve the g77 compatibility function UNLINK.  */
2474
2475 void
2476 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2477 {
2478   f->ts.type = BT_INTEGER;
2479   f->ts.kind = 4;
2480   f->value.function.name = gfc_get_string (PREFIX ("unlink"));
2481 }
2482
2483
2484 void
2485 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
2486 {
2487   gfc_typespec ts;
2488   gfc_clear_ts (&ts);
2489
2490   f->ts.type = BT_CHARACTER;
2491   f->ts.kind = gfc_default_character_kind;
2492
2493   if (unit->ts.kind != gfc_c_int_kind)
2494     {
2495       ts.type = BT_INTEGER;
2496       ts.kind = gfc_c_int_kind;
2497       ts.derived = NULL;
2498       ts.cl = NULL;
2499       gfc_convert_type (unit, &ts, 2);
2500     }
2501
2502   f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
2503 }
2504
2505
2506 void
2507 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
2508                     gfc_expr *field ATTRIBUTE_UNUSED)
2509 {
2510   if (vector->ts.type == BT_CHARACTER && vector->ref)
2511     gfc_resolve_substring_charlen (vector);
2512
2513   f->ts = vector->ts;
2514   f->rank = mask->rank;
2515   resolve_mask_arg (mask);
2516
2517   if (vector->ts.type == BT_CHARACTER)
2518     {
2519       if (vector->ts.kind == 1)
2520         f->value.function.name
2521           = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
2522       else
2523         f->value.function.name
2524           = gfc_get_string (PREFIX ("unpack%d_char%d"),
2525                             field->rank > 0 ? 1 : 0, vector->ts.kind);
2526     }
2527   else
2528     f->value.function.name
2529       = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
2530 }
2531
2532
2533 void
2534 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
2535                     gfc_expr *set ATTRIBUTE_UNUSED,
2536                     gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2537 {
2538   f->ts.type = BT_INTEGER;
2539   if (kind)
2540     f->ts.kind = mpz_get_si (kind->value.integer);
2541   else
2542     f->ts.kind = gfc_default_integer_kind;
2543   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2544 }
2545
2546
2547 void
2548 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2549 {
2550   f->ts.type = i->ts.type;
2551   f->ts.kind = gfc_kind_max (i, j);
2552
2553   if (i->ts.kind != j->ts.kind)
2554     {
2555       if (i->ts.kind == gfc_kind_max (i, j))
2556         gfc_convert_type (j, &i->ts, 2);
2557       else
2558         gfc_convert_type (i, &j->ts, 2);
2559     }
2560
2561   f->value.function.name
2562     = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2563 }
2564
2565
2566 /* Intrinsic subroutine resolution.  */
2567
2568 void
2569 gfc_resolve_alarm_sub (gfc_code *c)
2570 {
2571   const char *name;
2572   gfc_expr *seconds, *handler, *status;
2573   gfc_typespec ts;
2574   gfc_clear_ts (&ts);
2575
2576   seconds = c->ext.actual->expr;
2577   handler = c->ext.actual->next->expr;
2578   status = c->ext.actual->next->next->expr;
2579   ts.type = BT_INTEGER;
2580   ts.kind = gfc_c_int_kind;
2581
2582   /* handler can be either BT_INTEGER or BT_PROCEDURE.
2583      In all cases, the status argument is of default integer kind
2584      (enforced in check.c) so that the function suffix is fixed.  */
2585   if (handler->ts.type == BT_INTEGER)
2586     {
2587       if (handler->ts.kind != gfc_c_int_kind)
2588         gfc_convert_type (handler, &ts, 2);
2589       name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2590                              gfc_default_integer_kind);
2591     }
2592   else
2593     name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
2594                            gfc_default_integer_kind);
2595
2596   if (seconds->ts.kind != gfc_c_int_kind)
2597     gfc_convert_type (seconds, &ts, 2);
2598
2599   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2600 }
2601
2602 void
2603 gfc_resolve_cpu_time (gfc_code *c)
2604 {
2605   const char *name;
2606   name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2607   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2608 }
2609
2610
2611 void
2612 gfc_resolve_mvbits (gfc_code *c)
2613 {
2614   const char *name;
2615   gfc_typespec ts;
2616   gfc_clear_ts (&ts);
2617
2618   /* FROMPOS, LEN and TOPOS are restricted to small values.  As such,
2619      they will be converted so that they fit into a C int.  */
2620   ts.type = BT_INTEGER;
2621   ts.kind = gfc_c_int_kind;
2622   if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
2623     gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
2624   if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
2625     gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
2626   if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
2627     gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
2628
2629   /* TO and FROM are guaranteed to have the same kind parameter.  */
2630   name = gfc_get_string (PREFIX ("mvbits_i%d"),
2631                          c->ext.actual->expr->ts.kind);
2632   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2633   /* Mark as elemental subroutine as this does not happen automatically.  */
2634   c->resolved_sym->attr.elemental = 1;
2635 }
2636
2637
2638 void
2639 gfc_resolve_random_number (gfc_code *c)
2640 {
2641   const char *name;
2642   int kind;
2643
2644   kind = c->ext.actual->expr->ts.kind;
2645   if (c->ext.actual->expr->rank == 0)
2646     name = gfc_get_string (PREFIX ("random_r%d"), kind);
2647   else
2648     name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2649
2650   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2651 }
2652
2653
2654 void
2655 gfc_resolve_random_seed (gfc_code *c)
2656 {
2657   const char *name;
2658
2659   name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
2660   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2661 }
2662
2663
2664 void
2665 gfc_resolve_rename_sub (gfc_code *c)
2666 {
2667   const char *name;
2668   int kind;
2669
2670   if (c->ext.actual->next->next->expr != NULL)
2671     kind = c->ext.actual->next->next->expr->ts.kind;
2672   else
2673     kind = gfc_default_integer_kind;
2674
2675   name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2676   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2677 }
2678
2679
2680 void
2681 gfc_resolve_kill_sub (gfc_code *c)
2682 {
2683   const char *name;
2684   int kind;
2685
2686   if (c->ext.actual->next->next->expr != NULL)
2687     kind = c->ext.actual->next->next->expr->ts.kind;
2688   else
2689     kind = gfc_default_integer_kind;
2690
2691   name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
2692   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2693 }
2694
2695
2696 void
2697 gfc_resolve_link_sub (gfc_code *c)
2698 {
2699   const char *name;
2700   int kind;
2701
2702   if (c->ext.actual->next->next->expr != NULL)
2703     kind = c->ext.actual->next->next->expr->ts.kind;
2704   else
2705     kind = gfc_default_integer_kind;
2706
2707   name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
2708   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2709 }
2710
2711
2712 void
2713 gfc_resolve_symlnk_sub (gfc_code *c)
2714 {
2715   const char *name;
2716   int kind;
2717
2718   if (c->ext.actual->next->next->expr != NULL)
2719     kind = c->ext.actual->next->next->expr->ts.kind;
2720   else
2721     kind = gfc_default_integer_kind;
2722
2723   name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
2724   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2725 }
2726
2727
2728 /* G77 compatibility subroutines dtime() and etime().  */
2729
2730 void
2731 gfc_resolve_dtime_sub (gfc_code *c)
2732 {
2733   const char *name;
2734   name = gfc_get_string (PREFIX ("dtime_sub"));
2735   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2736 }
2737
2738 void
2739 gfc_resolve_etime_sub (gfc_code *c)
2740 {
2741   const char *name;
2742   name = gfc_get_string (PREFIX ("etime_sub"));
2743   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2744 }
2745
2746
2747 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime().  */
2748
2749 void
2750 gfc_resolve_itime (gfc_code *c)
2751 {
2752   c->resolved_sym
2753     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2754                                                     gfc_default_integer_kind));
2755 }
2756
2757 void
2758 gfc_resolve_idate (gfc_code *c)
2759 {
2760   c->resolved_sym
2761     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2762                                                     gfc_default_integer_kind));
2763 }
2764
2765 void
2766 gfc_resolve_ltime (gfc_code *c)
2767 {
2768   c->resolved_sym
2769     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2770                                                     gfc_default_integer_kind));
2771 }
2772
2773 void
2774 gfc_resolve_gmtime (gfc_code *c)
2775 {
2776   c->resolved_sym
2777     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2778                                                     gfc_default_integer_kind));
2779 }
2780
2781
2782 /* G77 compatibility subroutine second().  */
2783
2784 void
2785 gfc_resolve_second_sub (gfc_code *c)
2786 {
2787   const char *name;
2788   name = gfc_get_string (PREFIX ("second_sub"));
2789   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2790 }
2791
2792
2793 void
2794 gfc_resolve_sleep_sub (gfc_code *c)
2795 {
2796   const char *name;
2797   int kind;
2798
2799   if (c->ext.actual->expr != NULL)
2800     kind = c->ext.actual->expr->ts.kind;
2801   else
2802     kind = gfc_default_integer_kind;
2803
2804   name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
2805   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2806 }
2807
2808
2809 /* G77 compatibility function srand().  */
2810
2811 void
2812 gfc_resolve_srand (gfc_code *c)
2813 {
2814   const char *name;
2815   name = gfc_get_string (PREFIX ("srand"));
2816   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2817 }
2818
2819
2820 /* Resolve the getarg intrinsic subroutine.  */
2821
2822 void
2823 gfc_resolve_getarg (gfc_code *c)
2824 {
2825   const char *name;
2826
2827   if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
2828     {
2829       gfc_typespec ts;
2830       gfc_clear_ts (&ts);
2831
2832       ts.type = BT_INTEGER;
2833       ts.kind = gfc_default_integer_kind;
2834
2835       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2836     }
2837
2838   name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
2839   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2840 }
2841
2842
2843 /* Resolve the getcwd intrinsic subroutine.  */
2844
2845 void
2846 gfc_resolve_getcwd_sub (gfc_code *c)
2847 {
2848   const char *name;
2849   int kind;
2850
2851   if (c->ext.actual->next->expr != NULL)
2852     kind = c->ext.actual->next->expr->ts.kind;
2853   else
2854     kind = gfc_default_integer_kind;
2855
2856   name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
2857   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2858 }
2859
2860
2861 /* Resolve the get_command intrinsic subroutine.  */
2862
2863 void
2864 gfc_resolve_get_command (gfc_code *c)
2865 {
2866   const char *name;
2867   int kind;
2868   kind = gfc_default_integer_kind;
2869   name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
2870   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2871 }
2872
2873
2874 /* Resolve the get_command_argument intrinsic subroutine.  */
2875
2876 void
2877 gfc_resolve_get_command_argument (gfc_code *c)
2878 {
2879   const char *name;
2880   int kind;
2881   kind = gfc_default_integer_kind;
2882   name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
2883   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2884 }
2885
2886
2887 /* Resolve the get_environment_variable intrinsic subroutine.  */
2888
2889 void
2890 gfc_resolve_get_environment_variable (gfc_code *code)
2891 {
2892   const char *name;
2893   int kind;
2894   kind = gfc_default_integer_kind;
2895   name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
2896   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2897 }
2898
2899
2900 void
2901 gfc_resolve_signal_sub (gfc_code *c)
2902 {
2903   const char *name;
2904   gfc_expr *number, *handler, *status;
2905   gfc_typespec ts;
2906   gfc_clear_ts (&ts);
2907
2908   number = c->ext.actual->expr;
2909   handler = c->ext.actual->next->expr;
2910   status = c->ext.actual->next->next->expr;
2911   ts.type = BT_INTEGER;
2912   ts.kind = gfc_c_int_kind;
2913
2914   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2915   if (handler->ts.type == BT_INTEGER)
2916     {
2917       if (handler->ts.kind != gfc_c_int_kind)
2918         gfc_convert_type (handler, &ts, 2);
2919       name = gfc_get_string (PREFIX ("signal_sub_int"));
2920     }
2921   else
2922     name = gfc_get_string (PREFIX ("signal_sub"));
2923
2924   if (number->ts.kind != gfc_c_int_kind)
2925     gfc_convert_type (number, &ts, 2);
2926   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2927     gfc_convert_type (status, &ts, 2);
2928
2929   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2930 }
2931
2932
2933 /* Resolve the SYSTEM intrinsic subroutine.  */
2934
2935 void
2936 gfc_resolve_system_sub (gfc_code *c)
2937 {
2938   const char *name;
2939   name = gfc_get_string (PREFIX ("system_sub"));
2940   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2941 }
2942
2943
2944 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2945
2946 void
2947 gfc_resolve_system_clock (gfc_code *c)
2948 {
2949   const char *name;
2950   int kind;
2951
2952   if (c->ext.actual->expr != NULL)
2953     kind = c->ext.actual->expr->ts.kind;
2954   else if (c->ext.actual->next->expr != NULL)
2955       kind = c->ext.actual->next->expr->ts.kind;
2956   else if (c->ext.actual->next->next->expr != NULL)
2957       kind = c->ext.actual->next->next->expr->ts.kind;
2958   else
2959     kind = gfc_default_integer_kind;
2960
2961   name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
2962   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2963 }
2964
2965
2966 /* Resolve the EXIT intrinsic subroutine.  */
2967
2968 void
2969 gfc_resolve_exit (gfc_code *c)
2970 {
2971   const char *name;
2972   gfc_typespec ts;
2973   gfc_expr *n;
2974   gfc_clear_ts (&ts);
2975
2976   /* The STATUS argument has to be of default kind.  If it is not,
2977      we convert it.  */
2978   ts.type = BT_INTEGER;
2979   ts.kind = gfc_default_integer_kind;
2980   n = c->ext.actual->expr;
2981   if (n != NULL && n->ts.kind != ts.kind)
2982     gfc_convert_type (n, &ts, 2);
2983
2984   name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
2985   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2986 }
2987
2988
2989 /* Resolve the FLUSH intrinsic subroutine.  */
2990
2991 void
2992 gfc_resolve_flush (gfc_code *c)
2993 {
2994   const char *name;
2995   gfc_typespec ts;
2996   gfc_expr *n;
2997   gfc_clear_ts (&ts);
2998
2999   ts.type = BT_INTEGER;
3000   ts.kind = gfc_default_integer_kind;
3001   n = c->ext.actual->expr;
3002   if (n != NULL && n->ts.kind != ts.kind)
3003     gfc_convert_type (n, &ts, 2);
3004
3005   name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3006   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3007 }
3008
3009
3010 void
3011 gfc_resolve_free (gfc_code *c)
3012 {
3013   gfc_typespec ts;
3014   gfc_expr *n;
3015   gfc_clear_ts (&ts);
3016
3017   ts.type = BT_INTEGER;
3018   ts.kind = gfc_index_integer_kind;
3019   n = c->ext.actual->expr;
3020   if (n->ts.kind != ts.kind)
3021     gfc_convert_type (n, &ts, 2);
3022
3023   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3024 }
3025
3026
3027 void
3028 gfc_resolve_ctime_sub (gfc_code *c)
3029 {
3030   gfc_typespec ts;
3031   gfc_clear_ts (&ts);
3032
3033   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3034   if (c->ext.actual->expr->ts.kind != 8)
3035     {
3036       ts.type = BT_INTEGER;
3037       ts.kind = 8;
3038       ts.derived = NULL;
3039       ts.cl = NULL;
3040       gfc_convert_type (c->ext.actual->expr, &ts, 2);
3041     }
3042
3043   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3044 }
3045
3046
3047 void
3048 gfc_resolve_fdate_sub (gfc_code *c)
3049 {
3050   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3051 }
3052
3053
3054 void
3055 gfc_resolve_gerror (gfc_code *c)
3056 {
3057   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3058 }
3059
3060
3061 void
3062 gfc_resolve_getlog (gfc_code *c)
3063 {
3064   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3065 }
3066
3067
3068 void
3069 gfc_resolve_hostnm_sub (gfc_code *c)
3070 {
3071   const char *name;
3072   int kind;
3073
3074   if (c->ext.actual->next->expr != NULL)
3075     kind = c->ext.actual->next->expr->ts.kind;
3076   else
3077     kind = gfc_default_integer_kind;
3078
3079   name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3080   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3081 }
3082
3083
3084 void
3085 gfc_resolve_perror (gfc_code *c)
3086 {
3087   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3088 }
3089
3090 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
3091
3092 void
3093 gfc_resolve_stat_sub (gfc_code *c)
3094 {
3095   const char *name;
3096   name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3097   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3098 }
3099
3100
3101 void
3102 gfc_resolve_lstat_sub (gfc_code *c)
3103 {
3104   const char *name;
3105   name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3106   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3107 }
3108
3109
3110 void
3111 gfc_resolve_fstat_sub (gfc_code *c)
3112 {
3113   const char *name;
3114   gfc_expr *u;
3115   gfc_typespec *ts;
3116
3117   u = c->ext.actual->expr;
3118   ts = &c->ext.actual->next->expr->ts;
3119   if (u->ts.kind != ts->kind)
3120     gfc_convert_type (u, ts, 2);
3121   name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3122   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3123 }
3124
3125
3126 void
3127 gfc_resolve_fgetc_sub (gfc_code *c)
3128 {
3129   const char *name;
3130   gfc_typespec ts;
3131   gfc_expr *u, *st;
3132   gfc_clear_ts (&ts);
3133
3134   u = c->ext.actual->expr;
3135   st = c->ext.actual->next->next->expr;
3136
3137   if (u->ts.kind != gfc_c_int_kind)
3138     {
3139       ts.type = BT_INTEGER;
3140       ts.kind = gfc_c_int_kind;
3141       ts.derived = NULL;
3142       ts.cl = NULL;
3143       gfc_convert_type (u, &ts, 2);
3144     }
3145
3146   if (st != NULL)
3147     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3148   else
3149     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3150
3151   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3152 }
3153
3154
3155 void
3156 gfc_resolve_fget_sub (gfc_code *c)
3157 {
3158   const char *name;
3159   gfc_expr *st;
3160
3161   st = c->ext.actual->next->expr;
3162   if (st != NULL)
3163     name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3164   else
3165     name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3166
3167   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3168 }
3169
3170
3171 void
3172 gfc_resolve_fputc_sub (gfc_code *c)
3173 {
3174   const char *name;
3175   gfc_typespec ts;
3176   gfc_expr *u, *st;
3177   gfc_clear_ts (&ts);
3178
3179   u = c->ext.actual->expr;
3180   st = c->ext.actual->next->next->expr;
3181
3182   if (u->ts.kind != gfc_c_int_kind)
3183     {
3184       ts.type = BT_INTEGER;
3185       ts.kind = gfc_c_int_kind;
3186       ts.derived = NULL;
3187       ts.cl = NULL;
3188       gfc_convert_type (u, &ts, 2);
3189     }
3190
3191   if (st != NULL)
3192     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3193   else
3194     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3195
3196   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3197 }
3198
3199
3200 void
3201 gfc_resolve_fput_sub (gfc_code *c)
3202 {
3203   const char *name;
3204   gfc_expr *st;
3205
3206   st = c->ext.actual->next->expr;
3207   if (st != NULL)
3208     name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3209   else
3210     name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3211
3212   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3213 }
3214
3215
3216 void
3217 gfc_resolve_fseek_sub (gfc_code *c)
3218 {
3219   gfc_expr *unit;
3220   gfc_expr *offset;
3221   gfc_expr *whence;
3222   gfc_expr *status;
3223   gfc_typespec ts;
3224   gfc_clear_ts (&ts);
3225
3226   unit   = c->ext.actual->expr;
3227   offset = c->ext.actual->next->expr;
3228   whence = c->ext.actual->next->next->expr;
3229   status = c->ext.actual->next->next->next->expr;
3230
3231   if (unit->ts.kind != gfc_c_int_kind)
3232     {
3233       ts.type = BT_INTEGER;
3234       ts.kind = gfc_c_int_kind;
3235       ts.derived = NULL;
3236       ts.cl = NULL;
3237       gfc_convert_type (unit, &ts, 2);
3238     }
3239
3240   if (offset->ts.kind != gfc_intio_kind)
3241     {
3242       ts.type = BT_INTEGER;
3243       ts.kind = gfc_intio_kind;
3244       ts.derived = NULL;
3245       ts.cl = NULL;
3246       gfc_convert_type (offset, &ts, 2);
3247     }
3248
3249   if (whence->ts.kind != gfc_c_int_kind)
3250     {
3251       ts.type = BT_INTEGER;
3252       ts.kind = gfc_c_int_kind;
3253       ts.derived = NULL;
3254       ts.cl = NULL;
3255       gfc_convert_type (whence, &ts, 2);
3256     }
3257
3258   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3259 }
3260
3261 void
3262 gfc_resolve_ftell_sub (gfc_code *c)
3263 {
3264   const char *name;
3265   gfc_expr *unit;
3266   gfc_expr *offset;
3267   gfc_typespec ts;
3268   gfc_clear_ts (&ts);
3269
3270   unit = c->ext.actual->expr;
3271   offset = c->ext.actual->next->expr;
3272
3273   if (unit->ts.kind != gfc_c_int_kind)
3274     {
3275       ts.type = BT_INTEGER;
3276       ts.kind = gfc_c_int_kind;
3277       ts.derived = NULL;
3278       ts.cl = NULL;
3279       gfc_convert_type (unit, &ts, 2);
3280     }
3281
3282   name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3283   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3284 }
3285
3286
3287 void
3288 gfc_resolve_ttynam_sub (gfc_code *c)
3289 {
3290   gfc_typespec ts;
3291   gfc_clear_ts (&ts);
3292
3293   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3294     {
3295       ts.type = BT_INTEGER;
3296       ts.kind = gfc_c_int_kind;
3297       ts.derived = NULL;
3298       ts.cl = NULL;
3299       gfc_convert_type (c->ext.actual->expr, &ts, 2);
3300     }
3301
3302   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3303 }
3304
3305
3306 /* Resolve the UMASK intrinsic subroutine.  */
3307
3308 void
3309 gfc_resolve_umask_sub (gfc_code *c)
3310 {
3311   const char *name;
3312   int kind;
3313
3314   if (c->ext.actual->next->expr != NULL)
3315     kind = c->ext.actual->next->expr->ts.kind;
3316   else
3317     kind = gfc_default_integer_kind;
3318
3319   name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3320   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3321 }
3322
3323 /* Resolve the UNLINK intrinsic subroutine.  */
3324
3325 void
3326 gfc_resolve_unlink_sub (gfc_code *c)
3327 {
3328   const char *name;
3329   int kind;
3330
3331   if (c->ext.actual->next->expr != NULL)
3332     kind = c->ext.actual->next->expr->ts.kind;
3333   else
3334     kind = gfc_default_integer_kind;
3335
3336   name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3337   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3338 }