gcc/fortran/iresolve.c

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