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