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