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