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