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