gcc/fortran/iresolve.c

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