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