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