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