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