gcc/fortran/iresolve.c

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