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