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 /********************** Resolution functions **********************/
  63
  64
  65 void
  66 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
  67 {
  68   f->ts = a->ts;
  69   if (f->ts.type == BT_COMPLEX)
  70     f->ts.type = BT_REAL;
  71
  72   f->value.function.name =
  73     gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
  74 }
  75
  76
  77 void
  78 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
  79 {
  80   f->ts = x->ts;
  81   f->value.function.name =
  82     gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
  83 }
  84
  85
  86 void
  87 gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
  88 {
  89   f->ts = x->ts;
  90   f->value.function.name =
  91     gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
  92 }
  93
  94
  95 void
  96 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
  97 {
  98   f->ts.type = BT_REAL;
  99   f->ts.kind = x->ts.kind;
 100   f->value.function.name =
 101     gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 102 }
 103
 104
 105 void
 106 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 107 {
 108   f->ts.type = a->ts.type;
 109   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 110
 111   /* The resolved name is only used for specific intrinsics where
 112      the return kind is the same as the arg kind.  */
 113   f->value.function.name =
 114     gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 115 }
 116
 117
 118 void
 119 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
 120 {
 121   gfc_resolve_aint (f, a, NULL);
 122 }
 123
 124
 125 void
 126 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 127 {
 128   f->ts = mask->ts;
 129
 130   if (dim != NULL)
 131     {
 132       gfc_resolve_dim_arg (dim);
 133       f->rank = mask->rank - 1;
 134       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 135     }
 136
 137   f->value.function.name =
 138     gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
 139                     mask->ts.kind);
 140 }
 141
 142
 143 void
 144 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 145 {
 146   f->ts.type = a->ts.type;
 147   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 148
 149   /* The resolved name is only used for specific intrinsics where
 150      the return kind is the same as the arg kind.  */
 151   f->value.function.name =
 152     gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 153 }
 154
 155
 156 void
 157 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
 158 {
 159   gfc_resolve_anint (f, a, NULL);
 160 }
 161
 162
 163 void
 164 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 165 {
 166   f->ts = mask->ts;
 167
 168   if (dim != NULL)
 169     {
 170       gfc_resolve_dim_arg (dim);
 171       f->rank = mask->rank - 1;
 172       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 173     }
 174
 175   f->value.function.name =
 176     gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
 177                     mask->ts.kind);
 178 }
 179
 180
 181 void
 182 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
 183 {
 184   f->ts = x->ts;
 185   f->value.function.name =
 186     gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 187 }
 188
 189 void
 190 gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
 191 {
 192   f->ts = x->ts;
 193   f->value.function.name =
 194     gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 195 }
 196
 197 void
 198 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
 199 {
 200   f->ts = x->ts;
 201   f->value.function.name =
 202     gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 203 }
 204
 205 void
 206 gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
 207 {
 208   f->ts = x->ts;
 209   f->value.function.name =
 210     gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 211 }
 212
 213 void
 214 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
 215                    gfc_expr * y ATTRIBUTE_UNUSED)
 216 {
 217   f->ts = x->ts;
 218   f->value.function.name =
 219     gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 220 }
 221
 222
 223 /* Resolve the BESYN and BESJN intrinsics.  */
 224
 225 void
 226 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
 227 {
 228   gfc_typespec ts;
 229
 230   f->ts = x->ts;
 231   if (n->ts.kind != gfc_c_int_kind)
 232     {
 233       ts.type = BT_INTEGER;
 234       ts.kind = gfc_c_int_kind;
 235       gfc_convert_type (n, &ts, 2);
 236     }
 237   f->value.function.name = gfc_get_string ("<intrinsic>");
 238 }
 239
 240
 241 void
 242 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
 243 {
 244   f->ts.type = BT_LOGICAL;
 245   f->ts.kind = gfc_default_logical_kind;
 246
 247   f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
 248                                            pos->ts.kind);
 249 }
 250
 251
 252 void
 253 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 254 {
 255   f->ts.type = BT_INTEGER;
 256   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 257     : mpz_get_si (kind->value.integer);
 258
 259   f->value.function.name =
 260     gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
 261                     gfc_type_letter (a->ts.type), a->ts.kind);
 262 }
 263
 264
 265 void
 266 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 267 {
 268   f->ts.type = BT_CHARACTER;
 269   f->ts.kind = (kind == NULL) ? gfc_default_character_kind
 270     : mpz_get_si (kind->value.integer);
 271
 272   f->value.function.name =
 273     gfc_get_string ("__char_%d_%c%d", f->ts.kind,
 274                     gfc_type_letter (a->ts.type), a->ts.kind);
 275 }
 276
 277
 278 void
 279 gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
 280 {
 281   f->ts.type = BT_INTEGER;
 282   f->ts.kind = gfc_default_integer_kind;
 283   f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
 284 }
 285
 286
 287 void
 288 gfc_resolve_chdir_sub (gfc_code * c)
 289 {
 290   const char *name;
 291   int kind;
 292
 293   if (c->ext.actual->next->expr != NULL)
 294     kind = c->ext.actual->next->expr->ts.kind;
 295   else
 296     kind = gfc_default_integer_kind;
 297
 298   name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
 299   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 300 }
 301
 302
 303 void
 304 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 305 {
 306   f->ts.type = BT_COMPLEX;
 307   f->ts.kind = (kind == NULL) ? gfc_default_real_kind
 308     : mpz_get_si (kind->value.integer);
 309
 310   if (y == NULL)
 311     f->value.function.name =
 312       gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
 313                       gfc_type_letter (x->ts.type), x->ts.kind);
 314   else
 315     f->value.function.name =
 316       gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
 317                       gfc_type_letter (x->ts.type), x->ts.kind,
 318                       gfc_type_letter (y->ts.type), y->ts.kind);
 319 }
 320
 321 void
 322 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
 323 {
 324   gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
 325 }
 326
 327 void
 328 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
 329 {
 330   f->ts = x->ts;
 331   f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
 332 }
 333
 334
 335 void
 336 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
 337 {
 338   f->ts = x->ts;
 339   f->value.function.name =
 340     gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 341 }
 342
 343
 344 void
 345 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
 346 {
 347   f->ts = x->ts;
 348   f->value.function.name =
 349     gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 350 }
 351
 352
 353 void
 354 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 355 {
 356   f->ts.type = BT_INTEGER;
 357   f->ts.kind = gfc_default_integer_kind;
 358
 359   if (dim != NULL)
 360     {
 361       f->rank = mask->rank - 1;
 362       gfc_resolve_dim_arg (dim);
 363       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 364     }
 365
 366   f->value.function.name =
 367     gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
 368                     gfc_type_letter (mask->ts.type), mask->ts.kind);
 369 }
 370
 371
 372 void
 373 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
 374                     gfc_expr * shift,
 375                     gfc_expr * dim)
 376 {
 377   int n;
 378
 379   f->ts = array->ts;
 380   f->rank = array->rank;
 381   f->shape = gfc_copy_shape (array->shape, array->rank);
 382
 383   if (shift->rank > 0)
 384     n = 1;
 385   else
 386     n = 0;
 387
 388   /* Convert shift to at least gfc_default_integer_kind, so we don't need
 389      kind=1 and kind=2 versions of the library functions.  */
 390   if (shift->ts.kind < gfc_default_integer_kind)
 391     {
 392       gfc_typespec ts;
 393       ts.type = BT_INTEGER;
 394       ts.kind = gfc_default_integer_kind;
 395       gfc_convert_type_warn (shift, &ts, 2, 0);
 396     }
 397
 398   if (dim != NULL)
 399     {
 400       gfc_resolve_dim_arg (dim);
 401       /* Convert dim to shift's kind, so we don't need so many variations.  */
 402       if (dim->ts.kind != shift->ts.kind)
 403         gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 404     }
 405   f->value.function.name =
 406     gfc_get_string (PREFIX("cshift%d_%d"), n, shift->ts.kind);
 407 }
 408
 409
 410 void
 411 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
 412 {
 413   f->ts.type = BT_REAL;
 414   f->ts.kind = gfc_default_double_kind;
 415   f->value.function.name =
 416     gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 417 }
 418
 419
 420 void
 421 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
 422                  gfc_expr * y ATTRIBUTE_UNUSED)
 423 {
 424   f->ts = x->ts;
 425   f->value.function.name =
 426     gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 427 }
 428
 429
 430 void
 431 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 432 {
 433   gfc_expr temp;
 434
 435   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 436     {
 437       f->ts.type = BT_LOGICAL;
 438       f->ts.kind = gfc_default_logical_kind;
 439     }
 440   else
 441     {
 442       temp.expr_type = EXPR_OP;
 443       gfc_clear_ts (&temp.ts);
 444       temp.value.op.operator = INTRINSIC_NONE;
 445       temp.value.op.op1 = a;
 446       temp.value.op.op2 = b;
 447       gfc_type_convert_binary (&temp);
 448       f->ts = temp.ts;
 449     }
 450
 451   f->value.function.name =
 452     gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
 453                     f->ts.kind);
 454 }
 455
 456
 457 void
 458 gfc_resolve_dprod (gfc_expr * f,
 459                    gfc_expr * a ATTRIBUTE_UNUSED,
 460                    gfc_expr * b ATTRIBUTE_UNUSED)
 461 {
 462   f->ts.kind = gfc_default_double_kind;
 463   f->ts.type = BT_REAL;
 464
 465   f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
 466 }
 467
 468
 469 void
 470 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
 471                      gfc_expr * shift,
 472                      gfc_expr * boundary,
 473                      gfc_expr * dim)
 474 {
 475   int n;
 476
 477   f->ts = array->ts;
 478   f->rank = array->rank;
 479   f->shape = gfc_copy_shape (array->shape, array->rank);
 480
 481   n = 0;
 482   if (shift->rank > 0)
 483     n = n | 1;
 484   if (boundary && boundary->rank > 0)
 485     n = n | 2;
 486
 487   /* Convert shift to at least gfc_default_integer_kind, so we don't need
 488      kind=1 and kind=2 versions of the library functions.  */
 489   if (shift->ts.kind < gfc_default_integer_kind)
 490     {
 491       gfc_typespec ts;
 492       ts.type = BT_INTEGER;
 493       ts.kind = gfc_default_integer_kind;
 494       gfc_convert_type_warn (shift, &ts, 2, 0);
 495     }
 496
 497   if (dim != NULL)
 498     {
 499       gfc_resolve_dim_arg (dim);
 500       /* Convert dim to shift's kind, so we don't need so many variations.  */
 501       if (dim->ts.kind != shift->ts.kind)
 502         gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 503     }
 504
 505   f->value.function.name =
 506     gfc_get_string (PREFIX("eoshift%d_%d"), n, shift->ts.kind);
 507 }
 508
 509
 510 void
 511 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
 512 {
 513   f->ts = x->ts;
 514   f->value.function.name =
 515     gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 516 }
 517
 518
 519 void
 520 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
 521 {
 522   f->ts.type = BT_INTEGER;
 523   f->ts.kind = gfc_default_integer_kind;
 524
 525   f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
 526 }
 527
 528
 529 void
 530 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 531 {
 532   f->ts.type = BT_INTEGER;
 533   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 534     : mpz_get_si (kind->value.integer);
 535
 536   f->value.function.name =
 537     gfc_get_string ("__floor%d_%c%d", f->ts.kind,
 538                     gfc_type_letter (a->ts.type), a->ts.kind);
 539 }
 540
 541
 542 void
 543 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
 544 {
 545   f->ts.type = BT_INTEGER;
 546   f->ts.kind = gfc_default_integer_kind;
 547   if (n->ts.kind != f->ts.kind)
 548     gfc_convert_type (n, &f->ts, 2);
 549   f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
 550 }
 551
 552
 553 void
 554 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
 555 {
 556   f->ts = x->ts;
 557   f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
 558 }
 559
 560
 561 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
 562
 563 void
 564 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
 565 {
 566   f->ts = x->ts;
 567   f->value.function.name = gfc_get_string ("<intrinsic>");
 568 }
 569
 570
 571 void
 572 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
 573 {
 574   f->ts.type = BT_INTEGER;
 575   f->ts.kind = 4;
 576   f->value.function.name = gfc_get_string (PREFIX("getcwd"));
 577 }
 578
 579
 580 void
 581 gfc_resolve_getgid (gfc_expr * f)
 582 {
 583   f->ts.type = BT_INTEGER;
 584   f->ts.kind = 4;
 585   f->value.function.name = gfc_get_string (PREFIX("getgid"));
 586 }
 587
 588
 589 void
 590 gfc_resolve_getpid (gfc_expr * f)
 591 {
 592   f->ts.type = BT_INTEGER;
 593   f->ts.kind = 4;
 594   f->value.function.name = gfc_get_string (PREFIX("getpid"));
 595 }
 596
 597
 598 void
 599 gfc_resolve_getuid (gfc_expr * f)
 600 {
 601   f->ts.type = BT_INTEGER;
 602   f->ts.kind = 4;
 603   f->value.function.name = gfc_get_string (PREFIX("getuid"));
 604 }
 605
 606 void
 607 gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
 608 {
 609   f->ts.type = BT_INTEGER;
 610   f->ts.kind = 4;
 611   f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
 612 }
 613
 614 void
 615 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 616 {
 617   /* If the kind of i and j are different, then g77 cross-promoted the
 618      kinds to the largest value.  The Fortran 95 standard requires the
 619      kinds to match.  */
 620   if (i->ts.kind != j->ts.kind)
 621     {
 622       if (i->ts.kind == gfc_kind_max (i,j))
 623         gfc_convert_type(j, &i->ts, 2);
 624       else
 625         gfc_convert_type(i, &j->ts, 2);
 626     }
 627
 628   f->ts = i->ts;
 629   f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
 630 }
 631
 632
 633 void
 634 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
 635 {
 636   f->ts = i->ts;
 637   f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
 638 }
 639
 640
 641 void
 642 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
 643                    gfc_expr * pos ATTRIBUTE_UNUSED,
 644                    gfc_expr * len ATTRIBUTE_UNUSED)
 645 {
 646   f->ts = i->ts;
 647   f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
 648 }
 649
 650
 651 void
 652 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
 653                    gfc_expr * pos ATTRIBUTE_UNUSED)
 654 {
 655   f->ts = i->ts;
 656   f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
 657 }
 658
 659
 660 void
 661 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
 662 {
 663   f->ts.type = BT_INTEGER;
 664   f->ts.kind = gfc_default_integer_kind;
 665
 666   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 667 }
 668
 669
 670 void
 671 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
 672 {
 673   gfc_resolve_nint (f, a, NULL);
 674 }
 675
 676
 677 void
 678 gfc_resolve_ierrno (gfc_expr * f)
 679 {
 680   f->ts.type = BT_INTEGER;
 681   f->ts.kind = gfc_default_integer_kind;
 682   f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
 683 }
 684
 685
 686 void
 687 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 688 {
 689   /* If the kind of i and j are different, then g77 cross-promoted the
 690      kinds to the largest value.  The Fortran 95 standard requires the
 691      kinds to match.  */
 692   if (i->ts.kind != j->ts.kind)
 693     {
 694       if (i->ts.kind == gfc_kind_max (i,j))
 695         gfc_convert_type(j, &i->ts, 2);
 696       else
 697         gfc_convert_type(i, &j->ts, 2);
 698     }
 699
 700   f->ts = i->ts;
 701   f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
 702 }
 703
 704
 705 void
 706 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 707 {
 708   /* If the kind of i and j are different, then g77 cross-promoted the
 709      kinds to the largest value.  The Fortran 95 standard requires the
 710      kinds to match.  */
 711   if (i->ts.kind != j->ts.kind)
 712     {
 713       if (i->ts.kind == gfc_kind_max (i,j))
 714         gfc_convert_type(j, &i->ts, 2);
 715       else
 716         gfc_convert_type(i, &j->ts, 2);
 717     }
 718
 719   f->ts = i->ts;
 720   f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
 721 }
 722
 723
 724 void
 725 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 726 {
 727   f->ts.type = BT_INTEGER;
 728   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 729     : mpz_get_si (kind->value.integer);
 730
 731   f->value.function.name =
 732     gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
 733                     a->ts.kind);
 734 }
 735
 736
 737 void
 738 gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
 739 {
 740   gfc_typespec ts;
 741
 742   f->ts.type = BT_LOGICAL;
 743   f->ts.kind = gfc_default_integer_kind;
 744   if (u->ts.kind != gfc_c_int_kind)
 745     {
 746       ts.type = BT_INTEGER;
 747       ts.kind = gfc_c_int_kind;
 748       ts.derived = NULL;
 749       ts.cl = NULL;
 750       gfc_convert_type (u, &ts, 2);
 751     }
 752
 753   f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
 754 }
 755
 756
 757 void
 758 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
 759 {
 760   f->ts = i->ts;
 761   f->value.function.name =
 762     gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
 763 }
 764
 765
 766 void
 767 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
 768                     gfc_expr * size)
 769 {
 770   int s_kind;
 771
 772   s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
 773
 774   f->ts = i->ts;
 775   f->value.function.name =
 776     gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
 777 }
 778
 779
 780 void
 781 gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
 782                   ATTRIBUTE_UNUSED gfc_expr * s)
 783 {
 784   f->ts.type = BT_INTEGER;
 785   f->ts.kind = gfc_default_integer_kind;
 786
 787   f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
 788 }
 789
 790
 791 void
 792 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
 793                     gfc_expr * dim)
 794 {
 795   static char lbound[] = "__lbound";
 796
 797   f->ts.type = BT_INTEGER;
 798   f->ts.kind = gfc_default_integer_kind;
 799
 800   if (dim == NULL)
 801     {
 802       f->rank = 1;
 803       f->shape = gfc_get_shape (1);
 804       mpz_init_set_ui (f->shape[0], array->rank);
 805     }
 806
 807   f->value.function.name = lbound;
 808 }
 809
 810
 811 void
 812 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
 813 {
 814   f->ts.type = BT_INTEGER;
 815   f->ts.kind = gfc_default_integer_kind;
 816   f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
 817 }
 818
 819
 820 void
 821 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
 822 {
 823   f->ts.type = BT_INTEGER;
 824   f->ts.kind = gfc_default_integer_kind;
 825   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
 826 }
 827
 828
 829 void
 830 gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
 831                   gfc_expr * p2 ATTRIBUTE_UNUSED)
 832 {
 833   f->ts.type = BT_INTEGER;
 834   f->ts.kind = gfc_default_integer_kind;
 835   f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
 836 }
 837
 838
 839 void
 840 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
 841 {
 842   f->ts = x->ts;
 843   f->value.function.name =
 844     gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 845 }
 846
 847
 848 void
 849 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
 850 {
 851   f->ts = x->ts;
 852   f->value.function.name =
 853     gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 854 }
 855
 856
 857 void
 858 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 859 {
 860   f->ts.type = BT_LOGICAL;
 861   f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
 862     : mpz_get_si (kind->value.integer);
 863   f->rank = a->rank;
 864
 865   f->value.function.name =
 866     gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
 867                     gfc_type_letter (a->ts.type), a->ts.kind);
 868 }
 869
 870
 871 void
 872 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 873 {
 874   gfc_expr temp;
 875
 876   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 877     {
 878       f->ts.type = BT_LOGICAL;
 879       f->ts.kind = gfc_default_logical_kind;
 880     }
 881   else
 882     {
 883       temp.expr_type = EXPR_OP;
 884       gfc_clear_ts (&temp.ts);
 885       temp.value.op.operator = INTRINSIC_NONE;
 886       temp.value.op.op1 = a;
 887       temp.value.op.op2 = b;
 888       gfc_type_convert_binary (&temp);
 889       f->ts = temp.ts;
 890     }
 891
 892   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
 893
 894   f->value.function.name =
 895     gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
 896                     f->ts.kind);
 897 }
 898
 899
 900 static void
 901 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
 902 {
 903   gfc_actual_arglist *a;
 904
 905   f->ts.type = args->expr->ts.type;
 906   f->ts.kind = args->expr->ts.kind;
 907   /* Find the largest type kind.  */
 908   for (a = args->next; a; a = a->next)
 909     {
 910       if (a->expr->ts.kind > f->ts.kind)
 911         f->ts.kind = a->expr->ts.kind;
 912     }
 913
 914   /* Convert all parameters to the required kind.  */
 915   for (a = args; a; a = a->next)
 916     {
 917       if (a->expr->ts.kind != f->ts.kind)
 918         gfc_convert_type (a->expr, &f->ts, 2);
 919     }
 920
 921   f->value.function.name =
 922     gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
 923 }
 924
 925
 926 void
 927 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
 928 {
 929   gfc_resolve_minmax ("__max_%c%d", f, args);
 930 }
 931
 932
 933 void
 934 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 935                     gfc_expr * mask)
 936 {
 937   const char *name;
 938
 939   f->ts.type = BT_INTEGER;
 940   f->ts.kind = gfc_default_integer_kind;
 941
 942   if (dim == NULL)
 943     f->rank = 1;
 944   else
 945     {
 946       f->rank = array->rank - 1;
 947       gfc_resolve_dim_arg (dim);
 948     }
 949
 950   name = mask ? "mmaxloc" : "maxloc";
 951   f->value.function.name =
 952     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
 953                     gfc_type_letter (array->ts.type), array->ts.kind);
 954 }
 955
 956
 957 void
 958 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 959                     gfc_expr * mask)
 960 {
 961   f->ts = array->ts;
 962
 963   if (dim != NULL)
 964     {
 965       f->rank = array->rank - 1;
 966       gfc_resolve_dim_arg (dim);
 967     }
 968
 969   f->value.function.name =
 970     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
 971                     gfc_type_letter (array->ts.type), array->ts.kind);
 972 }
 973
 974
 975 void
 976 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
 977                    gfc_expr * fsource ATTRIBUTE_UNUSED,
 978                    gfc_expr * mask ATTRIBUTE_UNUSED)
 979 {
 980   f->ts = tsource->ts;
 981   f->value.function.name =
 982     gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
 983                     tsource->ts.kind);
 984 }
 985
 986
 987 void
 988 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
 989 {
 990   gfc_resolve_minmax ("__min_%c%d", f, args);
 991 }
 992
 993
 994 void
 995 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 996                     gfc_expr * mask)
 997 {
 998   const char *name;
 999
1000   f->ts.type = BT_INTEGER;
1001   f->ts.kind = gfc_default_integer_kind;
1002
1003   if (dim == NULL)
1004     f->rank = 1;
1005   else
1006     {
1007       f->rank = array->rank - 1;
1008       gfc_resolve_dim_arg (dim);
1009     }
1010
1011   name = mask ? "mminloc" : "minloc";
1012   f->value.function.name =
1013     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1014                     gfc_type_letter (array->ts.type), array->ts.kind);
1015 }
1016
1017
1018 void
1019 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1020                     gfc_expr * mask)
1021 {
1022   f->ts = array->ts;
1023
1024   if (dim != NULL)
1025     {
1026       f->rank = array->rank - 1;
1027       gfc_resolve_dim_arg (dim);
1028     }
1029
1030   f->value.function.name =
1031     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
1032                     gfc_type_letter (array->ts.type), array->ts.kind);
1033 }
1034
1035
1036 void
1037 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
1038                  gfc_expr * p ATTRIBUTE_UNUSED)
1039 {
1040   f->ts = a->ts;
1041   f->value.function.name =
1042     gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1043 }
1044
1045
1046 void
1047 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
1048                     gfc_expr * p ATTRIBUTE_UNUSED)
1049 {
1050   f->ts = a->ts;
1051   f->value.function.name =
1052     gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
1053                     a->ts.kind);
1054 }
1055
1056 void
1057 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1058 {
1059   f->ts = a->ts;
1060   f->value.function.name =
1061     gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1062             a->ts.kind);
1063 }
1064
1065 void
1066 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1067 {
1068   f->ts.type = BT_INTEGER;
1069   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1070     : mpz_get_si (kind->value.integer);
1071
1072   f->value.function.name =
1073     gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1074 }
1075
1076
1077 void
1078 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1079 {
1080   f->ts = i->ts;
1081   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1082 }
1083
1084
1085 void
1086 gfc_resolve_pack (gfc_expr * f,
1087                   gfc_expr * array ATTRIBUTE_UNUSED,
1088                   gfc_expr * mask,
1089                   gfc_expr * vector ATTRIBUTE_UNUSED)
1090 {
1091   f->ts = array->ts;
1092   f->rank = 1;
1093
1094   if (mask->rank != 0)
1095     f->value.function.name = PREFIX("pack");
1096   else
1097     {
1098       /* We convert mask to default logical only in the scalar case.
1099          In the array case we can simply read the array as if it were
1100          of type default logical.  */
1101       if (mask->ts.kind != gfc_default_logical_kind)
1102         {
1103           gfc_typespec ts;
1104
1105           ts.type = BT_LOGICAL;
1106           ts.kind = gfc_default_logical_kind;
1107           gfc_convert_type (mask, &ts, 2);
1108         }
1109
1110       f->value.function.name = PREFIX("pack_s");
1111     }
1112 }
1113
1114
1115 void
1116 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1117                      gfc_expr * mask)
1118 {
1119   f->ts = array->ts;
1120
1121   if (dim != NULL)
1122     {
1123       f->rank = array->rank - 1;
1124       gfc_resolve_dim_arg (dim);
1125     }
1126
1127   f->value.function.name =
1128     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1129                     gfc_type_letter (array->ts.type), array->ts.kind);
1130 }
1131
1132
1133 void
1134 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1135 {
1136   f->ts.type = BT_REAL;
1137
1138   if (kind != NULL)
1139     f->ts.kind = mpz_get_si (kind->value.integer);
1140   else
1141     f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1142       a->ts.kind : gfc_default_real_kind;
1143
1144   f->value.function.name =
1145     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1146                     gfc_type_letter (a->ts.type), a->ts.kind);
1147 }
1148
1149
1150 void
1151 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1152                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1153 {
1154   f->ts.type = BT_INTEGER;
1155   f->ts.kind = gfc_default_integer_kind;
1156   f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1157 }
1158
1159
1160 void
1161 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1162                     gfc_expr * ncopies ATTRIBUTE_UNUSED)
1163 {
1164   f->ts.type = BT_CHARACTER;
1165   f->ts.kind = string->ts.kind;
1166   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1167 }
1168
1169
1170 void
1171 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1172                      gfc_expr * pad ATTRIBUTE_UNUSED,
1173                      gfc_expr * order ATTRIBUTE_UNUSED)
1174 {
1175   mpz_t rank;
1176   int kind;
1177   int i;
1178
1179   f->ts = source->ts;
1180
1181   gfc_array_size (shape, &rank);
1182   f->rank = mpz_get_si (rank);
1183   mpz_clear (rank);
1184   switch (source->ts.type)
1185     {
1186     case BT_COMPLEX:
1187       kind = source->ts.kind * 2;
1188       break;
1189
1190     case BT_REAL:
1191     case BT_INTEGER:
1192     case BT_LOGICAL:
1193       kind = source->ts.kind;
1194       break;
1195
1196     default:
1197       kind = 0;
1198       break;
1199     }
1200
1201   switch (kind)
1202     {
1203     case 4:
1204     case 8:
1205     /* case 16: */
1206       if (source->ts.type == BT_COMPLEX)
1207         f->value.function.name =
1208           gfc_get_string (PREFIX("reshape_%c%d"),
1209                           gfc_type_letter (BT_COMPLEX), source->ts.kind);
1210       else
1211         f->value.function.name =
1212           gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1213
1214       break;
1215
1216     default:
1217       f->value.function.name = PREFIX("reshape");
1218       break;
1219     }
1220
1221   /* TODO: Make this work with a constant ORDER parameter.  */
1222   if (shape->expr_type == EXPR_ARRAY
1223       && gfc_is_constant_expr (shape)
1224       && order == NULL)
1225     {
1226       gfc_constructor *c;
1227       f->shape = gfc_get_shape (f->rank);
1228       c = shape->value.constructor;
1229       for (i = 0; i < f->rank; i++)
1230         {
1231           mpz_init_set (f->shape[i], c->expr->value.integer);
1232           c = c->next;
1233         }
1234     }
1235
1236   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1237      so many runtime variations.  */
1238   if (shape->ts.kind != gfc_index_integer_kind)
1239     {
1240       gfc_typespec ts = shape->ts;
1241       ts.kind = gfc_index_integer_kind;
1242       gfc_convert_type_warn (shape, &ts, 2, 0);
1243     }
1244   if (order && order->ts.kind != gfc_index_integer_kind)
1245     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1246 }
1247
1248
1249 void
1250 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1251 {
1252   f->ts = x->ts;
1253   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1254 }
1255
1256
1257 void
1258 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1259 {
1260   f->ts = x->ts;
1261
1262   /* The implementation calls scalbn which takes an int as the
1263      second argument.  */
1264   if (i->ts.kind != gfc_c_int_kind)
1265     {
1266       gfc_typespec ts;
1267
1268       ts.type = BT_INTEGER;
1269       ts.kind = gfc_default_integer_kind;
1270
1271       gfc_convert_type_warn (i, &ts, 2, 0);
1272     }
1273
1274   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1275 }
1276
1277
1278 void
1279 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1280                   gfc_expr * set ATTRIBUTE_UNUSED,
1281                   gfc_expr * back ATTRIBUTE_UNUSED)
1282 {
1283   f->ts.type = BT_INTEGER;
1284   f->ts.kind = gfc_default_integer_kind;
1285   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1286 }
1287
1288
1289 void
1290 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1291 {
1292   f->ts = x->ts;
1293
1294   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1295      convert type so we don't have to implement all possible
1296      permutations.  */
1297   if (i->ts.kind != 4)
1298     {
1299       gfc_typespec ts;
1300
1301       ts.type = BT_INTEGER;
1302       ts.kind = gfc_default_integer_kind;
1303
1304       gfc_convert_type_warn (i, &ts, 2, 0);
1305     }
1306
1307   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1308 }
1309
1310
1311 void
1312 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1313 {
1314   f->ts.type = BT_INTEGER;
1315   f->ts.kind = gfc_default_integer_kind;
1316   f->rank = 1;
1317   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1318   f->shape = gfc_get_shape (1);
1319   mpz_init_set_ui (f->shape[0], array->rank);
1320 }
1321
1322
1323 void
1324 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1325 {
1326   f->ts = a->ts;
1327   f->value.function.name =
1328     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1329 }
1330
1331
1332 void
1333 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1334 {
1335   f->ts = x->ts;
1336   f->value.function.name =
1337     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1338 }
1339
1340
1341 void
1342 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1343 {
1344   f->ts = x->ts;
1345   f->value.function.name =
1346     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1347 }
1348
1349
1350 void
1351 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1352 {
1353   f->ts = x->ts;
1354   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1355 }
1356
1357
1358 void
1359 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1360                     gfc_expr * dim,
1361                     gfc_expr * ncopies)
1362 {
1363   f->ts = source->ts;
1364   f->rank = source->rank + 1;
1365   f->value.function.name = PREFIX("spread");
1366
1367   gfc_resolve_dim_arg (dim);
1368   gfc_resolve_index (ncopies, 1);
1369 }
1370
1371
1372 void
1373 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1374 {
1375   f->ts = x->ts;
1376   f->value.function.name =
1377     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1378 }
1379
1380
1381 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1382
1383 void
1384 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1385                   gfc_expr * a ATTRIBUTE_UNUSED)
1386 {
1387   f->ts.type = BT_INTEGER;
1388   f->ts.kind = gfc_default_integer_kind;
1389   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1390 }
1391
1392
1393 void
1394 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1395 {
1396   f->ts.type = BT_INTEGER;
1397   f->ts.kind = gfc_default_integer_kind;
1398   if (n->ts.kind != f->ts.kind)
1399     gfc_convert_type (n, &f->ts, 2);
1400
1401   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1402 }
1403
1404
1405 void
1406 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1407                  gfc_expr * mask)
1408 {
1409   f->ts = array->ts;
1410
1411   if (dim != NULL)
1412     {
1413       f->rank = array->rank - 1;
1414       gfc_resolve_dim_arg (dim);
1415     }
1416
1417   f->value.function.name =
1418     gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1419                     gfc_type_letter (array->ts.type), array->ts.kind);
1420 }
1421
1422
1423 void
1424 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1425                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1426 {
1427   f->ts.type = BT_INTEGER;
1428   f->ts.kind = gfc_default_integer_kind;
1429   f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1430 }
1431
1432
1433 /* Resolve the g77 compatibility function SYSTEM.  */
1434
1435 void
1436 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1437 {
1438   f->ts.type = BT_INTEGER;
1439   f->ts.kind = 4;
1440   f->value.function.name = gfc_get_string (PREFIX("system"));
1441 }
1442
1443
1444 void
1445 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1446 {
1447   f->ts = x->ts;
1448   f->value.function.name =
1449     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1450 }
1451
1452
1453 void
1454 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1455 {
1456   f->ts = x->ts;
1457   f->value.function.name =
1458     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1459 }
1460
1461
1462 void
1463 gfc_resolve_time (gfc_expr * f)
1464 {
1465   f->ts.type = BT_INTEGER;
1466   f->ts.kind = 4;
1467   f->value.function.name = gfc_get_string (PREFIX("time_func"));
1468 }
1469
1470
1471 void
1472 gfc_resolve_time8 (gfc_expr * f)
1473 {
1474   f->ts.type = BT_INTEGER;
1475   f->ts.kind = 8;
1476   f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1477 }
1478
1479
1480 void
1481 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1482                       gfc_expr * mold, gfc_expr * size)
1483 {
1484   /* TODO: Make this do something meaningful.  */
1485   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1486
1487   f->ts = mold->ts;
1488
1489   if (size == NULL && mold->rank == 0)
1490     {
1491       f->rank = 0;
1492       f->value.function.name = transfer0;
1493     }
1494   else
1495     {
1496       f->rank = 1;
1497       f->value.function.name = transfer1;
1498     }
1499 }
1500
1501
1502 void
1503 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1504 {
1505   int kind;
1506
1507   f->ts = matrix->ts;
1508   f->rank = 2;
1509   if (matrix->shape)
1510     {
1511       f->shape = gfc_get_shape (2);
1512       mpz_init_set (f->shape[0], matrix->shape[1]);
1513       mpz_init_set (f->shape[1], matrix->shape[0]);
1514     }
1515
1516   kind = matrix->ts.kind;
1517
1518   switch (kind)
1519     {
1520     case 4:
1521     case 8:
1522       switch (matrix->ts.type)
1523         {
1524         case BT_COMPLEX:
1525           f->value.function.name =
1526             gfc_get_string (PREFIX("transpose_c%d"), kind);
1527           break;
1528
1529         case BT_INTEGER:
1530         case BT_REAL:
1531         case BT_LOGICAL:
1532           /* Use the integer routines for real and logical cases.  This
1533              assumes they all have the same alignment requirements.  */
1534           f->value.function.name =
1535             gfc_get_string (PREFIX("transpose_i%d"), kind);
1536           break;
1537
1538         default:
1539           f->value.function.name = PREFIX("transpose");
1540           break;
1541         }
1542       break;
1543
1544     default:
1545       f->value.function.name = PREFIX("transpose");
1546     }
1547 }
1548
1549
1550 void
1551 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1552 {
1553   f->ts.type = BT_CHARACTER;
1554   f->ts.kind = string->ts.kind;
1555   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1556 }
1557
1558
1559 void
1560 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1561                     gfc_expr * dim)
1562 {
1563   static char ubound[] = "__ubound";
1564
1565   f->ts.type = BT_INTEGER;
1566   f->ts.kind = gfc_default_integer_kind;
1567
1568   if (dim == NULL)
1569     {
1570       f->rank = 1;
1571       f->shape = gfc_get_shape (1);
1572       mpz_init_set_ui (f->shape[0], array->rank);
1573     }
1574
1575   f->value.function.name = ubound;
1576 }
1577
1578
1579 /* Resolve the g77 compatibility function UMASK.  */
1580
1581 void
1582 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1583 {
1584   f->ts.type = BT_INTEGER;
1585   f->ts.kind = n->ts.kind;
1586   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1587 }
1588
1589
1590 /* Resolve the g77 compatibility function UNLINK.  */
1591
1592 void
1593 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1594 {
1595   f->ts.type = BT_INTEGER;
1596   f->ts.kind = 4;
1597   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1598 }
1599
1600 void
1601 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1602                     gfc_expr * field ATTRIBUTE_UNUSED)
1603 {
1604   f->ts.type = vector->ts.type;
1605   f->ts.kind = vector->ts.kind;
1606   f->rank = mask->rank;
1607
1608   f->value.function.name =
1609     gfc_get_string (PREFIX("unpack%d"), field->rank > 0 ? 1 : 0);
1610 }
1611
1612
1613 void
1614 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1615                     gfc_expr * set ATTRIBUTE_UNUSED,
1616                     gfc_expr * back ATTRIBUTE_UNUSED)
1617 {
1618   f->ts.type = BT_INTEGER;
1619   f->ts.kind = gfc_default_integer_kind;
1620   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1621 }
1622
1623
1624 /* Intrinsic subroutine resolution.  */
1625
1626 void
1627 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1628 {
1629   const char *name;
1630
1631   name = gfc_get_string (PREFIX("cpu_time_%d"),
1632                          c->ext.actual->expr->ts.kind);
1633   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1634 }
1635
1636
1637 void
1638 gfc_resolve_mvbits (gfc_code * c)
1639 {
1640   const char *name;
1641   int kind;
1642
1643   kind = c->ext.actual->expr->ts.kind;
1644   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1645
1646   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1647 }
1648
1649
1650 void
1651 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1652 {
1653   const char *name;
1654   int kind;
1655
1656   kind = c->ext.actual->expr->ts.kind;
1657   if (c->ext.actual->expr->rank == 0)
1658     name = gfc_get_string (PREFIX("random_r%d"), kind);
1659   else
1660     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1661
1662   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1663 }
1664
1665
1666 void
1667 gfc_resolve_rename_sub (gfc_code * c)
1668 {
1669   const char *name;
1670   int kind;
1671
1672   if (c->ext.actual->next->next->expr != NULL)
1673     kind = c->ext.actual->next->next->expr->ts.kind;
1674   else
1675     kind = gfc_default_integer_kind;
1676
1677   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
1678   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1679 }
1680
1681
1682 void
1683 gfc_resolve_kill_sub (gfc_code * c)
1684 {
1685   const char *name;
1686   int kind;
1687
1688   if (c->ext.actual->next->next->expr != NULL)
1689     kind = c->ext.actual->next->next->expr->ts.kind;
1690   else
1691     kind = gfc_default_integer_kind;
1692
1693   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
1694   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1695 }
1696
1697
1698 void
1699 gfc_resolve_link_sub (gfc_code * c)
1700 {
1701   const char *name;
1702   int kind;
1703
1704   if (c->ext.actual->next->next->expr != NULL)
1705     kind = c->ext.actual->next->next->expr->ts.kind;
1706   else
1707     kind = gfc_default_integer_kind;
1708
1709   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
1710   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1711 }
1712
1713
1714 void
1715 gfc_resolve_symlnk_sub (gfc_code * c)
1716 {
1717   const char *name;
1718   int kind;
1719
1720   if (c->ext.actual->next->next->expr != NULL)
1721     kind = c->ext.actual->next->next->expr->ts.kind;
1722   else
1723     kind = gfc_default_integer_kind;
1724
1725   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
1726   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1727 }
1728
1729
1730 /* G77 compatibility subroutines etime() and dtime().  */
1731
1732 void
1733 gfc_resolve_etime_sub (gfc_code * c)
1734 {
1735   const char *name;
1736
1737   name = gfc_get_string (PREFIX("etime_sub"));
1738   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1739 }
1740
1741
1742 /* G77 compatibility subroutine second().  */
1743
1744 void
1745 gfc_resolve_second_sub (gfc_code * c)
1746 {
1747   const char *name;
1748
1749   name = gfc_get_string (PREFIX("second_sub"));
1750   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1751 }
1752
1753
1754 void
1755 gfc_resolve_sleep_sub (gfc_code * c)
1756 {
1757   const char *name;
1758   int kind;
1759
1760   if (c->ext.actual->expr != NULL)
1761     kind = c->ext.actual->expr->ts.kind;
1762   else
1763     kind = gfc_default_integer_kind;
1764
1765   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
1766   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1767 }
1768
1769
1770 /* G77 compatibility function srand().  */
1771
1772 void
1773 gfc_resolve_srand (gfc_code * c)
1774 {
1775   const char *name;
1776   name = gfc_get_string (PREFIX("srand"));
1777   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1778 }
1779
1780
1781 /* Resolve the getarg intrinsic subroutine.  */
1782
1783 void
1784 gfc_resolve_getarg (gfc_code * c)
1785 {
1786   const char *name;
1787   int kind;
1788
1789   kind = gfc_default_integer_kind;
1790   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1791   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1792 }
1793
1794 /* Resolve the getcwd intrinsic subroutine.  */
1795
1796 void
1797 gfc_resolve_getcwd_sub (gfc_code * c)
1798 {
1799   const char *name;
1800   int kind;
1801
1802   if (c->ext.actual->next->expr != NULL)
1803     kind = c->ext.actual->next->expr->ts.kind;
1804   else
1805     kind = gfc_default_integer_kind;
1806
1807   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1808   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1809 }
1810
1811
1812 /* Resolve the get_command intrinsic subroutine.  */
1813
1814 void
1815 gfc_resolve_get_command (gfc_code * c)
1816 {
1817   const char *name;
1818   int kind;
1819
1820   kind = gfc_default_integer_kind;
1821   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1822   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1823 }
1824
1825
1826 /* Resolve the get_command_argument intrinsic subroutine.  */
1827
1828 void
1829 gfc_resolve_get_command_argument (gfc_code * c)
1830 {
1831   const char *name;
1832   int kind;
1833
1834   kind = gfc_default_integer_kind;
1835   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1836   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1837 }
1838
1839 /* Resolve the get_environment_variable intrinsic subroutine.  */
1840
1841 void
1842 gfc_resolve_get_environment_variable (gfc_code * code)
1843 {
1844   const char *name;
1845   int kind;
1846
1847   kind = gfc_default_integer_kind;
1848   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1849   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1850 }
1851
1852 /* Resolve the SYSTEM intrinsic subroutine.  */
1853
1854 void
1855 gfc_resolve_system_sub (gfc_code * c)
1856 {
1857   const char *name;
1858
1859   name = gfc_get_string (PREFIX("system_sub"));
1860   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1861 }
1862
1863 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1864
1865 void
1866 gfc_resolve_system_clock (gfc_code * c)
1867 {
1868   const char *name;
1869   int kind;
1870
1871   if (c->ext.actual->expr != NULL)
1872     kind = c->ext.actual->expr->ts.kind;
1873   else if (c->ext.actual->next->expr != NULL)
1874       kind = c->ext.actual->next->expr->ts.kind;
1875   else if (c->ext.actual->next->next->expr != NULL)
1876       kind = c->ext.actual->next->next->expr->ts.kind;
1877   else
1878     kind = gfc_default_integer_kind;
1879
1880   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1881   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1882 }
1883
1884 /* Resolve the EXIT intrinsic subroutine.  */
1885
1886 void
1887 gfc_resolve_exit (gfc_code * c)
1888 {
1889   const char *name;
1890   int kind;
1891
1892   if (c->ext.actual->expr != NULL)
1893     kind = c->ext.actual->expr->ts.kind;
1894   else
1895     kind = gfc_default_integer_kind;
1896
1897   name = gfc_get_string (PREFIX("exit_i%d"), kind);
1898   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1899 }
1900
1901 /* Resolve the FLUSH intrinsic subroutine.  */
1902
1903 void
1904 gfc_resolve_flush (gfc_code * c)
1905 {
1906   const char *name;
1907   gfc_typespec ts;
1908   gfc_expr *n;
1909
1910   ts.type = BT_INTEGER;
1911   ts.kind = gfc_default_integer_kind;
1912   n = c->ext.actual->expr;
1913   if (n != NULL
1914       && n->ts.kind != ts.kind)
1915     gfc_convert_type (n, &ts, 2);
1916
1917   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1918   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1919 }
1920
1921
1922 void
1923 gfc_resolve_gerror (gfc_code * c)
1924 {
1925   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
1926 }
1927
1928
1929 void
1930 gfc_resolve_getlog (gfc_code * c)
1931 {
1932   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
1933 }
1934
1935
1936 void
1937 gfc_resolve_hostnm_sub (gfc_code * c)
1938 {
1939   const char *name;
1940   int kind;
1941
1942   if (c->ext.actual->next->expr != NULL)
1943     kind = c->ext.actual->next->expr->ts.kind;
1944   else
1945     kind = gfc_default_integer_kind;
1946
1947   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
1948   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1949 }
1950
1951
1952 void
1953 gfc_resolve_perror (gfc_code * c)
1954 {
1955   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
1956 }
1957
1958 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
1959
1960 void
1961 gfc_resolve_stat_sub (gfc_code * c)
1962 {
1963   const char *name;
1964
1965   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
1966   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1967 }
1968
1969
1970 void
1971 gfc_resolve_fstat_sub (gfc_code * c)
1972 {
1973   const char *name;
1974   gfc_expr *u;
1975   gfc_typespec *ts;
1976
1977   u = c->ext.actual->expr;
1978   ts = &c->ext.actual->next->expr->ts;
1979   if (u->ts.kind != ts->kind)
1980     gfc_convert_type (u, ts, 2);
1981   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
1982   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1983 }
1984
1985
1986 void
1987 gfc_resolve_ttynam_sub (gfc_code * c)
1988 {
1989   gfc_typespec ts;
1990
1991   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
1992     {
1993       ts.type = BT_INTEGER;
1994       ts.kind = gfc_c_int_kind;
1995       ts.derived = NULL;
1996       ts.cl = NULL;
1997       gfc_convert_type (c->ext.actual->expr, &ts, 2);
1998     }
1999
2000   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2001 }
2002
2003
2004 /* Resolve the UMASK intrinsic subroutine.  */
2005
2006 void
2007 gfc_resolve_umask_sub (gfc_code * c)
2008 {
2009   const char *name;
2010   int kind;
2011
2012   if (c->ext.actual->next->expr != NULL)
2013     kind = c->ext.actual->next->expr->ts.kind;
2014   else
2015     kind = gfc_default_integer_kind;
2016
2017   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2018   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2019 }
2020
2021 /* Resolve the UNLINK intrinsic subroutine.  */
2022
2023 void
2024 gfc_resolve_unlink_sub (gfc_code * c)
2025 {
2026   const char *name;
2027   int kind;
2028
2029   if (c->ext.actual->next->expr != NULL)
2030     kind = c->ext.actual->next->expr->ts.kind;
2031   else
2032     kind = gfc_default_integer_kind;
2033
2034   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2035   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2036 }