gcc/fortran/iresolve.c

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