gcc/fortran/iresolve.c

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