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   f->ts = x->ts;
1758   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1759 }
1760
1761
1762 void
1763 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1764 {
1765   f->ts = x->ts;
1766
1767   /* The implementation calls scalbn which takes an int as the
1768      second argument.  */
1769   if (i->ts.kind != gfc_c_int_kind)
1770     {
1771       gfc_typespec ts;
1772
1773       ts.type = BT_INTEGER;
1774       ts.kind = gfc_default_integer_kind;
1775
1776       gfc_convert_type_warn (i, &ts, 2, 0);
1777     }
1778
1779   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1780 }
1781
1782
1783 void
1784 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1785                   gfc_expr * set ATTRIBUTE_UNUSED,
1786                   gfc_expr * back ATTRIBUTE_UNUSED)
1787 {
1788   f->ts.type = BT_INTEGER;
1789   f->ts.kind = gfc_default_integer_kind;
1790   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1791 }
1792
1793
1794 void
1795 gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0)
1796 {
1797   t1->ts = t0->ts;
1798   t1->value.function.name =
1799     gfc_get_string (PREFIX("secnds"));
1800 }
1801
1802
1803 void
1804 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1805 {
1806   f->ts = x->ts;
1807
1808   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1809      convert type so we don't have to implement all possible
1810      permutations.  */
1811   if (i->ts.kind != 4)
1812     {
1813       gfc_typespec ts;
1814
1815       ts.type = BT_INTEGER;
1816       ts.kind = gfc_default_integer_kind;
1817
1818       gfc_convert_type_warn (i, &ts, 2, 0);
1819     }
1820
1821   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1822 }
1823
1824
1825 void
1826 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1827 {
1828   f->ts.type = BT_INTEGER;
1829   f->ts.kind = gfc_default_integer_kind;
1830   f->rank = 1;
1831   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1832   f->shape = gfc_get_shape (1);
1833   mpz_init_set_ui (f->shape[0], array->rank);
1834 }
1835
1836
1837 void
1838 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1839 {
1840   f->ts = a->ts;
1841   f->value.function.name =
1842     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1843 }
1844
1845
1846 void
1847 gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
1848 {
1849   f->ts.type = BT_INTEGER;
1850   f->ts.kind = gfc_c_int_kind;
1851
1852   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
1853   if (handler->ts.type == BT_INTEGER)
1854     {
1855       if (handler->ts.kind != gfc_c_int_kind)
1856         gfc_convert_type (handler, &f->ts, 2);
1857       f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
1858     }
1859   else
1860     f->value.function.name = gfc_get_string (PREFIX("signal_func"));
1861
1862   if (number->ts.kind != gfc_c_int_kind)
1863     gfc_convert_type (number, &f->ts, 2);
1864 }
1865
1866
1867 void
1868 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1869 {
1870   f->ts = x->ts;
1871   f->value.function.name =
1872     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1873 }
1874
1875
1876 void
1877 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1878 {
1879   f->ts = x->ts;
1880   f->value.function.name =
1881     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1882 }
1883
1884
1885 void
1886 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1887 {
1888   f->ts = x->ts;
1889   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1890 }
1891
1892
1893 void
1894 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1895                     gfc_expr * dim,
1896                     gfc_expr * ncopies)
1897 {
1898   if (source->ts.type == BT_CHARACTER)
1899     check_charlen_present (source);
1900
1901   f->ts = source->ts;
1902   f->rank = source->rank + 1;
1903   if (source->rank == 0)
1904     f->value.function.name = (source->ts.type == BT_CHARACTER
1905                               ? PREFIX("spread_char_scalar")
1906                               : PREFIX("spread_scalar"));
1907   else
1908     f->value.function.name = (source->ts.type == BT_CHARACTER
1909                               ? PREFIX("spread_char")
1910                               : PREFIX("spread"));
1911
1912   if (dim && gfc_is_constant_expr (dim)
1913         && ncopies && gfc_is_constant_expr (ncopies)
1914         && source->shape[0])
1915     {
1916       int i, idim;
1917       idim = mpz_get_ui (dim->value.integer);
1918       f->shape = gfc_get_shape (f->rank);
1919       for (i = 0; i < (idim - 1); i++)
1920         mpz_init_set (f->shape[i], source->shape[i]);
1921
1922       mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
1923
1924       for (i = idim; i < f->rank ; i++)
1925         mpz_init_set (f->shape[i], source->shape[i-1]);
1926     }
1927
1928
1929   gfc_resolve_dim_arg (dim);
1930   gfc_resolve_index (ncopies, 1);
1931 }
1932
1933
1934 void
1935 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1936 {
1937   f->ts = x->ts;
1938   f->value.function.name =
1939     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1940 }
1941
1942
1943 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1944
1945 void
1946 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1947                   gfc_expr * a ATTRIBUTE_UNUSED)
1948 {
1949   f->ts.type = BT_INTEGER;
1950   f->ts.kind = gfc_default_integer_kind;
1951   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1952 }
1953
1954
1955 void
1956 gfc_resolve_lstat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1957                    gfc_expr * a ATTRIBUTE_UNUSED)
1958 {
1959   f->ts.type = BT_INTEGER;
1960   f->ts.kind = gfc_default_integer_kind;
1961   f->value.function.name = gfc_get_string (PREFIX("lstat_i%d"), f->ts.kind);
1962 }
1963
1964
1965 void
1966 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1967 {
1968   f->ts.type = BT_INTEGER;
1969   f->ts.kind = gfc_default_integer_kind;
1970   if (n->ts.kind != f->ts.kind)
1971     gfc_convert_type (n, &f->ts, 2);
1972
1973   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1974 }
1975
1976
1977 void
1978 gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
1979 {
1980   gfc_typespec ts;
1981
1982   f->ts.type = BT_INTEGER;
1983   f->ts.kind = gfc_c_int_kind;
1984   if (u->ts.kind != gfc_c_int_kind)
1985     {
1986       ts.type = BT_INTEGER;
1987       ts.kind = gfc_c_int_kind;
1988       ts.derived = NULL;
1989       ts.cl = NULL;
1990       gfc_convert_type (u, &ts, 2);
1991     }
1992
1993   f->value.function.name = gfc_get_string (PREFIX("fgetc"));
1994 }
1995
1996
1997 void
1998 gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
1999 {
2000   f->ts.type = BT_INTEGER;
2001   f->ts.kind = gfc_c_int_kind;
2002   f->value.function.name = gfc_get_string (PREFIX("fget"));
2003 }
2004
2005
2006 void
2007 gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
2008 {
2009   gfc_typespec ts;
2010
2011   f->ts.type = BT_INTEGER;
2012   f->ts.kind = gfc_c_int_kind;
2013   if (u->ts.kind != gfc_c_int_kind)
2014     {
2015       ts.type = BT_INTEGER;
2016       ts.kind = gfc_c_int_kind;
2017       ts.derived = NULL;
2018       ts.cl = NULL;
2019       gfc_convert_type (u, &ts, 2);
2020     }
2021
2022   f->value.function.name = gfc_get_string (PREFIX("fputc"));
2023 }
2024
2025
2026 void
2027 gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
2028 {
2029   f->ts.type = BT_INTEGER;
2030   f->ts.kind = gfc_c_int_kind;
2031   f->value.function.name = gfc_get_string (PREFIX("fput"));
2032 }
2033
2034
2035 void
2036 gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
2037 {
2038   gfc_typespec ts;
2039
2040   f->ts.type = BT_INTEGER;
2041   f->ts.kind = gfc_index_integer_kind;
2042   if (u->ts.kind != gfc_c_int_kind)
2043     {
2044       ts.type = BT_INTEGER;
2045       ts.kind = gfc_c_int_kind;
2046       ts.derived = NULL;
2047       ts.cl = NULL;
2048       gfc_convert_type (u, &ts, 2);
2049     }
2050
2051   f->value.function.name = gfc_get_string (PREFIX("ftell"));
2052 }
2053
2054
2055 void
2056 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
2057                  gfc_expr * mask)
2058 {
2059   const char *name;
2060
2061   f->ts = array->ts;
2062
2063   if (mask)
2064     {
2065       if (mask->rank == 0)
2066         name = "ssum";
2067       else
2068         name = "msum";
2069
2070       /* The mask can be kind 4 or 8 for the array case.  For the
2071          scalar case, coerce it to default kind unconditionally.  */
2072       if ((mask->ts.kind < gfc_default_logical_kind)
2073           || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
2074         {
2075           gfc_typespec ts;
2076           ts.type = BT_LOGICAL;
2077           ts.kind = gfc_default_logical_kind;
2078           gfc_convert_type_warn (mask, &ts, 2, 0);
2079         }
2080     }
2081   else
2082     name = "sum";
2083
2084   if (dim != NULL)
2085     {
2086       f->rank = array->rank - 1;
2087       gfc_resolve_dim_arg (dim);
2088     }
2089
2090   f->value.function.name =
2091     gfc_get_string (PREFIX("%s_%c%d"), name,
2092                     gfc_type_letter (array->ts.type), array->ts.kind);
2093 }
2094
2095
2096 void
2097 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
2098                     gfc_expr * p2 ATTRIBUTE_UNUSED)
2099 {
2100   f->ts.type = BT_INTEGER;
2101   f->ts.kind = gfc_default_integer_kind;
2102   f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
2103 }
2104
2105
2106 /* Resolve the g77 compatibility function SYSTEM.  */
2107
2108 void
2109 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
2110 {
2111   f->ts.type = BT_INTEGER;
2112   f->ts.kind = 4;
2113   f->value.function.name = gfc_get_string (PREFIX("system"));
2114 }
2115
2116
2117 void
2118 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
2119 {
2120   f->ts = x->ts;
2121   f->value.function.name =
2122     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2123 }
2124
2125
2126 void
2127 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
2128 {
2129   f->ts = x->ts;
2130   f->value.function.name =
2131     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2132 }
2133
2134
2135 void
2136 gfc_resolve_time (gfc_expr * f)
2137 {
2138   f->ts.type = BT_INTEGER;
2139   f->ts.kind = 4;
2140   f->value.function.name = gfc_get_string (PREFIX("time_func"));
2141 }
2142
2143
2144 void
2145 gfc_resolve_time8 (gfc_expr * f)
2146 {
2147   f->ts.type = BT_INTEGER;
2148   f->ts.kind = 8;
2149   f->value.function.name = gfc_get_string (PREFIX("time8_func"));
2150 }
2151
2152
2153 void
2154 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
2155                       gfc_expr * mold, gfc_expr * size)
2156 {
2157   /* TODO: Make this do something meaningful.  */
2158   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2159
2160   f->ts = mold->ts;
2161
2162   if (size == NULL && mold->rank == 0)
2163     {
2164       f->rank = 0;
2165       f->value.function.name = transfer0;
2166     }
2167   else
2168     {
2169       f->rank = 1;
2170       f->value.function.name = transfer1;
2171       if (size && gfc_is_constant_expr (size))
2172         {
2173           f->shape = gfc_get_shape (1);
2174           mpz_init_set (f->shape[0], size->value.integer);
2175         }
2176     }
2177 }
2178
2179
2180 void
2181 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
2182 {
2183   f->ts = matrix->ts;
2184   f->rank = 2;
2185   if (matrix->shape)
2186     {
2187       f->shape = gfc_get_shape (2);
2188       mpz_init_set (f->shape[0], matrix->shape[1]);
2189       mpz_init_set (f->shape[1], matrix->shape[0]);
2190     }
2191
2192   switch (matrix->ts.kind)
2193     {
2194     case 4:
2195     case 8:
2196     case 10:
2197     case 16:
2198       switch (matrix->ts.type)
2199         {
2200         case BT_REAL:
2201         case BT_COMPLEX:
2202           f->value.function.name =
2203             gfc_get_string (PREFIX("transpose_%c%d"),
2204                             gfc_type_letter (matrix->ts.type),
2205                             matrix->ts.kind);
2206           break;
2207
2208         case BT_INTEGER:
2209         case BT_LOGICAL:
2210           /* Use the integer routines for real and logical cases.  This
2211              assumes they all have the same alignment requirements.  */
2212           f->value.function.name =
2213             gfc_get_string (PREFIX("transpose_i%d"), matrix->ts.kind);
2214           break;
2215
2216         default:
2217           f->value.function.name = PREFIX("transpose");
2218           break;
2219         }
2220       break;
2221
2222     default:
2223       f->value.function.name = (matrix->ts.type == BT_CHARACTER
2224                                 ? PREFIX("transpose_char")
2225                                 : PREFIX("transpose"));
2226       break;
2227     }
2228 }
2229
2230
2231 void
2232 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
2233 {
2234   f->ts.type = BT_CHARACTER;
2235   f->ts.kind = string->ts.kind;
2236   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2237 }
2238
2239
2240 void
2241 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
2242                     gfc_expr * dim)
2243 {
2244   static char ubound[] = "__ubound";
2245
2246   f->ts.type = BT_INTEGER;
2247   f->ts.kind = gfc_default_integer_kind;
2248
2249   if (dim == NULL)
2250     {
2251       f->rank = 1;
2252       f->shape = gfc_get_shape (1);
2253       mpz_init_set_ui (f->shape[0], array->rank);
2254     }
2255
2256   f->value.function.name = ubound;
2257 }
2258
2259
2260 /* Resolve the g77 compatibility function UMASK.  */
2261
2262 void
2263 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
2264 {
2265   f->ts.type = BT_INTEGER;
2266   f->ts.kind = n->ts.kind;
2267   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
2268 }
2269
2270
2271 /* Resolve the g77 compatibility function UNLINK.  */
2272
2273 void
2274 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
2275 {
2276   f->ts.type = BT_INTEGER;
2277   f->ts.kind = 4;
2278   f->value.function.name = gfc_get_string (PREFIX("unlink"));
2279 }
2280
2281
2282 void
2283 gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
2284 {
2285   gfc_typespec ts;
2286
2287   f->ts.type = BT_CHARACTER;
2288   f->ts.kind = gfc_default_character_kind;
2289
2290   if (unit->ts.kind != gfc_c_int_kind)
2291     {
2292       ts.type = BT_INTEGER;
2293       ts.kind = gfc_c_int_kind;
2294       ts.derived = NULL;
2295       ts.cl = NULL;
2296       gfc_convert_type (unit, &ts, 2);
2297     }
2298
2299   f->value.function.name = gfc_get_string (PREFIX("ttynam"));
2300 }
2301
2302
2303 void
2304 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
2305                     gfc_expr * field ATTRIBUTE_UNUSED)
2306 {
2307   f->ts = vector->ts;
2308   f->rank = mask->rank;
2309
2310   f->value.function.name =
2311     gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
2312                     vector->ts.type == BT_CHARACTER ? "_char" : "");
2313 }
2314
2315
2316 void
2317 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
2318                     gfc_expr * set ATTRIBUTE_UNUSED,
2319                     gfc_expr * back ATTRIBUTE_UNUSED)
2320 {
2321   f->ts.type = BT_INTEGER;
2322   f->ts.kind = gfc_default_integer_kind;
2323   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2324 }
2325
2326
2327 void
2328 gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
2329 {
2330   f->ts.type = i->ts.type;
2331   f->ts.kind = gfc_kind_max (i,j);
2332
2333   if (i->ts.kind != j->ts.kind)
2334     {
2335       if (i->ts.kind == gfc_kind_max (i,j))
2336         gfc_convert_type(j, &i->ts, 2);
2337       else
2338         gfc_convert_type(i, &j->ts, 2);
2339     }
2340
2341   f->value.function.name = gfc_get_string ("__xor_%c%d",
2342                                            gfc_type_letter (i->ts.type),
2343                                            f->ts.kind);
2344 }
2345
2346
2347 /* Intrinsic subroutine resolution.  */
2348
2349 void
2350 gfc_resolve_alarm_sub (gfc_code * c)
2351 {
2352   const char *name;
2353   gfc_expr *seconds, *handler, *status;
2354   gfc_typespec ts;
2355
2356   seconds = c->ext.actual->expr;
2357   handler = c->ext.actual->next->expr;
2358   status = c->ext.actual->next->next->expr;
2359   ts.type = BT_INTEGER;
2360   ts.kind = gfc_c_int_kind;
2361
2362   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2363   if (handler->ts.type == BT_INTEGER)
2364     {
2365       if (handler->ts.kind != gfc_c_int_kind)
2366         gfc_convert_type (handler, &ts, 2);
2367       name = gfc_get_string (PREFIX("alarm_sub_int"));
2368     }
2369   else
2370     name = gfc_get_string (PREFIX("alarm_sub"));
2371
2372   if (seconds->ts.kind != gfc_c_int_kind)
2373     gfc_convert_type (seconds, &ts, 2);
2374   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2375     gfc_convert_type (status, &ts, 2);
2376
2377   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2378 }
2379
2380 void
2381 gfc_resolve_cpu_time (gfc_code * c)
2382 {
2383   const char *name;
2384
2385   name = gfc_get_string (PREFIX("cpu_time_%d"),
2386                          c->ext.actual->expr->ts.kind);
2387   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2388 }
2389
2390
2391 void
2392 gfc_resolve_mvbits (gfc_code * c)
2393 {
2394   const char *name;
2395   int kind;
2396
2397   kind = c->ext.actual->expr->ts.kind;
2398   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
2399
2400   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2401 }
2402
2403
2404 void
2405 gfc_resolve_random_number (gfc_code * c)
2406 {
2407   const char *name;
2408   int kind;
2409
2410   kind = c->ext.actual->expr->ts.kind;
2411   if (c->ext.actual->expr->rank == 0)
2412     name = gfc_get_string (PREFIX("random_r%d"), kind);
2413   else
2414     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
2415
2416   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2417 }
2418
2419
2420 void
2421 gfc_resolve_rename_sub (gfc_code * c)
2422 {
2423   const char *name;
2424   int kind;
2425
2426   if (c->ext.actual->next->next->expr != NULL)
2427     kind = c->ext.actual->next->next->expr->ts.kind;
2428   else
2429     kind = gfc_default_integer_kind;
2430
2431   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
2432   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2433 }
2434
2435
2436 void
2437 gfc_resolve_kill_sub (gfc_code * c)
2438 {
2439   const char *name;
2440   int kind;
2441
2442   if (c->ext.actual->next->next->expr != NULL)
2443     kind = c->ext.actual->next->next->expr->ts.kind;
2444   else
2445     kind = gfc_default_integer_kind;
2446
2447   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
2448   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2449 }
2450
2451
2452 void
2453 gfc_resolve_link_sub (gfc_code * c)
2454 {
2455   const char *name;
2456   int kind;
2457
2458   if (c->ext.actual->next->next->expr != NULL)
2459     kind = c->ext.actual->next->next->expr->ts.kind;
2460   else
2461     kind = gfc_default_integer_kind;
2462
2463   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
2464   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2465 }
2466
2467
2468 void
2469 gfc_resolve_symlnk_sub (gfc_code * c)
2470 {
2471   const char *name;
2472   int kind;
2473
2474   if (c->ext.actual->next->next->expr != NULL)
2475     kind = c->ext.actual->next->next->expr->ts.kind;
2476   else
2477     kind = gfc_default_integer_kind;
2478
2479   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
2480   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2481 }
2482
2483
2484 /* G77 compatibility subroutines etime() and dtime().  */
2485
2486 void
2487 gfc_resolve_etime_sub (gfc_code * c)
2488 {
2489   const char *name;
2490
2491   name = gfc_get_string (PREFIX("etime_sub"));
2492   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2493 }
2494
2495
2496 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime().  */
2497
2498 void
2499 gfc_resolve_itime (gfc_code * c)
2500 {
2501   c->resolved_sym = gfc_get_intrinsic_sub_symbol
2502                       (gfc_get_string (PREFIX("itime_i%d"),
2503                                        gfc_default_integer_kind));
2504 }
2505
2506 void
2507 gfc_resolve_idate (gfc_code * c)
2508 {
2509   c->resolved_sym = gfc_get_intrinsic_sub_symbol
2510                       (gfc_get_string (PREFIX("idate_i%d"),
2511                                        gfc_default_integer_kind));
2512 }
2513
2514 void
2515 gfc_resolve_ltime (gfc_code * c)
2516 {
2517   c->resolved_sym = gfc_get_intrinsic_sub_symbol
2518                       (gfc_get_string (PREFIX("ltime_i%d"),
2519                                        gfc_default_integer_kind));
2520 }
2521
2522 void
2523 gfc_resolve_gmtime (gfc_code * c)
2524 {
2525   c->resolved_sym = gfc_get_intrinsic_sub_symbol
2526                       (gfc_get_string (PREFIX("gmtime_i%d"),
2527                                        gfc_default_integer_kind));
2528 }
2529
2530
2531 /* G77 compatibility subroutine second().  */
2532
2533 void
2534 gfc_resolve_second_sub (gfc_code * c)
2535 {
2536   const char *name;
2537
2538   name = gfc_get_string (PREFIX("second_sub"));
2539   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2540 }
2541
2542
2543 void
2544 gfc_resolve_sleep_sub (gfc_code * c)
2545 {
2546   const char *name;
2547   int kind;
2548
2549   if (c->ext.actual->expr != NULL)
2550     kind = c->ext.actual->expr->ts.kind;
2551   else
2552     kind = gfc_default_integer_kind;
2553
2554   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
2555   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2556 }
2557
2558
2559 /* G77 compatibility function srand().  */
2560
2561 void
2562 gfc_resolve_srand (gfc_code * c)
2563 {
2564   const char *name;
2565   name = gfc_get_string (PREFIX("srand"));
2566   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2567 }
2568
2569
2570 /* Resolve the getarg intrinsic subroutine.  */
2571
2572 void
2573 gfc_resolve_getarg (gfc_code * c)
2574 {
2575   const char *name;
2576   int kind;
2577
2578   kind = gfc_default_integer_kind;
2579   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
2580   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2581 }
2582
2583 /* Resolve the getcwd intrinsic subroutine.  */
2584
2585 void
2586 gfc_resolve_getcwd_sub (gfc_code * c)
2587 {
2588   const char *name;
2589   int kind;
2590
2591   if (c->ext.actual->next->expr != NULL)
2592     kind = c->ext.actual->next->expr->ts.kind;
2593   else
2594     kind = gfc_default_integer_kind;
2595
2596   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
2597   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2598 }
2599
2600
2601 /* Resolve the get_command intrinsic subroutine.  */
2602
2603 void
2604 gfc_resolve_get_command (gfc_code * c)
2605 {
2606   const char *name;
2607   int kind;
2608
2609   kind = gfc_default_integer_kind;
2610   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
2611   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2612 }
2613
2614
2615 /* Resolve the get_command_argument intrinsic subroutine.  */
2616
2617 void
2618 gfc_resolve_get_command_argument (gfc_code * c)
2619 {
2620   const char *name;
2621   int kind;
2622
2623   kind = gfc_default_integer_kind;
2624   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
2625   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2626 }
2627
2628 /* Resolve the get_environment_variable intrinsic subroutine.  */
2629
2630 void
2631 gfc_resolve_get_environment_variable (gfc_code * code)
2632 {
2633   const char *name;
2634   int kind;
2635
2636   kind = gfc_default_integer_kind;
2637   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
2638   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2639 }
2640
2641 void
2642 gfc_resolve_signal_sub (gfc_code * c)
2643 {
2644   const char *name;
2645   gfc_expr *number, *handler, *status;
2646   gfc_typespec ts;
2647
2648   number = c->ext.actual->expr;
2649   handler = c->ext.actual->next->expr;
2650   status = c->ext.actual->next->next->expr;
2651   ts.type = BT_INTEGER;
2652   ts.kind = gfc_c_int_kind;
2653
2654   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2655   if (handler->ts.type == BT_INTEGER)
2656     {
2657       if (handler->ts.kind != gfc_c_int_kind)
2658         gfc_convert_type (handler, &ts, 2);
2659       name = gfc_get_string (PREFIX("signal_sub_int"));
2660     }
2661   else
2662     name = gfc_get_string (PREFIX("signal_sub"));
2663
2664   if (number->ts.kind != gfc_c_int_kind)
2665     gfc_convert_type (number, &ts, 2);
2666   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2667     gfc_convert_type (status, &ts, 2);
2668
2669   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2670 }
2671
2672 /* Resolve the SYSTEM intrinsic subroutine.  */
2673
2674 void
2675 gfc_resolve_system_sub (gfc_code * c)
2676 {
2677   const char *name;
2678
2679   name = gfc_get_string (PREFIX("system_sub"));
2680   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2681 }
2682
2683 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2684
2685 void
2686 gfc_resolve_system_clock (gfc_code * c)
2687 {
2688   const char *name;
2689   int kind;
2690
2691   if (c->ext.actual->expr != NULL)
2692     kind = c->ext.actual->expr->ts.kind;
2693   else if (c->ext.actual->next->expr != NULL)
2694       kind = c->ext.actual->next->expr->ts.kind;
2695   else if (c->ext.actual->next->next->expr != NULL)
2696       kind = c->ext.actual->next->next->expr->ts.kind;
2697   else
2698     kind = gfc_default_integer_kind;
2699
2700   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
2701   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2702 }
2703
2704 /* Resolve the EXIT intrinsic subroutine.  */
2705
2706 void
2707 gfc_resolve_exit (gfc_code * c)
2708 {
2709   const char *name;
2710   int kind;
2711
2712   if (c->ext.actual->expr != NULL)
2713     kind = c->ext.actual->expr->ts.kind;
2714   else
2715     kind = gfc_default_integer_kind;
2716
2717   name = gfc_get_string (PREFIX("exit_i%d"), kind);
2718   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2719 }
2720
2721 /* Resolve the FLUSH intrinsic subroutine.  */
2722
2723 void
2724 gfc_resolve_flush (gfc_code * c)
2725 {
2726   const char *name;
2727   gfc_typespec ts;
2728   gfc_expr *n;
2729
2730   ts.type = BT_INTEGER;
2731   ts.kind = gfc_default_integer_kind;
2732   n = c->ext.actual->expr;
2733   if (n != NULL
2734       && n->ts.kind != ts.kind)
2735     gfc_convert_type (n, &ts, 2);
2736
2737   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
2738   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2739 }
2740
2741
2742 void
2743 gfc_resolve_free (gfc_code * c)
2744 {
2745   gfc_typespec ts;
2746   gfc_expr *n;
2747
2748   ts.type = BT_INTEGER;
2749   ts.kind = gfc_index_integer_kind;
2750   n = c->ext.actual->expr;
2751   if (n->ts.kind != ts.kind)
2752     gfc_convert_type (n, &ts, 2);
2753
2754   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
2755 }
2756
2757
2758 void
2759 gfc_resolve_ctime_sub (gfc_code * c)
2760 {
2761   gfc_typespec ts;
2762
2763   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2764   if (c->ext.actual->expr->ts.kind != 8)
2765     {
2766       ts.type = BT_INTEGER;
2767       ts.kind = 8;
2768       ts.derived = NULL;
2769       ts.cl = NULL;
2770       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2771     }
2772
2773   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
2774 }
2775
2776
2777 void
2778 gfc_resolve_fdate_sub (gfc_code * c)
2779 {
2780   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2781 }
2782
2783
2784 void
2785 gfc_resolve_gerror (gfc_code * c)
2786 {
2787   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2788 }
2789
2790
2791 void
2792 gfc_resolve_getlog (gfc_code * c)
2793 {
2794   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2795 }
2796
2797
2798 void
2799 gfc_resolve_hostnm_sub (gfc_code * c)
2800 {
2801   const char *name;
2802   int kind;
2803
2804   if (c->ext.actual->next->expr != NULL)
2805     kind = c->ext.actual->next->expr->ts.kind;
2806   else
2807     kind = gfc_default_integer_kind;
2808
2809   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2810   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2811 }
2812
2813
2814 void
2815 gfc_resolve_perror (gfc_code * c)
2816 {
2817   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2818 }
2819
2820 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
2821
2822 void
2823 gfc_resolve_stat_sub (gfc_code * c)
2824 {
2825   const char *name;
2826
2827   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2828   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2829 }
2830
2831
2832 void
2833 gfc_resolve_lstat_sub (gfc_code * c)
2834 {
2835   const char *name;
2836
2837   name = gfc_get_string (PREFIX("lstat_i%d_sub"), gfc_default_integer_kind);
2838   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2839 }
2840
2841
2842 void
2843 gfc_resolve_fstat_sub (gfc_code * c)
2844 {
2845   const char *name;
2846   gfc_expr *u;
2847   gfc_typespec *ts;
2848
2849   u = c->ext.actual->expr;
2850   ts = &c->ext.actual->next->expr->ts;
2851   if (u->ts.kind != ts->kind)
2852     gfc_convert_type (u, ts, 2);
2853   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2854   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2855 }
2856
2857
2858 void
2859 gfc_resolve_fgetc_sub (gfc_code * c)
2860 {
2861   const char *name;
2862   gfc_typespec ts;
2863   gfc_expr *u, *st;
2864
2865   u = c->ext.actual->expr;
2866   st = c->ext.actual->next->next->expr;
2867
2868   if (u->ts.kind != gfc_c_int_kind)
2869     {
2870       ts.type = BT_INTEGER;
2871       ts.kind = gfc_c_int_kind;
2872       ts.derived = NULL;
2873       ts.cl = NULL;
2874       gfc_convert_type (u, &ts, 2);
2875     }
2876
2877   if (st != NULL)
2878     name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
2879   else
2880     name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
2881
2882   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2883 }
2884
2885
2886 void
2887 gfc_resolve_fget_sub (gfc_code * c)
2888 {
2889   const char *name;
2890   gfc_expr *st;
2891
2892   st = c->ext.actual->next->expr;
2893   if (st != NULL)
2894     name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
2895   else
2896     name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
2897
2898   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2899 }
2900
2901
2902 void
2903 gfc_resolve_fputc_sub (gfc_code * c)
2904 {
2905   const char *name;
2906   gfc_typespec ts;
2907   gfc_expr *u, *st;
2908
2909   u = c->ext.actual->expr;
2910   st = c->ext.actual->next->next->expr;
2911
2912   if (u->ts.kind != gfc_c_int_kind)
2913     {
2914       ts.type = BT_INTEGER;
2915       ts.kind = gfc_c_int_kind;
2916       ts.derived = NULL;
2917       ts.cl = NULL;
2918       gfc_convert_type (u, &ts, 2);
2919     }
2920
2921   if (st != NULL)
2922     name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
2923   else
2924     name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
2925
2926   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2927 }
2928
2929
2930 void
2931 gfc_resolve_fput_sub (gfc_code * c)
2932 {
2933   const char *name;
2934   gfc_expr *st;
2935
2936   st = c->ext.actual->next->expr;
2937   if (st != NULL)
2938     name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
2939   else
2940     name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
2941
2942   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2943 }
2944
2945
2946 void
2947 gfc_resolve_ftell_sub (gfc_code * c)
2948 {
2949   const char *name;
2950   gfc_expr *unit;
2951   gfc_expr *offset;
2952   gfc_typespec ts;
2953
2954   unit = c->ext.actual->expr;
2955   offset = c->ext.actual->next->expr;
2956
2957   if (unit->ts.kind != gfc_c_int_kind)
2958     {
2959       ts.type = BT_INTEGER;
2960       ts.kind = gfc_c_int_kind;
2961       ts.derived = NULL;
2962       ts.cl = NULL;
2963       gfc_convert_type (unit, &ts, 2);
2964     }
2965
2966   name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
2967   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2968 }
2969
2970
2971 void
2972 gfc_resolve_ttynam_sub (gfc_code * c)
2973 {
2974   gfc_typespec ts;
2975
2976   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2977     {
2978       ts.type = BT_INTEGER;
2979       ts.kind = gfc_c_int_kind;
2980       ts.derived = NULL;
2981       ts.cl = NULL;
2982       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2983     }
2984
2985   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2986 }
2987
2988
2989 /* Resolve the UMASK intrinsic subroutine.  */
2990
2991 void
2992 gfc_resolve_umask_sub (gfc_code * c)
2993 {
2994   const char *name;
2995   int kind;
2996
2997   if (c->ext.actual->next->expr != NULL)
2998     kind = c->ext.actual->next->expr->ts.kind;
2999   else
3000     kind = gfc_default_integer_kind;
3001
3002   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
3003   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3004 }
3005
3006 /* Resolve the UNLINK intrinsic subroutine.  */
3007
3008 void
3009 gfc_resolve_unlink_sub (gfc_code * c)
3010 {
3011   const char *name;
3012   int kind;
3013
3014   if (c->ext.actual->next->expr != NULL)
3015     kind = c->ext.actual->next->expr->ts.kind;
3016   else
3017     kind = gfc_default_integer_kind;
3018
3019   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
3020   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3021 }