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