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