gcc/fortran/iresolve.c

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