gcc/fortran/iresolve.c

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