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