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