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     case BT_REAL:
1503     case BT_INTEGER:
1504     case BT_LOGICAL:
1505       kind = source->ts.kind;
1506       break;
1507
1508     default:
1509       kind = 0;
1510       break;
1511     }
1512
1513   switch (kind)
1514     {
1515     case 4:
1516     case 8:
1517     case 10:
1518     case 16:
1519       if (source->ts.type == BT_COMPLEX)
1520         f->value.function.name =
1521           gfc_get_string (PREFIX("reshape_%c%d"),
1522                           gfc_type_letter (BT_COMPLEX), source->ts.kind);
1523       else if (source->ts.type == BT_REAL && kind == 10)
1524         f->value.function.name =
1525           gfc_get_string (PREFIX("reshape_%c%d"),
1526                           gfc_type_letter (BT_REAL), source->ts.kind);
1527       else
1528         f->value.function.name =
1529           gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1530
1531       break;
1532
1533     default:
1534       f->value.function.name = (source->ts.type == BT_CHARACTER
1535                                 ? PREFIX("reshape_char")
1536                                 : PREFIX("reshape"));
1537       break;
1538     }
1539
1540   /* TODO: Make this work with a constant ORDER parameter.  */
1541   if (shape->expr_type == EXPR_ARRAY
1542       && gfc_is_constant_expr (shape)
1543       && order == NULL)
1544     {
1545       gfc_constructor *c;
1546       f->shape = gfc_get_shape (f->rank);
1547       c = shape->value.constructor;
1548       for (i = 0; i < f->rank; i++)
1549         {
1550           mpz_init_set (f->shape[i], c->expr->value.integer);
1551           c = c->next;
1552         }
1553     }
1554
1555   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1556      so many runtime variations.  */
1557   if (shape->ts.kind != gfc_index_integer_kind)
1558     {
1559       gfc_typespec ts = shape->ts;
1560       ts.kind = gfc_index_integer_kind;
1561       gfc_convert_type_warn (shape, &ts, 2, 0);
1562     }
1563   if (order && order->ts.kind != gfc_index_integer_kind)
1564     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1565 }
1566
1567
1568 void
1569 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1570 {
1571   f->ts = x->ts;
1572   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1573 }
1574
1575
1576 void
1577 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1578 {
1579   f->ts = x->ts;
1580
1581   /* The implementation calls scalbn which takes an int as the
1582      second argument.  */
1583   if (i->ts.kind != gfc_c_int_kind)
1584     {
1585       gfc_typespec ts;
1586
1587       ts.type = BT_INTEGER;
1588       ts.kind = gfc_default_integer_kind;
1589
1590       gfc_convert_type_warn (i, &ts, 2, 0);
1591     }
1592
1593   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1594 }
1595
1596
1597 void
1598 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1599                   gfc_expr * set ATTRIBUTE_UNUSED,
1600                   gfc_expr * back ATTRIBUTE_UNUSED)
1601 {
1602   f->ts.type = BT_INTEGER;
1603   f->ts.kind = gfc_default_integer_kind;
1604   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1605 }
1606
1607
1608 void
1609 gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0)
1610 {
1611   t1->ts = t0->ts;
1612   t1->value.function.name =
1613     gfc_get_string (PREFIX("secnds"));
1614 }
1615
1616
1617 void
1618 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1619 {
1620   f->ts = x->ts;
1621
1622   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1623      convert type so we don't have to implement all possible
1624      permutations.  */
1625   if (i->ts.kind != 4)
1626     {
1627       gfc_typespec ts;
1628
1629       ts.type = BT_INTEGER;
1630       ts.kind = gfc_default_integer_kind;
1631
1632       gfc_convert_type_warn (i, &ts, 2, 0);
1633     }
1634
1635   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1636 }
1637
1638
1639 void
1640 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1641 {
1642   f->ts.type = BT_INTEGER;
1643   f->ts.kind = gfc_default_integer_kind;
1644   f->rank = 1;
1645   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1646   f->shape = gfc_get_shape (1);
1647   mpz_init_set_ui (f->shape[0], array->rank);
1648 }
1649
1650
1651 void
1652 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1653 {
1654   f->ts = a->ts;
1655   f->value.function.name =
1656     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1657 }
1658
1659
1660 void
1661 gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
1662 {
1663   f->ts.type = BT_INTEGER;
1664   f->ts.kind = gfc_c_int_kind;
1665
1666   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
1667   if (handler->ts.type == BT_INTEGER)
1668     {
1669       if (handler->ts.kind != gfc_c_int_kind)
1670         gfc_convert_type (handler, &f->ts, 2);
1671       f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
1672     }
1673   else
1674     f->value.function.name = gfc_get_string (PREFIX("signal_func"));
1675
1676   if (number->ts.kind != gfc_c_int_kind)
1677     gfc_convert_type (number, &f->ts, 2);
1678 }
1679
1680
1681 void
1682 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1683 {
1684   f->ts = x->ts;
1685   f->value.function.name =
1686     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1687 }
1688
1689
1690 void
1691 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1692 {
1693   f->ts = x->ts;
1694   f->value.function.name =
1695     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1696 }
1697
1698
1699 void
1700 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1701 {
1702   f->ts = x->ts;
1703   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1704 }
1705
1706
1707 void
1708 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1709                     gfc_expr * dim,
1710                     gfc_expr * ncopies)
1711 {
1712   if (source->ts.type == BT_CHARACTER)
1713     check_charlen_present (source);
1714
1715   f->ts = source->ts;
1716   f->rank = source->rank + 1;
1717   if (source->rank == 0)
1718     f->value.function.name = (source->ts.type == BT_CHARACTER
1719                               ? PREFIX("spread_char_scalar")
1720                               : PREFIX("spread_scalar"));
1721   else
1722     f->value.function.name = (source->ts.type == BT_CHARACTER
1723                               ? PREFIX("spread_char")
1724                               : PREFIX("spread"));
1725
1726   gfc_resolve_dim_arg (dim);
1727   gfc_resolve_index (ncopies, 1);
1728 }
1729
1730
1731 void
1732 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1733 {
1734   f->ts = x->ts;
1735   f->value.function.name =
1736     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1737 }
1738
1739
1740 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1741
1742 void
1743 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1744                   gfc_expr * a ATTRIBUTE_UNUSED)
1745 {
1746   f->ts.type = BT_INTEGER;
1747   f->ts.kind = gfc_default_integer_kind;
1748   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1749 }
1750
1751
1752 void
1753 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1754 {
1755   f->ts.type = BT_INTEGER;
1756   f->ts.kind = gfc_default_integer_kind;
1757   if (n->ts.kind != f->ts.kind)
1758     gfc_convert_type (n, &f->ts, 2);
1759
1760   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1761 }
1762
1763
1764 void
1765 gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
1766 {
1767   gfc_typespec ts;
1768
1769   f->ts.type = BT_INTEGER;
1770   f->ts.kind = gfc_c_int_kind;
1771   if (u->ts.kind != gfc_c_int_kind)
1772     {
1773       ts.type = BT_INTEGER;
1774       ts.kind = gfc_c_int_kind;
1775       ts.derived = NULL;
1776       ts.cl = NULL;
1777       gfc_convert_type (u, &ts, 2);
1778     }
1779
1780   f->value.function.name = gfc_get_string (PREFIX("fgetc"));
1781 }
1782
1783
1784 void
1785 gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
1786 {
1787   f->ts.type = BT_INTEGER;
1788   f->ts.kind = gfc_c_int_kind;
1789   f->value.function.name = gfc_get_string (PREFIX("fget"));
1790 }
1791
1792
1793 void
1794 gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
1795 {
1796   gfc_typespec ts;
1797
1798   f->ts.type = BT_INTEGER;
1799   f->ts.kind = gfc_c_int_kind;
1800   if (u->ts.kind != gfc_c_int_kind)
1801     {
1802       ts.type = BT_INTEGER;
1803       ts.kind = gfc_c_int_kind;
1804       ts.derived = NULL;
1805       ts.cl = NULL;
1806       gfc_convert_type (u, &ts, 2);
1807     }
1808
1809   f->value.function.name = gfc_get_string (PREFIX("fputc"));
1810 }
1811
1812
1813 void
1814 gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
1815 {
1816   f->ts.type = BT_INTEGER;
1817   f->ts.kind = gfc_c_int_kind;
1818   f->value.function.name = gfc_get_string (PREFIX("fput"));
1819 }
1820
1821
1822 void
1823 gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
1824 {
1825   gfc_typespec ts;
1826
1827   f->ts.type = BT_INTEGER;
1828   f->ts.kind = gfc_index_integer_kind;
1829   if (u->ts.kind != gfc_c_int_kind)
1830     {
1831       ts.type = BT_INTEGER;
1832       ts.kind = gfc_c_int_kind;
1833       ts.derived = NULL;
1834       ts.cl = NULL;
1835       gfc_convert_type (u, &ts, 2);
1836     }
1837
1838   f->value.function.name = gfc_get_string (PREFIX("ftell"));
1839 }
1840
1841
1842 void
1843 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1844                  gfc_expr * mask)
1845 {
1846   const char *name;
1847
1848   f->ts = array->ts;
1849
1850   if (mask)
1851     {
1852       if (mask->rank == 0)
1853         name = "ssum";
1854       else
1855         name = "msum";
1856
1857       /* The mask can be kind 4 or 8 for the array case.  For the
1858          scalar case, coerce it to default kind unconditionally.  */
1859       if ((mask->ts.kind < gfc_default_logical_kind)
1860           || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
1861         {
1862           gfc_typespec ts;
1863           ts.type = BT_LOGICAL;
1864           ts.kind = gfc_default_logical_kind;
1865           gfc_convert_type_warn (mask, &ts, 2, 0);
1866         }
1867     }
1868   else
1869     name = "sum";
1870
1871   if (dim != NULL)
1872     {
1873       f->rank = array->rank - 1;
1874       gfc_resolve_dim_arg (dim);
1875     }
1876
1877   f->value.function.name =
1878     gfc_get_string (PREFIX("%s_%c%d"), name,
1879                     gfc_type_letter (array->ts.type), array->ts.kind);
1880 }
1881
1882
1883 void
1884 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1885                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1886 {
1887   f->ts.type = BT_INTEGER;
1888   f->ts.kind = gfc_default_integer_kind;
1889   f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1890 }
1891
1892
1893 /* Resolve the g77 compatibility function SYSTEM.  */
1894
1895 void
1896 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1897 {
1898   f->ts.type = BT_INTEGER;
1899   f->ts.kind = 4;
1900   f->value.function.name = gfc_get_string (PREFIX("system"));
1901 }
1902
1903
1904 void
1905 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1906 {
1907   f->ts = x->ts;
1908   f->value.function.name =
1909     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1910 }
1911
1912
1913 void
1914 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1915 {
1916   f->ts = x->ts;
1917   f->value.function.name =
1918     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1919 }
1920
1921
1922 void
1923 gfc_resolve_time (gfc_expr * f)
1924 {
1925   f->ts.type = BT_INTEGER;
1926   f->ts.kind = 4;
1927   f->value.function.name = gfc_get_string (PREFIX("time_func"));
1928 }
1929
1930
1931 void
1932 gfc_resolve_time8 (gfc_expr * f)
1933 {
1934   f->ts.type = BT_INTEGER;
1935   f->ts.kind = 8;
1936   f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1937 }
1938
1939
1940 void
1941 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1942                       gfc_expr * mold, gfc_expr * size)
1943 {
1944   /* TODO: Make this do something meaningful.  */
1945   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1946
1947   f->ts = mold->ts;
1948
1949   if (size == NULL && mold->rank == 0)
1950     {
1951       f->rank = 0;
1952       f->value.function.name = transfer0;
1953     }
1954   else
1955     {
1956       f->rank = 1;
1957       f->value.function.name = transfer1;
1958     }
1959 }
1960
1961
1962 void
1963 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1964 {
1965   int kind;
1966
1967   f->ts = matrix->ts;
1968   f->rank = 2;
1969   if (matrix->shape)
1970     {
1971       f->shape = gfc_get_shape (2);
1972       mpz_init_set (f->shape[0], matrix->shape[1]);
1973       mpz_init_set (f->shape[1], matrix->shape[0]);
1974     }
1975
1976   kind = matrix->ts.kind;
1977
1978   switch (kind)
1979     {
1980     case 4:
1981     case 8:
1982     case 10:
1983     case 16:
1984       switch (matrix->ts.type)
1985         {
1986         case BT_COMPLEX:
1987           f->value.function.name =
1988             gfc_get_string (PREFIX("transpose_c%d"), kind);
1989           break;
1990
1991         case BT_REAL:
1992           /* There is no kind=10 integer type.  We need to
1993              call the real version.  */
1994           if (kind == 10)
1995             {
1996               f->value.function.name =
1997                 gfc_get_string (PREFIX("transpose_r%d"), kind);
1998               break;
1999             }
2000
2001           /* Fall through */
2002
2003         case BT_INTEGER:
2004         case BT_LOGICAL:
2005           /* Use the integer routines for real and logical cases.  This
2006              assumes they all have the same alignment requirements.  */
2007           f->value.function.name =
2008             gfc_get_string (PREFIX("transpose_i%d"), kind);
2009           break;
2010
2011         default:
2012           f->value.function.name = PREFIX("transpose");
2013           break;
2014         }
2015       break;
2016
2017     default:
2018       f->value.function.name = (matrix->ts.type == BT_CHARACTER
2019                                 ? PREFIX("transpose_char")
2020                                 : PREFIX("transpose"));
2021       break;
2022     }
2023 }
2024
2025
2026 void
2027 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
2028 {
2029   f->ts.type = BT_CHARACTER;
2030   f->ts.kind = string->ts.kind;
2031   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2032 }
2033
2034
2035 void
2036 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
2037                     gfc_expr * dim)
2038 {
2039   static char ubound[] = "__ubound";
2040
2041   f->ts.type = BT_INTEGER;
2042   f->ts.kind = gfc_default_integer_kind;
2043
2044   if (dim == NULL)
2045     {
2046       f->rank = 1;
2047       f->shape = gfc_get_shape (1);
2048       mpz_init_set_ui (f->shape[0], array->rank);
2049     }
2050
2051   f->value.function.name = ubound;
2052 }
2053
2054
2055 /* Resolve the g77 compatibility function UMASK.  */
2056
2057 void
2058 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
2059 {
2060   f->ts.type = BT_INTEGER;
2061   f->ts.kind = n->ts.kind;
2062   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
2063 }
2064
2065
2066 /* Resolve the g77 compatibility function UNLINK.  */
2067
2068 void
2069 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
2070 {
2071   f->ts.type = BT_INTEGER;
2072   f->ts.kind = 4;
2073   f->value.function.name = gfc_get_string (PREFIX("unlink"));
2074 }
2075
2076
2077 void
2078 gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
2079 {
2080   gfc_typespec ts;
2081
2082   f->ts.type = BT_CHARACTER;
2083   f->ts.kind = gfc_default_character_kind;
2084
2085   if (unit->ts.kind != gfc_c_int_kind)
2086     {
2087       ts.type = BT_INTEGER;
2088       ts.kind = gfc_c_int_kind;
2089       ts.derived = NULL;
2090       ts.cl = NULL;
2091       gfc_convert_type (unit, &ts, 2);
2092     }
2093
2094   f->value.function.name = gfc_get_string (PREFIX("ttynam"));
2095 }
2096
2097
2098 void
2099 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
2100                     gfc_expr * field ATTRIBUTE_UNUSED)
2101 {
2102   f->ts = vector->ts;
2103   f->rank = mask->rank;
2104
2105   f->value.function.name =
2106     gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
2107                     vector->ts.type == BT_CHARACTER ? "_char" : "");
2108 }
2109
2110
2111 void
2112 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
2113                     gfc_expr * set ATTRIBUTE_UNUSED,
2114                     gfc_expr * back ATTRIBUTE_UNUSED)
2115 {
2116   f->ts.type = BT_INTEGER;
2117   f->ts.kind = gfc_default_integer_kind;
2118   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2119 }
2120
2121
2122 void
2123 gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
2124 {
2125   f->ts.type = i->ts.type;
2126   f->ts.kind = gfc_kind_max (i,j);
2127
2128   if (i->ts.kind != j->ts.kind)
2129     {
2130       if (i->ts.kind == gfc_kind_max (i,j))
2131         gfc_convert_type(j, &i->ts, 2);
2132       else
2133         gfc_convert_type(i, &j->ts, 2);
2134     }
2135
2136   f->value.function.name = gfc_get_string ("__xor_%c%d",
2137                                            gfc_type_letter (i->ts.type),
2138                                            f->ts.kind);
2139 }
2140
2141
2142 /* Intrinsic subroutine resolution.  */
2143
2144 void
2145 gfc_resolve_alarm_sub (gfc_code * c)
2146 {
2147   const char *name;
2148   gfc_expr *seconds, *handler, *status;
2149   gfc_typespec ts;
2150
2151   seconds = c->ext.actual->expr;
2152   handler = c->ext.actual->next->expr;
2153   status = c->ext.actual->next->next->expr;
2154   ts.type = BT_INTEGER;
2155   ts.kind = gfc_c_int_kind;
2156
2157   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2158   if (handler->ts.type == BT_INTEGER)
2159     {
2160       if (handler->ts.kind != gfc_c_int_kind)
2161         gfc_convert_type (handler, &ts, 2);
2162       name = gfc_get_string (PREFIX("alarm_sub_int"));
2163     }
2164   else
2165     name = gfc_get_string (PREFIX("alarm_sub"));
2166
2167   if (seconds->ts.kind != gfc_c_int_kind)
2168     gfc_convert_type (seconds, &ts, 2);
2169   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2170     gfc_convert_type (status, &ts, 2);
2171
2172   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2173 }
2174
2175 void
2176 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
2177 {
2178   const char *name;
2179
2180   name = gfc_get_string (PREFIX("cpu_time_%d"),
2181                          c->ext.actual->expr->ts.kind);
2182   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2183 }
2184
2185
2186 void
2187 gfc_resolve_mvbits (gfc_code * c)
2188 {
2189   const char *name;
2190   int kind;
2191
2192   kind = c->ext.actual->expr->ts.kind;
2193   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
2194
2195   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2196 }
2197
2198
2199 void
2200 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
2201 {
2202   const char *name;
2203   int kind;
2204
2205   kind = c->ext.actual->expr->ts.kind;
2206   if (c->ext.actual->expr->rank == 0)
2207     name = gfc_get_string (PREFIX("random_r%d"), kind);
2208   else
2209     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
2210
2211   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2212 }
2213
2214
2215 void
2216 gfc_resolve_rename_sub (gfc_code * c)
2217 {
2218   const char *name;
2219   int kind;
2220
2221   if (c->ext.actual->next->next->expr != NULL)
2222     kind = c->ext.actual->next->next->expr->ts.kind;
2223   else
2224     kind = gfc_default_integer_kind;
2225
2226   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
2227   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2228 }
2229
2230
2231 void
2232 gfc_resolve_kill_sub (gfc_code * c)
2233 {
2234   const char *name;
2235   int kind;
2236
2237   if (c->ext.actual->next->next->expr != NULL)
2238     kind = c->ext.actual->next->next->expr->ts.kind;
2239   else
2240     kind = gfc_default_integer_kind;
2241
2242   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
2243   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2244 }
2245
2246
2247 void
2248 gfc_resolve_link_sub (gfc_code * c)
2249 {
2250   const char *name;
2251   int kind;
2252
2253   if (c->ext.actual->next->next->expr != NULL)
2254     kind = c->ext.actual->next->next->expr->ts.kind;
2255   else
2256     kind = gfc_default_integer_kind;
2257
2258   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
2259   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2260 }
2261
2262
2263 void
2264 gfc_resolve_symlnk_sub (gfc_code * c)
2265 {
2266   const char *name;
2267   int kind;
2268
2269   if (c->ext.actual->next->next->expr != NULL)
2270     kind = c->ext.actual->next->next->expr->ts.kind;
2271   else
2272     kind = gfc_default_integer_kind;
2273
2274   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
2275   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2276 }
2277
2278
2279 /* G77 compatibility subroutines etime() and dtime().  */
2280
2281 void
2282 gfc_resolve_etime_sub (gfc_code * c)
2283 {
2284   const char *name;
2285
2286   name = gfc_get_string (PREFIX("etime_sub"));
2287   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2288 }
2289
2290
2291 /* G77 compatibility subroutine second().  */
2292
2293 void
2294 gfc_resolve_second_sub (gfc_code * c)
2295 {
2296   const char *name;
2297
2298   name = gfc_get_string (PREFIX("second_sub"));
2299   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2300 }
2301
2302
2303 void
2304 gfc_resolve_sleep_sub (gfc_code * c)
2305 {
2306   const char *name;
2307   int kind;
2308
2309   if (c->ext.actual->expr != NULL)
2310     kind = c->ext.actual->expr->ts.kind;
2311   else
2312     kind = gfc_default_integer_kind;
2313
2314   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
2315   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2316 }
2317
2318
2319 /* G77 compatibility function srand().  */
2320
2321 void
2322 gfc_resolve_srand (gfc_code * c)
2323 {
2324   const char *name;
2325   name = gfc_get_string (PREFIX("srand"));
2326   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2327 }
2328
2329
2330 /* Resolve the getarg intrinsic subroutine.  */
2331
2332 void
2333 gfc_resolve_getarg (gfc_code * c)
2334 {
2335   const char *name;
2336   int kind;
2337
2338   kind = gfc_default_integer_kind;
2339   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
2340   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2341 }
2342
2343 /* Resolve the getcwd intrinsic subroutine.  */
2344
2345 void
2346 gfc_resolve_getcwd_sub (gfc_code * c)
2347 {
2348   const char *name;
2349   int kind;
2350
2351   if (c->ext.actual->next->expr != NULL)
2352     kind = c->ext.actual->next->expr->ts.kind;
2353   else
2354     kind = gfc_default_integer_kind;
2355
2356   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
2357   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2358 }
2359
2360
2361 /* Resolve the get_command intrinsic subroutine.  */
2362
2363 void
2364 gfc_resolve_get_command (gfc_code * c)
2365 {
2366   const char *name;
2367   int kind;
2368
2369   kind = gfc_default_integer_kind;
2370   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
2371   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2372 }
2373
2374
2375 /* Resolve the get_command_argument intrinsic subroutine.  */
2376
2377 void
2378 gfc_resolve_get_command_argument (gfc_code * c)
2379 {
2380   const char *name;
2381   int kind;
2382
2383   kind = gfc_default_integer_kind;
2384   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
2385   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2386 }
2387
2388 /* Resolve the get_environment_variable intrinsic subroutine.  */
2389
2390 void
2391 gfc_resolve_get_environment_variable (gfc_code * code)
2392 {
2393   const char *name;
2394   int kind;
2395
2396   kind = gfc_default_integer_kind;
2397   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
2398   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2399 }
2400
2401 void
2402 gfc_resolve_signal_sub (gfc_code * c)
2403 {
2404   const char *name;
2405   gfc_expr *number, *handler, *status;
2406   gfc_typespec ts;
2407
2408   number = c->ext.actual->expr;
2409   handler = c->ext.actual->next->expr;
2410   status = c->ext.actual->next->next->expr;
2411   ts.type = BT_INTEGER;
2412   ts.kind = gfc_c_int_kind;
2413
2414   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2415   if (handler->ts.type == BT_INTEGER)
2416     {
2417       if (handler->ts.kind != gfc_c_int_kind)
2418         gfc_convert_type (handler, &ts, 2);
2419       name = gfc_get_string (PREFIX("signal_sub_int"));
2420     }
2421   else
2422     name = gfc_get_string (PREFIX("signal_sub"));
2423
2424   if (number->ts.kind != gfc_c_int_kind)
2425     gfc_convert_type (number, &ts, 2);
2426   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2427     gfc_convert_type (status, &ts, 2);
2428
2429   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2430 }
2431
2432 /* Resolve the SYSTEM intrinsic subroutine.  */
2433
2434 void
2435 gfc_resolve_system_sub (gfc_code * c)
2436 {
2437   const char *name;
2438
2439   name = gfc_get_string (PREFIX("system_sub"));
2440   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2441 }
2442
2443 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2444
2445 void
2446 gfc_resolve_system_clock (gfc_code * c)
2447 {
2448   const char *name;
2449   int kind;
2450
2451   if (c->ext.actual->expr != NULL)
2452     kind = c->ext.actual->expr->ts.kind;
2453   else if (c->ext.actual->next->expr != NULL)
2454       kind = c->ext.actual->next->expr->ts.kind;
2455   else if (c->ext.actual->next->next->expr != NULL)
2456       kind = c->ext.actual->next->next->expr->ts.kind;
2457   else
2458     kind = gfc_default_integer_kind;
2459
2460   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
2461   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2462 }
2463
2464 /* Resolve the EXIT intrinsic subroutine.  */
2465
2466 void
2467 gfc_resolve_exit (gfc_code * c)
2468 {
2469   const char *name;
2470   int kind;
2471
2472   if (c->ext.actual->expr != NULL)
2473     kind = c->ext.actual->expr->ts.kind;
2474   else
2475     kind = gfc_default_integer_kind;
2476
2477   name = gfc_get_string (PREFIX("exit_i%d"), kind);
2478   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2479 }
2480
2481 /* Resolve the FLUSH intrinsic subroutine.  */
2482
2483 void
2484 gfc_resolve_flush (gfc_code * c)
2485 {
2486   const char *name;
2487   gfc_typespec ts;
2488   gfc_expr *n;
2489
2490   ts.type = BT_INTEGER;
2491   ts.kind = gfc_default_integer_kind;
2492   n = c->ext.actual->expr;
2493   if (n != NULL
2494       && n->ts.kind != ts.kind)
2495     gfc_convert_type (n, &ts, 2);
2496
2497   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
2498   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2499 }
2500
2501
2502 void
2503 gfc_resolve_free (gfc_code * c)
2504 {
2505   gfc_typespec ts;
2506   gfc_expr *n;
2507
2508   ts.type = BT_INTEGER;
2509   ts.kind = gfc_index_integer_kind;
2510   n = c->ext.actual->expr;
2511   if (n->ts.kind != ts.kind)
2512     gfc_convert_type (n, &ts, 2);
2513
2514   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
2515 }
2516
2517
2518 void
2519 gfc_resolve_ctime_sub (gfc_code * c)
2520 {
2521   gfc_typespec ts;
2522
2523   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2524   if (c->ext.actual->expr->ts.kind != 8)
2525     {
2526       ts.type = BT_INTEGER;
2527       ts.kind = 8;
2528       ts.derived = NULL;
2529       ts.cl = NULL;
2530       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2531     }
2532
2533   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
2534 }
2535
2536
2537 void
2538 gfc_resolve_fdate_sub (gfc_code * c)
2539 {
2540   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2541 }
2542
2543
2544 void
2545 gfc_resolve_gerror (gfc_code * c)
2546 {
2547   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2548 }
2549
2550
2551 void
2552 gfc_resolve_getlog (gfc_code * c)
2553 {
2554   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2555 }
2556
2557
2558 void
2559 gfc_resolve_hostnm_sub (gfc_code * c)
2560 {
2561   const char *name;
2562   int kind;
2563
2564   if (c->ext.actual->next->expr != NULL)
2565     kind = c->ext.actual->next->expr->ts.kind;
2566   else
2567     kind = gfc_default_integer_kind;
2568
2569   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2570   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2571 }
2572
2573
2574 void
2575 gfc_resolve_perror (gfc_code * c)
2576 {
2577   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2578 }
2579
2580 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
2581
2582 void
2583 gfc_resolve_stat_sub (gfc_code * c)
2584 {
2585   const char *name;
2586
2587   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2588   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2589 }
2590
2591
2592 void
2593 gfc_resolve_fstat_sub (gfc_code * c)
2594 {
2595   const char *name;
2596   gfc_expr *u;
2597   gfc_typespec *ts;
2598
2599   u = c->ext.actual->expr;
2600   ts = &c->ext.actual->next->expr->ts;
2601   if (u->ts.kind != ts->kind)
2602     gfc_convert_type (u, ts, 2);
2603   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2604   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2605 }
2606
2607
2608 void
2609 gfc_resolve_fgetc_sub (gfc_code * c)
2610 {
2611   const char *name;
2612   gfc_typespec ts;
2613   gfc_expr *u, *st;
2614
2615   u = c->ext.actual->expr;
2616   st = c->ext.actual->next->next->expr;
2617
2618   if (u->ts.kind != gfc_c_int_kind)
2619     {
2620       ts.type = BT_INTEGER;
2621       ts.kind = gfc_c_int_kind;
2622       ts.derived = NULL;
2623       ts.cl = NULL;
2624       gfc_convert_type (u, &ts, 2);
2625     }
2626
2627   if (st != NULL)
2628     name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
2629   else
2630     name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
2631
2632   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2633 }
2634
2635
2636 void
2637 gfc_resolve_fget_sub (gfc_code * c)
2638 {
2639   const char *name;
2640   gfc_expr *st;
2641
2642   st = c->ext.actual->next->expr;
2643   if (st != NULL)
2644     name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
2645   else
2646     name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
2647
2648   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2649 }
2650
2651
2652 void
2653 gfc_resolve_fputc_sub (gfc_code * c)
2654 {
2655   const char *name;
2656   gfc_typespec ts;
2657   gfc_expr *u, *st;
2658
2659   u = c->ext.actual->expr;
2660   st = c->ext.actual->next->next->expr;
2661
2662   if (u->ts.kind != gfc_c_int_kind)
2663     {
2664       ts.type = BT_INTEGER;
2665       ts.kind = gfc_c_int_kind;
2666       ts.derived = NULL;
2667       ts.cl = NULL;
2668       gfc_convert_type (u, &ts, 2);
2669     }
2670
2671   if (st != NULL)
2672     name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
2673   else
2674     name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
2675
2676   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2677 }
2678
2679
2680 void
2681 gfc_resolve_fput_sub (gfc_code * c)
2682 {
2683   const char *name;
2684   gfc_expr *st;
2685
2686   st = c->ext.actual->next->expr;
2687   if (st != NULL)
2688     name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
2689   else
2690     name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
2691
2692   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2693 }
2694
2695
2696 void
2697 gfc_resolve_ftell_sub (gfc_code * c)
2698 {
2699   const char *name;
2700   gfc_expr *unit;
2701   gfc_expr *offset;
2702   gfc_typespec ts;
2703
2704   unit = c->ext.actual->expr;
2705   offset = c->ext.actual->next->expr;
2706
2707   if (unit->ts.kind != gfc_c_int_kind)
2708     {
2709       ts.type = BT_INTEGER;
2710       ts.kind = gfc_c_int_kind;
2711       ts.derived = NULL;
2712       ts.cl = NULL;
2713       gfc_convert_type (unit, &ts, 2);
2714     }
2715
2716   name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
2717   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2718 }
2719
2720
2721 void
2722 gfc_resolve_ttynam_sub (gfc_code * c)
2723 {
2724   gfc_typespec ts;
2725
2726   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2727     {
2728       ts.type = BT_INTEGER;
2729       ts.kind = gfc_c_int_kind;
2730       ts.derived = NULL;
2731       ts.cl = NULL;
2732       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2733     }
2734
2735   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2736 }
2737
2738
2739 /* Resolve the UMASK intrinsic subroutine.  */
2740
2741 void
2742 gfc_resolve_umask_sub (gfc_code * c)
2743 {
2744   const char *name;
2745   int kind;
2746
2747   if (c->ext.actual->next->expr != NULL)
2748     kind = c->ext.actual->next->expr->ts.kind;
2749   else
2750     kind = gfc_default_integer_kind;
2751
2752   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2753   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2754 }
2755
2756 /* Resolve the UNLINK intrinsic subroutine.  */
2757
2758 void
2759 gfc_resolve_unlink_sub (gfc_code * c)
2760 {
2761   const char *name;
2762   int kind;
2763
2764   if (c->ext.actual->next->expr != NULL)
2765     kind = c->ext.actual->next->expr->ts.kind;
2766   else
2767     kind = gfc_default_integer_kind;
2768
2769   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2770   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2771 }