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