gcc/fortran/iresolve.c

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