gcc/fortran/iresolve.c

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