1/* Intrinsic translation 2 Copyright (C) 2002-2015 Free Software Foundation, Inc. 3 Contributed by Paul Brook <paul@nowt.org> 4 and Steven Bosscher <s.bosscher@student.tudelft.nl> 5 6This file is part of GCC. 7 8GCC is free software; you can redistribute it and/or modify it under 9the terms of the GNU General Public License as published by the Free 10Software Foundation; either version 3, or (at your option) any later 11version. 12 13GCC is distributed in the hope that it will be useful, but WITHOUT ANY 14WARRANTY; without even the implied warranty of MERCHANTABILITY or 15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 16for more details. 17 18You should have received a copy of the GNU General Public License 19along with GCC; see the file COPYING3. If not see 20<http://www.gnu.org/licenses/>. */ 21 22/* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */ 23 24#include "config.h" 25#include "system.h" 26#include "coretypes.h" 27#include "tm.h" /* For UNITS_PER_WORD. */ 28#include "hash-set.h" 29#include "machmode.h" 30#include "vec.h" 31#include "double-int.h" 32#include "input.h" 33#include "alias.h" 34#include "symtab.h" 35#include "wide-int.h" 36#include "inchash.h" 37#include "real.h" 38#include "tree.h" 39#include "fold-const.h" 40#include "stringpool.h" 41#include "tree-nested.h" 42#include "stor-layout.h" 43#include "ggc.h" 44#include "gfortran.h" 45#include "diagnostic-core.h" /* For internal_error. */ 46#include "toplev.h" /* For rest_of_decl_compilation. */ 47#include "flags.h" 48#include "arith.h" 49#include "intrinsic.h" 50#include "trans.h" 51#include "trans-const.h" 52#include "trans-types.h" 53#include "trans-array.h" 54#include "dependency.h" /* For CAF array alias analysis. */ 55/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ 56#include "trans-stmt.h" 57#include "tree-nested.h" 58 59/* This maps Fortran intrinsic math functions to external library or GCC 60 builtin functions. */ 61typedef struct GTY(()) gfc_intrinsic_map_t { 62 /* The explicit enum is required to work around inadequacies in the 63 garbage collection/gengtype parsing mechanism. */ 64 enum gfc_isym_id id; 65 66 /* Enum value from the "language-independent", aka C-centric, part 67 of gcc, or END_BUILTINS of no such value set. */ 68 enum built_in_function float_built_in; 69 enum built_in_function double_built_in; 70 enum built_in_function long_double_built_in; 71 enum built_in_function complex_float_built_in; 72 enum built_in_function complex_double_built_in; 73 enum built_in_function complex_long_double_built_in; 74 75 /* True if the naming pattern is to prepend "c" for complex and 76 append "f" for kind=4. False if the naming pattern is to 77 prepend "_gfortran_" and append "[rc](4|8|10|16)". */ 78 bool libm_name; 79 80 /* True if a complex version of the function exists. */ 81 bool complex_available; 82 83 /* True if the function should be marked const. */ 84 bool is_constant; 85 86 /* The base library name of this function. */ 87 const char *name; 88 89 /* Cache decls created for the various operand types. */ 90 tree real4_decl; 91 tree real8_decl; 92 tree real10_decl; 93 tree real16_decl; 94 tree complex4_decl; 95 tree complex8_decl; 96 tree complex10_decl; 97 tree complex16_decl; 98} 99gfc_intrinsic_map_t; 100 101/* ??? The NARGS==1 hack here is based on the fact that (c99 at least) 102 defines complex variants of all of the entries in mathbuiltins.def 103 except for atan2. */ 104#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \ 105 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ 106 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ 107 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ 108 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, 109 110#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \ 111 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ 112 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \ 113 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \ 114 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, 115 116#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \ 117 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ 118 END_BUILTINS, END_BUILTINS, END_BUILTINS, \ 119 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ 120 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } 121 122#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \ 123 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ 124 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ 125 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \ 126 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, 127 128static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = 129{ 130 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and 131 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond 132 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */ 133#include "mathbuiltins.def" 134 135 /* Functions in libgfortran. */ 136 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false), 137 138 /* End the list. */ 139 LIB_FUNCTION (NONE, NULL, false) 140 141}; 142#undef OTHER_BUILTIN 143#undef LIB_FUNCTION 144#undef DEFINE_MATH_BUILTIN 145#undef DEFINE_MATH_BUILTIN_C 146 147 148enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR }; 149 150 151/* Find the correct variant of a given builtin from its argument. */ 152static tree 153builtin_decl_for_precision (enum built_in_function base_built_in, 154 int precision) 155{ 156 enum built_in_function i = END_BUILTINS; 157 158 gfc_intrinsic_map_t *m; 159 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++) 160 ; 161 162 if (precision == TYPE_PRECISION (float_type_node)) 163 i = m->float_built_in; 164 else if (precision == TYPE_PRECISION (double_type_node)) 165 i = m->double_built_in; 166 else if (precision == TYPE_PRECISION (long_double_type_node)) 167 i = m->long_double_built_in; 168 else if (precision == TYPE_PRECISION (float128_type_node)) 169 { 170 /* Special treatment, because it is not exactly a built-in, but 171 a library function. */ 172 return m->real16_decl; 173 } 174 175 return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i)); 176} 177 178 179tree 180gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in, 181 int kind) 182{ 183 int i = gfc_validate_kind (BT_REAL, kind, false); 184 185 if (gfc_real_kinds[i].c_float128) 186 { 187 /* For __float128, the story is a bit different, because we return 188 a decl to a library function rather than a built-in. */ 189 gfc_intrinsic_map_t *m; 190 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++) 191 ; 192 193 return m->real16_decl; 194 } 195 196 return builtin_decl_for_precision (double_built_in, 197 gfc_real_kinds[i].mode_precision); 198} 199 200 201/* Evaluate the arguments to an intrinsic function. The value 202 of NARGS may be less than the actual number of arguments in EXPR 203 to allow optional "KIND" arguments that are not included in the 204 generated code to be ignored. */ 205 206static void 207gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr, 208 tree *argarray, int nargs) 209{ 210 gfc_actual_arglist *actual; 211 gfc_expr *e; 212 gfc_intrinsic_arg *formal; 213 gfc_se argse; 214 int curr_arg; 215 216 formal = expr->value.function.isym->formal; 217 actual = expr->value.function.actual; 218 219 for (curr_arg = 0; curr_arg < nargs; curr_arg++, 220 actual = actual->next, 221 formal = formal ? formal->next : NULL) 222 { 223 gcc_assert (actual); 224 e = actual->expr; 225 /* Skip omitted optional arguments. */ 226 if (!e) 227 { 228 --curr_arg; 229 continue; 230 } 231 232 /* Evaluate the parameter. This will substitute scalarized 233 references automatically. */ 234 gfc_init_se (&argse, se); 235 236 if (e->ts.type == BT_CHARACTER) 237 { 238 gfc_conv_expr (&argse, e); 239 gfc_conv_string_parameter (&argse); 240 argarray[curr_arg++] = argse.string_length; 241 gcc_assert (curr_arg < nargs); 242 } 243 else 244 gfc_conv_expr_val (&argse, e); 245 246 /* If an optional argument is itself an optional dummy argument, 247 check its presence and substitute a null if absent. */ 248 if (e->expr_type == EXPR_VARIABLE 249 && e->symtree->n.sym->attr.optional 250 && formal 251 && formal->optional) 252 gfc_conv_missing_dummy (&argse, e, formal->ts, 0); 253 254 gfc_add_block_to_block (&se->pre, &argse.pre); 255 gfc_add_block_to_block (&se->post, &argse.post); 256 argarray[curr_arg] = argse.expr; 257 } 258} 259 260/* Count the number of actual arguments to the intrinsic function EXPR 261 including any "hidden" string length arguments. */ 262 263static unsigned int 264gfc_intrinsic_argument_list_length (gfc_expr *expr) 265{ 266 int n = 0; 267 gfc_actual_arglist *actual; 268 269 for (actual = expr->value.function.actual; actual; actual = actual->next) 270 { 271 if (!actual->expr) 272 continue; 273 274 if (actual->expr->ts.type == BT_CHARACTER) 275 n += 2; 276 else 277 n++; 278 } 279 280 return n; 281} 282 283 284/* Conversions between different types are output by the frontend as 285 intrinsic functions. We implement these directly with inline code. */ 286 287static void 288gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) 289{ 290 tree type; 291 tree *args; 292 int nargs; 293 294 nargs = gfc_intrinsic_argument_list_length (expr); 295 args = XALLOCAVEC (tree, nargs); 296 297 /* Evaluate all the arguments passed. Whilst we're only interested in the 298 first one here, there are other parts of the front-end that assume this 299 and will trigger an ICE if it's not the case. */ 300 type = gfc_typenode_for_spec (&expr->ts); 301 gcc_assert (expr->value.function.actual->expr); 302 gfc_conv_intrinsic_function_args (se, expr, args, nargs); 303 304 /* Conversion between character kinds involves a call to a library 305 function. */ 306 if (expr->ts.type == BT_CHARACTER) 307 { 308 tree fndecl, var, addr, tmp; 309 310 if (expr->ts.kind == 1 311 && expr->value.function.actual->expr->ts.kind == 4) 312 fndecl = gfor_fndecl_convert_char4_to_char1; 313 else if (expr->ts.kind == 4 314 && expr->value.function.actual->expr->ts.kind == 1) 315 fndecl = gfor_fndecl_convert_char1_to_char4; 316 else 317 gcc_unreachable (); 318 319 /* Create the variable storing the converted value. */ 320 type = gfc_get_pchar_type (expr->ts.kind); 321 var = gfc_create_var (type, "str"); 322 addr = gfc_build_addr_expr (build_pointer_type (type), var); 323 324 /* Call the library function that will perform the conversion. */ 325 gcc_assert (nargs >= 2); 326 tmp = build_call_expr_loc (input_location, 327 fndecl, 3, addr, args[0], args[1]); 328 gfc_add_expr_to_block (&se->pre, tmp); 329 330 /* Free the temporary afterwards. */ 331 tmp = gfc_call_free (var); 332 gfc_add_expr_to_block (&se->post, tmp); 333 334 se->expr = var; 335 se->string_length = args[0]; 336 337 return; 338 } 339 340 /* Conversion from complex to non-complex involves taking the real 341 component of the value. */ 342 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE 343 && expr->ts.type != BT_COMPLEX) 344 { 345 tree artype; 346 347 artype = TREE_TYPE (TREE_TYPE (args[0])); 348 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype, 349 args[0]); 350 } 351 352 se->expr = convert (type, args[0]); 353} 354 355/* This is needed because the gcc backend only implements 356 FIX_TRUNC_EXPR, which is the same as INT() in Fortran. 357 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1 358 Similarly for CEILING. */ 359 360static tree 361build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up) 362{ 363 tree tmp; 364 tree cond; 365 tree argtype; 366 tree intval; 367 368 argtype = TREE_TYPE (arg); 369 arg = gfc_evaluate_now (arg, pblock); 370 371 intval = convert (type, arg); 372 intval = gfc_evaluate_now (intval, pblock); 373 374 tmp = convert (argtype, intval); 375 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR, 376 boolean_type_node, tmp, arg); 377 378 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type, 379 intval, build_int_cst (type, 1)); 380 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp); 381 return tmp; 382} 383 384 385/* Round to nearest integer, away from zero. */ 386 387static tree 388build_round_expr (tree arg, tree restype) 389{ 390 tree argtype; 391 tree fn; 392 int argprec, resprec; 393 394 argtype = TREE_TYPE (arg); 395 argprec = TYPE_PRECISION (argtype); 396 resprec = TYPE_PRECISION (restype); 397 398 /* Depending on the type of the result, choose the int intrinsic 399 (iround, available only as a builtin, therefore cannot use it for 400 __float128), long int intrinsic (lround family) or long long 401 intrinsic (llround). We might also need to convert the result 402 afterwards. */ 403 if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE) 404 fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec); 405 else if (resprec <= LONG_TYPE_SIZE) 406 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec); 407 else if (resprec <= LONG_LONG_TYPE_SIZE) 408 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec); 409 else 410 gcc_unreachable (); 411 412 return fold_convert (restype, build_call_expr_loc (input_location, 413 fn, 1, arg)); 414} 415 416 417/* Convert a real to an integer using a specific rounding mode. 418 Ideally we would just build the corresponding GENERIC node, 419 however the RTL expander only actually supports FIX_TRUNC_EXPR. */ 420 421static tree 422build_fix_expr (stmtblock_t * pblock, tree arg, tree type, 423 enum rounding_mode op) 424{ 425 switch (op) 426 { 427 case RND_FLOOR: 428 return build_fixbound_expr (pblock, arg, type, 0); 429 break; 430 431 case RND_CEIL: 432 return build_fixbound_expr (pblock, arg, type, 1); 433 break; 434 435 case RND_ROUND: 436 return build_round_expr (arg, type); 437 break; 438 439 case RND_TRUNC: 440 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg); 441 break; 442 443 default: 444 gcc_unreachable (); 445 } 446} 447 448 449/* Round a real value using the specified rounding mode. 450 We use a temporary integer of that same kind size as the result. 451 Values larger than those that can be represented by this kind are 452 unchanged, as they will not be accurate enough to represent the 453 rounding. 454 huge = HUGE (KIND (a)) 455 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a 456 */ 457 458static void 459gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) 460{ 461 tree type; 462 tree itype; 463 tree arg[2]; 464 tree tmp; 465 tree cond; 466 tree decl; 467 mpfr_t huge; 468 int n, nargs; 469 int kind; 470 471 kind = expr->ts.kind; 472 nargs = gfc_intrinsic_argument_list_length (expr); 473 474 decl = NULL_TREE; 475 /* We have builtin functions for some cases. */ 476 switch (op) 477 { 478 case RND_ROUND: 479 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind); 480 break; 481 482 case RND_TRUNC: 483 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind); 484 break; 485 486 default: 487 gcc_unreachable (); 488 } 489 490 /* Evaluate the argument. */ 491 gcc_assert (expr->value.function.actual->expr); 492 gfc_conv_intrinsic_function_args (se, expr, arg, nargs); 493 494 /* Use a builtin function if one exists. */ 495 if (decl != NULL_TREE) 496 { 497 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]); 498 return; 499 } 500 501 /* This code is probably redundant, but we'll keep it lying around just 502 in case. */ 503 type = gfc_typenode_for_spec (&expr->ts); 504 arg[0] = gfc_evaluate_now (arg[0], &se->pre); 505 506 /* Test if the value is too large to handle sensibly. */ 507 gfc_set_model_kind (kind); 508 mpfr_init (huge); 509 n = gfc_validate_kind (BT_INTEGER, kind, false); 510 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); 511 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); 512 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0], 513 tmp); 514 515 mpfr_neg (huge, huge, GFC_RND_MODE); 516 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); 517 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0], 518 tmp); 519 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, 520 cond, tmp); 521 itype = gfc_get_int_type (kind); 522 523 tmp = build_fix_expr (&se->pre, arg[0], itype, op); 524 tmp = convert (type, tmp); 525 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp, 526 arg[0]); 527 mpfr_clear (huge); 528} 529 530 531/* Convert to an integer using the specified rounding mode. */ 532 533static void 534gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op) 535{ 536 tree type; 537 tree *args; 538 int nargs; 539 540 nargs = gfc_intrinsic_argument_list_length (expr); 541 args = XALLOCAVEC (tree, nargs); 542 543 /* Evaluate the argument, we process all arguments even though we only 544 use the first one for code generation purposes. */ 545 type = gfc_typenode_for_spec (&expr->ts); 546 gcc_assert (expr->value.function.actual->expr); 547 gfc_conv_intrinsic_function_args (se, expr, args, nargs); 548 549 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE) 550 { 551 /* Conversion to a different integer kind. */ 552 se->expr = convert (type, args[0]); 553 } 554 else 555 { 556 /* Conversion from complex to non-complex involves taking the real 557 component of the value. */ 558 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE 559 && expr->ts.type != BT_COMPLEX) 560 { 561 tree artype; 562 563 artype = TREE_TYPE (TREE_TYPE (args[0])); 564 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype, 565 args[0]); 566 } 567 568 se->expr = build_fix_expr (&se->pre, args[0], type, op); 569 } 570} 571 572 573/* Get the imaginary component of a value. */ 574 575static void 576gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr) 577{ 578 tree arg; 579 580 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 581 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR, 582 TREE_TYPE (TREE_TYPE (arg)), arg); 583} 584 585 586/* Get the complex conjugate of a value. */ 587 588static void 589gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr) 590{ 591 tree arg; 592 593 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 594 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg); 595} 596 597 598 599static tree 600define_quad_builtin (const char *name, tree type, bool is_const) 601{ 602 tree fndecl; 603 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name), 604 type); 605 606 /* Mark the decl as external. */ 607 DECL_EXTERNAL (fndecl) = 1; 608 TREE_PUBLIC (fndecl) = 1; 609 610 /* Mark it __attribute__((const)). */ 611 TREE_READONLY (fndecl) = is_const; 612 613 rest_of_decl_compilation (fndecl, 1, 0); 614 615 return fndecl; 616} 617 618 619 620/* Initialize function decls for library functions. The external functions 621 are created as required. Builtin functions are added here. */ 622 623void 624gfc_build_intrinsic_lib_fndecls (void) 625{ 626 gfc_intrinsic_map_t *m; 627 tree quad_decls[END_BUILTINS + 1]; 628 629 if (gfc_real16_is_float128) 630 { 631 /* If we have soft-float types, we create the decls for their 632 C99-like library functions. For now, we only handle __float128 633 q-suffixed functions. */ 634 635 tree type, complex_type, func_1, func_2, func_cabs, func_frexp; 636 tree func_iround, func_lround, func_llround, func_scalbn, func_cpow; 637 638 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1)); 639 640 type = float128_type_node; 641 complex_type = complex_float128_type_node; 642 /* type (*) (type) */ 643 func_1 = build_function_type_list (type, type, NULL_TREE); 644 /* int (*) (type) */ 645 func_iround = build_function_type_list (integer_type_node, 646 type, NULL_TREE); 647 /* long (*) (type) */ 648 func_lround = build_function_type_list (long_integer_type_node, 649 type, NULL_TREE); 650 /* long long (*) (type) */ 651 func_llround = build_function_type_list (long_long_integer_type_node, 652 type, NULL_TREE); 653 /* type (*) (type, type) */ 654 func_2 = build_function_type_list (type, type, type, NULL_TREE); 655 /* type (*) (type, &int) */ 656 func_frexp 657 = build_function_type_list (type, 658 type, 659 build_pointer_type (integer_type_node), 660 NULL_TREE); 661 /* type (*) (type, int) */ 662 func_scalbn = build_function_type_list (type, 663 type, integer_type_node, NULL_TREE); 664 /* type (*) (complex type) */ 665 func_cabs = build_function_type_list (type, complex_type, NULL_TREE); 666 /* complex type (*) (complex type, complex type) */ 667 func_cpow 668 = build_function_type_list (complex_type, 669 complex_type, complex_type, NULL_TREE); 670 671#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) 672#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) 673#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) 674 675 /* Only these built-ins are actually needed here. These are used directly 676 from the code, when calling builtin_decl_for_precision() or 677 builtin_decl_for_float_type(). The others are all constructed by 678 gfc_get_intrinsic_lib_fndecl(). */ 679#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \ 680 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST); 681 682#include "mathbuiltins.def" 683 684#undef OTHER_BUILTIN 685#undef LIB_FUNCTION 686#undef DEFINE_MATH_BUILTIN 687#undef DEFINE_MATH_BUILTIN_C 688 689 } 690 691 /* Add GCC builtin functions. */ 692 for (m = gfc_intrinsic_map; 693 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) 694 { 695 if (m->float_built_in != END_BUILTINS) 696 m->real4_decl = builtin_decl_explicit (m->float_built_in); 697 if (m->complex_float_built_in != END_BUILTINS) 698 m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in); 699 if (m->double_built_in != END_BUILTINS) 700 m->real8_decl = builtin_decl_explicit (m->double_built_in); 701 if (m->complex_double_built_in != END_BUILTINS) 702 m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in); 703 704 /* If real(kind=10) exists, it is always long double. */ 705 if (m->long_double_built_in != END_BUILTINS) 706 m->real10_decl = builtin_decl_explicit (m->long_double_built_in); 707 if (m->complex_long_double_built_in != END_BUILTINS) 708 m->complex10_decl 709 = builtin_decl_explicit (m->complex_long_double_built_in); 710 711 if (!gfc_real16_is_float128) 712 { 713 if (m->long_double_built_in != END_BUILTINS) 714 m->real16_decl = builtin_decl_explicit (m->long_double_built_in); 715 if (m->complex_long_double_built_in != END_BUILTINS) 716 m->complex16_decl 717 = builtin_decl_explicit (m->complex_long_double_built_in); 718 } 719 else if (quad_decls[m->double_built_in] != NULL_TREE) 720 { 721 /* Quad-precision function calls are constructed when first 722 needed by builtin_decl_for_precision(), except for those 723 that will be used directly (define by OTHER_BUILTIN). */ 724 m->real16_decl = quad_decls[m->double_built_in]; 725 } 726 else if (quad_decls[m->complex_double_built_in] != NULL_TREE) 727 { 728 /* Same thing for the complex ones. */ 729 m->complex16_decl = quad_decls[m->double_built_in]; 730 } 731 } 732} 733 734 735/* Create a fndecl for a simple intrinsic library function. */ 736 737static tree 738gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) 739{ 740 tree type; 741 vec<tree, va_gc> *argtypes; 742 tree fndecl; 743 gfc_actual_arglist *actual; 744 tree *pdecl; 745 gfc_typespec *ts; 746 char name[GFC_MAX_SYMBOL_LEN + 3]; 747 748 ts = &expr->ts; 749 if (ts->type == BT_REAL) 750 { 751 switch (ts->kind) 752 { 753 case 4: 754 pdecl = &m->real4_decl; 755 break; 756 case 8: 757 pdecl = &m->real8_decl; 758 break; 759 case 10: 760 pdecl = &m->real10_decl; 761 break; 762 case 16: 763 pdecl = &m->real16_decl; 764 break; 765 default: 766 gcc_unreachable (); 767 } 768 } 769 else if (ts->type == BT_COMPLEX) 770 { 771 gcc_assert (m->complex_available); 772 773 switch (ts->kind) 774 { 775 case 4: 776 pdecl = &m->complex4_decl; 777 break; 778 case 8: 779 pdecl = &m->complex8_decl; 780 break; 781 case 10: 782 pdecl = &m->complex10_decl; 783 break; 784 case 16: 785 pdecl = &m->complex16_decl; 786 break; 787 default: 788 gcc_unreachable (); 789 } 790 } 791 else 792 gcc_unreachable (); 793 794 if (*pdecl) 795 return *pdecl; 796 797 if (m->libm_name) 798 { 799 int n = gfc_validate_kind (BT_REAL, ts->kind, false); 800 if (gfc_real_kinds[n].c_float) 801 snprintf (name, sizeof (name), "%s%s%s", 802 ts->type == BT_COMPLEX ? "c" : "", m->name, "f"); 803 else if (gfc_real_kinds[n].c_double) 804 snprintf (name, sizeof (name), "%s%s", 805 ts->type == BT_COMPLEX ? "c" : "", m->name); 806 else if (gfc_real_kinds[n].c_long_double) 807 snprintf (name, sizeof (name), "%s%s%s", 808 ts->type == BT_COMPLEX ? "c" : "", m->name, "l"); 809 else if (gfc_real_kinds[n].c_float128) 810 snprintf (name, sizeof (name), "%s%s%s", 811 ts->type == BT_COMPLEX ? "c" : "", m->name, "q"); 812 else 813 gcc_unreachable (); 814 } 815 else 816 { 817 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name, 818 ts->type == BT_COMPLEX ? 'c' : 'r', 819 ts->kind); 820 } 821 822 argtypes = NULL; 823 for (actual = expr->value.function.actual; actual; actual = actual->next) 824 { 825 type = gfc_typenode_for_spec (&actual->expr->ts); 826 vec_safe_push (argtypes, type); 827 } 828 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes); 829 fndecl = build_decl (input_location, 830 FUNCTION_DECL, get_identifier (name), type); 831 832 /* Mark the decl as external. */ 833 DECL_EXTERNAL (fndecl) = 1; 834 TREE_PUBLIC (fndecl) = 1; 835 836 /* Mark it __attribute__((const)), if possible. */ 837 TREE_READONLY (fndecl) = m->is_constant; 838 839 rest_of_decl_compilation (fndecl, 1, 0); 840 841 (*pdecl) = fndecl; 842 return fndecl; 843} 844 845 846/* Convert an intrinsic function into an external or builtin call. */ 847 848static void 849gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) 850{ 851 gfc_intrinsic_map_t *m; 852 tree fndecl; 853 tree rettype; 854 tree *args; 855 unsigned int num_args; 856 gfc_isym_id id; 857 858 id = expr->value.function.isym->id; 859 /* Find the entry for this function. */ 860 for (m = gfc_intrinsic_map; 861 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) 862 { 863 if (id == m->id) 864 break; 865 } 866 867 if (m->id == GFC_ISYM_NONE) 868 { 869 gfc_internal_error ("Intrinsic function %qs (%d) not recognized", 870 expr->value.function.name, id); 871 } 872 873 /* Get the decl and generate the call. */ 874 num_args = gfc_intrinsic_argument_list_length (expr); 875 args = XALLOCAVEC (tree, num_args); 876 877 gfc_conv_intrinsic_function_args (se, expr, args, num_args); 878 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr); 879 rettype = TREE_TYPE (TREE_TYPE (fndecl)); 880 881 fndecl = build_addr (fndecl, current_function_decl); 882 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args); 883} 884 885 886/* If bounds-checking is enabled, create code to verify at runtime that the 887 string lengths for both expressions are the same (needed for e.g. MERGE). 888 If bounds-checking is not enabled, does nothing. */ 889 890void 891gfc_trans_same_strlen_check (const char* intr_name, locus* where, 892 tree a, tree b, stmtblock_t* target) 893{ 894 tree cond; 895 tree name; 896 897 /* If bounds-checking is disabled, do nothing. */ 898 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) 899 return; 900 901 /* Compare the two string lengths. */ 902 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b); 903 904 /* Output the runtime-check. */ 905 name = gfc_build_cstring_const (intr_name); 906 name = gfc_build_addr_expr (pchar_type_node, name); 907 gfc_trans_runtime_check (true, false, cond, target, where, 908 "Unequal character lengths (%ld/%ld) in %s", 909 fold_convert (long_integer_type_node, a), 910 fold_convert (long_integer_type_node, b), name); 911} 912 913 914/* The EXPONENT(X) intrinsic function is translated into 915 int ret; 916 return isfinite(X) ? (frexp (X, &ret) , ret) : huge 917 so that if X is a NaN or infinity, the result is HUGE(0). 918 */ 919 920static void 921gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) 922{ 923 tree arg, type, res, tmp, frexp, cond, huge; 924 int i; 925 926 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, 927 expr->value.function.actual->expr->ts.kind); 928 929 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 930 arg = gfc_evaluate_now (arg, &se->pre); 931 932 i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false); 933 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind); 934 cond = build_call_expr_loc (input_location, 935 builtin_decl_explicit (BUILT_IN_ISFINITE), 936 1, arg); 937 938 res = gfc_create_var (integer_type_node, NULL); 939 tmp = build_call_expr_loc (input_location, frexp, 2, arg, 940 gfc_build_addr_expr (NULL_TREE, res)); 941 tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node, 942 tmp, res); 943 se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node, 944 cond, tmp, huge); 945 946 type = gfc_typenode_for_spec (&expr->ts); 947 se->expr = fold_convert (type, se->expr); 948} 949 950 951/* Fill in the following structure 952 struct caf_vector_t { 953 size_t nvec; // size of the vector 954 union { 955 struct { 956 void *vector; 957 int kind; 958 } v; 959 struct { 960 ptrdiff_t lower_bound; 961 ptrdiff_t upper_bound; 962 ptrdiff_t stride; 963 } triplet; 964 } u; 965 } */ 966 967static void 968conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc, 969 tree lower, tree upper, tree stride, 970 tree vector, int kind, tree nvec) 971{ 972 tree field, type, tmp; 973 974 desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE); 975 type = TREE_TYPE (desc); 976 977 field = gfc_advance_chain (TYPE_FIELDS (type), 0); 978 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 979 desc, field, NULL_TREE); 980 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec)); 981 982 /* Access union. */ 983 field = gfc_advance_chain (TYPE_FIELDS (type), 1); 984 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 985 desc, field, NULL_TREE); 986 type = TREE_TYPE (desc); 987 988 /* Access the inner struct. */ 989 field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1); 990 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 991 desc, field, NULL_TREE); 992 type = TREE_TYPE (desc); 993 994 if (vector != NULL_TREE) 995 { 996 /* Set dim.lower/upper/stride. */ 997 field = gfc_advance_chain (TYPE_FIELDS (type), 0); 998 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 999 desc, field, NULL_TREE); 1000 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector)); 1001 field = gfc_advance_chain (TYPE_FIELDS (type), 1); 1002 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 1003 desc, field, NULL_TREE); 1004 gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind)); 1005 } 1006 else 1007 { 1008 /* Set vector and kind. */ 1009 field = gfc_advance_chain (TYPE_FIELDS (type), 0); 1010 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 1011 desc, field, NULL_TREE); 1012 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower)); 1013 1014 field = gfc_advance_chain (TYPE_FIELDS (type), 1); 1015 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 1016 desc, field, NULL_TREE); 1017 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper)); 1018 1019 field = gfc_advance_chain (TYPE_FIELDS (type), 2); 1020 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 1021 desc, field, NULL_TREE); 1022 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride)); 1023 } 1024} 1025 1026 1027static tree 1028conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar) 1029{ 1030 gfc_se argse; 1031 tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec; 1032 tree lbound, ubound, tmp; 1033 int i; 1034 1035 var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector"); 1036 1037 for (i = 0; i < ar->dimen; i++) 1038 switch (ar->dimen_type[i]) 1039 { 1040 case DIMEN_RANGE: 1041 if (ar->end[i]) 1042 { 1043 gfc_init_se (&argse, NULL); 1044 gfc_conv_expr (&argse, ar->end[i]); 1045 gfc_add_block_to_block (block, &argse.pre); 1046 upper = gfc_evaluate_now (argse.expr, block); 1047 } 1048 else 1049 upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); 1050 if (ar->stride[i]) 1051 { 1052 gfc_init_se (&argse, NULL); 1053 gfc_conv_expr (&argse, ar->stride[i]); 1054 gfc_add_block_to_block (block, &argse.pre); 1055 stride = gfc_evaluate_now (argse.expr, block); 1056 } 1057 else 1058 stride = gfc_index_one_node; 1059 1060 /* Fall through. */ 1061 case DIMEN_ELEMENT: 1062 if (ar->start[i]) 1063 { 1064 gfc_init_se (&argse, NULL); 1065 gfc_conv_expr (&argse, ar->start[i]); 1066 gfc_add_block_to_block (block, &argse.pre); 1067 lower = gfc_evaluate_now (argse.expr, block); 1068 } 1069 else 1070 lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); 1071 if (ar->dimen_type[i] == DIMEN_ELEMENT) 1072 { 1073 upper = lower; 1074 stride = gfc_index_one_node; 1075 } 1076 vector = NULL_TREE; 1077 nvec = size_zero_node; 1078 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride, 1079 vector, 0, nvec); 1080 break; 1081 1082 case DIMEN_VECTOR: 1083 gfc_init_se (&argse, NULL); 1084 argse.descriptor_only = 1; 1085 gfc_conv_expr_descriptor (&argse, ar->start[i]); 1086 gfc_add_block_to_block (block, &argse.pre); 1087 vector = argse.expr; 1088 lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]); 1089 ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]); 1090 nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL); 1091 tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]); 1092 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR, 1093 TREE_TYPE (nvec), nvec, tmp); 1094 lower = gfc_index_zero_node; 1095 upper = gfc_index_zero_node; 1096 stride = gfc_index_zero_node; 1097 vector = gfc_conv_descriptor_data_get (vector); 1098 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride, 1099 vector, ar->start[i]->ts.kind, nvec); 1100 break; 1101 default: 1102 gcc_unreachable(); 1103 } 1104 return gfc_build_addr_expr (NULL_TREE, var); 1105} 1106 1107 1108/* Get data from a remote coarray. */ 1109 1110static void 1111gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, 1112 tree may_require_tmp) 1113{ 1114 gfc_expr *array_expr; 1115 gfc_se argse; 1116 tree caf_decl, token, offset, image_index, tmp; 1117 tree res_var, dst_var, type, kind, vec; 1118 1119 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); 1120 1121 if (se->ss && se->ss->info->useflags) 1122 { 1123 /* Access the previously obtained result. */ 1124 gfc_conv_tmp_array_ref (se); 1125 return; 1126 } 1127 1128 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */ 1129 array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr; 1130 type = gfc_typenode_for_spec (&array_expr->ts); 1131 1132 res_var = lhs; 1133 dst_var = lhs; 1134 1135 vec = null_pointer_node; 1136 1137 gfc_init_se (&argse, NULL); 1138 if (array_expr->rank == 0) 1139 { 1140 symbol_attribute attr; 1141 1142 gfc_clear_attr (&attr); 1143 gfc_conv_expr (&argse, array_expr); 1144 1145 if (lhs == NULL_TREE) 1146 { 1147 gfc_clear_attr (&attr); 1148 if (array_expr->ts.type == BT_CHARACTER) 1149 res_var = gfc_conv_string_tmp (se, build_pointer_type (type), 1150 argse.string_length); 1151 else 1152 res_var = gfc_create_var (type, "caf_res"); 1153 dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr); 1154 dst_var = gfc_build_addr_expr (NULL_TREE, dst_var); 1155 } 1156 argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); 1157 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr); 1158 } 1159 else 1160 { 1161 /* If has_vector, pass descriptor for whole array and the 1162 vector bounds separately. */ 1163 gfc_array_ref *ar, ar2; 1164 bool has_vector = false; 1165 1166 if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr)) 1167 { 1168 has_vector = true; 1169 ar = gfc_find_array_ref (expr); 1170 ar2 = *ar; 1171 memset (ar, '\0', sizeof (*ar)); 1172 ar->as = ar2.as; 1173 ar->type = AR_FULL; 1174 } 1175 gfc_conv_expr_descriptor (&argse, array_expr); 1176 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that 1177 has the wrong type if component references are done. */ 1178 gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr), 1179 gfc_get_dtype_rank_type (has_vector ? ar2.dimen 1180 : array_expr->rank, 1181 type)); 1182 if (has_vector) 1183 { 1184 vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2); 1185 *ar = ar2; 1186 } 1187 1188 if (lhs == NULL_TREE) 1189 { 1190 /* Create temporary. */ 1191 for (int n = 0; n < se->ss->loop->dimen; n++) 1192 if (se->loop->to[n] == NULL_TREE) 1193 { 1194 se->loop->from[n] = 1195 gfc_conv_descriptor_lbound_get (argse.expr, gfc_rank_cst[n]); 1196 se->loop->to[n] = 1197 gfc_conv_descriptor_ubound_get (argse.expr, gfc_rank_cst[n]); 1198 } 1199 gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type, 1200 NULL_TREE, false, true, false, 1201 &array_expr->where); 1202 res_var = se->ss->info->data.array.descriptor; 1203 dst_var = gfc_build_addr_expr (NULL_TREE, res_var); 1204 } 1205 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr); 1206 } 1207 1208 kind = build_int_cst (integer_type_node, expr->ts.kind); 1209 if (lhs_kind == NULL_TREE) 1210 lhs_kind = kind; 1211 1212 gfc_add_block_to_block (&se->pre, &argse.pre); 1213 gfc_add_block_to_block (&se->post, &argse.post); 1214 1215 caf_decl = gfc_get_tree_for_caf_expr (array_expr); 1216 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) 1217 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); 1218 image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl); 1219 gfc_get_caf_token_offset (&token, &offset, caf_decl, argse.expr, array_expr); 1220 1221 /* No overlap possible as we have generated a temporary. */ 1222 if (lhs == NULL_TREE) 1223 may_require_tmp = boolean_false_node; 1224 1225 /* It guarantees memory consistency within the same segment */ 1226 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), 1227 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 1228 gfc_build_string_const (1, ""), 1229 NULL_TREE, NULL_TREE, 1230 tree_cons (NULL_TREE, tmp, NULL_TREE), 1231 NULL_TREE); 1232 ASM_VOLATILE_P (tmp) = 1; 1233 gfc_add_expr_to_block (&se->pre, tmp); 1234 1235 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 9, 1236 token, offset, image_index, argse.expr, vec, 1237 dst_var, kind, lhs_kind, may_require_tmp); 1238 gfc_add_expr_to_block (&se->pre, tmp); 1239 1240 if (se->ss) 1241 gfc_advance_se_ss_chain (se); 1242 1243 se->expr = res_var; 1244 if (array_expr->ts.type == BT_CHARACTER) 1245 se->string_length = argse.string_length; 1246} 1247 1248 1249/* Send data to a remove coarray. */ 1250 1251static tree 1252conv_caf_send (gfc_code *code) { 1253 gfc_expr *lhs_expr, *rhs_expr; 1254 gfc_se lhs_se, rhs_se; 1255 stmtblock_t block; 1256 tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind; 1257 tree may_require_tmp; 1258 tree lhs_type = NULL_TREE; 1259 tree vec = null_pointer_node, rhs_vec = null_pointer_node; 1260 1261 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); 1262 1263 lhs_expr = code->ext.actual->expr; 1264 rhs_expr = code->ext.actual->next->expr; 1265 may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, false) == 0 1266 ? boolean_false_node : boolean_true_node; 1267 gfc_init_block (&block); 1268 1269 /* LHS. */ 1270 gfc_init_se (&lhs_se, NULL); 1271 if (lhs_expr->rank == 0) 1272 { 1273 symbol_attribute attr; 1274 gfc_clear_attr (&attr); 1275 gfc_conv_expr (&lhs_se, lhs_expr); 1276 lhs_type = TREE_TYPE (lhs_se.expr); 1277 lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr); 1278 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); 1279 } 1280 else 1281 { 1282 /* If has_vector, pass descriptor for whole array and the 1283 vector bounds separately. */ 1284 gfc_array_ref *ar, ar2; 1285 bool has_vector = false; 1286 1287 if (gfc_is_coindexed (lhs_expr) && gfc_has_vector_subscript (lhs_expr)) 1288 { 1289 has_vector = true; 1290 ar = gfc_find_array_ref (lhs_expr); 1291 ar2 = *ar; 1292 memset (ar, '\0', sizeof (*ar)); 1293 ar->as = ar2.as; 1294 ar->type = AR_FULL; 1295 } 1296 lhs_se.want_pointer = 1; 1297 gfc_conv_expr_descriptor (&lhs_se, lhs_expr); 1298 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that 1299 has the wrong type if component references are done. */ 1300 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); 1301 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); 1302 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), 1303 gfc_get_dtype_rank_type (has_vector ? ar2.dimen 1304 : lhs_expr->rank, 1305 lhs_type)); 1306 if (has_vector) 1307 { 1308 vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2); 1309 *ar = ar2; 1310 } 1311 } 1312 1313 lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind); 1314 gfc_add_block_to_block (&block, &lhs_se.pre); 1315 1316 /* Special case: RHS is a coarray but LHS is not; this code path avoids a 1317 temporary and a loop. */ 1318 if (!gfc_is_coindexed (lhs_expr)) 1319 { 1320 gcc_assert (gfc_is_coindexed (rhs_expr)); 1321 gfc_init_se (&rhs_se, NULL); 1322 gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind, 1323 may_require_tmp); 1324 gfc_add_block_to_block (&block, &rhs_se.pre); 1325 gfc_add_block_to_block (&block, &rhs_se.post); 1326 gfc_add_block_to_block (&block, &lhs_se.post); 1327 return gfc_finish_block (&block); 1328 } 1329 1330 /* Obtain token, offset and image index for the LHS. */ 1331 1332 caf_decl = gfc_get_tree_for_caf_expr (lhs_expr); 1333 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) 1334 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); 1335 image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl); 1336 gfc_get_caf_token_offset (&token, &offset, caf_decl, lhs_se.expr, lhs_expr); 1337 1338 /* RHS. */ 1339 gfc_init_se (&rhs_se, NULL); 1340 if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym 1341 && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION) 1342 rhs_expr = rhs_expr->value.function.actual->expr; 1343 if (rhs_expr->rank == 0) 1344 { 1345 symbol_attribute attr; 1346 gfc_clear_attr (&attr); 1347 gfc_conv_expr (&rhs_se, rhs_expr); 1348 if (!gfc_is_coindexed (rhs_expr) && rhs_expr->ts.type != BT_CHARACTER) 1349 rhs_se.expr = fold_convert (lhs_type , rhs_se.expr); 1350 rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr); 1351 rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr); 1352 } 1353 else 1354 { 1355 /* If has_vector, pass descriptor for whole array and the 1356 vector bounds separately. */ 1357 gfc_array_ref *ar, ar2; 1358 bool has_vector = false; 1359 tree tmp2; 1360 1361 if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr)) 1362 { 1363 has_vector = true; 1364 ar = gfc_find_array_ref (rhs_expr); 1365 ar2 = *ar; 1366 memset (ar, '\0', sizeof (*ar)); 1367 ar->as = ar2.as; 1368 ar->type = AR_FULL; 1369 } 1370 rhs_se.want_pointer = 1; 1371 gfc_conv_expr_descriptor (&rhs_se, rhs_expr); 1372 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that 1373 has the wrong type if component references are done. */ 1374 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr); 1375 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts); 1376 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp), 1377 gfc_get_dtype_rank_type (has_vector ? ar2.dimen 1378 : rhs_expr->rank, 1379 tmp2)); 1380 if (has_vector) 1381 { 1382 rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2); 1383 *ar = ar2; 1384 } 1385 } 1386 1387 gfc_add_block_to_block (&block, &rhs_se.pre); 1388 1389 rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind); 1390 1391 if (!gfc_is_coindexed (rhs_expr)) 1392 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 9, token, 1393 offset, image_index, lhs_se.expr, vec, 1394 rhs_se.expr, lhs_kind, rhs_kind, may_require_tmp); 1395 else 1396 { 1397 tree rhs_token, rhs_offset, rhs_image_index; 1398 1399 /* It guarantees memory consistency within the same segment */ 1400 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), 1401 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 1402 gfc_build_string_const (1, ""), 1403 NULL_TREE, NULL_TREE, 1404 tree_cons (NULL_TREE, tmp, NULL_TREE), 1405 NULL_TREE); 1406 ASM_VOLATILE_P (tmp) = 1; 1407 gfc_add_expr_to_block (&block, tmp); 1408 1409 caf_decl = gfc_get_tree_for_caf_expr (rhs_expr); 1410 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) 1411 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); 1412 rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl); 1413 gfc_get_caf_token_offset (&rhs_token, &rhs_offset, caf_decl, rhs_se.expr, 1414 rhs_expr); 1415 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget, 13, 1416 token, offset, image_index, lhs_se.expr, vec, 1417 rhs_token, rhs_offset, rhs_image_index, 1418 rhs_se.expr, rhs_vec, lhs_kind, rhs_kind, 1419 may_require_tmp); 1420 } 1421 gfc_add_expr_to_block (&block, tmp); 1422 gfc_add_block_to_block (&block, &lhs_se.post); 1423 gfc_add_block_to_block (&block, &rhs_se.post); 1424 1425 /* It guarantees memory consistency within the same segment */ 1426 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), 1427 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 1428 gfc_build_string_const (1, ""), 1429 NULL_TREE, NULL_TREE, 1430 tree_cons (NULL_TREE, tmp, NULL_TREE), 1431 NULL_TREE); 1432 ASM_VOLATILE_P (tmp) = 1; 1433 gfc_add_expr_to_block (&block, tmp); 1434 1435 return gfc_finish_block (&block); 1436} 1437 1438 1439static void 1440trans_this_image (gfc_se * se, gfc_expr *expr) 1441{ 1442 stmtblock_t loop; 1443 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, 1444 lbound, ubound, extent, ml; 1445 gfc_se argse; 1446 int rank, corank; 1447 gfc_expr *distance = expr->value.function.actual->next->next->expr; 1448 1449 if (expr->value.function.actual->expr 1450 && !gfc_is_coarray (expr->value.function.actual->expr)) 1451 distance = expr->value.function.actual->expr; 1452 1453 /* The case -fcoarray=single is handled elsewhere. */ 1454 gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE); 1455 1456 /* Argument-free version: THIS_IMAGE(). */ 1457 if (distance || expr->value.function.actual->expr == NULL) 1458 { 1459 if (distance) 1460 { 1461 gfc_init_se (&argse, NULL); 1462 gfc_conv_expr_val (&argse, distance); 1463 gfc_add_block_to_block (&se->pre, &argse.pre); 1464 gfc_add_block_to_block (&se->post, &argse.post); 1465 tmp = fold_convert (integer_type_node, argse.expr); 1466 } 1467 else 1468 tmp = integer_zero_node; 1469 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, 1470 tmp); 1471 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), 1472 tmp); 1473 return; 1474 } 1475 1476 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */ 1477 1478 type = gfc_get_int_type (gfc_default_integer_kind); 1479 corank = gfc_get_corank (expr->value.function.actual->expr); 1480 rank = expr->value.function.actual->expr->rank; 1481 1482 /* Obtain the descriptor of the COARRAY. */ 1483 gfc_init_se (&argse, NULL); 1484 argse.want_coarray = 1; 1485 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); 1486 gfc_add_block_to_block (&se->pre, &argse.pre); 1487 gfc_add_block_to_block (&se->post, &argse.post); 1488 desc = argse.expr; 1489 1490 if (se->ss) 1491 { 1492 /* Create an implicit second parameter from the loop variable. */ 1493 gcc_assert (!expr->value.function.actual->next->expr); 1494 gcc_assert (corank > 0); 1495 gcc_assert (se->loop->dimen == 1); 1496 gcc_assert (se->ss->info->expr == expr); 1497 1498 dim_arg = se->loop->loopvar[0]; 1499 dim_arg = fold_build2_loc (input_location, PLUS_EXPR, 1500 gfc_array_index_type, dim_arg, 1501 build_int_cst (TREE_TYPE (dim_arg), 1)); 1502 gfc_advance_se_ss_chain (se); 1503 } 1504 else 1505 { 1506 /* Use the passed DIM= argument. */ 1507 gcc_assert (expr->value.function.actual->next->expr); 1508 gfc_init_se (&argse, NULL); 1509 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr, 1510 gfc_array_index_type); 1511 gfc_add_block_to_block (&se->pre, &argse.pre); 1512 dim_arg = argse.expr; 1513 1514 if (INTEGER_CST_P (dim_arg)) 1515 { 1516 if (wi::ltu_p (dim_arg, 1) 1517 || wi::gtu_p (dim_arg, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))) 1518 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid " 1519 "dimension index", expr->value.function.isym->name, 1520 &expr->where); 1521 } 1522 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 1523 { 1524 dim_arg = gfc_evaluate_now (dim_arg, &se->pre); 1525 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 1526 dim_arg, 1527 build_int_cst (TREE_TYPE (dim_arg), 1)); 1528 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))]; 1529 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 1530 dim_arg, tmp); 1531 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, 1532 boolean_type_node, cond, tmp); 1533 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, 1534 gfc_msg_fault); 1535 } 1536 } 1537 1538 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer, 1539 one always has a dim_arg argument. 1540 1541 m = this_image() - 1 1542 if (corank == 1) 1543 { 1544 sub(1) = m + lcobound(corank) 1545 return; 1546 } 1547 i = rank 1548 min_var = min (rank + corank - 2, rank + dim_arg - 1) 1549 for (;;) 1550 { 1551 extent = gfc_extent(i) 1552 ml = m 1553 m = m/extent 1554 if (i >= min_var) 1555 goto exit_label 1556 i++ 1557 } 1558 exit_label: 1559 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg) 1560 : m + lcobound(corank) 1561 */ 1562 1563 /* this_image () - 1. */ 1564 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, 1565 integer_zero_node); 1566 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, 1567 fold_convert (type, tmp), build_int_cst (type, 1)); 1568 if (corank == 1) 1569 { 1570 /* sub(1) = m + lcobound(corank). */ 1571 lbound = gfc_conv_descriptor_lbound_get (desc, 1572 build_int_cst (TREE_TYPE (gfc_array_index_type), 1573 corank+rank-1)); 1574 lbound = fold_convert (type, lbound); 1575 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound); 1576 1577 se->expr = tmp; 1578 return; 1579 } 1580 1581 m = gfc_create_var (type, NULL); 1582 ml = gfc_create_var (type, NULL); 1583 loop_var = gfc_create_var (integer_type_node, NULL); 1584 min_var = gfc_create_var (integer_type_node, NULL); 1585 1586 /* m = this_image () - 1. */ 1587 gfc_add_modify (&se->pre, m, tmp); 1588 1589 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */ 1590 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, 1591 fold_convert (integer_type_node, dim_arg), 1592 build_int_cst (integer_type_node, rank - 1)); 1593 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node, 1594 build_int_cst (integer_type_node, rank + corank - 2), 1595 tmp); 1596 gfc_add_modify (&se->pre, min_var, tmp); 1597 1598 /* i = rank. */ 1599 tmp = build_int_cst (integer_type_node, rank); 1600 gfc_add_modify (&se->pre, loop_var, tmp); 1601 1602 exit_label = gfc_build_label_decl (NULL_TREE); 1603 TREE_USED (exit_label) = 1; 1604 1605 /* Loop body. */ 1606 gfc_init_block (&loop); 1607 1608 /* ml = m. */ 1609 gfc_add_modify (&loop, ml, m); 1610 1611 /* extent = ... */ 1612 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var); 1613 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var); 1614 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); 1615 extent = fold_convert (type, extent); 1616 1617 /* m = m/extent. */ 1618 gfc_add_modify (&loop, m, 1619 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, 1620 m, extent)); 1621 1622 /* Exit condition: if (i >= min_var) goto exit_label. */ 1623 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var, 1624 min_var); 1625 tmp = build1_v (GOTO_EXPR, exit_label); 1626 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, 1627 build_empty_stmt (input_location)); 1628 gfc_add_expr_to_block (&loop, tmp); 1629 1630 /* Increment loop variable: i++. */ 1631 gfc_add_modify (&loop, loop_var, 1632 fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, 1633 loop_var, 1634 build_int_cst (integer_type_node, 1))); 1635 1636 /* Making the loop... actually loop! */ 1637 tmp = gfc_finish_block (&loop); 1638 tmp = build1_v (LOOP_EXPR, tmp); 1639 gfc_add_expr_to_block (&se->pre, tmp); 1640 1641 /* The exit label. */ 1642 tmp = build1_v (LABEL_EXPR, exit_label); 1643 gfc_add_expr_to_block (&se->pre, tmp); 1644 1645 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg) 1646 : m + lcobound(corank) */ 1647 1648 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg, 1649 build_int_cst (TREE_TYPE (dim_arg), corank)); 1650 1651 lbound = gfc_conv_descriptor_lbound_get (desc, 1652 fold_build2_loc (input_location, PLUS_EXPR, 1653 gfc_array_index_type, dim_arg, 1654 build_int_cst (TREE_TYPE (dim_arg), rank-1))); 1655 lbound = fold_convert (type, lbound); 1656 1657 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml, 1658 fold_build2_loc (input_location, MULT_EXPR, type, 1659 m, extent)); 1660 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound); 1661 1662 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp, 1663 fold_build2_loc (input_location, PLUS_EXPR, type, 1664 m, lbound)); 1665} 1666 1667 1668static void 1669trans_image_index (gfc_se * se, gfc_expr *expr) 1670{ 1671 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, 1672 tmp, invalid_bound; 1673 gfc_se argse, subse; 1674 int rank, corank, codim; 1675 1676 type = gfc_get_int_type (gfc_default_integer_kind); 1677 corank = gfc_get_corank (expr->value.function.actual->expr); 1678 rank = expr->value.function.actual->expr->rank; 1679 1680 /* Obtain the descriptor of the COARRAY. */ 1681 gfc_init_se (&argse, NULL); 1682 argse.want_coarray = 1; 1683 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); 1684 gfc_add_block_to_block (&se->pre, &argse.pre); 1685 gfc_add_block_to_block (&se->post, &argse.post); 1686 desc = argse.expr; 1687 1688 /* Obtain a handle to the SUB argument. */ 1689 gfc_init_se (&subse, NULL); 1690 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr); 1691 gfc_add_block_to_block (&se->pre, &subse.pre); 1692 gfc_add_block_to_block (&se->post, &subse.post); 1693 subdesc = build_fold_indirect_ref_loc (input_location, 1694 gfc_conv_descriptor_data_get (subse.expr)); 1695 1696 /* Fortran 2008 does not require that the values remain in the cobounds, 1697 thus we need explicitly check this - and return 0 if they are exceeded. */ 1698 1699 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]); 1700 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL); 1701 invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 1702 fold_convert (gfc_array_index_type, tmp), 1703 lbound); 1704 1705 for (codim = corank + rank - 2; codim >= rank; codim--) 1706 { 1707 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); 1708 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]); 1709 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL); 1710 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 1711 fold_convert (gfc_array_index_type, tmp), 1712 lbound); 1713 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR, 1714 boolean_type_node, invalid_bound, cond); 1715 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 1716 fold_convert (gfc_array_index_type, tmp), 1717 ubound); 1718 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR, 1719 boolean_type_node, invalid_bound, cond); 1720 } 1721 1722 invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND); 1723 1724 /* See Fortran 2008, C.10 for the following algorithm. */ 1725 1726 /* coindex = sub(corank) - lcobound(n). */ 1727 coindex = fold_convert (gfc_array_index_type, 1728 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], 1729 NULL)); 1730 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]); 1731 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 1732 fold_convert (gfc_array_index_type, coindex), 1733 lbound); 1734 1735 for (codim = corank + rank - 2; codim >= rank; codim--) 1736 { 1737 tree extent, ubound; 1738 1739 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */ 1740 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); 1741 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]); 1742 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); 1743 1744 /* coindex *= extent. */ 1745 coindex = fold_build2_loc (input_location, MULT_EXPR, 1746 gfc_array_index_type, coindex, extent); 1747 1748 /* coindex += sub(codim). */ 1749 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL); 1750 coindex = fold_build2_loc (input_location, PLUS_EXPR, 1751 gfc_array_index_type, coindex, 1752 fold_convert (gfc_array_index_type, tmp)); 1753 1754 /* coindex -= lbound(codim). */ 1755 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); 1756 coindex = fold_build2_loc (input_location, MINUS_EXPR, 1757 gfc_array_index_type, coindex, lbound); 1758 } 1759 1760 coindex = fold_build2_loc (input_location, PLUS_EXPR, type, 1761 fold_convert(type, coindex), 1762 build_int_cst (type, 1)); 1763 1764 /* Return 0 if "coindex" exceeds num_images(). */ 1765 1766 if (flag_coarray == GFC_FCOARRAY_SINGLE) 1767 num_images = build_int_cst (type, 1); 1768 else 1769 { 1770 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, 1771 integer_zero_node, 1772 build_int_cst (integer_type_node, -1)); 1773 num_images = fold_convert (type, tmp); 1774 } 1775 1776 tmp = gfc_create_var (type, NULL); 1777 gfc_add_modify (&se->pre, tmp, coindex); 1778 1779 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp, 1780 num_images); 1781 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, 1782 cond, 1783 fold_convert (boolean_type_node, invalid_bound)); 1784 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, 1785 build_int_cst (type, 0), tmp); 1786} 1787 1788 1789static void 1790trans_num_images (gfc_se * se, gfc_expr *expr) 1791{ 1792 tree tmp, distance, failed; 1793 gfc_se argse; 1794 1795 if (expr->value.function.actual->expr) 1796 { 1797 gfc_init_se (&argse, NULL); 1798 gfc_conv_expr_val (&argse, expr->value.function.actual->expr); 1799 gfc_add_block_to_block (&se->pre, &argse.pre); 1800 gfc_add_block_to_block (&se->post, &argse.post); 1801 distance = fold_convert (integer_type_node, argse.expr); 1802 } 1803 else 1804 distance = integer_zero_node; 1805 1806 if (expr->value.function.actual->next->expr) 1807 { 1808 gfc_init_se (&argse, NULL); 1809 gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr); 1810 gfc_add_block_to_block (&se->pre, &argse.pre); 1811 gfc_add_block_to_block (&se->post, &argse.post); 1812 failed = fold_convert (integer_type_node, argse.expr); 1813 } 1814 else 1815 failed = build_int_cst (integer_type_node, -1); 1816 1817 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, 1818 distance, failed); 1819 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); 1820} 1821 1822 1823static void 1824gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) 1825{ 1826 gfc_se argse; 1827 1828 gfc_init_se (&argse, NULL); 1829 argse.data_not_needed = 1; 1830 argse.descriptor_only = 1; 1831 1832 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); 1833 gfc_add_block_to_block (&se->pre, &argse.pre); 1834 gfc_add_block_to_block (&se->post, &argse.post); 1835 1836 se->expr = gfc_conv_descriptor_rank (argse.expr); 1837} 1838 1839 1840/* Evaluate a single upper or lower bound. */ 1841/* TODO: bound intrinsic generates way too much unnecessary code. */ 1842 1843static void 1844gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) 1845{ 1846 gfc_actual_arglist *arg; 1847 gfc_actual_arglist *arg2; 1848 tree desc; 1849 tree type; 1850 tree bound; 1851 tree tmp; 1852 tree cond, cond1, cond3, cond4, size; 1853 tree ubound; 1854 tree lbound; 1855 gfc_se argse; 1856 gfc_array_spec * as; 1857 bool assumed_rank_lb_one; 1858 1859 arg = expr->value.function.actual; 1860 arg2 = arg->next; 1861 1862 if (se->ss) 1863 { 1864 /* Create an implicit second parameter from the loop variable. */ 1865 gcc_assert (!arg2->expr); 1866 gcc_assert (se->loop->dimen == 1); 1867 gcc_assert (se->ss->info->expr == expr); 1868 gfc_advance_se_ss_chain (se); 1869 bound = se->loop->loopvar[0]; 1870 bound = fold_build2_loc (input_location, MINUS_EXPR, 1871 gfc_array_index_type, bound, 1872 se->loop->from[0]); 1873 } 1874 else 1875 { 1876 /* use the passed argument. */ 1877 gcc_assert (arg2->expr); 1878 gfc_init_se (&argse, NULL); 1879 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); 1880 gfc_add_block_to_block (&se->pre, &argse.pre); 1881 bound = argse.expr; 1882 /* Convert from one based to zero based. */ 1883 bound = fold_build2_loc (input_location, MINUS_EXPR, 1884 gfc_array_index_type, bound, 1885 gfc_index_one_node); 1886 } 1887 1888 /* TODO: don't re-evaluate the descriptor on each iteration. */ 1889 /* Get a descriptor for the first parameter. */ 1890 gfc_init_se (&argse, NULL); 1891 gfc_conv_expr_descriptor (&argse, arg->expr); 1892 gfc_add_block_to_block (&se->pre, &argse.pre); 1893 gfc_add_block_to_block (&se->post, &argse.post); 1894 1895 desc = argse.expr; 1896 1897 as = gfc_get_full_arrayspec_from_expr (arg->expr); 1898 1899 if (INTEGER_CST_P (bound)) 1900 { 1901 if (((!as || as->type != AS_ASSUMED_RANK) 1902 && wi::geu_p (bound, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))) 1903 || wi::gtu_p (bound, GFC_MAX_DIMENSIONS)) 1904 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid " 1905 "dimension index", upper ? "UBOUND" : "LBOUND", 1906 &expr->where); 1907 } 1908 1909 if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK)) 1910 { 1911 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 1912 { 1913 bound = gfc_evaluate_now (bound, &se->pre); 1914 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 1915 bound, build_int_cst (TREE_TYPE (bound), 0)); 1916 if (as && as->type == AS_ASSUMED_RANK) 1917 tmp = gfc_conv_descriptor_rank (desc); 1918 else 1919 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; 1920 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, 1921 bound, fold_convert(TREE_TYPE (bound), tmp)); 1922 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, 1923 boolean_type_node, cond, tmp); 1924 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, 1925 gfc_msg_fault); 1926 } 1927 } 1928 1929 /* Take care of the lbound shift for assumed-rank arrays, which are 1930 nonallocatable and nonpointers. Those has a lbound of 1. */ 1931 assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK 1932 && ((arg->expr->ts.type != BT_CLASS 1933 && !arg->expr->symtree->n.sym->attr.allocatable 1934 && !arg->expr->symtree->n.sym->attr.pointer) 1935 || (arg->expr->ts.type == BT_CLASS 1936 && !CLASS_DATA (arg->expr)->attr.allocatable 1937 && !CLASS_DATA (arg->expr)->attr.class_pointer)); 1938 1939 ubound = gfc_conv_descriptor_ubound_get (desc, bound); 1940 lbound = gfc_conv_descriptor_lbound_get (desc, bound); 1941 1942 /* 13.14.53: Result value for LBOUND 1943 1944 Case (i): For an array section or for an array expression other than a 1945 whole array or array structure component, LBOUND(ARRAY, DIM) 1946 has the value 1. For a whole array or array structure 1947 component, LBOUND(ARRAY, DIM) has the value: 1948 (a) equal to the lower bound for subscript DIM of ARRAY if 1949 dimension DIM of ARRAY does not have extent zero 1950 or if ARRAY is an assumed-size array of rank DIM, 1951 or (b) 1 otherwise. 1952 1953 13.14.113: Result value for UBOUND 1954 1955 Case (i): For an array section or for an array expression other than a 1956 whole array or array structure component, UBOUND(ARRAY, DIM) 1957 has the value equal to the number of elements in the given 1958 dimension; otherwise, it has a value equal to the upper bound 1959 for subscript DIM of ARRAY if dimension DIM of ARRAY does 1960 not have size zero and has value zero if dimension DIM has 1961 size zero. */ 1962 1963 if (!upper && assumed_rank_lb_one) 1964 se->expr = gfc_index_one_node; 1965 else if (as) 1966 { 1967 tree stride = gfc_conv_descriptor_stride_get (desc, bound); 1968 1969 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, 1970 ubound, lbound); 1971 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, 1972 stride, gfc_index_zero_node); 1973 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, 1974 boolean_type_node, cond3, cond1); 1975 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 1976 stride, gfc_index_zero_node); 1977 1978 if (upper) 1979 { 1980 tree cond5; 1981 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, 1982 boolean_type_node, cond3, cond4); 1983 cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 1984 gfc_index_one_node, lbound); 1985 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR, 1986 boolean_type_node, cond4, cond5); 1987 1988 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, 1989 boolean_type_node, cond, cond5); 1990 1991 if (assumed_rank_lb_one) 1992 { 1993 tmp = fold_build2_loc (input_location, MINUS_EXPR, 1994 gfc_array_index_type, ubound, lbound); 1995 tmp = fold_build2_loc (input_location, PLUS_EXPR, 1996 gfc_array_index_type, tmp, gfc_index_one_node); 1997 } 1998 else 1999 tmp = ubound; 2000 2001 se->expr = fold_build3_loc (input_location, COND_EXPR, 2002 gfc_array_index_type, cond, 2003 tmp, gfc_index_zero_node); 2004 } 2005 else 2006 { 2007 if (as->type == AS_ASSUMED_SIZE) 2008 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 2009 bound, build_int_cst (TREE_TYPE (bound), 2010 arg->expr->rank - 1)); 2011 else 2012 cond = boolean_false_node; 2013 2014 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, 2015 boolean_type_node, cond3, cond4); 2016 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, 2017 boolean_type_node, cond, cond1); 2018 2019 se->expr = fold_build3_loc (input_location, COND_EXPR, 2020 gfc_array_index_type, cond, 2021 lbound, gfc_index_one_node); 2022 } 2023 } 2024 else 2025 { 2026 if (upper) 2027 { 2028 size = fold_build2_loc (input_location, MINUS_EXPR, 2029 gfc_array_index_type, ubound, lbound); 2030 se->expr = fold_build2_loc (input_location, PLUS_EXPR, 2031 gfc_array_index_type, size, 2032 gfc_index_one_node); 2033 se->expr = fold_build2_loc (input_location, MAX_EXPR, 2034 gfc_array_index_type, se->expr, 2035 gfc_index_zero_node); 2036 } 2037 else 2038 se->expr = gfc_index_one_node; 2039 } 2040 2041 type = gfc_typenode_for_spec (&expr->ts); 2042 se->expr = convert (type, se->expr); 2043} 2044 2045 2046static void 2047conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) 2048{ 2049 gfc_actual_arglist *arg; 2050 gfc_actual_arglist *arg2; 2051 gfc_se argse; 2052 tree bound, resbound, resbound2, desc, cond, tmp; 2053 tree type; 2054 int corank; 2055 2056 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND 2057 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND 2058 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE); 2059 2060 arg = expr->value.function.actual; 2061 arg2 = arg->next; 2062 2063 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); 2064 corank = gfc_get_corank (arg->expr); 2065 2066 gfc_init_se (&argse, NULL); 2067 argse.want_coarray = 1; 2068 2069 gfc_conv_expr_descriptor (&argse, arg->expr); 2070 gfc_add_block_to_block (&se->pre, &argse.pre); 2071 gfc_add_block_to_block (&se->post, &argse.post); 2072 desc = argse.expr; 2073 2074 if (se->ss) 2075 { 2076 /* Create an implicit second parameter from the loop variable. */ 2077 gcc_assert (!arg2->expr); 2078 gcc_assert (corank > 0); 2079 gcc_assert (se->loop->dimen == 1); 2080 gcc_assert (se->ss->info->expr == expr); 2081 2082 bound = se->loop->loopvar[0]; 2083 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 2084 bound, gfc_rank_cst[arg->expr->rank]); 2085 gfc_advance_se_ss_chain (se); 2086 } 2087 else 2088 { 2089 /* use the passed argument. */ 2090 gcc_assert (arg2->expr); 2091 gfc_init_se (&argse, NULL); 2092 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); 2093 gfc_add_block_to_block (&se->pre, &argse.pre); 2094 bound = argse.expr; 2095 2096 if (INTEGER_CST_P (bound)) 2097 { 2098 if (wi::ltu_p (bound, 1) 2099 || wi::gtu_p (bound, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))) 2100 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid " 2101 "dimension index", expr->value.function.isym->name, 2102 &expr->where); 2103 } 2104 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 2105 { 2106 bound = gfc_evaluate_now (bound, &se->pre); 2107 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 2108 bound, build_int_cst (TREE_TYPE (bound), 1)); 2109 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))]; 2110 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 2111 bound, tmp); 2112 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, 2113 boolean_type_node, cond, tmp); 2114 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, 2115 gfc_msg_fault); 2116 } 2117 2118 2119 /* Subtract 1 to get to zero based and add dimensions. */ 2120 switch (arg->expr->rank) 2121 { 2122 case 0: 2123 bound = fold_build2_loc (input_location, MINUS_EXPR, 2124 gfc_array_index_type, bound, 2125 gfc_index_one_node); 2126 case 1: 2127 break; 2128 default: 2129 bound = fold_build2_loc (input_location, PLUS_EXPR, 2130 gfc_array_index_type, bound, 2131 gfc_rank_cst[arg->expr->rank - 1]); 2132 } 2133 } 2134 2135 resbound = gfc_conv_descriptor_lbound_get (desc, bound); 2136 2137 /* Handle UCOBOUND with special handling of the last codimension. */ 2138 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND) 2139 { 2140 /* Last codimension: For -fcoarray=single just return 2141 the lcobound - otherwise add 2142 ceiling (real (num_images ()) / real (size)) - 1 2143 = (num_images () + size - 1) / size - 1 2144 = (num_images - 1) / size(), 2145 where size is the product of the extent of all but the last 2146 codimension. */ 2147 2148 if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1) 2149 { 2150 tree cosize; 2151 2152 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank); 2153 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2154 2, integer_zero_node, 2155 build_int_cst (integer_type_node, -1)); 2156 tmp = fold_build2_loc (input_location, MINUS_EXPR, 2157 gfc_array_index_type, 2158 fold_convert (gfc_array_index_type, tmp), 2159 build_int_cst (gfc_array_index_type, 1)); 2160 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, 2161 gfc_array_index_type, tmp, 2162 fold_convert (gfc_array_index_type, cosize)); 2163 resbound = fold_build2_loc (input_location, PLUS_EXPR, 2164 gfc_array_index_type, resbound, tmp); 2165 } 2166 else if (flag_coarray != GFC_FCOARRAY_SINGLE) 2167 { 2168 /* ubound = lbound + num_images() - 1. */ 2169 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2170 2, integer_zero_node, 2171 build_int_cst (integer_type_node, -1)); 2172 tmp = fold_build2_loc (input_location, MINUS_EXPR, 2173 gfc_array_index_type, 2174 fold_convert (gfc_array_index_type, tmp), 2175 build_int_cst (gfc_array_index_type, 1)); 2176 resbound = fold_build2_loc (input_location, PLUS_EXPR, 2177 gfc_array_index_type, resbound, tmp); 2178 } 2179 2180 if (corank > 1) 2181 { 2182 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 2183 bound, 2184 build_int_cst (TREE_TYPE (bound), 2185 arg->expr->rank + corank - 1)); 2186 2187 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound); 2188 se->expr = fold_build3_loc (input_location, COND_EXPR, 2189 gfc_array_index_type, cond, 2190 resbound, resbound2); 2191 } 2192 else 2193 se->expr = resbound; 2194 } 2195 else 2196 se->expr = resbound; 2197 2198 type = gfc_typenode_for_spec (&expr->ts); 2199 se->expr = convert (type, se->expr); 2200} 2201 2202 2203static void 2204conv_intrinsic_stride (gfc_se * se, gfc_expr * expr) 2205{ 2206 gfc_actual_arglist *array_arg; 2207 gfc_actual_arglist *dim_arg; 2208 gfc_se argse; 2209 tree desc, tmp; 2210 2211 array_arg = expr->value.function.actual; 2212 dim_arg = array_arg->next; 2213 2214 gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE); 2215 2216 gfc_init_se (&argse, NULL); 2217 gfc_conv_expr_descriptor (&argse, array_arg->expr); 2218 gfc_add_block_to_block (&se->pre, &argse.pre); 2219 gfc_add_block_to_block (&se->post, &argse.post); 2220 desc = argse.expr; 2221 2222 gcc_assert (dim_arg->expr); 2223 gfc_init_se (&argse, NULL); 2224 gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type); 2225 gfc_add_block_to_block (&se->pre, &argse.pre); 2226 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 2227 argse.expr, gfc_index_one_node); 2228 se->expr = gfc_conv_descriptor_stride_get (desc, tmp); 2229} 2230 2231 2232static void 2233gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) 2234{ 2235 tree arg, cabs; 2236 2237 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 2238 2239 switch (expr->value.function.actual->expr->ts.type) 2240 { 2241 case BT_INTEGER: 2242 case BT_REAL: 2243 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg), 2244 arg); 2245 break; 2246 2247 case BT_COMPLEX: 2248 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind); 2249 se->expr = build_call_expr_loc (input_location, cabs, 1, arg); 2250 break; 2251 2252 default: 2253 gcc_unreachable (); 2254 } 2255} 2256 2257 2258/* Create a complex value from one or two real components. */ 2259 2260static void 2261gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) 2262{ 2263 tree real; 2264 tree imag; 2265 tree type; 2266 tree *args; 2267 unsigned int num_args; 2268 2269 num_args = gfc_intrinsic_argument_list_length (expr); 2270 args = XALLOCAVEC (tree, num_args); 2271 2272 type = gfc_typenode_for_spec (&expr->ts); 2273 gfc_conv_intrinsic_function_args (se, expr, args, num_args); 2274 real = convert (TREE_TYPE (type), args[0]); 2275 if (both) 2276 imag = convert (TREE_TYPE (type), args[1]); 2277 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE) 2278 { 2279 imag = fold_build1_loc (input_location, IMAGPART_EXPR, 2280 TREE_TYPE (TREE_TYPE (args[0])), args[0]); 2281 imag = convert (TREE_TYPE (type), imag); 2282 } 2283 else 2284 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); 2285 2286 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag); 2287} 2288 2289 2290/* Remainder function MOD(A, P) = A - INT(A / P) * P 2291 MODULO(A, P) = A - FLOOR (A / P) * P 2292 2293 The obvious algorithms above are numerically instable for large 2294 arguments, hence these intrinsics are instead implemented via calls 2295 to the fmod family of functions. It is the responsibility of the 2296 user to ensure that the second argument is non-zero. */ 2297 2298static void 2299gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) 2300{ 2301 tree type; 2302 tree tmp; 2303 tree test; 2304 tree test2; 2305 tree fmod; 2306 tree zero; 2307 tree args[2]; 2308 2309 gfc_conv_intrinsic_function_args (se, expr, args, 2); 2310 2311 switch (expr->ts.type) 2312 { 2313 case BT_INTEGER: 2314 /* Integer case is easy, we've got a builtin op. */ 2315 type = TREE_TYPE (args[0]); 2316 2317 if (modulo) 2318 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type, 2319 args[0], args[1]); 2320 else 2321 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type, 2322 args[0], args[1]); 2323 break; 2324 2325 case BT_REAL: 2326 fmod = NULL_TREE; 2327 /* Check if we have a builtin fmod. */ 2328 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind); 2329 2330 /* The builtin should always be available. */ 2331 gcc_assert (fmod != NULL_TREE); 2332 2333 tmp = build_addr (fmod, current_function_decl); 2334 se->expr = build_call_array_loc (input_location, 2335 TREE_TYPE (TREE_TYPE (fmod)), 2336 tmp, 2, args); 2337 if (modulo == 0) 2338 return; 2339 2340 type = TREE_TYPE (args[0]); 2341 2342 args[0] = gfc_evaluate_now (args[0], &se->pre); 2343 args[1] = gfc_evaluate_now (args[1], &se->pre); 2344 2345 /* Definition: 2346 modulo = arg - floor (arg/arg2) * arg2 2347 2348 In order to calculate the result accurately, we use the fmod 2349 function as follows. 2350 2351 res = fmod (arg, arg2); 2352 if (res) 2353 { 2354 if ((arg < 0) xor (arg2 < 0)) 2355 res += arg2; 2356 } 2357 else 2358 res = copysign (0., arg2); 2359 2360 => As two nested ternary exprs: 2361 2362 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res) 2363 : copysign (0., arg2); 2364 2365 */ 2366 2367 zero = gfc_build_const (type, integer_zero_node); 2368 tmp = gfc_evaluate_now (se->expr, &se->pre); 2369 if (!flag_signed_zeros) 2370 { 2371 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 2372 args[0], zero); 2373 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 2374 args[1], zero); 2375 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR, 2376 boolean_type_node, test, test2); 2377 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 2378 tmp, zero); 2379 test = fold_build2_loc (input_location, TRUTH_AND_EXPR, 2380 boolean_type_node, test, test2); 2381 test = gfc_evaluate_now (test, &se->pre); 2382 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test, 2383 fold_build2_loc (input_location, 2384 PLUS_EXPR, 2385 type, tmp, args[1]), 2386 tmp); 2387 } 2388 else 2389 { 2390 tree expr1, copysign, cscall; 2391 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, 2392 expr->ts.kind); 2393 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 2394 args[0], zero); 2395 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 2396 args[1], zero); 2397 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR, 2398 boolean_type_node, test, test2); 2399 expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2, 2400 fold_build2_loc (input_location, 2401 PLUS_EXPR, 2402 type, tmp, args[1]), 2403 tmp); 2404 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 2405 tmp, zero); 2406 cscall = build_call_expr_loc (input_location, copysign, 2, zero, 2407 args[1]); 2408 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test, 2409 expr1, cscall); 2410 } 2411 return; 2412 2413 default: 2414 gcc_unreachable (); 2415 } 2416} 2417 2418/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S)) 2419 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S) 2420 where the right shifts are logical (i.e. 0's are shifted in). 2421 Because SHIFT_EXPR's want shifts strictly smaller than the integral 2422 type width, we have to special-case both S == 0 and S == BITSIZE(J): 2423 DSHIFTL(I,J,0) = I 2424 DSHIFTL(I,J,BITSIZE) = J 2425 DSHIFTR(I,J,0) = J 2426 DSHIFTR(I,J,BITSIZE) = I. */ 2427 2428static void 2429gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl) 2430{ 2431 tree type, utype, stype, arg1, arg2, shift, res, left, right; 2432 tree args[3], cond, tmp; 2433 int bitsize; 2434 2435 gfc_conv_intrinsic_function_args (se, expr, args, 3); 2436 2437 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1])); 2438 type = TREE_TYPE (args[0]); 2439 bitsize = TYPE_PRECISION (type); 2440 utype = unsigned_type_for (type); 2441 stype = TREE_TYPE (args[2]); 2442 2443 arg1 = gfc_evaluate_now (args[0], &se->pre); 2444 arg2 = gfc_evaluate_now (args[1], &se->pre); 2445 shift = gfc_evaluate_now (args[2], &se->pre); 2446 2447 /* The generic case. */ 2448 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype, 2449 build_int_cst (stype, bitsize), shift); 2450 left = fold_build2_loc (input_location, LSHIFT_EXPR, type, 2451 arg1, dshiftl ? shift : tmp); 2452 2453 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype, 2454 fold_convert (utype, arg2), dshiftl ? tmp : shift); 2455 right = fold_convert (type, right); 2456 2457 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right); 2458 2459 /* Special cases. */ 2460 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift, 2461 build_int_cst (stype, 0)); 2462 res = fold_build3_loc (input_location, COND_EXPR, type, cond, 2463 dshiftl ? arg1 : arg2, res); 2464 2465 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift, 2466 build_int_cst (stype, bitsize)); 2467 res = fold_build3_loc (input_location, COND_EXPR, type, cond, 2468 dshiftl ? arg2 : arg1, res); 2469 2470 se->expr = res; 2471} 2472 2473 2474/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */ 2475 2476static void 2477gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr) 2478{ 2479 tree val; 2480 tree tmp; 2481 tree type; 2482 tree zero; 2483 tree args[2]; 2484 2485 gfc_conv_intrinsic_function_args (se, expr, args, 2); 2486 type = TREE_TYPE (args[0]); 2487 2488 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]); 2489 val = gfc_evaluate_now (val, &se->pre); 2490 2491 zero = gfc_build_const (type, integer_zero_node); 2492 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero); 2493 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val); 2494} 2495 2496 2497/* SIGN(A, B) is absolute value of A times sign of B. 2498 The real value versions use library functions to ensure the correct 2499 handling of negative zero. Integer case implemented as: 2500 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp } 2501 */ 2502 2503static void 2504gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) 2505{ 2506 tree tmp; 2507 tree type; 2508 tree args[2]; 2509 2510 gfc_conv_intrinsic_function_args (se, expr, args, 2); 2511 if (expr->ts.type == BT_REAL) 2512 { 2513 tree abs; 2514 2515 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); 2516 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); 2517 2518 /* We explicitly have to ignore the minus sign. We do so by using 2519 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */ 2520 if (!flag_sign_zero 2521 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1])))) 2522 { 2523 tree cond, zero; 2524 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node); 2525 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 2526 args[1], zero); 2527 se->expr = fold_build3_loc (input_location, COND_EXPR, 2528 TREE_TYPE (args[0]), cond, 2529 build_call_expr_loc (input_location, abs, 1, 2530 args[0]), 2531 build_call_expr_loc (input_location, tmp, 2, 2532 args[0], args[1])); 2533 } 2534 else 2535 se->expr = build_call_expr_loc (input_location, tmp, 2, 2536 args[0], args[1]); 2537 return; 2538 } 2539 2540 /* Having excluded floating point types, we know we are now dealing 2541 with signed integer types. */ 2542 type = TREE_TYPE (args[0]); 2543 2544 /* Args[0] is used multiple times below. */ 2545 args[0] = gfc_evaluate_now (args[0], &se->pre); 2546 2547 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if 2548 the signs of A and B are the same, and of all ones if they differ. */ 2549 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]); 2550 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp, 2551 build_int_cst (type, TYPE_PRECISION (type) - 1)); 2552 tmp = gfc_evaluate_now (tmp, &se->pre); 2553 2554 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp] 2555 is all ones (i.e. -1). */ 2556 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type, 2557 fold_build2_loc (input_location, PLUS_EXPR, 2558 type, args[0], tmp), tmp); 2559} 2560 2561 2562/* Test for the presence of an optional argument. */ 2563 2564static void 2565gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr) 2566{ 2567 gfc_expr *arg; 2568 2569 arg = expr->value.function.actual->expr; 2570 gcc_assert (arg->expr_type == EXPR_VARIABLE); 2571 se->expr = gfc_conv_expr_present (arg->symtree->n.sym); 2572 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); 2573} 2574 2575 2576/* Calculate the double precision product of two single precision values. */ 2577 2578static void 2579gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr) 2580{ 2581 tree type; 2582 tree args[2]; 2583 2584 gfc_conv_intrinsic_function_args (se, expr, args, 2); 2585 2586 /* Convert the args to double precision before multiplying. */ 2587 type = gfc_typenode_for_spec (&expr->ts); 2588 args[0] = convert (type, args[0]); 2589 args[1] = convert (type, args[1]); 2590 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0], 2591 args[1]); 2592} 2593 2594 2595/* Return a length one character string containing an ascii character. */ 2596 2597static void 2598gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) 2599{ 2600 tree arg[2]; 2601 tree var; 2602 tree type; 2603 unsigned int num_args; 2604 2605 num_args = gfc_intrinsic_argument_list_length (expr); 2606 gfc_conv_intrinsic_function_args (se, expr, arg, num_args); 2607 2608 type = gfc_get_char_type (expr->ts.kind); 2609 var = gfc_create_var (type, "char"); 2610 2611 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]); 2612 gfc_add_modify (&se->pre, var, arg[0]); 2613 se->expr = gfc_build_addr_expr (build_pointer_type (type), var); 2614 se->string_length = build_int_cst (gfc_charlen_type_node, 1); 2615} 2616 2617 2618static void 2619gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) 2620{ 2621 tree var; 2622 tree len; 2623 tree tmp; 2624 tree cond; 2625 tree fndecl; 2626 tree *args; 2627 unsigned int num_args; 2628 2629 num_args = gfc_intrinsic_argument_list_length (expr) + 2; 2630 args = XALLOCAVEC (tree, num_args); 2631 2632 var = gfc_create_var (pchar_type_node, "pstr"); 2633 len = gfc_create_var (gfc_charlen_type_node, "len"); 2634 2635 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); 2636 args[0] = gfc_build_addr_expr (NULL_TREE, var); 2637 args[1] = gfc_build_addr_expr (NULL_TREE, len); 2638 2639 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl); 2640 tmp = build_call_array_loc (input_location, 2641 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)), 2642 fndecl, num_args, args); 2643 gfc_add_expr_to_block (&se->pre, tmp); 2644 2645 /* Free the temporary afterwards, if necessary. */ 2646 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 2647 len, build_int_cst (TREE_TYPE (len), 0)); 2648 tmp = gfc_call_free (var); 2649 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); 2650 gfc_add_expr_to_block (&se->post, tmp); 2651 2652 se->expr = var; 2653 se->string_length = len; 2654} 2655 2656 2657static void 2658gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) 2659{ 2660 tree var; 2661 tree len; 2662 tree tmp; 2663 tree cond; 2664 tree fndecl; 2665 tree *args; 2666 unsigned int num_args; 2667 2668 num_args = gfc_intrinsic_argument_list_length (expr) + 2; 2669 args = XALLOCAVEC (tree, num_args); 2670 2671 var = gfc_create_var (pchar_type_node, "pstr"); 2672 len = gfc_create_var (gfc_charlen_type_node, "len"); 2673 2674 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); 2675 args[0] = gfc_build_addr_expr (NULL_TREE, var); 2676 args[1] = gfc_build_addr_expr (NULL_TREE, len); 2677 2678 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl); 2679 tmp = build_call_array_loc (input_location, 2680 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)), 2681 fndecl, num_args, args); 2682 gfc_add_expr_to_block (&se->pre, tmp); 2683 2684 /* Free the temporary afterwards, if necessary. */ 2685 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 2686 len, build_int_cst (TREE_TYPE (len), 0)); 2687 tmp = gfc_call_free (var); 2688 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); 2689 gfc_add_expr_to_block (&se->post, tmp); 2690 2691 se->expr = var; 2692 se->string_length = len; 2693} 2694 2695 2696/* Call the SYSTEM_CLOCK library functions, handling the type and kind 2697 conversions. */ 2698 2699static tree 2700conv_intrinsic_system_clock (gfc_code *code) 2701{ 2702 stmtblock_t block; 2703 gfc_se count_se, count_rate_se, count_max_se; 2704 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE; 2705 tree tmp; 2706 int least; 2707 2708 gfc_expr *count = code->ext.actual->expr; 2709 gfc_expr *count_rate = code->ext.actual->next->expr; 2710 gfc_expr *count_max = code->ext.actual->next->next->expr; 2711 2712 /* Evaluate our arguments. */ 2713 if (count) 2714 { 2715 gfc_init_se (&count_se, NULL); 2716 gfc_conv_expr (&count_se, count); 2717 } 2718 2719 if (count_rate) 2720 { 2721 gfc_init_se (&count_rate_se, NULL); 2722 gfc_conv_expr (&count_rate_se, count_rate); 2723 } 2724 2725 if (count_max) 2726 { 2727 gfc_init_se (&count_max_se, NULL); 2728 gfc_conv_expr (&count_max_se, count_max); 2729 } 2730 2731 /* Find the smallest kind found of the arguments. */ 2732 least = 16; 2733 least = (count && count->ts.kind < least) ? count->ts.kind : least; 2734 least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind 2735 : least; 2736 least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind 2737 : least; 2738 2739 /* Prepare temporary variables. */ 2740 2741 if (count) 2742 { 2743 if (least >= 8) 2744 arg1 = gfc_create_var (gfc_get_int_type (8), "count"); 2745 else if (least == 4) 2746 arg1 = gfc_create_var (gfc_get_int_type (4), "count"); 2747 else if (count->ts.kind == 1) 2748 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int, 2749 count->ts.kind); 2750 else 2751 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int, 2752 count->ts.kind); 2753 } 2754 2755 if (count_rate) 2756 { 2757 if (least >= 8) 2758 arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate"); 2759 else if (least == 4) 2760 arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate"); 2761 else 2762 arg2 = integer_zero_node; 2763 } 2764 2765 if (count_max) 2766 { 2767 if (least >= 8) 2768 arg3 = gfc_create_var (gfc_get_int_type (8), "count_max"); 2769 else if (least == 4) 2770 arg3 = gfc_create_var (gfc_get_int_type (4), "count_max"); 2771 else 2772 arg3 = integer_zero_node; 2773 } 2774 2775 /* Make the function call. */ 2776 gfc_init_block (&block); 2777 2778if (least <= 2) 2779 { 2780 if (least == 1) 2781 { 2782 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) 2783 : null_pointer_node; 2784 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) 2785 : null_pointer_node; 2786 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) 2787 : null_pointer_node; 2788 } 2789 2790 if (least == 2) 2791 { 2792 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) 2793 : null_pointer_node; 2794 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) 2795 : null_pointer_node; 2796 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) 2797 : null_pointer_node; 2798 } 2799 } 2800else 2801 { 2802 if (least == 4) 2803 { 2804 tmp = build_call_expr_loc (input_location, 2805 gfor_fndecl_system_clock4, 3, 2806 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) 2807 : null_pointer_node, 2808 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) 2809 : null_pointer_node, 2810 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) 2811 : null_pointer_node); 2812 gfc_add_expr_to_block (&block, tmp); 2813 } 2814 /* Handle kind>=8, 10, or 16 arguments */ 2815 if (least >= 8) 2816 { 2817 tmp = build_call_expr_loc (input_location, 2818 gfor_fndecl_system_clock8, 3, 2819 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) 2820 : null_pointer_node, 2821 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) 2822 : null_pointer_node, 2823 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) 2824 : null_pointer_node); 2825 gfc_add_expr_to_block (&block, tmp); 2826 } 2827 } 2828 2829 /* And store values back if needed. */ 2830 if (arg1 && arg1 != count_se.expr) 2831 gfc_add_modify (&block, count_se.expr, 2832 fold_convert (TREE_TYPE (count_se.expr), arg1)); 2833 if (arg2 && arg2 != count_rate_se.expr) 2834 gfc_add_modify (&block, count_rate_se.expr, 2835 fold_convert (TREE_TYPE (count_rate_se.expr), arg2)); 2836 if (arg3 && arg3 != count_max_se.expr) 2837 gfc_add_modify (&block, count_max_se.expr, 2838 fold_convert (TREE_TYPE (count_max_se.expr), arg3)); 2839 2840 return gfc_finish_block (&block); 2841} 2842 2843 2844/* Return a character string containing the tty name. */ 2845 2846static void 2847gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) 2848{ 2849 tree var; 2850 tree len; 2851 tree tmp; 2852 tree cond; 2853 tree fndecl; 2854 tree *args; 2855 unsigned int num_args; 2856 2857 num_args = gfc_intrinsic_argument_list_length (expr) + 2; 2858 args = XALLOCAVEC (tree, num_args); 2859 2860 var = gfc_create_var (pchar_type_node, "pstr"); 2861 len = gfc_create_var (gfc_charlen_type_node, "len"); 2862 2863 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); 2864 args[0] = gfc_build_addr_expr (NULL_TREE, var); 2865 args[1] = gfc_build_addr_expr (NULL_TREE, len); 2866 2867 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl); 2868 tmp = build_call_array_loc (input_location, 2869 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)), 2870 fndecl, num_args, args); 2871 gfc_add_expr_to_block (&se->pre, tmp); 2872 2873 /* Free the temporary afterwards, if necessary. */ 2874 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 2875 len, build_int_cst (TREE_TYPE (len), 0)); 2876 tmp = gfc_call_free (var); 2877 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); 2878 gfc_add_expr_to_block (&se->post, tmp); 2879 2880 se->expr = var; 2881 se->string_length = len; 2882} 2883 2884 2885/* Get the minimum/maximum value of all the parameters. 2886 minmax (a1, a2, a3, ...) 2887 { 2888 mvar = a1; 2889 if (a2 .op. mvar || isnan (mvar)) 2890 mvar = a2; 2891 if (a3 .op. mvar || isnan (mvar)) 2892 mvar = a3; 2893 ... 2894 return mvar 2895 } 2896 */ 2897 2898/* TODO: Mismatching types can occur when specific names are used. 2899 These should be handled during resolution. */ 2900static void 2901gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) 2902{ 2903 tree tmp; 2904 tree mvar; 2905 tree val; 2906 tree thencase; 2907 tree *args; 2908 tree type; 2909 gfc_actual_arglist *argexpr; 2910 unsigned int i, nargs; 2911 2912 nargs = gfc_intrinsic_argument_list_length (expr); 2913 args = XALLOCAVEC (tree, nargs); 2914 2915 gfc_conv_intrinsic_function_args (se, expr, args, nargs); 2916 type = gfc_typenode_for_spec (&expr->ts); 2917 2918 argexpr = expr->value.function.actual; 2919 if (TREE_TYPE (args[0]) != type) 2920 args[0] = convert (type, args[0]); 2921 /* Only evaluate the argument once. */ 2922 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0])) 2923 args[0] = gfc_evaluate_now (args[0], &se->pre); 2924 2925 mvar = gfc_create_var (type, "M"); 2926 gfc_add_modify (&se->pre, mvar, args[0]); 2927 for (i = 1, argexpr = argexpr->next; i < nargs; i++) 2928 { 2929 tree cond, isnan; 2930 2931 val = args[i]; 2932 2933 /* Handle absent optional arguments by ignoring the comparison. */ 2934 if (argexpr->expr->expr_type == EXPR_VARIABLE 2935 && argexpr->expr->symtree->n.sym->attr.optional 2936 && TREE_CODE (val) == INDIRECT_REF) 2937 cond = fold_build2_loc (input_location, 2938 NE_EXPR, boolean_type_node, 2939 TREE_OPERAND (val, 0), 2940 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0)); 2941 else 2942 { 2943 cond = NULL_TREE; 2944 2945 /* Only evaluate the argument once. */ 2946 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val)) 2947 val = gfc_evaluate_now (val, &se->pre); 2948 } 2949 2950 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val)); 2951 2952 tmp = fold_build2_loc (input_location, op, boolean_type_node, 2953 convert (type, val), mvar); 2954 2955 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to 2956 __builtin_isnan might be made dependent on that module being loaded, 2957 to help performance of programs that don't rely on IEEE semantics. */ 2958 if (FLOAT_TYPE_P (TREE_TYPE (mvar))) 2959 { 2960 isnan = build_call_expr_loc (input_location, 2961 builtin_decl_explicit (BUILT_IN_ISNAN), 2962 1, mvar); 2963 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, 2964 boolean_type_node, tmp, 2965 fold_convert (boolean_type_node, isnan)); 2966 } 2967 tmp = build3_v (COND_EXPR, tmp, thencase, 2968 build_empty_stmt (input_location)); 2969 2970 if (cond != NULL_TREE) 2971 tmp = build3_v (COND_EXPR, cond, tmp, 2972 build_empty_stmt (input_location)); 2973 2974 gfc_add_expr_to_block (&se->pre, tmp); 2975 argexpr = argexpr->next; 2976 } 2977 se->expr = mvar; 2978} 2979 2980 2981/* Generate library calls for MIN and MAX intrinsics for character 2982 variables. */ 2983static void 2984gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) 2985{ 2986 tree *args; 2987 tree var, len, fndecl, tmp, cond, function; 2988 unsigned int nargs; 2989 2990 nargs = gfc_intrinsic_argument_list_length (expr); 2991 args = XALLOCAVEC (tree, nargs + 4); 2992 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs); 2993 2994 /* Create the result variables. */ 2995 len = gfc_create_var (gfc_charlen_type_node, "len"); 2996 args[0] = gfc_build_addr_expr (NULL_TREE, len); 2997 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); 2998 args[1] = gfc_build_addr_expr (ppvoid_type_node, var); 2999 args[2] = build_int_cst (integer_type_node, op); 3000 args[3] = build_int_cst (integer_type_node, nargs / 2); 3001 3002 if (expr->ts.kind == 1) 3003 function = gfor_fndecl_string_minmax; 3004 else if (expr->ts.kind == 4) 3005 function = gfor_fndecl_string_minmax_char4; 3006 else 3007 gcc_unreachable (); 3008 3009 /* Make the function call. */ 3010 fndecl = build_addr (function, current_function_decl); 3011 tmp = build_call_array_loc (input_location, 3012 TREE_TYPE (TREE_TYPE (function)), fndecl, 3013 nargs + 4, args); 3014 gfc_add_expr_to_block (&se->pre, tmp); 3015 3016 /* Free the temporary afterwards, if necessary. */ 3017 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 3018 len, build_int_cst (TREE_TYPE (len), 0)); 3019 tmp = gfc_call_free (var); 3020 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); 3021 gfc_add_expr_to_block (&se->post, tmp); 3022 3023 se->expr = var; 3024 se->string_length = len; 3025} 3026 3027 3028/* Create a symbol node for this intrinsic. The symbol from the frontend 3029 has the generic name. */ 3030 3031static gfc_symbol * 3032gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional) 3033{ 3034 gfc_symbol *sym; 3035 3036 /* TODO: Add symbols for intrinsic function to the global namespace. */ 3037 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5); 3038 sym = gfc_new_symbol (expr->value.function.name, NULL); 3039 3040 sym->ts = expr->ts; 3041 sym->attr.external = 1; 3042 sym->attr.function = 1; 3043 sym->attr.always_explicit = 1; 3044 sym->attr.proc = PROC_INTRINSIC; 3045 sym->attr.flavor = FL_PROCEDURE; 3046 sym->result = sym; 3047 if (expr->rank > 0) 3048 { 3049 sym->attr.dimension = 1; 3050 sym->as = gfc_get_array_spec (); 3051 sym->as->type = AS_ASSUMED_SHAPE; 3052 sym->as->rank = expr->rank; 3053 } 3054 3055 gfc_copy_formal_args_intr (sym, expr->value.function.isym, 3056 ignore_optional ? expr->value.function.actual 3057 : NULL); 3058 3059 return sym; 3060} 3061 3062/* Generate a call to an external intrinsic function. */ 3063static void 3064gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) 3065{ 3066 gfc_symbol *sym; 3067 vec<tree, va_gc> *append_args; 3068 3069 gcc_assert (!se->ss || se->ss->info->expr == expr); 3070 3071 if (se->ss) 3072 gcc_assert (expr->rank > 0); 3073 else 3074 gcc_assert (expr->rank == 0); 3075 3076 sym = gfc_get_symbol_for_expr (expr, se->ignore_optional); 3077 3078 /* Calls to libgfortran_matmul need to be appended special arguments, 3079 to be able to call the BLAS ?gemm functions if required and possible. */ 3080 append_args = NULL; 3081 if (expr->value.function.isym->id == GFC_ISYM_MATMUL 3082 && sym->ts.type != BT_LOGICAL) 3083 { 3084 tree cint = gfc_get_int_type (gfc_c_int_kind); 3085 3086 if (flag_external_blas 3087 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX) 3088 && (sym->ts.kind == 4 || sym->ts.kind == 8)) 3089 { 3090 tree gemm_fndecl; 3091 3092 if (sym->ts.type == BT_REAL) 3093 { 3094 if (sym->ts.kind == 4) 3095 gemm_fndecl = gfor_fndecl_sgemm; 3096 else 3097 gemm_fndecl = gfor_fndecl_dgemm; 3098 } 3099 else 3100 { 3101 if (sym->ts.kind == 4) 3102 gemm_fndecl = gfor_fndecl_cgemm; 3103 else 3104 gemm_fndecl = gfor_fndecl_zgemm; 3105 } 3106 3107 vec_alloc (append_args, 3); 3108 append_args->quick_push (build_int_cst (cint, 1)); 3109 append_args->quick_push (build_int_cst (cint, 3110 flag_blas_matmul_limit)); 3111 append_args->quick_push (gfc_build_addr_expr (NULL_TREE, 3112 gemm_fndecl)); 3113 } 3114 else 3115 { 3116 vec_alloc (append_args, 3); 3117 append_args->quick_push (build_int_cst (cint, 0)); 3118 append_args->quick_push (build_int_cst (cint, 0)); 3119 append_args->quick_push (null_pointer_node); 3120 } 3121 } 3122 3123 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, 3124 append_args); 3125 gfc_free_symbol (sym); 3126} 3127 3128/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR. 3129 Implemented as 3130 any(a) 3131 { 3132 forall (i=...) 3133 if (a[i] != 0) 3134 return 1 3135 end forall 3136 return 0 3137 } 3138 all(a) 3139 { 3140 forall (i=...) 3141 if (a[i] == 0) 3142 return 0 3143 end forall 3144 return 1 3145 } 3146 */ 3147static void 3148gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op) 3149{ 3150 tree resvar; 3151 stmtblock_t block; 3152 stmtblock_t body; 3153 tree type; 3154 tree tmp; 3155 tree found; 3156 gfc_loopinfo loop; 3157 gfc_actual_arglist *actual; 3158 gfc_ss *arrayss; 3159 gfc_se arrayse; 3160 tree exit_label; 3161 3162 if (se->ss) 3163 { 3164 gfc_conv_intrinsic_funcall (se, expr); 3165 return; 3166 } 3167 3168 actual = expr->value.function.actual; 3169 type = gfc_typenode_for_spec (&expr->ts); 3170 /* Initialize the result. */ 3171 resvar = gfc_create_var (type, "test"); 3172 if (op == EQ_EXPR) 3173 tmp = convert (type, boolean_true_node); 3174 else 3175 tmp = convert (type, boolean_false_node); 3176 gfc_add_modify (&se->pre, resvar, tmp); 3177 3178 /* Walk the arguments. */ 3179 arrayss = gfc_walk_expr (actual->expr); 3180 gcc_assert (arrayss != gfc_ss_terminator); 3181 3182 /* Initialize the scalarizer. */ 3183 gfc_init_loopinfo (&loop); 3184 exit_label = gfc_build_label_decl (NULL_TREE); 3185 TREE_USED (exit_label) = 1; 3186 gfc_add_ss_to_loop (&loop, arrayss); 3187 3188 /* Initialize the loop. */ 3189 gfc_conv_ss_startstride (&loop); 3190 gfc_conv_loop_setup (&loop, &expr->where); 3191 3192 gfc_mark_ss_chain_used (arrayss, 1); 3193 /* Generate the loop body. */ 3194 gfc_start_scalarized_body (&loop, &body); 3195 3196 /* If the condition matches then set the return value. */ 3197 gfc_start_block (&block); 3198 if (op == EQ_EXPR) 3199 tmp = convert (type, boolean_false_node); 3200 else 3201 tmp = convert (type, boolean_true_node); 3202 gfc_add_modify (&block, resvar, tmp); 3203 3204 /* And break out of the loop. */ 3205 tmp = build1_v (GOTO_EXPR, exit_label); 3206 gfc_add_expr_to_block (&block, tmp); 3207 3208 found = gfc_finish_block (&block); 3209 3210 /* Check this element. */ 3211 gfc_init_se (&arrayse, NULL); 3212 gfc_copy_loopinfo_to_se (&arrayse, &loop); 3213 arrayse.ss = arrayss; 3214 gfc_conv_expr_val (&arrayse, actual->expr); 3215 3216 gfc_add_block_to_block (&body, &arrayse.pre); 3217 tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr, 3218 build_int_cst (TREE_TYPE (arrayse.expr), 0)); 3219 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location)); 3220 gfc_add_expr_to_block (&body, tmp); 3221 gfc_add_block_to_block (&body, &arrayse.post); 3222 3223 gfc_trans_scalarizing_loops (&loop, &body); 3224 3225 /* Add the exit label. */ 3226 tmp = build1_v (LABEL_EXPR, exit_label); 3227 gfc_add_expr_to_block (&loop.pre, tmp); 3228 3229 gfc_add_block_to_block (&se->pre, &loop.pre); 3230 gfc_add_block_to_block (&se->pre, &loop.post); 3231 gfc_cleanup_loop (&loop); 3232 3233 se->expr = resvar; 3234} 3235 3236/* COUNT(A) = Number of true elements in A. */ 3237static void 3238gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) 3239{ 3240 tree resvar; 3241 tree type; 3242 stmtblock_t body; 3243 tree tmp; 3244 gfc_loopinfo loop; 3245 gfc_actual_arglist *actual; 3246 gfc_ss *arrayss; 3247 gfc_se arrayse; 3248 3249 if (se->ss) 3250 { 3251 gfc_conv_intrinsic_funcall (se, expr); 3252 return; 3253 } 3254 3255 actual = expr->value.function.actual; 3256 3257 type = gfc_typenode_for_spec (&expr->ts); 3258 /* Initialize the result. */ 3259 resvar = gfc_create_var (type, "count"); 3260 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0)); 3261 3262 /* Walk the arguments. */ 3263 arrayss = gfc_walk_expr (actual->expr); 3264 gcc_assert (arrayss != gfc_ss_terminator); 3265 3266 /* Initialize the scalarizer. */ 3267 gfc_init_loopinfo (&loop); 3268 gfc_add_ss_to_loop (&loop, arrayss); 3269 3270 /* Initialize the loop. */ 3271 gfc_conv_ss_startstride (&loop); 3272 gfc_conv_loop_setup (&loop, &expr->where); 3273 3274 gfc_mark_ss_chain_used (arrayss, 1); 3275 /* Generate the loop body. */ 3276 gfc_start_scalarized_body (&loop, &body); 3277 3278 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar), 3279 resvar, build_int_cst (TREE_TYPE (resvar), 1)); 3280 tmp = build2_v (MODIFY_EXPR, resvar, tmp); 3281 3282 gfc_init_se (&arrayse, NULL); 3283 gfc_copy_loopinfo_to_se (&arrayse, &loop); 3284 arrayse.ss = arrayss; 3285 gfc_conv_expr_val (&arrayse, actual->expr); 3286 tmp = build3_v (COND_EXPR, arrayse.expr, tmp, 3287 build_empty_stmt (input_location)); 3288 3289 gfc_add_block_to_block (&body, &arrayse.pre); 3290 gfc_add_expr_to_block (&body, tmp); 3291 gfc_add_block_to_block (&body, &arrayse.post); 3292 3293 gfc_trans_scalarizing_loops (&loop, &body); 3294 3295 gfc_add_block_to_block (&se->pre, &loop.pre); 3296 gfc_add_block_to_block (&se->pre, &loop.post); 3297 gfc_cleanup_loop (&loop); 3298 3299 se->expr = resvar; 3300} 3301 3302 3303/* Update given gfc_se to have ss component pointing to the nested gfc_ss 3304 struct and return the corresponding loopinfo. */ 3305 3306static gfc_loopinfo * 3307enter_nested_loop (gfc_se *se) 3308{ 3309 se->ss = se->ss->nested_ss; 3310 gcc_assert (se->ss == se->ss->loop->ss); 3311 3312 return se->ss->loop; 3313} 3314 3315 3316/* Inline implementation of the sum and product intrinsics. */ 3317static void 3318gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, 3319 bool norm2) 3320{ 3321 tree resvar; 3322 tree scale = NULL_TREE; 3323 tree type; 3324 stmtblock_t body; 3325 stmtblock_t block; 3326 tree tmp; 3327 gfc_loopinfo loop, *ploop; 3328 gfc_actual_arglist *arg_array, *arg_mask; 3329 gfc_ss *arrayss = NULL; 3330 gfc_ss *maskss = NULL; 3331 gfc_se arrayse; 3332 gfc_se maskse; 3333 gfc_se *parent_se; 3334 gfc_expr *arrayexpr; 3335 gfc_expr *maskexpr; 3336 3337 if (expr->rank > 0) 3338 { 3339 gcc_assert (gfc_inline_intrinsic_function_p (expr)); 3340 parent_se = se; 3341 } 3342 else 3343 parent_se = NULL; 3344 3345 type = gfc_typenode_for_spec (&expr->ts); 3346 /* Initialize the result. */ 3347 resvar = gfc_create_var (type, "val"); 3348 if (norm2) 3349 { 3350 /* result = 0.0; 3351 scale = 1.0. */ 3352 scale = gfc_create_var (type, "scale"); 3353 gfc_add_modify (&se->pre, scale, 3354 gfc_build_const (type, integer_one_node)); 3355 tmp = gfc_build_const (type, integer_zero_node); 3356 } 3357 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR) 3358 tmp = gfc_build_const (type, integer_zero_node); 3359 else if (op == NE_EXPR) 3360 /* PARITY. */ 3361 tmp = convert (type, boolean_false_node); 3362 else if (op == BIT_AND_EXPR) 3363 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR, 3364 type, integer_one_node)); 3365 else 3366 tmp = gfc_build_const (type, integer_one_node); 3367 3368 gfc_add_modify (&se->pre, resvar, tmp); 3369 3370 arg_array = expr->value.function.actual; 3371 3372 arrayexpr = arg_array->expr; 3373 3374 if (op == NE_EXPR || norm2) 3375 /* PARITY and NORM2. */ 3376 maskexpr = NULL; 3377 else 3378 { 3379 arg_mask = arg_array->next->next; 3380 gcc_assert (arg_mask != NULL); 3381 maskexpr = arg_mask->expr; 3382 } 3383 3384 if (expr->rank == 0) 3385 { 3386 /* Walk the arguments. */ 3387 arrayss = gfc_walk_expr (arrayexpr); 3388 gcc_assert (arrayss != gfc_ss_terminator); 3389 3390 if (maskexpr && maskexpr->rank > 0) 3391 { 3392 maskss = gfc_walk_expr (maskexpr); 3393 gcc_assert (maskss != gfc_ss_terminator); 3394 } 3395 else 3396 maskss = NULL; 3397 3398 /* Initialize the scalarizer. */ 3399 gfc_init_loopinfo (&loop); 3400 gfc_add_ss_to_loop (&loop, arrayss); 3401 if (maskexpr && maskexpr->rank > 0) 3402 gfc_add_ss_to_loop (&loop, maskss); 3403 3404 /* Initialize the loop. */ 3405 gfc_conv_ss_startstride (&loop); 3406 gfc_conv_loop_setup (&loop, &expr->where); 3407 3408 gfc_mark_ss_chain_used (arrayss, 1); 3409 if (maskexpr && maskexpr->rank > 0) 3410 gfc_mark_ss_chain_used (maskss, 1); 3411 3412 ploop = &loop; 3413 } 3414 else 3415 /* All the work has been done in the parent loops. */ 3416 ploop = enter_nested_loop (se); 3417 3418 gcc_assert (ploop); 3419 3420 /* Generate the loop body. */ 3421 gfc_start_scalarized_body (ploop, &body); 3422 3423 /* If we have a mask, only add this element if the mask is set. */ 3424 if (maskexpr && maskexpr->rank > 0) 3425 { 3426 gfc_init_se (&maskse, parent_se); 3427 gfc_copy_loopinfo_to_se (&maskse, ploop); 3428 if (expr->rank == 0) 3429 maskse.ss = maskss; 3430 gfc_conv_expr_val (&maskse, maskexpr); 3431 gfc_add_block_to_block (&body, &maskse.pre); 3432 3433 gfc_start_block (&block); 3434 } 3435 else 3436 gfc_init_block (&block); 3437 3438 /* Do the actual summation/product. */ 3439 gfc_init_se (&arrayse, parent_se); 3440 gfc_copy_loopinfo_to_se (&arrayse, ploop); 3441 if (expr->rank == 0) 3442 arrayse.ss = arrayss; 3443 gfc_conv_expr_val (&arrayse, arrayexpr); 3444 gfc_add_block_to_block (&block, &arrayse.pre); 3445 3446 if (norm2) 3447 { 3448 /* if (x (i) != 0.0) 3449 { 3450 absX = abs(x(i)) 3451 if (absX > scale) 3452 { 3453 val = scale/absX; 3454 result = 1.0 + result * val * val; 3455 scale = absX; 3456 } 3457 else 3458 { 3459 val = absX/scale; 3460 result += val * val; 3461 } 3462 } */ 3463 tree res1, res2, cond, absX, val; 3464 stmtblock_t ifblock1, ifblock2, ifblock3; 3465 3466 gfc_init_block (&ifblock1); 3467 3468 absX = gfc_create_var (type, "absX"); 3469 gfc_add_modify (&ifblock1, absX, 3470 fold_build1_loc (input_location, ABS_EXPR, type, 3471 arrayse.expr)); 3472 val = gfc_create_var (type, "val"); 3473 gfc_add_expr_to_block (&ifblock1, val); 3474 3475 gfc_init_block (&ifblock2); 3476 gfc_add_modify (&ifblock2, val, 3477 fold_build2_loc (input_location, RDIV_EXPR, type, scale, 3478 absX)); 3479 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); 3480 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1); 3481 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1, 3482 gfc_build_const (type, integer_one_node)); 3483 gfc_add_modify (&ifblock2, resvar, res1); 3484 gfc_add_modify (&ifblock2, scale, absX); 3485 res1 = gfc_finish_block (&ifblock2); 3486 3487 gfc_init_block (&ifblock3); 3488 gfc_add_modify (&ifblock3, val, 3489 fold_build2_loc (input_location, RDIV_EXPR, type, absX, 3490 scale)); 3491 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); 3492 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2); 3493 gfc_add_modify (&ifblock3, resvar, res2); 3494 res2 = gfc_finish_block (&ifblock3); 3495 3496 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 3497 absX, scale); 3498 tmp = build3_v (COND_EXPR, cond, res1, res2); 3499 gfc_add_expr_to_block (&ifblock1, tmp); 3500 tmp = gfc_finish_block (&ifblock1); 3501 3502 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 3503 arrayse.expr, 3504 gfc_build_const (type, integer_zero_node)); 3505 3506 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); 3507 gfc_add_expr_to_block (&block, tmp); 3508 } 3509 else 3510 { 3511 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr); 3512 gfc_add_modify (&block, resvar, tmp); 3513 } 3514 3515 gfc_add_block_to_block (&block, &arrayse.post); 3516 3517 if (maskexpr && maskexpr->rank > 0) 3518 { 3519 /* We enclose the above in if (mask) {...} . */ 3520 3521 tmp = gfc_finish_block (&block); 3522 tmp = build3_v (COND_EXPR, maskse.expr, tmp, 3523 build_empty_stmt (input_location)); 3524 } 3525 else 3526 tmp = gfc_finish_block (&block); 3527 gfc_add_expr_to_block (&body, tmp); 3528 3529 gfc_trans_scalarizing_loops (ploop, &body); 3530 3531 /* For a scalar mask, enclose the loop in an if statement. */ 3532 if (maskexpr && maskexpr->rank == 0) 3533 { 3534 gfc_init_block (&block); 3535 gfc_add_block_to_block (&block, &ploop->pre); 3536 gfc_add_block_to_block (&block, &ploop->post); 3537 tmp = gfc_finish_block (&block); 3538 3539 if (expr->rank > 0) 3540 { 3541 tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp, 3542 build_empty_stmt (input_location)); 3543 gfc_advance_se_ss_chain (se); 3544 } 3545 else 3546 { 3547 gcc_assert (expr->rank == 0); 3548 gfc_init_se (&maskse, NULL); 3549 gfc_conv_expr_val (&maskse, maskexpr); 3550 tmp = build3_v (COND_EXPR, maskse.expr, tmp, 3551 build_empty_stmt (input_location)); 3552 } 3553 3554 gfc_add_expr_to_block (&block, tmp); 3555 gfc_add_block_to_block (&se->pre, &block); 3556 gcc_assert (se->post.head == NULL); 3557 } 3558 else 3559 { 3560 gfc_add_block_to_block (&se->pre, &ploop->pre); 3561 gfc_add_block_to_block (&se->pre, &ploop->post); 3562 } 3563 3564 if (expr->rank == 0) 3565 gfc_cleanup_loop (ploop); 3566 3567 if (norm2) 3568 { 3569 /* result = scale * sqrt(result). */ 3570 tree sqrt; 3571 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind); 3572 resvar = build_call_expr_loc (input_location, 3573 sqrt, 1, resvar); 3574 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar); 3575 } 3576 3577 se->expr = resvar; 3578} 3579 3580 3581/* Inline implementation of the dot_product intrinsic. This function 3582 is based on gfc_conv_intrinsic_arith (the previous function). */ 3583static void 3584gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) 3585{ 3586 tree resvar; 3587 tree type; 3588 stmtblock_t body; 3589 stmtblock_t block; 3590 tree tmp; 3591 gfc_loopinfo loop; 3592 gfc_actual_arglist *actual; 3593 gfc_ss *arrayss1, *arrayss2; 3594 gfc_se arrayse1, arrayse2; 3595 gfc_expr *arrayexpr1, *arrayexpr2; 3596 3597 type = gfc_typenode_for_spec (&expr->ts); 3598 3599 /* Initialize the result. */ 3600 resvar = gfc_create_var (type, "val"); 3601 if (expr->ts.type == BT_LOGICAL) 3602 tmp = build_int_cst (type, 0); 3603 else 3604 tmp = gfc_build_const (type, integer_zero_node); 3605 3606 gfc_add_modify (&se->pre, resvar, tmp); 3607 3608 /* Walk argument #1. */ 3609 actual = expr->value.function.actual; 3610 arrayexpr1 = actual->expr; 3611 arrayss1 = gfc_walk_expr (arrayexpr1); 3612 gcc_assert (arrayss1 != gfc_ss_terminator); 3613 3614 /* Walk argument #2. */ 3615 actual = actual->next; 3616 arrayexpr2 = actual->expr; 3617 arrayss2 = gfc_walk_expr (arrayexpr2); 3618 gcc_assert (arrayss2 != gfc_ss_terminator); 3619 3620 /* Initialize the scalarizer. */ 3621 gfc_init_loopinfo (&loop); 3622 gfc_add_ss_to_loop (&loop, arrayss1); 3623 gfc_add_ss_to_loop (&loop, arrayss2); 3624 3625 /* Initialize the loop. */ 3626 gfc_conv_ss_startstride (&loop); 3627 gfc_conv_loop_setup (&loop, &expr->where); 3628 3629 gfc_mark_ss_chain_used (arrayss1, 1); 3630 gfc_mark_ss_chain_used (arrayss2, 1); 3631 3632 /* Generate the loop body. */ 3633 gfc_start_scalarized_body (&loop, &body); 3634 gfc_init_block (&block); 3635 3636 /* Make the tree expression for [conjg(]array1[)]. */ 3637 gfc_init_se (&arrayse1, NULL); 3638 gfc_copy_loopinfo_to_se (&arrayse1, &loop); 3639 arrayse1.ss = arrayss1; 3640 gfc_conv_expr_val (&arrayse1, arrayexpr1); 3641 if (expr->ts.type == BT_COMPLEX) 3642 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type, 3643 arrayse1.expr); 3644 gfc_add_block_to_block (&block, &arrayse1.pre); 3645 3646 /* Make the tree expression for array2. */ 3647 gfc_init_se (&arrayse2, NULL); 3648 gfc_copy_loopinfo_to_se (&arrayse2, &loop); 3649 arrayse2.ss = arrayss2; 3650 gfc_conv_expr_val (&arrayse2, arrayexpr2); 3651 gfc_add_block_to_block (&block, &arrayse2.pre); 3652 3653 /* Do the actual product and sum. */ 3654 if (expr->ts.type == BT_LOGICAL) 3655 { 3656 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type, 3657 arrayse1.expr, arrayse2.expr); 3658 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp); 3659 } 3660 else 3661 { 3662 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr, 3663 arrayse2.expr); 3664 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp); 3665 } 3666 gfc_add_modify (&block, resvar, tmp); 3667 3668 /* Finish up the loop block and the loop. */ 3669 tmp = gfc_finish_block (&block); 3670 gfc_add_expr_to_block (&body, tmp); 3671 3672 gfc_trans_scalarizing_loops (&loop, &body); 3673 gfc_add_block_to_block (&se->pre, &loop.pre); 3674 gfc_add_block_to_block (&se->pre, &loop.post); 3675 gfc_cleanup_loop (&loop); 3676 3677 se->expr = resvar; 3678} 3679 3680 3681/* Emit code for minloc or maxloc intrinsic. There are many different cases 3682 we need to handle. For performance reasons we sometimes create two 3683 loops instead of one, where the second one is much simpler. 3684 Examples for minloc intrinsic: 3685 1) Result is an array, a call is generated 3686 2) Array mask is used and NaNs need to be supported: 3687 limit = Infinity; 3688 pos = 0; 3689 S = from; 3690 while (S <= to) { 3691 if (mask[S]) { 3692 if (pos == 0) pos = S + (1 - from); 3693 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } 3694 } 3695 S++; 3696 } 3697 goto lab2; 3698 lab1:; 3699 while (S <= to) { 3700 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } 3701 S++; 3702 } 3703 lab2:; 3704 3) NaNs need to be supported, but it is known at compile time or cheaply 3705 at runtime whether array is nonempty or not: 3706 limit = Infinity; 3707 pos = 0; 3708 S = from; 3709 while (S <= to) { 3710 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } 3711 S++; 3712 } 3713 if (from <= to) pos = 1; 3714 goto lab2; 3715 lab1:; 3716 while (S <= to) { 3717 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } 3718 S++; 3719 } 3720 lab2:; 3721 4) NaNs aren't supported, array mask is used: 3722 limit = infinities_supported ? Infinity : huge (limit); 3723 pos = 0; 3724 S = from; 3725 while (S <= to) { 3726 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; } 3727 S++; 3728 } 3729 goto lab2; 3730 lab1:; 3731 while (S <= to) { 3732 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } 3733 S++; 3734 } 3735 lab2:; 3736 5) Same without array mask: 3737 limit = infinities_supported ? Infinity : huge (limit); 3738 pos = (from <= to) ? 1 : 0; 3739 S = from; 3740 while (S <= to) { 3741 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } 3742 S++; 3743 } 3744 For 3) and 5), if mask is scalar, this all goes into a conditional, 3745 setting pos = 0; in the else branch. */ 3746 3747static void 3748gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) 3749{ 3750 stmtblock_t body; 3751 stmtblock_t block; 3752 stmtblock_t ifblock; 3753 stmtblock_t elseblock; 3754 tree limit; 3755 tree type; 3756 tree tmp; 3757 tree cond; 3758 tree elsetmp; 3759 tree ifbody; 3760 tree offset; 3761 tree nonempty; 3762 tree lab1, lab2; 3763 gfc_loopinfo loop; 3764 gfc_actual_arglist *actual; 3765 gfc_ss *arrayss; 3766 gfc_ss *maskss; 3767 gfc_se arrayse; 3768 gfc_se maskse; 3769 gfc_expr *arrayexpr; 3770 gfc_expr *maskexpr; 3771 tree pos; 3772 int n; 3773 3774 if (se->ss) 3775 { 3776 gfc_conv_intrinsic_funcall (se, expr); 3777 return; 3778 } 3779 3780 /* Initialize the result. */ 3781 pos = gfc_create_var (gfc_array_index_type, "pos"); 3782 offset = gfc_create_var (gfc_array_index_type, "offset"); 3783 type = gfc_typenode_for_spec (&expr->ts); 3784 3785 /* Walk the arguments. */ 3786 actual = expr->value.function.actual; 3787 arrayexpr = actual->expr; 3788 arrayss = gfc_walk_expr (arrayexpr); 3789 gcc_assert (arrayss != gfc_ss_terminator); 3790 3791 actual = actual->next->next; 3792 gcc_assert (actual); 3793 maskexpr = actual->expr; 3794 nonempty = NULL; 3795 if (maskexpr && maskexpr->rank != 0) 3796 { 3797 maskss = gfc_walk_expr (maskexpr); 3798 gcc_assert (maskss != gfc_ss_terminator); 3799 } 3800 else 3801 { 3802 mpz_t asize; 3803 if (gfc_array_size (arrayexpr, &asize)) 3804 { 3805 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); 3806 mpz_clear (asize); 3807 nonempty = fold_build2_loc (input_location, GT_EXPR, 3808 boolean_type_node, nonempty, 3809 gfc_index_zero_node); 3810 } 3811 maskss = NULL; 3812 } 3813 3814 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit"); 3815 switch (arrayexpr->ts.type) 3816 { 3817 case BT_REAL: 3818 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind); 3819 break; 3820 3821 case BT_INTEGER: 3822 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); 3823 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, 3824 arrayexpr->ts.kind); 3825 break; 3826 3827 default: 3828 gcc_unreachable (); 3829 } 3830 3831 /* We start with the most negative possible value for MAXLOC, and the most 3832 positive possible value for MINLOC. The most negative possible value is 3833 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive 3834 possible value is HUGE in both cases. */ 3835 if (op == GT_EXPR) 3836 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp); 3837 if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER) 3838 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp, 3839 build_int_cst (TREE_TYPE (tmp), 1)); 3840 3841 gfc_add_modify (&se->pre, limit, tmp); 3842 3843 /* Initialize the scalarizer. */ 3844 gfc_init_loopinfo (&loop); 3845 gfc_add_ss_to_loop (&loop, arrayss); 3846 if (maskss) 3847 gfc_add_ss_to_loop (&loop, maskss); 3848 3849 /* Initialize the loop. */ 3850 gfc_conv_ss_startstride (&loop); 3851 3852 /* The code generated can have more than one loop in sequence (see the 3853 comment at the function header). This doesn't work well with the 3854 scalarizer, which changes arrays' offset when the scalarization loops 3855 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc 3856 are currently inlined in the scalar case only (for which loop is of rank 3857 one). As there is no dependency to care about in that case, there is no 3858 temporary, so that we can use the scalarizer temporary code to handle 3859 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used 3860 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later 3861 to restore offset. 3862 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this 3863 should eventually go away. We could either create two loops properly, 3864 or find another way to save/restore the array offsets between the two 3865 loops (without conflicting with temporary management), or use a single 3866 loop minmaxloc implementation. See PR 31067. */ 3867 loop.temp_dim = loop.dimen; 3868 gfc_conv_loop_setup (&loop, &expr->where); 3869 3870 gcc_assert (loop.dimen == 1); 3871 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0]) 3872 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, 3873 loop.from[0], loop.to[0]); 3874 3875 lab1 = NULL; 3876 lab2 = NULL; 3877 /* Initialize the position to zero, following Fortran 2003. We are free 3878 to do this because Fortran 95 allows the result of an entirely false 3879 mask to be processor dependent. If we know at compile time the array 3880 is non-empty and no MASK is used, we can initialize to 1 to simplify 3881 the inner loop. */ 3882 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit))) 3883 gfc_add_modify (&loop.pre, pos, 3884 fold_build3_loc (input_location, COND_EXPR, 3885 gfc_array_index_type, 3886 nonempty, gfc_index_one_node, 3887 gfc_index_zero_node)); 3888 else 3889 { 3890 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node); 3891 lab1 = gfc_build_label_decl (NULL_TREE); 3892 TREE_USED (lab1) = 1; 3893 lab2 = gfc_build_label_decl (NULL_TREE); 3894 TREE_USED (lab2) = 1; 3895 } 3896 3897 /* An offset must be added to the loop 3898 counter to obtain the required position. */ 3899 gcc_assert (loop.from[0]); 3900 3901 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 3902 gfc_index_one_node, loop.from[0]); 3903 gfc_add_modify (&loop.pre, offset, tmp); 3904 3905 gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1); 3906 if (maskss) 3907 gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1); 3908 /* Generate the loop body. */ 3909 gfc_start_scalarized_body (&loop, &body); 3910 3911 /* If we have a mask, only check this element if the mask is set. */ 3912 if (maskss) 3913 { 3914 gfc_init_se (&maskse, NULL); 3915 gfc_copy_loopinfo_to_se (&maskse, &loop); 3916 maskse.ss = maskss; 3917 gfc_conv_expr_val (&maskse, maskexpr); 3918 gfc_add_block_to_block (&body, &maskse.pre); 3919 3920 gfc_start_block (&block); 3921 } 3922 else 3923 gfc_init_block (&block); 3924 3925 /* Compare with the current limit. */ 3926 gfc_init_se (&arrayse, NULL); 3927 gfc_copy_loopinfo_to_se (&arrayse, &loop); 3928 arrayse.ss = arrayss; 3929 gfc_conv_expr_val (&arrayse, arrayexpr); 3930 gfc_add_block_to_block (&block, &arrayse.pre); 3931 3932 /* We do the following if this is a more extreme value. */ 3933 gfc_start_block (&ifblock); 3934 3935 /* Assign the value to the limit... */ 3936 gfc_add_modify (&ifblock, limit, arrayse.expr); 3937 3938 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit))) 3939 { 3940 stmtblock_t ifblock2; 3941 tree ifbody2; 3942 3943 gfc_start_block (&ifblock2); 3944 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), 3945 loop.loopvar[0], offset); 3946 gfc_add_modify (&ifblock2, pos, tmp); 3947 ifbody2 = gfc_finish_block (&ifblock2); 3948 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos, 3949 gfc_index_zero_node); 3950 tmp = build3_v (COND_EXPR, cond, ifbody2, 3951 build_empty_stmt (input_location)); 3952 gfc_add_expr_to_block (&block, tmp); 3953 } 3954 3955 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), 3956 loop.loopvar[0], offset); 3957 gfc_add_modify (&ifblock, pos, tmp); 3958 3959 if (lab1) 3960 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1)); 3961 3962 ifbody = gfc_finish_block (&ifblock); 3963 3964 if (!lab1 || HONOR_NANS (DECL_MODE (limit))) 3965 { 3966 if (lab1) 3967 cond = fold_build2_loc (input_location, 3968 op == GT_EXPR ? GE_EXPR : LE_EXPR, 3969 boolean_type_node, arrayse.expr, limit); 3970 else 3971 cond = fold_build2_loc (input_location, op, boolean_type_node, 3972 arrayse.expr, limit); 3973 3974 ifbody = build3_v (COND_EXPR, cond, ifbody, 3975 build_empty_stmt (input_location)); 3976 } 3977 gfc_add_expr_to_block (&block, ifbody); 3978 3979 if (maskss) 3980 { 3981 /* We enclose the above in if (mask) {...}. */ 3982 tmp = gfc_finish_block (&block); 3983 3984 tmp = build3_v (COND_EXPR, maskse.expr, tmp, 3985 build_empty_stmt (input_location)); 3986 } 3987 else 3988 tmp = gfc_finish_block (&block); 3989 gfc_add_expr_to_block (&body, tmp); 3990 3991 if (lab1) 3992 { 3993 gfc_trans_scalarized_loop_boundary (&loop, &body); 3994 3995 if (HONOR_NANS (DECL_MODE (limit))) 3996 { 3997 if (nonempty != NULL) 3998 { 3999 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node); 4000 tmp = build3_v (COND_EXPR, nonempty, ifbody, 4001 build_empty_stmt (input_location)); 4002 gfc_add_expr_to_block (&loop.code[0], tmp); 4003 } 4004 } 4005 4006 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2)); 4007 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1)); 4008 4009 /* If we have a mask, only check this element if the mask is set. */ 4010 if (maskss) 4011 { 4012 gfc_init_se (&maskse, NULL); 4013 gfc_copy_loopinfo_to_se (&maskse, &loop); 4014 maskse.ss = maskss; 4015 gfc_conv_expr_val (&maskse, maskexpr); 4016 gfc_add_block_to_block (&body, &maskse.pre); 4017 4018 gfc_start_block (&block); 4019 } 4020 else 4021 gfc_init_block (&block); 4022 4023 /* Compare with the current limit. */ 4024 gfc_init_se (&arrayse, NULL); 4025 gfc_copy_loopinfo_to_se (&arrayse, &loop); 4026 arrayse.ss = arrayss; 4027 gfc_conv_expr_val (&arrayse, arrayexpr); 4028 gfc_add_block_to_block (&block, &arrayse.pre); 4029 4030 /* We do the following if this is a more extreme value. */ 4031 gfc_start_block (&ifblock); 4032 4033 /* Assign the value to the limit... */ 4034 gfc_add_modify (&ifblock, limit, arrayse.expr); 4035 4036 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), 4037 loop.loopvar[0], offset); 4038 gfc_add_modify (&ifblock, pos, tmp); 4039 4040 ifbody = gfc_finish_block (&ifblock); 4041 4042 cond = fold_build2_loc (input_location, op, boolean_type_node, 4043 arrayse.expr, limit); 4044 4045 tmp = build3_v (COND_EXPR, cond, ifbody, 4046 build_empty_stmt (input_location)); 4047 gfc_add_expr_to_block (&block, tmp); 4048 4049 if (maskss) 4050 { 4051 /* We enclose the above in if (mask) {...}. */ 4052 tmp = gfc_finish_block (&block); 4053 4054 tmp = build3_v (COND_EXPR, maskse.expr, tmp, 4055 build_empty_stmt (input_location)); 4056 } 4057 else 4058 tmp = gfc_finish_block (&block); 4059 gfc_add_expr_to_block (&body, tmp); 4060 /* Avoid initializing loopvar[0] again, it should be left where 4061 it finished by the first loop. */ 4062 loop.from[0] = loop.loopvar[0]; 4063 } 4064 4065 gfc_trans_scalarizing_loops (&loop, &body); 4066 4067 if (lab2) 4068 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2)); 4069 4070 /* For a scalar mask, enclose the loop in an if statement. */ 4071 if (maskexpr && maskss == NULL) 4072 { 4073 gfc_init_se (&maskse, NULL); 4074 gfc_conv_expr_val (&maskse, maskexpr); 4075 gfc_init_block (&block); 4076 gfc_add_block_to_block (&block, &loop.pre); 4077 gfc_add_block_to_block (&block, &loop.post); 4078 tmp = gfc_finish_block (&block); 4079 4080 /* For the else part of the scalar mask, just initialize 4081 the pos variable the same way as above. */ 4082 4083 gfc_init_block (&elseblock); 4084 gfc_add_modify (&elseblock, pos, gfc_index_zero_node); 4085 elsetmp = gfc_finish_block (&elseblock); 4086 4087 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp); 4088 gfc_add_expr_to_block (&block, tmp); 4089 gfc_add_block_to_block (&se->pre, &block); 4090 } 4091 else 4092 { 4093 gfc_add_block_to_block (&se->pre, &loop.pre); 4094 gfc_add_block_to_block (&se->pre, &loop.post); 4095 } 4096 gfc_cleanup_loop (&loop); 4097 4098 se->expr = convert (type, pos); 4099} 4100 4101/* Emit code for minval or maxval intrinsic. There are many different cases 4102 we need to handle. For performance reasons we sometimes create two 4103 loops instead of one, where the second one is much simpler. 4104 Examples for minval intrinsic: 4105 1) Result is an array, a call is generated 4106 2) Array mask is used and NaNs need to be supported, rank 1: 4107 limit = Infinity; 4108 nonempty = false; 4109 S = from; 4110 while (S <= to) { 4111 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; } 4112 S++; 4113 } 4114 limit = nonempty ? NaN : huge (limit); 4115 lab: 4116 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; } 4117 3) NaNs need to be supported, but it is known at compile time or cheaply 4118 at runtime whether array is nonempty or not, rank 1: 4119 limit = Infinity; 4120 S = from; 4121 while (S <= to) { if (a[S] <= limit) goto lab; S++; } 4122 limit = (from <= to) ? NaN : huge (limit); 4123 lab: 4124 while (S <= to) { limit = min (a[S], limit); S++; } 4125 4) Array mask is used and NaNs need to be supported, rank > 1: 4126 limit = Infinity; 4127 nonempty = false; 4128 fast = false; 4129 S1 = from1; 4130 while (S1 <= to1) { 4131 S2 = from2; 4132 while (S2 <= to2) { 4133 if (mask[S1][S2]) { 4134 if (fast) limit = min (a[S1][S2], limit); 4135 else { 4136 nonempty = true; 4137 if (a[S1][S2] <= limit) { 4138 limit = a[S1][S2]; 4139 fast = true; 4140 } 4141 } 4142 } 4143 S2++; 4144 } 4145 S1++; 4146 } 4147 if (!fast) 4148 limit = nonempty ? NaN : huge (limit); 4149 5) NaNs need to be supported, but it is known at compile time or cheaply 4150 at runtime whether array is nonempty or not, rank > 1: 4151 limit = Infinity; 4152 fast = false; 4153 S1 = from1; 4154 while (S1 <= to1) { 4155 S2 = from2; 4156 while (S2 <= to2) { 4157 if (fast) limit = min (a[S1][S2], limit); 4158 else { 4159 if (a[S1][S2] <= limit) { 4160 limit = a[S1][S2]; 4161 fast = true; 4162 } 4163 } 4164 S2++; 4165 } 4166 S1++; 4167 } 4168 if (!fast) 4169 limit = (nonempty_array) ? NaN : huge (limit); 4170 6) NaNs aren't supported, but infinities are. Array mask is used: 4171 limit = Infinity; 4172 nonempty = false; 4173 S = from; 4174 while (S <= to) { 4175 if (mask[S]) { nonempty = true; limit = min (a[S], limit); } 4176 S++; 4177 } 4178 limit = nonempty ? limit : huge (limit); 4179 7) Same without array mask: 4180 limit = Infinity; 4181 S = from; 4182 while (S <= to) { limit = min (a[S], limit); S++; } 4183 limit = (from <= to) ? limit : huge (limit); 4184 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER): 4185 limit = huge (limit); 4186 S = from; 4187 while (S <= to) { limit = min (a[S], limit); S++); } 4188 (or 4189 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; } 4190 with array mask instead). 4191 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional, 4192 setting limit = huge (limit); in the else branch. */ 4193 4194static void 4195gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) 4196{ 4197 tree limit; 4198 tree type; 4199 tree tmp; 4200 tree ifbody; 4201 tree nonempty; 4202 tree nonempty_var; 4203 tree lab; 4204 tree fast; 4205 tree huge_cst = NULL, nan_cst = NULL; 4206 stmtblock_t body; 4207 stmtblock_t block, block2; 4208 gfc_loopinfo loop; 4209 gfc_actual_arglist *actual; 4210 gfc_ss *arrayss; 4211 gfc_ss *maskss; 4212 gfc_se arrayse; 4213 gfc_se maskse; 4214 gfc_expr *arrayexpr; 4215 gfc_expr *maskexpr; 4216 int n; 4217 4218 if (se->ss) 4219 { 4220 gfc_conv_intrinsic_funcall (se, expr); 4221 return; 4222 } 4223 4224 type = gfc_typenode_for_spec (&expr->ts); 4225 /* Initialize the result. */ 4226 limit = gfc_create_var (type, "limit"); 4227 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false); 4228 switch (expr->ts.type) 4229 { 4230 case BT_REAL: 4231 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, 4232 expr->ts.kind, 0); 4233 if (HONOR_INFINITIES (DECL_MODE (limit))) 4234 { 4235 REAL_VALUE_TYPE real; 4236 real_inf (&real); 4237 tmp = build_real (type, real); 4238 } 4239 else 4240 tmp = huge_cst; 4241 if (HONOR_NANS (DECL_MODE (limit))) 4242 nan_cst = gfc_build_nan (type, ""); 4243 break; 4244 4245 case BT_INTEGER: 4246 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind); 4247 break; 4248 4249 default: 4250 gcc_unreachable (); 4251 } 4252 4253 /* We start with the most negative possible value for MAXVAL, and the most 4254 positive possible value for MINVAL. The most negative possible value is 4255 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive 4256 possible value is HUGE in both cases. */ 4257 if (op == GT_EXPR) 4258 { 4259 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp); 4260 if (huge_cst) 4261 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR, 4262 TREE_TYPE (huge_cst), huge_cst); 4263 } 4264 4265 if (op == GT_EXPR && expr->ts.type == BT_INTEGER) 4266 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), 4267 tmp, build_int_cst (type, 1)); 4268 4269 gfc_add_modify (&se->pre, limit, tmp); 4270 4271 /* Walk the arguments. */ 4272 actual = expr->value.function.actual; 4273 arrayexpr = actual->expr; 4274 arrayss = gfc_walk_expr (arrayexpr); 4275 gcc_assert (arrayss != gfc_ss_terminator); 4276 4277 actual = actual->next->next; 4278 gcc_assert (actual); 4279 maskexpr = actual->expr; 4280 nonempty = NULL; 4281 if (maskexpr && maskexpr->rank != 0) 4282 { 4283 maskss = gfc_walk_expr (maskexpr); 4284 gcc_assert (maskss != gfc_ss_terminator); 4285 } 4286 else 4287 { 4288 mpz_t asize; 4289 if (gfc_array_size (arrayexpr, &asize)) 4290 { 4291 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); 4292 mpz_clear (asize); 4293 nonempty = fold_build2_loc (input_location, GT_EXPR, 4294 boolean_type_node, nonempty, 4295 gfc_index_zero_node); 4296 } 4297 maskss = NULL; 4298 } 4299 4300 /* Initialize the scalarizer. */ 4301 gfc_init_loopinfo (&loop); 4302 gfc_add_ss_to_loop (&loop, arrayss); 4303 if (maskss) 4304 gfc_add_ss_to_loop (&loop, maskss); 4305 4306 /* Initialize the loop. */ 4307 gfc_conv_ss_startstride (&loop); 4308 4309 /* The code generated can have more than one loop in sequence (see the 4310 comment at the function header). This doesn't work well with the 4311 scalarizer, which changes arrays' offset when the scalarization loops 4312 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val 4313 are currently inlined in the scalar case only. As there is no dependency 4314 to care about in that case, there is no temporary, so that we can use the 4315 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim 4316 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use 4317 gfc_trans_scalarized_loop_boundary even later to restore offset. 4318 TODO: this prevents inlining of rank > 0 minmaxval calls, so this 4319 should eventually go away. We could either create two loops properly, 4320 or find another way to save/restore the array offsets between the two 4321 loops (without conflicting with temporary management), or use a single 4322 loop minmaxval implementation. See PR 31067. */ 4323 loop.temp_dim = loop.dimen; 4324 gfc_conv_loop_setup (&loop, &expr->where); 4325 4326 if (nonempty == NULL && maskss == NULL 4327 && loop.dimen == 1 && loop.from[0] && loop.to[0]) 4328 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, 4329 loop.from[0], loop.to[0]); 4330 nonempty_var = NULL; 4331 if (nonempty == NULL 4332 && (HONOR_INFINITIES (DECL_MODE (limit)) 4333 || HONOR_NANS (DECL_MODE (limit)))) 4334 { 4335 nonempty_var = gfc_create_var (boolean_type_node, "nonempty"); 4336 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node); 4337 nonempty = nonempty_var; 4338 } 4339 lab = NULL; 4340 fast = NULL; 4341 if (HONOR_NANS (DECL_MODE (limit))) 4342 { 4343 if (loop.dimen == 1) 4344 { 4345 lab = gfc_build_label_decl (NULL_TREE); 4346 TREE_USED (lab) = 1; 4347 } 4348 else 4349 { 4350 fast = gfc_create_var (boolean_type_node, "fast"); 4351 gfc_add_modify (&se->pre, fast, boolean_false_node); 4352 } 4353 } 4354 4355 gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1); 4356 if (maskss) 4357 gfc_mark_ss_chain_used (maskss, lab ? 3 : 1); 4358 /* Generate the loop body. */ 4359 gfc_start_scalarized_body (&loop, &body); 4360 4361 /* If we have a mask, only add this element if the mask is set. */ 4362 if (maskss) 4363 { 4364 gfc_init_se (&maskse, NULL); 4365 gfc_copy_loopinfo_to_se (&maskse, &loop); 4366 maskse.ss = maskss; 4367 gfc_conv_expr_val (&maskse, maskexpr); 4368 gfc_add_block_to_block (&body, &maskse.pre); 4369 4370 gfc_start_block (&block); 4371 } 4372 else 4373 gfc_init_block (&block); 4374 4375 /* Compare with the current limit. */ 4376 gfc_init_se (&arrayse, NULL); 4377 gfc_copy_loopinfo_to_se (&arrayse, &loop); 4378 arrayse.ss = arrayss; 4379 gfc_conv_expr_val (&arrayse, arrayexpr); 4380 gfc_add_block_to_block (&block, &arrayse.pre); 4381 4382 gfc_init_block (&block2); 4383 4384 if (nonempty_var) 4385 gfc_add_modify (&block2, nonempty_var, boolean_true_node); 4386 4387 if (HONOR_NANS (DECL_MODE (limit))) 4388 { 4389 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR, 4390 boolean_type_node, arrayse.expr, limit); 4391 if (lab) 4392 ifbody = build1_v (GOTO_EXPR, lab); 4393 else 4394 { 4395 stmtblock_t ifblock; 4396 4397 gfc_init_block (&ifblock); 4398 gfc_add_modify (&ifblock, limit, arrayse.expr); 4399 gfc_add_modify (&ifblock, fast, boolean_true_node); 4400 ifbody = gfc_finish_block (&ifblock); 4401 } 4402 tmp = build3_v (COND_EXPR, tmp, ifbody, 4403 build_empty_stmt (input_location)); 4404 gfc_add_expr_to_block (&block2, tmp); 4405 } 4406 else 4407 { 4408 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or 4409 signed zeros. */ 4410 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit))) 4411 { 4412 tmp = fold_build2_loc (input_location, op, boolean_type_node, 4413 arrayse.expr, limit); 4414 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); 4415 tmp = build3_v (COND_EXPR, tmp, ifbody, 4416 build_empty_stmt (input_location)); 4417 gfc_add_expr_to_block (&block2, tmp); 4418 } 4419 else 4420 { 4421 tmp = fold_build2_loc (input_location, 4422 op == GT_EXPR ? MAX_EXPR : MIN_EXPR, 4423 type, arrayse.expr, limit); 4424 gfc_add_modify (&block2, limit, tmp); 4425 } 4426 } 4427 4428 if (fast) 4429 { 4430 tree elsebody = gfc_finish_block (&block2); 4431 4432 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or 4433 signed zeros. */ 4434 if (HONOR_NANS (DECL_MODE (limit)) 4435 || HONOR_SIGNED_ZEROS (DECL_MODE (limit))) 4436 { 4437 tmp = fold_build2_loc (input_location, op, boolean_type_node, 4438 arrayse.expr, limit); 4439 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); 4440 ifbody = build3_v (COND_EXPR, tmp, ifbody, 4441 build_empty_stmt (input_location)); 4442 } 4443 else 4444 { 4445 tmp = fold_build2_loc (input_location, 4446 op == GT_EXPR ? MAX_EXPR : MIN_EXPR, 4447 type, arrayse.expr, limit); 4448 ifbody = build2_v (MODIFY_EXPR, limit, tmp); 4449 } 4450 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody); 4451 gfc_add_expr_to_block (&block, tmp); 4452 } 4453 else 4454 gfc_add_block_to_block (&block, &block2); 4455 4456 gfc_add_block_to_block (&block, &arrayse.post); 4457 4458 tmp = gfc_finish_block (&block); 4459 if (maskss) 4460 /* We enclose the above in if (mask) {...}. */ 4461 tmp = build3_v (COND_EXPR, maskse.expr, tmp, 4462 build_empty_stmt (input_location)); 4463 gfc_add_expr_to_block (&body, tmp); 4464 4465 if (lab) 4466 { 4467 gfc_trans_scalarized_loop_boundary (&loop, &body); 4468 4469 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, 4470 nan_cst, huge_cst); 4471 gfc_add_modify (&loop.code[0], limit, tmp); 4472 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab)); 4473 4474 /* If we have a mask, only add this element if the mask is set. */ 4475 if (maskss) 4476 { 4477 gfc_init_se (&maskse, NULL); 4478 gfc_copy_loopinfo_to_se (&maskse, &loop); 4479 maskse.ss = maskss; 4480 gfc_conv_expr_val (&maskse, maskexpr); 4481 gfc_add_block_to_block (&body, &maskse.pre); 4482 4483 gfc_start_block (&block); 4484 } 4485 else 4486 gfc_init_block (&block); 4487 4488 /* Compare with the current limit. */ 4489 gfc_init_se (&arrayse, NULL); 4490 gfc_copy_loopinfo_to_se (&arrayse, &loop); 4491 arrayse.ss = arrayss; 4492 gfc_conv_expr_val (&arrayse, arrayexpr); 4493 gfc_add_block_to_block (&block, &arrayse.pre); 4494 4495 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or 4496 signed zeros. */ 4497 if (HONOR_NANS (DECL_MODE (limit)) 4498 || HONOR_SIGNED_ZEROS (DECL_MODE (limit))) 4499 { 4500 tmp = fold_build2_loc (input_location, op, boolean_type_node, 4501 arrayse.expr, limit); 4502 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); 4503 tmp = build3_v (COND_EXPR, tmp, ifbody, 4504 build_empty_stmt (input_location)); 4505 gfc_add_expr_to_block (&block, tmp); 4506 } 4507 else 4508 { 4509 tmp = fold_build2_loc (input_location, 4510 op == GT_EXPR ? MAX_EXPR : MIN_EXPR, 4511 type, arrayse.expr, limit); 4512 gfc_add_modify (&block, limit, tmp); 4513 } 4514 4515 gfc_add_block_to_block (&block, &arrayse.post); 4516 4517 tmp = gfc_finish_block (&block); 4518 if (maskss) 4519 /* We enclose the above in if (mask) {...}. */ 4520 tmp = build3_v (COND_EXPR, maskse.expr, tmp, 4521 build_empty_stmt (input_location)); 4522 gfc_add_expr_to_block (&body, tmp); 4523 /* Avoid initializing loopvar[0] again, it should be left where 4524 it finished by the first loop. */ 4525 loop.from[0] = loop.loopvar[0]; 4526 } 4527 gfc_trans_scalarizing_loops (&loop, &body); 4528 4529 if (fast) 4530 { 4531 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, 4532 nan_cst, huge_cst); 4533 ifbody = build2_v (MODIFY_EXPR, limit, tmp); 4534 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location), 4535 ifbody); 4536 gfc_add_expr_to_block (&loop.pre, tmp); 4537 } 4538 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab) 4539 { 4540 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit, 4541 huge_cst); 4542 gfc_add_modify (&loop.pre, limit, tmp); 4543 } 4544 4545 /* For a scalar mask, enclose the loop in an if statement. */ 4546 if (maskexpr && maskss == NULL) 4547 { 4548 tree else_stmt; 4549 4550 gfc_init_se (&maskse, NULL); 4551 gfc_conv_expr_val (&maskse, maskexpr); 4552 gfc_init_block (&block); 4553 gfc_add_block_to_block (&block, &loop.pre); 4554 gfc_add_block_to_block (&block, &loop.post); 4555 tmp = gfc_finish_block (&block); 4556 4557 if (HONOR_INFINITIES (DECL_MODE (limit))) 4558 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst); 4559 else 4560 else_stmt = build_empty_stmt (input_location); 4561 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt); 4562 gfc_add_expr_to_block (&block, tmp); 4563 gfc_add_block_to_block (&se->pre, &block); 4564 } 4565 else 4566 { 4567 gfc_add_block_to_block (&se->pre, &loop.pre); 4568 gfc_add_block_to_block (&se->pre, &loop.post); 4569 } 4570 4571 gfc_cleanup_loop (&loop); 4572 4573 se->expr = limit; 4574} 4575 4576/* BTEST (i, pos) = (i & (1 << pos)) != 0. */ 4577static void 4578gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) 4579{ 4580 tree args[2]; 4581 tree type; 4582 tree tmp; 4583 4584 gfc_conv_intrinsic_function_args (se, expr, args, 2); 4585 type = TREE_TYPE (args[0]); 4586 4587 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type, 4588 build_int_cst (type, 1), args[1]); 4589 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp); 4590 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, 4591 build_int_cst (type, 0)); 4592 type = gfc_typenode_for_spec (&expr->ts); 4593 se->expr = convert (type, tmp); 4594} 4595 4596 4597/* Generate code for BGE, BGT, BLE and BLT intrinsics. */ 4598static void 4599gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op) 4600{ 4601 tree args[2]; 4602 4603 gfc_conv_intrinsic_function_args (se, expr, args, 2); 4604 4605 /* Convert both arguments to the unsigned type of the same size. */ 4606 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]); 4607 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]); 4608 4609 /* If they have unequal type size, convert to the larger one. */ 4610 if (TYPE_PRECISION (TREE_TYPE (args[0])) 4611 > TYPE_PRECISION (TREE_TYPE (args[1]))) 4612 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]); 4613 else if (TYPE_PRECISION (TREE_TYPE (args[1])) 4614 > TYPE_PRECISION (TREE_TYPE (args[0]))) 4615 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]); 4616 4617 /* Now, we compare them. */ 4618 se->expr = fold_build2_loc (input_location, op, boolean_type_node, 4619 args[0], args[1]); 4620} 4621 4622 4623/* Generate code to perform the specified operation. */ 4624static void 4625gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op) 4626{ 4627 tree args[2]; 4628 4629 gfc_conv_intrinsic_function_args (se, expr, args, 2); 4630 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]), 4631 args[0], args[1]); 4632} 4633 4634/* Bitwise not. */ 4635static void 4636gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr) 4637{ 4638 tree arg; 4639 4640 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 4641 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR, 4642 TREE_TYPE (arg), arg); 4643} 4644 4645/* Set or clear a single bit. */ 4646static void 4647gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) 4648{ 4649 tree args[2]; 4650 tree type; 4651 tree tmp; 4652 enum tree_code op; 4653 4654 gfc_conv_intrinsic_function_args (se, expr, args, 2); 4655 type = TREE_TYPE (args[0]); 4656 4657 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type, 4658 build_int_cst (type, 1), args[1]); 4659 if (set) 4660 op = BIT_IOR_EXPR; 4661 else 4662 { 4663 op = BIT_AND_EXPR; 4664 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp); 4665 } 4666 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp); 4667} 4668 4669/* Extract a sequence of bits. 4670 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */ 4671static void 4672gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) 4673{ 4674 tree args[3]; 4675 tree type; 4676 tree tmp; 4677 tree mask; 4678 4679 gfc_conv_intrinsic_function_args (se, expr, args, 3); 4680 type = TREE_TYPE (args[0]); 4681 4682 mask = build_int_cst (type, -1); 4683 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]); 4684 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask); 4685 4686 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]); 4687 4688 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask); 4689} 4690 4691static void 4692gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift, 4693 bool arithmetic) 4694{ 4695 tree args[2], type, num_bits, cond; 4696 4697 gfc_conv_intrinsic_function_args (se, expr, args, 2); 4698 4699 args[0] = gfc_evaluate_now (args[0], &se->pre); 4700 args[1] = gfc_evaluate_now (args[1], &se->pre); 4701 type = TREE_TYPE (args[0]); 4702 4703 if (!arithmetic) 4704 args[0] = fold_convert (unsigned_type_for (type), args[0]); 4705 else 4706 gcc_assert (right_shift); 4707 4708 se->expr = fold_build2_loc (input_location, 4709 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR, 4710 TREE_TYPE (args[0]), args[0], args[1]); 4711 4712 if (!arithmetic) 4713 se->expr = fold_convert (type, se->expr); 4714 4715 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas 4716 gcc requires a shift width < BIT_SIZE(I), so we have to catch this 4717 special case. */ 4718 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); 4719 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, 4720 args[1], num_bits); 4721 4722 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, 4723 build_int_cst (type, 0), se->expr); 4724} 4725 4726/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i)) 4727 ? 0 4728 : ((shift >= 0) ? i << shift : i >> -shift) 4729 where all shifts are logical shifts. */ 4730static void 4731gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) 4732{ 4733 tree args[2]; 4734 tree type; 4735 tree utype; 4736 tree tmp; 4737 tree width; 4738 tree num_bits; 4739 tree cond; 4740 tree lshift; 4741 tree rshift; 4742 4743 gfc_conv_intrinsic_function_args (se, expr, args, 2); 4744 4745 args[0] = gfc_evaluate_now (args[0], &se->pre); 4746 args[1] = gfc_evaluate_now (args[1], &se->pre); 4747 4748 type = TREE_TYPE (args[0]); 4749 utype = unsigned_type_for (type); 4750 4751 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]), 4752 args[1]); 4753 4754 /* Left shift if positive. */ 4755 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width); 4756 4757 /* Right shift if negative. 4758 We convert to an unsigned type because we want a logical shift. 4759 The standard doesn't define the case of shifting negative 4760 numbers, and we try to be compatible with other compilers, most 4761 notably g77, here. */ 4762 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR, 4763 utype, convert (utype, args[0]), width)); 4764 4765 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1], 4766 build_int_cst (TREE_TYPE (args[1]), 0)); 4767 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift); 4768 4769 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas 4770 gcc requires a shift width < BIT_SIZE(I), so we have to catch this 4771 special case. */ 4772 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); 4773 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width, 4774 num_bits); 4775 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, 4776 build_int_cst (type, 0), tmp); 4777} 4778 4779 4780/* Circular shift. AKA rotate or barrel shift. */ 4781 4782static void 4783gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) 4784{ 4785 tree *args; 4786 tree type; 4787 tree tmp; 4788 tree lrot; 4789 tree rrot; 4790 tree zero; 4791 unsigned int num_args; 4792 4793 num_args = gfc_intrinsic_argument_list_length (expr); 4794 args = XALLOCAVEC (tree, num_args); 4795 4796 gfc_conv_intrinsic_function_args (se, expr, args, num_args); 4797 4798 if (num_args == 3) 4799 { 4800 /* Use a library function for the 3 parameter version. */ 4801 tree int4type = gfc_get_int_type (4); 4802 4803 type = TREE_TYPE (args[0]); 4804 /* We convert the first argument to at least 4 bytes, and 4805 convert back afterwards. This removes the need for library 4806 functions for all argument sizes, and function will be 4807 aligned to at least 32 bits, so there's no loss. */ 4808 if (expr->ts.kind < 4) 4809 args[0] = convert (int4type, args[0]); 4810 4811 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would 4812 need loads of library functions. They cannot have values > 4813 BIT_SIZE (I) so the conversion is safe. */ 4814 args[1] = convert (int4type, args[1]); 4815 args[2] = convert (int4type, args[2]); 4816 4817 switch (expr->ts.kind) 4818 { 4819 case 1: 4820 case 2: 4821 case 4: 4822 tmp = gfor_fndecl_math_ishftc4; 4823 break; 4824 case 8: 4825 tmp = gfor_fndecl_math_ishftc8; 4826 break; 4827 case 16: 4828 tmp = gfor_fndecl_math_ishftc16; 4829 break; 4830 default: 4831 gcc_unreachable (); 4832 } 4833 se->expr = build_call_expr_loc (input_location, 4834 tmp, 3, args[0], args[1], args[2]); 4835 /* Convert the result back to the original type, if we extended 4836 the first argument's width above. */ 4837 if (expr->ts.kind < 4) 4838 se->expr = convert (type, se->expr); 4839 4840 return; 4841 } 4842 type = TREE_TYPE (args[0]); 4843 4844 /* Evaluate arguments only once. */ 4845 args[0] = gfc_evaluate_now (args[0], &se->pre); 4846 args[1] = gfc_evaluate_now (args[1], &se->pre); 4847 4848 /* Rotate left if positive. */ 4849 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]); 4850 4851 /* Rotate right if negative. */ 4852 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]), 4853 args[1]); 4854 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp); 4855 4856 zero = build_int_cst (TREE_TYPE (args[1]), 0); 4857 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1], 4858 zero); 4859 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot); 4860 4861 /* Do nothing if shift == 0. */ 4862 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1], 4863 zero); 4864 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0], 4865 rrot); 4866} 4867 4868 4869/* LEADZ (i) = (i == 0) ? BIT_SIZE (i) 4870 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i)) 4871 4872 The conditional expression is necessary because the result of LEADZ(0) 4873 is defined, but the result of __builtin_clz(0) is undefined for most 4874 targets. 4875 4876 For INTEGER kinds smaller than the C 'int' type, we have to subtract the 4877 difference in bit size between the argument of LEADZ and the C int. */ 4878 4879static void 4880gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr) 4881{ 4882 tree arg; 4883 tree arg_type; 4884 tree cond; 4885 tree result_type; 4886 tree leadz; 4887 tree bit_size; 4888 tree tmp; 4889 tree func; 4890 int s, argsize; 4891 4892 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 4893 argsize = TYPE_PRECISION (TREE_TYPE (arg)); 4894 4895 /* Which variant of __builtin_clz* should we call? */ 4896 if (argsize <= INT_TYPE_SIZE) 4897 { 4898 arg_type = unsigned_type_node; 4899 func = builtin_decl_explicit (BUILT_IN_CLZ); 4900 } 4901 else if (argsize <= LONG_TYPE_SIZE) 4902 { 4903 arg_type = long_unsigned_type_node; 4904 func = builtin_decl_explicit (BUILT_IN_CLZL); 4905 } 4906 else if (argsize <= LONG_LONG_TYPE_SIZE) 4907 { 4908 arg_type = long_long_unsigned_type_node; 4909 func = builtin_decl_explicit (BUILT_IN_CLZLL); 4910 } 4911 else 4912 { 4913 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); 4914 arg_type = gfc_build_uint_type (argsize); 4915 func = NULL_TREE; 4916 } 4917 4918 /* Convert the actual argument twice: first, to the unsigned type of the 4919 same size; then, to the proper argument type for the built-in 4920 function. But the return type is of the default INTEGER kind. */ 4921 arg = fold_convert (gfc_build_uint_type (argsize), arg); 4922 arg = fold_convert (arg_type, arg); 4923 arg = gfc_evaluate_now (arg, &se->pre); 4924 result_type = gfc_get_int_type (gfc_default_integer_kind); 4925 4926 /* Compute LEADZ for the case i .ne. 0. */ 4927 if (func) 4928 { 4929 s = TYPE_PRECISION (arg_type) - argsize; 4930 tmp = fold_convert (result_type, 4931 build_call_expr_loc (input_location, func, 4932 1, arg)); 4933 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type, 4934 tmp, build_int_cst (result_type, s)); 4935 } 4936 else 4937 { 4938 /* We end up here if the argument type is larger than 'long long'. 4939 We generate this code: 4940 4941 if (x & (ULL_MAX << ULL_SIZE) != 0) 4942 return clzll ((unsigned long long) (x >> ULLSIZE)); 4943 else 4944 return ULL_SIZE + clzll ((unsigned long long) x); 4945 where ULL_MAX is the largest value that a ULL_MAX can hold 4946 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE 4947 is the bit-size of the long long type (64 in this example). */ 4948 tree ullsize, ullmax, tmp1, tmp2, btmp; 4949 4950 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE); 4951 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR, 4952 long_long_unsigned_type_node, 4953 build_int_cst (long_long_unsigned_type_node, 4954 0)); 4955 4956 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type, 4957 fold_convert (arg_type, ullmax), ullsize); 4958 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, 4959 arg, cond); 4960 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 4961 cond, build_int_cst (arg_type, 0)); 4962 4963 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type, 4964 arg, ullsize); 4965 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1); 4966 btmp = builtin_decl_explicit (BUILT_IN_CLZLL); 4967 tmp1 = fold_convert (result_type, 4968 build_call_expr_loc (input_location, btmp, 1, tmp1)); 4969 4970 tmp2 = fold_convert (long_long_unsigned_type_node, arg); 4971 btmp = builtin_decl_explicit (BUILT_IN_CLZLL); 4972 tmp2 = fold_convert (result_type, 4973 build_call_expr_loc (input_location, btmp, 1, tmp2)); 4974 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type, 4975 tmp2, ullsize); 4976 4977 leadz = fold_build3_loc (input_location, COND_EXPR, result_type, 4978 cond, tmp1, tmp2); 4979 } 4980 4981 /* Build BIT_SIZE. */ 4982 bit_size = build_int_cst (result_type, argsize); 4983 4984 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 4985 arg, build_int_cst (arg_type, 0)); 4986 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond, 4987 bit_size, leadz); 4988} 4989 4990 4991/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i) 4992 4993 The conditional expression is necessary because the result of TRAILZ(0) 4994 is defined, but the result of __builtin_ctz(0) is undefined for most 4995 targets. */ 4996 4997static void 4998gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr) 4999{ 5000 tree arg; 5001 tree arg_type; 5002 tree cond; 5003 tree result_type; 5004 tree trailz; 5005 tree bit_size; 5006 tree func; 5007 int argsize; 5008 5009 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 5010 argsize = TYPE_PRECISION (TREE_TYPE (arg)); 5011 5012 /* Which variant of __builtin_ctz* should we call? */ 5013 if (argsize <= INT_TYPE_SIZE) 5014 { 5015 arg_type = unsigned_type_node; 5016 func = builtin_decl_explicit (BUILT_IN_CTZ); 5017 } 5018 else if (argsize <= LONG_TYPE_SIZE) 5019 { 5020 arg_type = long_unsigned_type_node; 5021 func = builtin_decl_explicit (BUILT_IN_CTZL); 5022 } 5023 else if (argsize <= LONG_LONG_TYPE_SIZE) 5024 { 5025 arg_type = long_long_unsigned_type_node; 5026 func = builtin_decl_explicit (BUILT_IN_CTZLL); 5027 } 5028 else 5029 { 5030 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); 5031 arg_type = gfc_build_uint_type (argsize); 5032 func = NULL_TREE; 5033 } 5034 5035 /* Convert the actual argument twice: first, to the unsigned type of the 5036 same size; then, to the proper argument type for the built-in 5037 function. But the return type is of the default INTEGER kind. */ 5038 arg = fold_convert (gfc_build_uint_type (argsize), arg); 5039 arg = fold_convert (arg_type, arg); 5040 arg = gfc_evaluate_now (arg, &se->pre); 5041 result_type = gfc_get_int_type (gfc_default_integer_kind); 5042 5043 /* Compute TRAILZ for the case i .ne. 0. */ 5044 if (func) 5045 trailz = fold_convert (result_type, build_call_expr_loc (input_location, 5046 func, 1, arg)); 5047 else 5048 { 5049 /* We end up here if the argument type is larger than 'long long'. 5050 We generate this code: 5051 5052 if ((x & ULL_MAX) == 0) 5053 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE)); 5054 else 5055 return ctzll ((unsigned long long) x); 5056 5057 where ULL_MAX is the largest value that a ULL_MAX can hold 5058 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE 5059 is the bit-size of the long long type (64 in this example). */ 5060 tree ullsize, ullmax, tmp1, tmp2, btmp; 5061 5062 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE); 5063 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR, 5064 long_long_unsigned_type_node, 5065 build_int_cst (long_long_unsigned_type_node, 0)); 5066 5067 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg, 5068 fold_convert (arg_type, ullmax)); 5069 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond, 5070 build_int_cst (arg_type, 0)); 5071 5072 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type, 5073 arg, ullsize); 5074 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1); 5075 btmp = builtin_decl_explicit (BUILT_IN_CTZLL); 5076 tmp1 = fold_convert (result_type, 5077 build_call_expr_loc (input_location, btmp, 1, tmp1)); 5078 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type, 5079 tmp1, ullsize); 5080 5081 tmp2 = fold_convert (long_long_unsigned_type_node, arg); 5082 btmp = builtin_decl_explicit (BUILT_IN_CTZLL); 5083 tmp2 = fold_convert (result_type, 5084 build_call_expr_loc (input_location, btmp, 1, tmp2)); 5085 5086 trailz = fold_build3_loc (input_location, COND_EXPR, result_type, 5087 cond, tmp1, tmp2); 5088 } 5089 5090 /* Build BIT_SIZE. */ 5091 bit_size = build_int_cst (result_type, argsize); 5092 5093 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 5094 arg, build_int_cst (arg_type, 0)); 5095 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond, 5096 bit_size, trailz); 5097} 5098 5099/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR; 5100 for types larger than "long long", we call the long long built-in for 5101 the lower and higher bits and combine the result. */ 5102 5103static void 5104gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity) 5105{ 5106 tree arg; 5107 tree arg_type; 5108 tree result_type; 5109 tree func; 5110 int argsize; 5111 5112 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 5113 argsize = TYPE_PRECISION (TREE_TYPE (arg)); 5114 result_type = gfc_get_int_type (gfc_default_integer_kind); 5115 5116 /* Which variant of the builtin should we call? */ 5117 if (argsize <= INT_TYPE_SIZE) 5118 { 5119 arg_type = unsigned_type_node; 5120 func = builtin_decl_explicit (parity 5121 ? BUILT_IN_PARITY 5122 : BUILT_IN_POPCOUNT); 5123 } 5124 else if (argsize <= LONG_TYPE_SIZE) 5125 { 5126 arg_type = long_unsigned_type_node; 5127 func = builtin_decl_explicit (parity 5128 ? BUILT_IN_PARITYL 5129 : BUILT_IN_POPCOUNTL); 5130 } 5131 else if (argsize <= LONG_LONG_TYPE_SIZE) 5132 { 5133 arg_type = long_long_unsigned_type_node; 5134 func = builtin_decl_explicit (parity 5135 ? BUILT_IN_PARITYLL 5136 : BUILT_IN_POPCOUNTLL); 5137 } 5138 else 5139 { 5140 /* Our argument type is larger than 'long long', which mean none 5141 of the POPCOUNT builtins covers it. We thus call the 'long long' 5142 variant multiple times, and add the results. */ 5143 tree utype, arg2, call1, call2; 5144 5145 /* For now, we only cover the case where argsize is twice as large 5146 as 'long long'. */ 5147 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); 5148 5149 func = builtin_decl_explicit (parity 5150 ? BUILT_IN_PARITYLL 5151 : BUILT_IN_POPCOUNTLL); 5152 5153 /* Convert it to an integer, and store into a variable. */ 5154 utype = gfc_build_uint_type (argsize); 5155 arg = fold_convert (utype, arg); 5156 arg = gfc_evaluate_now (arg, &se->pre); 5157 5158 /* Call the builtin twice. */ 5159 call1 = build_call_expr_loc (input_location, func, 1, 5160 fold_convert (long_long_unsigned_type_node, 5161 arg)); 5162 5163 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg, 5164 build_int_cst (utype, LONG_LONG_TYPE_SIZE)); 5165 call2 = build_call_expr_loc (input_location, func, 1, 5166 fold_convert (long_long_unsigned_type_node, 5167 arg2)); 5168 5169 /* Combine the results. */ 5170 if (parity) 5171 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type, 5172 call1, call2); 5173 else 5174 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type, 5175 call1, call2); 5176 5177 return; 5178 } 5179 5180 /* Convert the actual argument twice: first, to the unsigned type of the 5181 same size; then, to the proper argument type for the built-in 5182 function. */ 5183 arg = fold_convert (gfc_build_uint_type (argsize), arg); 5184 arg = fold_convert (arg_type, arg); 5185 5186 se->expr = fold_convert (result_type, 5187 build_call_expr_loc (input_location, func, 1, arg)); 5188} 5189 5190 5191/* Process an intrinsic with unspecified argument-types that has an optional 5192 argument (which could be of type character), e.g. EOSHIFT. For those, we 5193 need to append the string length of the optional argument if it is not 5194 present and the type is really character. 5195 primary specifies the position (starting at 1) of the non-optional argument 5196 specifying the type and optional gives the position of the optional 5197 argument in the arglist. */ 5198 5199static void 5200conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr, 5201 unsigned primary, unsigned optional) 5202{ 5203 gfc_actual_arglist* prim_arg; 5204 gfc_actual_arglist* opt_arg; 5205 unsigned cur_pos; 5206 gfc_actual_arglist* arg; 5207 gfc_symbol* sym; 5208 vec<tree, va_gc> *append_args; 5209 5210 /* Find the two arguments given as position. */ 5211 cur_pos = 0; 5212 prim_arg = NULL; 5213 opt_arg = NULL; 5214 for (arg = expr->value.function.actual; arg; arg = arg->next) 5215 { 5216 ++cur_pos; 5217 5218 if (cur_pos == primary) 5219 prim_arg = arg; 5220 if (cur_pos == optional) 5221 opt_arg = arg; 5222 5223 if (cur_pos >= primary && cur_pos >= optional) 5224 break; 5225 } 5226 gcc_assert (prim_arg); 5227 gcc_assert (prim_arg->expr); 5228 gcc_assert (opt_arg); 5229 5230 /* If we do have type CHARACTER and the optional argument is really absent, 5231 append a dummy 0 as string length. */ 5232 append_args = NULL; 5233 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr) 5234 { 5235 tree dummy; 5236 5237 dummy = build_int_cst (gfc_charlen_type_node, 0); 5238 vec_alloc (append_args, 1); 5239 append_args->quick_push (dummy); 5240 } 5241 5242 /* Build the call itself. */ 5243 gcc_assert (!se->ignore_optional); 5244 sym = gfc_get_symbol_for_expr (expr, false); 5245 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, 5246 append_args); 5247 gfc_free_symbol (sym); 5248} 5249 5250 5251/* The length of a character string. */ 5252static void 5253gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) 5254{ 5255 tree len; 5256 tree type; 5257 tree decl; 5258 gfc_symbol *sym; 5259 gfc_se argse; 5260 gfc_expr *arg; 5261 5262 gcc_assert (!se->ss); 5263 5264 arg = expr->value.function.actual->expr; 5265 5266 type = gfc_typenode_for_spec (&expr->ts); 5267 switch (arg->expr_type) 5268 { 5269 case EXPR_CONSTANT: 5270 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length); 5271 break; 5272 5273 case EXPR_ARRAY: 5274 /* Obtain the string length from the function used by 5275 trans-array.c(gfc_trans_array_constructor). */ 5276 len = NULL_TREE; 5277 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len); 5278 break; 5279 5280 case EXPR_VARIABLE: 5281 if (arg->ref == NULL 5282 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY)) 5283 { 5284 /* This doesn't catch all cases. 5285 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html 5286 and the surrounding thread. */ 5287 sym = arg->symtree->n.sym; 5288 decl = gfc_get_symbol_decl (sym); 5289 if (decl == current_function_decl && sym->attr.function 5290 && (sym->result == sym)) 5291 decl = gfc_get_fake_result_decl (sym, 0); 5292 5293 len = sym->ts.u.cl->backend_decl; 5294 gcc_assert (len); 5295 break; 5296 } 5297 5298 /* Otherwise fall through. */ 5299 5300 default: 5301 /* Anybody stupid enough to do this deserves inefficient code. */ 5302 gfc_init_se (&argse, se); 5303 if (arg->rank == 0) 5304 gfc_conv_expr (&argse, arg); 5305 else 5306 gfc_conv_expr_descriptor (&argse, arg); 5307 gfc_add_block_to_block (&se->pre, &argse.pre); 5308 gfc_add_block_to_block (&se->post, &argse.post); 5309 len = argse.string_length; 5310 break; 5311 } 5312 se->expr = convert (type, len); 5313} 5314 5315/* The length of a character string not including trailing blanks. */ 5316static void 5317gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) 5318{ 5319 int kind = expr->value.function.actual->expr->ts.kind; 5320 tree args[2], type, fndecl; 5321 5322 gfc_conv_intrinsic_function_args (se, expr, args, 2); 5323 type = gfc_typenode_for_spec (&expr->ts); 5324 5325 if (kind == 1) 5326 fndecl = gfor_fndecl_string_len_trim; 5327 else if (kind == 4) 5328 fndecl = gfor_fndecl_string_len_trim_char4; 5329 else 5330 gcc_unreachable (); 5331 5332 se->expr = build_call_expr_loc (input_location, 5333 fndecl, 2, args[0], args[1]); 5334 se->expr = convert (type, se->expr); 5335} 5336 5337 5338/* Returns the starting position of a substring within a string. */ 5339 5340static void 5341gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr, 5342 tree function) 5343{ 5344 tree logical4_type_node = gfc_get_logical_type (4); 5345 tree type; 5346 tree fndecl; 5347 tree *args; 5348 unsigned int num_args; 5349 5350 args = XALLOCAVEC (tree, 5); 5351 5352 /* Get number of arguments; characters count double due to the 5353 string length argument. Kind= is not passed to the library 5354 and thus ignored. */ 5355 if (expr->value.function.actual->next->next->expr == NULL) 5356 num_args = 4; 5357 else 5358 num_args = 5; 5359 5360 gfc_conv_intrinsic_function_args (se, expr, args, num_args); 5361 type = gfc_typenode_for_spec (&expr->ts); 5362 5363 if (num_args == 4) 5364 args[4] = build_int_cst (logical4_type_node, 0); 5365 else 5366 args[4] = convert (logical4_type_node, args[4]); 5367 5368 fndecl = build_addr (function, current_function_decl); 5369 se->expr = build_call_array_loc (input_location, 5370 TREE_TYPE (TREE_TYPE (function)), fndecl, 5371 5, args); 5372 se->expr = convert (type, se->expr); 5373 5374} 5375 5376/* The ascii value for a single character. */ 5377static void 5378gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) 5379{ 5380 tree args[3], type, pchartype; 5381 int nargs; 5382 5383 nargs = gfc_intrinsic_argument_list_length (expr); 5384 gfc_conv_intrinsic_function_args (se, expr, args, nargs); 5385 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1]))); 5386 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind); 5387 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]); 5388 type = gfc_typenode_for_spec (&expr->ts); 5389 5390 se->expr = build_fold_indirect_ref_loc (input_location, 5391 args[1]); 5392 se->expr = convert (type, se->expr); 5393} 5394 5395 5396/* Intrinsic ISNAN calls __builtin_isnan. */ 5397 5398static void 5399gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr) 5400{ 5401 tree arg; 5402 5403 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 5404 se->expr = build_call_expr_loc (input_location, 5405 builtin_decl_explicit (BUILT_IN_ISNAN), 5406 1, arg); 5407 STRIP_TYPE_NOPS (se->expr); 5408 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); 5409} 5410 5411 5412/* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare 5413 their argument against a constant integer value. */ 5414 5415static void 5416gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value) 5417{ 5418 tree arg; 5419 5420 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 5421 se->expr = fold_build2_loc (input_location, EQ_EXPR, 5422 gfc_typenode_for_spec (&expr->ts), 5423 arg, build_int_cst (TREE_TYPE (arg), value)); 5424} 5425 5426 5427 5428/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */ 5429 5430static void 5431gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) 5432{ 5433 tree tsource; 5434 tree fsource; 5435 tree mask; 5436 tree type; 5437 tree len, len2; 5438 tree *args; 5439 unsigned int num_args; 5440 5441 num_args = gfc_intrinsic_argument_list_length (expr); 5442 args = XALLOCAVEC (tree, num_args); 5443 5444 gfc_conv_intrinsic_function_args (se, expr, args, num_args); 5445 if (expr->ts.type != BT_CHARACTER) 5446 { 5447 tsource = args[0]; 5448 fsource = args[1]; 5449 mask = args[2]; 5450 } 5451 else 5452 { 5453 /* We do the same as in the non-character case, but the argument 5454 list is different because of the string length arguments. We 5455 also have to set the string length for the result. */ 5456 len = args[0]; 5457 tsource = args[1]; 5458 len2 = args[2]; 5459 fsource = args[3]; 5460 mask = args[4]; 5461 5462 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2, 5463 &se->pre); 5464 se->string_length = len; 5465 } 5466 type = TREE_TYPE (tsource); 5467 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource, 5468 fold_convert (type, fsource)); 5469} 5470 5471 5472/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */ 5473 5474static void 5475gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr) 5476{ 5477 tree args[3], mask, type; 5478 5479 gfc_conv_intrinsic_function_args (se, expr, args, 3); 5480 mask = gfc_evaluate_now (args[2], &se->pre); 5481 5482 type = TREE_TYPE (args[0]); 5483 gcc_assert (TREE_TYPE (args[1]) == type); 5484 gcc_assert (TREE_TYPE (mask) == type); 5485 5486 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask); 5487 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1], 5488 fold_build1_loc (input_location, BIT_NOT_EXPR, 5489 type, mask)); 5490 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type, 5491 args[0], args[1]); 5492} 5493 5494 5495/* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n) 5496 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */ 5497 5498static void 5499gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left) 5500{ 5501 tree arg, allones, type, utype, res, cond, bitsize; 5502 int i; 5503 5504 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 5505 arg = gfc_evaluate_now (arg, &se->pre); 5506 5507 type = gfc_get_int_type (expr->ts.kind); 5508 utype = unsigned_type_for (type); 5509 5510 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false); 5511 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size); 5512 5513 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, 5514 build_int_cst (utype, 0)); 5515 5516 if (left) 5517 { 5518 /* Left-justified mask. */ 5519 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg), 5520 bitsize, arg); 5521 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones, 5522 fold_convert (utype, res)); 5523 5524 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly 5525 smaller than type width. */ 5526 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg, 5527 build_int_cst (TREE_TYPE (arg), 0)); 5528 res = fold_build3_loc (input_location, COND_EXPR, utype, cond, 5529 build_int_cst (utype, 0), res); 5530 } 5531 else 5532 { 5533 /* Right-justified mask. */ 5534 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones, 5535 fold_convert (utype, arg)); 5536 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res); 5537 5538 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift 5539 strictly smaller than type width. */ 5540 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 5541 arg, bitsize); 5542 res = fold_build3_loc (input_location, COND_EXPR, utype, 5543 cond, allones, res); 5544 } 5545 5546 se->expr = fold_convert (type, res); 5547} 5548 5549 5550/* FRACTION (s) is translated into: 5551 isfinite (s) ? frexp (s, &dummy_int) : NaN */ 5552static void 5553gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr) 5554{ 5555 tree arg, type, tmp, res, frexp, cond; 5556 5557 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); 5558 5559 type = gfc_typenode_for_spec (&expr->ts); 5560 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 5561 arg = gfc_evaluate_now (arg, &se->pre); 5562 5563 cond = build_call_expr_loc (input_location, 5564 builtin_decl_explicit (BUILT_IN_ISFINITE), 5565 1, arg); 5566 5567 tmp = gfc_create_var (integer_type_node, NULL); 5568 res = build_call_expr_loc (input_location, frexp, 2, 5569 fold_convert (type, arg), 5570 gfc_build_addr_expr (NULL_TREE, tmp)); 5571 res = fold_convert (type, res); 5572 5573 se->expr = fold_build3_loc (input_location, COND_EXPR, type, 5574 cond, res, gfc_build_nan (type, "")); 5575} 5576 5577 5578/* NEAREST (s, dir) is translated into 5579 tmp = copysign (HUGE_VAL, dir); 5580 return nextafter (s, tmp); 5581 */ 5582static void 5583gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr) 5584{ 5585 tree args[2], type, tmp, nextafter, copysign, huge_val; 5586 5587 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind); 5588 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); 5589 5590 type = gfc_typenode_for_spec (&expr->ts); 5591 gfc_conv_intrinsic_function_args (se, expr, args, 2); 5592 5593 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind); 5594 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val, 5595 fold_convert (type, args[1])); 5596 se->expr = build_call_expr_loc (input_location, nextafter, 2, 5597 fold_convert (type, args[0]), tmp); 5598 se->expr = fold_convert (type, se->expr); 5599} 5600 5601 5602/* SPACING (s) is translated into 5603 int e; 5604 if (!isfinite (s)) 5605 res = NaN; 5606 else if (s == 0) 5607 res = tiny; 5608 else 5609 { 5610 frexp (s, &e); 5611 e = e - prec; 5612 e = MAX_EXPR (e, emin); 5613 res = scalbn (1., e); 5614 } 5615 return res; 5616 5617 where prec is the precision of s, gfc_real_kinds[k].digits, 5618 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1, 5619 and tiny is tiny(s), gfc_real_kinds[k].tiny. */ 5620 5621static void 5622gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) 5623{ 5624 tree arg, type, prec, emin, tiny, res, e; 5625 tree cond, nan, tmp, frexp, scalbn; 5626 int k; 5627 stmtblock_t block; 5628 5629 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); 5630 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits); 5631 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1); 5632 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0); 5633 5634 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); 5635 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); 5636 5637 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 5638 arg = gfc_evaluate_now (arg, &se->pre); 5639 5640 type = gfc_typenode_for_spec (&expr->ts); 5641 e = gfc_create_var (integer_type_node, NULL); 5642 res = gfc_create_var (type, NULL); 5643 5644 5645 /* Build the block for s /= 0. */ 5646 gfc_start_block (&block); 5647 tmp = build_call_expr_loc (input_location, frexp, 2, arg, 5648 gfc_build_addr_expr (NULL_TREE, e)); 5649 gfc_add_expr_to_block (&block, tmp); 5650 5651 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e, 5652 prec); 5653 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR, 5654 integer_type_node, tmp, emin)); 5655 5656 tmp = build_call_expr_loc (input_location, scalbn, 2, 5657 build_real_from_int_cst (type, integer_one_node), e); 5658 gfc_add_modify (&block, res, tmp); 5659 5660 /* Finish by building the IF statement for value zero. */ 5661 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg, 5662 build_real_from_int_cst (type, integer_zero_node)); 5663 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny), 5664 gfc_finish_block (&block)); 5665 5666 /* And deal with infinities and NaNs. */ 5667 cond = build_call_expr_loc (input_location, 5668 builtin_decl_explicit (BUILT_IN_ISFINITE), 5669 1, arg); 5670 nan = gfc_build_nan (type, ""); 5671 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan)); 5672 5673 gfc_add_expr_to_block (&se->pre, tmp); 5674 se->expr = res; 5675} 5676 5677 5678/* RRSPACING (s) is translated into 5679 int e; 5680 real x; 5681 x = fabs (s); 5682 if (isfinite (x)) 5683 { 5684 if (x != 0) 5685 { 5686 frexp (s, &e); 5687 x = scalbn (x, precision - e); 5688 } 5689 } 5690 else 5691 x = NaN; 5692 return x; 5693 5694 where precision is gfc_real_kinds[k].digits. */ 5695 5696static void 5697gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) 5698{ 5699 tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs; 5700 int prec, k; 5701 stmtblock_t block; 5702 5703 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); 5704 prec = gfc_real_kinds[k].digits; 5705 5706 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); 5707 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); 5708 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); 5709 5710 type = gfc_typenode_for_spec (&expr->ts); 5711 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 5712 arg = gfc_evaluate_now (arg, &se->pre); 5713 5714 e = gfc_create_var (integer_type_node, NULL); 5715 x = gfc_create_var (type, NULL); 5716 gfc_add_modify (&se->pre, x, 5717 build_call_expr_loc (input_location, fabs, 1, arg)); 5718 5719 5720 gfc_start_block (&block); 5721 tmp = build_call_expr_loc (input_location, frexp, 2, arg, 5722 gfc_build_addr_expr (NULL_TREE, e)); 5723 gfc_add_expr_to_block (&block, tmp); 5724 5725 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, 5726 build_int_cst (integer_type_node, prec), e); 5727 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp); 5728 gfc_add_modify (&block, x, tmp); 5729 stmt = gfc_finish_block (&block); 5730 5731 /* if (x != 0) */ 5732 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x, 5733 build_real_from_int_cst (type, integer_zero_node)); 5734 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location)); 5735 5736 /* And deal with infinities and NaNs. */ 5737 cond = build_call_expr_loc (input_location, 5738 builtin_decl_explicit (BUILT_IN_ISFINITE), 5739 1, x); 5740 nan = gfc_build_nan (type, ""); 5741 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan)); 5742 5743 gfc_add_expr_to_block (&se->pre, tmp); 5744 se->expr = fold_convert (type, x); 5745} 5746 5747 5748/* SCALE (s, i) is translated into scalbn (s, i). */ 5749static void 5750gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr) 5751{ 5752 tree args[2], type, scalbn; 5753 5754 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); 5755 5756 type = gfc_typenode_for_spec (&expr->ts); 5757 gfc_conv_intrinsic_function_args (se, expr, args, 2); 5758 se->expr = build_call_expr_loc (input_location, scalbn, 2, 5759 fold_convert (type, args[0]), 5760 fold_convert (integer_type_node, args[1])); 5761 se->expr = fold_convert (type, se->expr); 5762} 5763 5764 5765/* SET_EXPONENT (s, i) is translated into 5766 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */ 5767static void 5768gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr) 5769{ 5770 tree args[2], type, tmp, frexp, scalbn, cond, nan, res; 5771 5772 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); 5773 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); 5774 5775 type = gfc_typenode_for_spec (&expr->ts); 5776 gfc_conv_intrinsic_function_args (se, expr, args, 2); 5777 args[0] = gfc_evaluate_now (args[0], &se->pre); 5778 5779 tmp = gfc_create_var (integer_type_node, NULL); 5780 tmp = build_call_expr_loc (input_location, frexp, 2, 5781 fold_convert (type, args[0]), 5782 gfc_build_addr_expr (NULL_TREE, tmp)); 5783 res = build_call_expr_loc (input_location, scalbn, 2, tmp, 5784 fold_convert (integer_type_node, args[1])); 5785 res = fold_convert (type, res); 5786 5787 /* Call to isfinite */ 5788 cond = build_call_expr_loc (input_location, 5789 builtin_decl_explicit (BUILT_IN_ISFINITE), 5790 1, args[0]); 5791 nan = gfc_build_nan (type, ""); 5792 5793 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, 5794 res, nan); 5795} 5796 5797 5798static void 5799gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) 5800{ 5801 gfc_actual_arglist *actual; 5802 tree arg1; 5803 tree type; 5804 tree fncall0; 5805 tree fncall1; 5806 gfc_se argse; 5807 5808 gfc_init_se (&argse, NULL); 5809 actual = expr->value.function.actual; 5810 5811 if (actual->expr->ts.type == BT_CLASS) 5812 gfc_add_class_array_ref (actual->expr); 5813 5814 argse.want_pointer = 1; 5815 argse.data_not_needed = 1; 5816 gfc_conv_expr_descriptor (&argse, actual->expr); 5817 gfc_add_block_to_block (&se->pre, &argse.pre); 5818 gfc_add_block_to_block (&se->post, &argse.post); 5819 arg1 = gfc_evaluate_now (argse.expr, &se->pre); 5820 5821 /* Build the call to size0. */ 5822 fncall0 = build_call_expr_loc (input_location, 5823 gfor_fndecl_size0, 1, arg1); 5824 5825 actual = actual->next; 5826 5827 if (actual->expr) 5828 { 5829 gfc_init_se (&argse, NULL); 5830 gfc_conv_expr_type (&argse, actual->expr, 5831 gfc_array_index_type); 5832 gfc_add_block_to_block (&se->pre, &argse.pre); 5833 5834 /* Unusually, for an intrinsic, size does not exclude 5835 an optional arg2, so we must test for it. */ 5836 if (actual->expr->expr_type == EXPR_VARIABLE 5837 && actual->expr->symtree->n.sym->attr.dummy 5838 && actual->expr->symtree->n.sym->attr.optional) 5839 { 5840 tree tmp; 5841 /* Build the call to size1. */ 5842 fncall1 = build_call_expr_loc (input_location, 5843 gfor_fndecl_size1, 2, 5844 arg1, argse.expr); 5845 5846 gfc_init_se (&argse, NULL); 5847 argse.want_pointer = 1; 5848 argse.data_not_needed = 1; 5849 gfc_conv_expr (&argse, actual->expr); 5850 gfc_add_block_to_block (&se->pre, &argse.pre); 5851 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 5852 argse.expr, null_pointer_node); 5853 tmp = gfc_evaluate_now (tmp, &se->pre); 5854 se->expr = fold_build3_loc (input_location, COND_EXPR, 5855 pvoid_type_node, tmp, fncall1, fncall0); 5856 } 5857 else 5858 { 5859 se->expr = NULL_TREE; 5860 argse.expr = fold_build2_loc (input_location, MINUS_EXPR, 5861 gfc_array_index_type, 5862 argse.expr, gfc_index_one_node); 5863 } 5864 } 5865 else if (expr->value.function.actual->expr->rank == 1) 5866 { 5867 argse.expr = gfc_index_zero_node; 5868 se->expr = NULL_TREE; 5869 } 5870 else 5871 se->expr = fncall0; 5872 5873 if (se->expr == NULL_TREE) 5874 { 5875 tree ubound, lbound; 5876 5877 arg1 = build_fold_indirect_ref_loc (input_location, 5878 arg1); 5879 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr); 5880 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr); 5881 se->expr = fold_build2_loc (input_location, MINUS_EXPR, 5882 gfc_array_index_type, ubound, lbound); 5883 se->expr = fold_build2_loc (input_location, PLUS_EXPR, 5884 gfc_array_index_type, 5885 se->expr, gfc_index_one_node); 5886 se->expr = fold_build2_loc (input_location, MAX_EXPR, 5887 gfc_array_index_type, se->expr, 5888 gfc_index_zero_node); 5889 } 5890 5891 type = gfc_typenode_for_spec (&expr->ts); 5892 se->expr = convert (type, se->expr); 5893} 5894 5895 5896/* Helper function to compute the size of a character variable, 5897 excluding the terminating null characters. The result has 5898 gfc_array_index_type type. */ 5899 5900tree 5901size_of_string_in_bytes (int kind, tree string_length) 5902{ 5903 tree bytesize; 5904 int i = gfc_validate_kind (BT_CHARACTER, kind, false); 5905 5906 bytesize = build_int_cst (gfc_array_index_type, 5907 gfc_character_kinds[i].bit_size / 8); 5908 5909 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 5910 bytesize, 5911 fold_convert (gfc_array_index_type, string_length)); 5912} 5913 5914 5915static void 5916gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) 5917{ 5918 gfc_expr *arg; 5919 gfc_se argse; 5920 tree source_bytes; 5921 tree tmp; 5922 tree lower; 5923 tree upper; 5924 tree byte_size; 5925 int n; 5926 5927 gfc_init_se (&argse, NULL); 5928 arg = expr->value.function.actual->expr; 5929 5930 if (arg->rank || arg->ts.type == BT_ASSUMED) 5931 gfc_conv_expr_descriptor (&argse, arg); 5932 else 5933 gfc_conv_expr_reference (&argse, arg); 5934 5935 if (arg->ts.type == BT_ASSUMED) 5936 { 5937 /* This only works if an array descriptor has been passed; thus, extract 5938 the size from the descriptor. */ 5939 gcc_assert (TYPE_PRECISION (gfc_array_index_type) 5940 == TYPE_PRECISION (size_type_node)); 5941 tmp = arg->symtree->n.sym->backend_decl; 5942 tmp = DECL_LANG_SPECIFIC (tmp) 5943 && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE 5944 ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp; 5945 if (POINTER_TYPE_P (TREE_TYPE (tmp))) 5946 tmp = build_fold_indirect_ref_loc (input_location, tmp); 5947 tmp = fold_convert (size_type_node, gfc_conv_descriptor_dtype (tmp)); 5948 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, TREE_TYPE (tmp), tmp, 5949 build_int_cst (TREE_TYPE (tmp), 5950 GFC_DTYPE_SIZE_SHIFT)); 5951 byte_size = fold_convert (gfc_array_index_type, tmp); 5952 } 5953 else if (arg->ts.type == BT_CLASS) 5954 { 5955 if (arg->rank) 5956 byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); 5957 else 5958 byte_size = gfc_class_vtab_size_get (argse.expr); 5959 } 5960 else 5961 { 5962 if (arg->ts.type == BT_CHARACTER) 5963 byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length); 5964 else 5965 { 5966 if (arg->rank == 0) 5967 byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location, 5968 argse.expr)); 5969 else 5970 byte_size = gfc_get_element_type (TREE_TYPE (argse.expr)); 5971 byte_size = fold_convert (gfc_array_index_type, 5972 size_in_bytes (byte_size)); 5973 } 5974 } 5975 5976 if (arg->rank == 0) 5977 se->expr = byte_size; 5978 else 5979 { 5980 source_bytes = gfc_create_var (gfc_array_index_type, "bytes"); 5981 gfc_add_modify (&argse.pre, source_bytes, byte_size); 5982 5983 if (arg->rank == -1) 5984 { 5985 tree cond, loop_var, exit_label; 5986 stmtblock_t body; 5987 5988 tmp = fold_convert (gfc_array_index_type, 5989 gfc_conv_descriptor_rank (argse.expr)); 5990 loop_var = gfc_create_var (gfc_array_index_type, "i"); 5991 gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node); 5992 exit_label = gfc_build_label_decl (NULL_TREE); 5993 5994 /* Create loop: 5995 for (;;) 5996 { 5997 if (i >= rank) 5998 goto exit; 5999 source_bytes = source_bytes * array.dim[i].extent; 6000 i = i + 1; 6001 } 6002 exit: */ 6003 gfc_start_block (&body); 6004 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, 6005 loop_var, tmp); 6006 tmp = build1_v (GOTO_EXPR, exit_label); 6007 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 6008 cond, tmp, build_empty_stmt (input_location)); 6009 gfc_add_expr_to_block (&body, tmp); 6010 6011 lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var); 6012 upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var); 6013 tmp = gfc_conv_array_extent_dim (lower, upper, NULL); 6014 tmp = fold_build2_loc (input_location, MULT_EXPR, 6015 gfc_array_index_type, tmp, source_bytes); 6016 gfc_add_modify (&body, source_bytes, tmp); 6017 6018 tmp = fold_build2_loc (input_location, PLUS_EXPR, 6019 gfc_array_index_type, loop_var, 6020 gfc_index_one_node); 6021 gfc_add_modify_loc (input_location, &body, loop_var, tmp); 6022 6023 tmp = gfc_finish_block (&body); 6024 6025 tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node, 6026 tmp); 6027 gfc_add_expr_to_block (&argse.pre, tmp); 6028 6029 tmp = build1_v (LABEL_EXPR, exit_label); 6030 gfc_add_expr_to_block (&argse.pre, tmp); 6031 } 6032 else 6033 { 6034 /* Obtain the size of the array in bytes. */ 6035 for (n = 0; n < arg->rank; n++) 6036 { 6037 tree idx; 6038 idx = gfc_rank_cst[n]; 6039 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); 6040 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); 6041 tmp = gfc_conv_array_extent_dim (lower, upper, NULL); 6042 tmp = fold_build2_loc (input_location, MULT_EXPR, 6043 gfc_array_index_type, tmp, source_bytes); 6044 gfc_add_modify (&argse.pre, source_bytes, tmp); 6045 } 6046 } 6047 se->expr = source_bytes; 6048 } 6049 6050 gfc_add_block_to_block (&se->pre, &argse.pre); 6051} 6052 6053 6054static void 6055gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) 6056{ 6057 gfc_expr *arg; 6058 gfc_se argse; 6059 tree type, result_type, tmp; 6060 6061 arg = expr->value.function.actual->expr; 6062 6063 gfc_init_se (&argse, NULL); 6064 result_type = gfc_get_int_type (expr->ts.kind); 6065 6066 if (arg->rank == 0) 6067 { 6068 if (arg->ts.type == BT_CLASS) 6069 { 6070 gfc_add_vptr_component (arg); 6071 gfc_add_size_component (arg); 6072 gfc_conv_expr (&argse, arg); 6073 tmp = fold_convert (result_type, argse.expr); 6074 goto done; 6075 } 6076 6077 gfc_conv_expr_reference (&argse, arg); 6078 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, 6079 argse.expr)); 6080 } 6081 else 6082 { 6083 argse.want_pointer = 0; 6084 gfc_conv_expr_descriptor (&argse, arg); 6085 if (arg->ts.type == BT_CLASS) 6086 { 6087 tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); 6088 tmp = fold_convert (result_type, tmp); 6089 goto done; 6090 } 6091 type = gfc_get_element_type (TREE_TYPE (argse.expr)); 6092 } 6093 6094 /* Obtain the argument's word length. */ 6095 if (arg->ts.type == BT_CHARACTER) 6096 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length); 6097 else 6098 tmp = size_in_bytes (type); 6099 tmp = fold_convert (result_type, tmp); 6100 6101done: 6102 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp, 6103 build_int_cst (result_type, BITS_PER_UNIT)); 6104 gfc_add_block_to_block (&se->pre, &argse.pre); 6105} 6106 6107 6108/* Intrinsic string comparison functions. */ 6109 6110static void 6111gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op) 6112{ 6113 tree args[4]; 6114 6115 gfc_conv_intrinsic_function_args (se, expr, args, 4); 6116 6117 se->expr 6118 = gfc_build_compare_string (args[0], args[1], args[2], args[3], 6119 expr->value.function.actual->expr->ts.kind, 6120 op); 6121 se->expr = fold_build2_loc (input_location, op, 6122 gfc_typenode_for_spec (&expr->ts), se->expr, 6123 build_int_cst (TREE_TYPE (se->expr), 0)); 6124} 6125 6126/* Generate a call to the adjustl/adjustr library function. */ 6127static void 6128gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl) 6129{ 6130 tree args[3]; 6131 tree len; 6132 tree type; 6133 tree var; 6134 tree tmp; 6135 6136 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2); 6137 len = args[1]; 6138 6139 type = TREE_TYPE (args[2]); 6140 var = gfc_conv_string_tmp (se, type, len); 6141 args[0] = var; 6142 6143 tmp = build_call_expr_loc (input_location, 6144 fndecl, 3, args[0], args[1], args[2]); 6145 gfc_add_expr_to_block (&se->pre, tmp); 6146 se->expr = var; 6147 se->string_length = len; 6148} 6149 6150 6151/* Generate code for the TRANSFER intrinsic: 6152 For scalar results: 6153 DEST = TRANSFER (SOURCE, MOLD) 6154 where: 6155 typeof<DEST> = typeof<MOLD> 6156 and: 6157 MOLD is scalar. 6158 6159 For array results: 6160 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE]) 6161 where: 6162 typeof<DEST> = typeof<MOLD> 6163 and: 6164 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)), 6165 sizeof (DEST(0) * SIZE). */ 6166static void 6167gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) 6168{ 6169 tree tmp; 6170 tree tmpdecl; 6171 tree ptr; 6172 tree extent; 6173 tree source; 6174 tree source_type; 6175 tree source_bytes; 6176 tree mold_type; 6177 tree dest_word_len; 6178 tree size_words; 6179 tree size_bytes; 6180 tree upper; 6181 tree lower; 6182 tree stmt; 6183 gfc_actual_arglist *arg; 6184 gfc_se argse; 6185 gfc_array_info *info; 6186 stmtblock_t block; 6187 int n; 6188 bool scalar_mold; 6189 gfc_expr *source_expr, *mold_expr; 6190 6191 info = NULL; 6192 if (se->loop) 6193 info = &se->ss->info->data.array; 6194 6195 /* Convert SOURCE. The output from this stage is:- 6196 source_bytes = length of the source in bytes 6197 source = pointer to the source data. */ 6198 arg = expr->value.function.actual; 6199 source_expr = arg->expr; 6200 6201 /* Ensure double transfer through LOGICAL preserves all 6202 the needed bits. */ 6203 if (arg->expr->expr_type == EXPR_FUNCTION 6204 && arg->expr->value.function.esym == NULL 6205 && arg->expr->value.function.isym != NULL 6206 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER 6207 && arg->expr->ts.type == BT_LOGICAL 6208 && expr->ts.type != arg->expr->ts.type) 6209 arg->expr->value.function.name = "__transfer_in_transfer"; 6210 6211 gfc_init_se (&argse, NULL); 6212 6213 source_bytes = gfc_create_var (gfc_array_index_type, NULL); 6214 6215 /* Obtain the pointer to source and the length of source in bytes. */ 6216 if (arg->expr->rank == 0) 6217 { 6218 gfc_conv_expr_reference (&argse, arg->expr); 6219 if (arg->expr->ts.type == BT_CLASS) 6220 source = gfc_class_data_get (argse.expr); 6221 else 6222 source = argse.expr; 6223 6224 /* Obtain the source word length. */ 6225 switch (arg->expr->ts.type) 6226 { 6227 case BT_CHARACTER: 6228 tmp = size_of_string_in_bytes (arg->expr->ts.kind, 6229 argse.string_length); 6230 break; 6231 case BT_CLASS: 6232 tmp = gfc_class_vtab_size_get (argse.expr); 6233 break; 6234 default: 6235 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, 6236 source)); 6237 tmp = fold_convert (gfc_array_index_type, 6238 size_in_bytes (source_type)); 6239 break; 6240 } 6241 } 6242 else 6243 { 6244 argse.want_pointer = 0; 6245 gfc_conv_expr_descriptor (&argse, arg->expr); 6246 source = gfc_conv_descriptor_data_get (argse.expr); 6247 source_type = gfc_get_element_type (TREE_TYPE (argse.expr)); 6248 6249 /* Repack the source if not simply contiguous. */ 6250 if (!gfc_is_simply_contiguous (arg->expr, false)) 6251 { 6252 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr); 6253 6254 if (warn_array_temporaries) 6255 gfc_warning (OPT_Warray_temporaries, 6256 "Creating array temporary at %L", &expr->where); 6257 6258 source = build_call_expr_loc (input_location, 6259 gfor_fndecl_in_pack, 1, tmp); 6260 source = gfc_evaluate_now (source, &argse.pre); 6261 6262 /* Free the temporary. */ 6263 gfc_start_block (&block); 6264 tmp = gfc_call_free (convert (pvoid_type_node, source)); 6265 gfc_add_expr_to_block (&block, tmp); 6266 stmt = gfc_finish_block (&block); 6267 6268 /* Clean up if it was repacked. */ 6269 gfc_init_block (&block); 6270 tmp = gfc_conv_array_data (argse.expr); 6271 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 6272 source, tmp); 6273 tmp = build3_v (COND_EXPR, tmp, stmt, 6274 build_empty_stmt (input_location)); 6275 gfc_add_expr_to_block (&block, tmp); 6276 gfc_add_block_to_block (&block, &se->post); 6277 gfc_init_block (&se->post); 6278 gfc_add_block_to_block (&se->post, &block); 6279 } 6280 6281 /* Obtain the source word length. */ 6282 if (arg->expr->ts.type == BT_CHARACTER) 6283 tmp = size_of_string_in_bytes (arg->expr->ts.kind, 6284 argse.string_length); 6285 else 6286 tmp = fold_convert (gfc_array_index_type, 6287 size_in_bytes (source_type)); 6288 6289 /* Obtain the size of the array in bytes. */ 6290 extent = gfc_create_var (gfc_array_index_type, NULL); 6291 for (n = 0; n < arg->expr->rank; n++) 6292 { 6293 tree idx; 6294 idx = gfc_rank_cst[n]; 6295 gfc_add_modify (&argse.pre, source_bytes, tmp); 6296 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); 6297 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); 6298 tmp = fold_build2_loc (input_location, MINUS_EXPR, 6299 gfc_array_index_type, upper, lower); 6300 gfc_add_modify (&argse.pre, extent, tmp); 6301 tmp = fold_build2_loc (input_location, PLUS_EXPR, 6302 gfc_array_index_type, extent, 6303 gfc_index_one_node); 6304 tmp = fold_build2_loc (input_location, MULT_EXPR, 6305 gfc_array_index_type, tmp, source_bytes); 6306 } 6307 } 6308 6309 gfc_add_modify (&argse.pre, source_bytes, tmp); 6310 gfc_add_block_to_block (&se->pre, &argse.pre); 6311 gfc_add_block_to_block (&se->post, &argse.post); 6312 6313 /* Now convert MOLD. The outputs are: 6314 mold_type = the TREE type of MOLD 6315 dest_word_len = destination word length in bytes. */ 6316 arg = arg->next; 6317 mold_expr = arg->expr; 6318 6319 gfc_init_se (&argse, NULL); 6320 6321 scalar_mold = arg->expr->rank == 0; 6322 6323 if (arg->expr->rank == 0) 6324 { 6325 gfc_conv_expr_reference (&argse, arg->expr); 6326 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, 6327 argse.expr)); 6328 } 6329 else 6330 { 6331 gfc_init_se (&argse, NULL); 6332 argse.want_pointer = 0; 6333 gfc_conv_expr_descriptor (&argse, arg->expr); 6334 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr)); 6335 } 6336 6337 gfc_add_block_to_block (&se->pre, &argse.pre); 6338 gfc_add_block_to_block (&se->post, &argse.post); 6339 6340 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0) 6341 { 6342 /* If this TRANSFER is nested in another TRANSFER, use a type 6343 that preserves all bits. */ 6344 if (arg->expr->ts.type == BT_LOGICAL) 6345 mold_type = gfc_get_int_type (arg->expr->ts.kind); 6346 } 6347 6348 /* Obtain the destination word length. */ 6349 switch (arg->expr->ts.type) 6350 { 6351 case BT_CHARACTER: 6352 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length); 6353 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp); 6354 break; 6355 case BT_CLASS: 6356 tmp = gfc_class_vtab_size_get (argse.expr); 6357 break; 6358 default: 6359 tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type)); 6360 break; 6361 } 6362 dest_word_len = gfc_create_var (gfc_array_index_type, NULL); 6363 gfc_add_modify (&se->pre, dest_word_len, tmp); 6364 6365 /* Finally convert SIZE, if it is present. */ 6366 arg = arg->next; 6367 size_words = gfc_create_var (gfc_array_index_type, NULL); 6368 6369 if (arg->expr) 6370 { 6371 gfc_init_se (&argse, NULL); 6372 gfc_conv_expr_reference (&argse, arg->expr); 6373 tmp = convert (gfc_array_index_type, 6374 build_fold_indirect_ref_loc (input_location, 6375 argse.expr)); 6376 gfc_add_block_to_block (&se->pre, &argse.pre); 6377 gfc_add_block_to_block (&se->post, &argse.post); 6378 } 6379 else 6380 tmp = NULL_TREE; 6381 6382 /* Separate array and scalar results. */ 6383 if (scalar_mold && tmp == NULL_TREE) 6384 goto scalar_transfer; 6385 6386 size_bytes = gfc_create_var (gfc_array_index_type, NULL); 6387 if (tmp != NULL_TREE) 6388 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 6389 tmp, dest_word_len); 6390 else 6391 tmp = source_bytes; 6392 6393 gfc_add_modify (&se->pre, size_bytes, tmp); 6394 gfc_add_modify (&se->pre, size_words, 6395 fold_build2_loc (input_location, CEIL_DIV_EXPR, 6396 gfc_array_index_type, 6397 size_bytes, dest_word_len)); 6398 6399 /* Evaluate the bounds of the result. If the loop range exists, we have 6400 to check if it is too large. If so, we modify loop->to be consistent 6401 with min(size, size(source)). Otherwise, size is made consistent with 6402 the loop range, so that the right number of bytes is transferred.*/ 6403 n = se->loop->order[0]; 6404 if (se->loop->to[n] != NULL_TREE) 6405 { 6406 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 6407 se->loop->to[n], se->loop->from[n]); 6408 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 6409 tmp, gfc_index_one_node); 6410 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type, 6411 tmp, size_words); 6412 gfc_add_modify (&se->pre, size_words, tmp); 6413 gfc_add_modify (&se->pre, size_bytes, 6414 fold_build2_loc (input_location, MULT_EXPR, 6415 gfc_array_index_type, 6416 size_words, dest_word_len)); 6417 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 6418 size_words, se->loop->from[n]); 6419 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 6420 upper, gfc_index_one_node); 6421 } 6422 else 6423 { 6424 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 6425 size_words, gfc_index_one_node); 6426 se->loop->from[n] = gfc_index_zero_node; 6427 } 6428 6429 se->loop->to[n] = upper; 6430 6431 /* Build a destination descriptor, using the pointer, source, as the 6432 data field. */ 6433 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type, 6434 NULL_TREE, false, true, false, &expr->where); 6435 6436 /* Cast the pointer to the result. */ 6437 tmp = gfc_conv_descriptor_data_get (info->descriptor); 6438 tmp = fold_convert (pvoid_type_node, tmp); 6439 6440 /* Use memcpy to do the transfer. */ 6441 tmp 6442 = build_call_expr_loc (input_location, 6443 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp, 6444 fold_convert (pvoid_type_node, source), 6445 fold_convert (size_type_node, 6446 fold_build2_loc (input_location, 6447 MIN_EXPR, 6448 gfc_array_index_type, 6449 size_bytes, 6450 source_bytes))); 6451 gfc_add_expr_to_block (&se->pre, tmp); 6452 6453 se->expr = info->descriptor; 6454 if (expr->ts.type == BT_CHARACTER) 6455 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len); 6456 6457 return; 6458 6459/* Deal with scalar results. */ 6460scalar_transfer: 6461 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type, 6462 dest_word_len, source_bytes); 6463 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, 6464 extent, gfc_index_zero_node); 6465 6466 if (expr->ts.type == BT_CHARACTER) 6467 { 6468 tree direct, indirect, free; 6469 6470 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source); 6471 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), 6472 "transfer"); 6473 6474 /* If source is longer than the destination, use a pointer to 6475 the source directly. */ 6476 gfc_init_block (&block); 6477 gfc_add_modify (&block, tmpdecl, ptr); 6478 direct = gfc_finish_block (&block); 6479 6480 /* Otherwise, allocate a string with the length of the destination 6481 and copy the source into it. */ 6482 gfc_init_block (&block); 6483 tmp = gfc_get_pchar_type (expr->ts.kind); 6484 tmp = gfc_call_malloc (&block, tmp, dest_word_len); 6485 gfc_add_modify (&block, tmpdecl, 6486 fold_convert (TREE_TYPE (ptr), tmp)); 6487 tmp = build_call_expr_loc (input_location, 6488 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, 6489 fold_convert (pvoid_type_node, tmpdecl), 6490 fold_convert (pvoid_type_node, ptr), 6491 fold_convert (size_type_node, extent)); 6492 gfc_add_expr_to_block (&block, tmp); 6493 indirect = gfc_finish_block (&block); 6494 6495 /* Wrap it up with the condition. */ 6496 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, 6497 dest_word_len, source_bytes); 6498 tmp = build3_v (COND_EXPR, tmp, direct, indirect); 6499 gfc_add_expr_to_block (&se->pre, tmp); 6500 6501 /* Free the temporary string, if necessary. */ 6502 free = gfc_call_free (tmpdecl); 6503 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 6504 dest_word_len, source_bytes); 6505 tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location)); 6506 gfc_add_expr_to_block (&se->post, tmp); 6507 6508 se->expr = tmpdecl; 6509 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len); 6510 } 6511 else 6512 { 6513 tmpdecl = gfc_create_var (mold_type, "transfer"); 6514 6515 ptr = convert (build_pointer_type (mold_type), source); 6516 6517 /* For CLASS results, allocate the needed memory first. */ 6518 if (mold_expr->ts.type == BT_CLASS) 6519 { 6520 tree cdata; 6521 cdata = gfc_class_data_get (tmpdecl); 6522 tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len); 6523 gfc_add_modify (&se->pre, cdata, tmp); 6524 } 6525 6526 /* Use memcpy to do the transfer. */ 6527 if (mold_expr->ts.type == BT_CLASS) 6528 tmp = gfc_class_data_get (tmpdecl); 6529 else 6530 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl); 6531 6532 tmp = build_call_expr_loc (input_location, 6533 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, 6534 fold_convert (pvoid_type_node, tmp), 6535 fold_convert (pvoid_type_node, ptr), 6536 fold_convert (size_type_node, extent)); 6537 gfc_add_expr_to_block (&se->pre, tmp); 6538 6539 /* For CLASS results, set the _vptr. */ 6540 if (mold_expr->ts.type == BT_CLASS) 6541 { 6542 tree vptr; 6543 gfc_symbol *vtab; 6544 vptr = gfc_class_vptr_get (tmpdecl); 6545 vtab = gfc_find_derived_vtab (source_expr->ts.u.derived); 6546 gcc_assert (vtab); 6547 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); 6548 gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp)); 6549 } 6550 6551 se->expr = tmpdecl; 6552 } 6553} 6554 6555 6556/* Generate code for the ALLOCATED intrinsic. 6557 Generate inline code that directly check the address of the argument. */ 6558 6559static void 6560gfc_conv_allocated (gfc_se *se, gfc_expr *expr) 6561{ 6562 gfc_actual_arglist *arg1; 6563 gfc_se arg1se; 6564 tree tmp; 6565 6566 gfc_init_se (&arg1se, NULL); 6567 arg1 = expr->value.function.actual; 6568 6569 if (arg1->expr->ts.type == BT_CLASS) 6570 { 6571 /* Make sure that class array expressions have both a _data 6572 component reference and an array reference.... */ 6573 if (CLASS_DATA (arg1->expr)->attr.dimension) 6574 gfc_add_class_array_ref (arg1->expr); 6575 /* .... whilst scalars only need the _data component. */ 6576 else 6577 gfc_add_data_component (arg1->expr); 6578 } 6579 6580 if (arg1->expr->rank == 0) 6581 { 6582 /* Allocatable scalar. */ 6583 arg1se.want_pointer = 1; 6584 gfc_conv_expr (&arg1se, arg1->expr); 6585 tmp = arg1se.expr; 6586 } 6587 else 6588 { 6589 /* Allocatable array. */ 6590 arg1se.descriptor_only = 1; 6591 gfc_conv_expr_descriptor (&arg1se, arg1->expr); 6592 tmp = gfc_conv_descriptor_data_get (arg1se.expr); 6593 } 6594 6595 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, 6596 fold_convert (TREE_TYPE (tmp), null_pointer_node)); 6597 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); 6598} 6599 6600 6601/* Generate code for the ASSOCIATED intrinsic. 6602 If both POINTER and TARGET are arrays, generate a call to library function 6603 _gfor_associated, and pass descriptors of POINTER and TARGET to it. 6604 In other cases, generate inline code that directly compare the address of 6605 POINTER with the address of TARGET. */ 6606 6607static void 6608gfc_conv_associated (gfc_se *se, gfc_expr *expr) 6609{ 6610 gfc_actual_arglist *arg1; 6611 gfc_actual_arglist *arg2; 6612 gfc_se arg1se; 6613 gfc_se arg2se; 6614 tree tmp2; 6615 tree tmp; 6616 tree nonzero_charlen; 6617 tree nonzero_arraylen; 6618 gfc_ss *ss; 6619 bool scalar; 6620 6621 gfc_init_se (&arg1se, NULL); 6622 gfc_init_se (&arg2se, NULL); 6623 arg1 = expr->value.function.actual; 6624 arg2 = arg1->next; 6625 6626 /* Check whether the expression is a scalar or not; we cannot use 6627 arg1->expr->rank as it can be nonzero for proc pointers. */ 6628 ss = gfc_walk_expr (arg1->expr); 6629 scalar = ss == gfc_ss_terminator; 6630 if (!scalar) 6631 gfc_free_ss_chain (ss); 6632 6633 if (!arg2->expr) 6634 { 6635 /* No optional target. */ 6636 if (scalar) 6637 { 6638 /* A pointer to a scalar. */ 6639 arg1se.want_pointer = 1; 6640 gfc_conv_expr (&arg1se, arg1->expr); 6641 if (arg1->expr->symtree->n.sym->attr.proc_pointer 6642 && arg1->expr->symtree->n.sym->attr.dummy) 6643 arg1se.expr = build_fold_indirect_ref_loc (input_location, 6644 arg1se.expr); 6645 if (arg1->expr->ts.type == BT_CLASS) 6646 { 6647 tmp2 = gfc_class_data_get (arg1se.expr); 6648 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2))) 6649 tmp2 = gfc_conv_descriptor_data_get (tmp2); 6650 } 6651 else 6652 tmp2 = arg1se.expr; 6653 } 6654 else 6655 { 6656 /* A pointer to an array. */ 6657 gfc_conv_expr_descriptor (&arg1se, arg1->expr); 6658 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr); 6659 } 6660 gfc_add_block_to_block (&se->pre, &arg1se.pre); 6661 gfc_add_block_to_block (&se->post, &arg1se.post); 6662 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2, 6663 fold_convert (TREE_TYPE (tmp2), null_pointer_node)); 6664 se->expr = tmp; 6665 } 6666 else 6667 { 6668 /* An optional target. */ 6669 if (arg2->expr->ts.type == BT_CLASS) 6670 gfc_add_data_component (arg2->expr); 6671 6672 nonzero_charlen = NULL_TREE; 6673 if (arg1->expr->ts.type == BT_CHARACTER) 6674 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR, 6675 boolean_type_node, 6676 arg1->expr->ts.u.cl->backend_decl, 6677 integer_zero_node); 6678 if (scalar) 6679 { 6680 /* A pointer to a scalar. */ 6681 arg1se.want_pointer = 1; 6682 gfc_conv_expr (&arg1se, arg1->expr); 6683 if (arg1->expr->symtree->n.sym->attr.proc_pointer 6684 && arg1->expr->symtree->n.sym->attr.dummy) 6685 arg1se.expr = build_fold_indirect_ref_loc (input_location, 6686 arg1se.expr); 6687 if (arg1->expr->ts.type == BT_CLASS) 6688 arg1se.expr = gfc_class_data_get (arg1se.expr); 6689 6690 arg2se.want_pointer = 1; 6691 gfc_conv_expr (&arg2se, arg2->expr); 6692 if (arg2->expr->symtree->n.sym->attr.proc_pointer 6693 && arg2->expr->symtree->n.sym->attr.dummy) 6694 arg2se.expr = build_fold_indirect_ref_loc (input_location, 6695 arg2se.expr); 6696 gfc_add_block_to_block (&se->pre, &arg1se.pre); 6697 gfc_add_block_to_block (&se->post, &arg1se.post); 6698 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 6699 arg1se.expr, arg2se.expr); 6700 tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 6701 arg1se.expr, null_pointer_node); 6702 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, 6703 boolean_type_node, tmp, tmp2); 6704 } 6705 else 6706 { 6707 /* An array pointer of zero length is not associated if target is 6708 present. */ 6709 arg1se.descriptor_only = 1; 6710 gfc_conv_expr_lhs (&arg1se, arg1->expr); 6711 if (arg1->expr->rank == -1) 6712 { 6713 tmp = gfc_conv_descriptor_rank (arg1se.expr); 6714 tmp = fold_build2_loc (input_location, MINUS_EXPR, 6715 TREE_TYPE (tmp), tmp, gfc_index_one_node); 6716 } 6717 else 6718 tmp = gfc_rank_cst[arg1->expr->rank - 1]; 6719 tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp); 6720 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, 6721 boolean_type_node, tmp, 6722 build_int_cst (TREE_TYPE (tmp), 0)); 6723 6724 /* A pointer to an array, call library function _gfor_associated. */ 6725 arg1se.want_pointer = 1; 6726 gfc_conv_expr_descriptor (&arg1se, arg1->expr); 6727 6728 arg2se.want_pointer = 1; 6729 gfc_conv_expr_descriptor (&arg2se, arg2->expr); 6730 gfc_add_block_to_block (&se->pre, &arg2se.pre); 6731 gfc_add_block_to_block (&se->post, &arg2se.post); 6732 se->expr = build_call_expr_loc (input_location, 6733 gfor_fndecl_associated, 2, 6734 arg1se.expr, arg2se.expr); 6735 se->expr = convert (boolean_type_node, se->expr); 6736 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, 6737 boolean_type_node, se->expr, 6738 nonzero_arraylen); 6739 } 6740 6741 /* If target is present zero character length pointers cannot 6742 be associated. */ 6743 if (nonzero_charlen != NULL_TREE) 6744 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, 6745 boolean_type_node, 6746 se->expr, nonzero_charlen); 6747 } 6748 6749 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); 6750} 6751 6752 6753/* Generate code for the SAME_TYPE_AS intrinsic. 6754 Generate inline code that directly checks the vindices. */ 6755 6756static void 6757gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) 6758{ 6759 gfc_expr *a, *b; 6760 gfc_se se1, se2; 6761 tree tmp; 6762 tree conda = NULL_TREE, condb = NULL_TREE; 6763 6764 gfc_init_se (&se1, NULL); 6765 gfc_init_se (&se2, NULL); 6766 6767 a = expr->value.function.actual->expr; 6768 b = expr->value.function.actual->next->expr; 6769 6770 if (UNLIMITED_POLY (a)) 6771 { 6772 tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl); 6773 conda = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 6774 tmp, build_int_cst (TREE_TYPE (tmp), 0)); 6775 } 6776 6777 if (UNLIMITED_POLY (b)) 6778 { 6779 tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl); 6780 condb = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 6781 tmp, build_int_cst (TREE_TYPE (tmp), 0)); 6782 } 6783 6784 if (a->ts.type == BT_CLASS) 6785 { 6786 gfc_add_vptr_component (a); 6787 gfc_add_hash_component (a); 6788 } 6789 else if (a->ts.type == BT_DERIVED) 6790 a = gfc_get_int_expr (gfc_default_integer_kind, NULL, 6791 a->ts.u.derived->hash_value); 6792 6793 if (b->ts.type == BT_CLASS) 6794 { 6795 gfc_add_vptr_component (b); 6796 gfc_add_hash_component (b); 6797 } 6798 else if (b->ts.type == BT_DERIVED) 6799 b = gfc_get_int_expr (gfc_default_integer_kind, NULL, 6800 b->ts.u.derived->hash_value); 6801 6802 gfc_conv_expr (&se1, a); 6803 gfc_conv_expr (&se2, b); 6804 6805 tmp = fold_build2_loc (input_location, EQ_EXPR, 6806 boolean_type_node, se1.expr, 6807 fold_convert (TREE_TYPE (se1.expr), se2.expr)); 6808 6809 if (conda) 6810 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 6811 boolean_type_node, conda, tmp); 6812 6813 if (condb) 6814 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 6815 boolean_type_node, condb, tmp); 6816 6817 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); 6818} 6819 6820 6821/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */ 6822 6823static void 6824gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr) 6825{ 6826 tree args[2]; 6827 6828 gfc_conv_intrinsic_function_args (se, expr, args, 2); 6829 se->expr = build_call_expr_loc (input_location, 6830 gfor_fndecl_sc_kind, 2, args[0], args[1]); 6831 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); 6832} 6833 6834 6835/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */ 6836 6837static void 6838gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr) 6839{ 6840 tree arg, type; 6841 6842 gfc_conv_intrinsic_function_args (se, expr, &arg, 1); 6843 6844 /* The argument to SELECTED_INT_KIND is INTEGER(4). */ 6845 type = gfc_get_int_type (4); 6846 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg)); 6847 6848 /* Convert it to the required type. */ 6849 type = gfc_typenode_for_spec (&expr->ts); 6850 se->expr = build_call_expr_loc (input_location, 6851 gfor_fndecl_si_kind, 1, arg); 6852 se->expr = fold_convert (type, se->expr); 6853} 6854 6855 6856/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */ 6857 6858static void 6859gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) 6860{ 6861 gfc_actual_arglist *actual; 6862 tree type; 6863 gfc_se argse; 6864 vec<tree, va_gc> *args = NULL; 6865 6866 for (actual = expr->value.function.actual; actual; actual = actual->next) 6867 { 6868 gfc_init_se (&argse, se); 6869 6870 /* Pass a NULL pointer for an absent arg. */ 6871 if (actual->expr == NULL) 6872 argse.expr = null_pointer_node; 6873 else 6874 { 6875 gfc_typespec ts; 6876 gfc_clear_ts (&ts); 6877 6878 if (actual->expr->ts.kind != gfc_c_int_kind) 6879 { 6880 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */ 6881 ts.type = BT_INTEGER; 6882 ts.kind = gfc_c_int_kind; 6883 gfc_convert_type (actual->expr, &ts, 2); 6884 } 6885 gfc_conv_expr_reference (&argse, actual->expr); 6886 } 6887 6888 gfc_add_block_to_block (&se->pre, &argse.pre); 6889 gfc_add_block_to_block (&se->post, &argse.post); 6890 vec_safe_push (args, argse.expr); 6891 } 6892 6893 /* Convert it to the required type. */ 6894 type = gfc_typenode_for_spec (&expr->ts); 6895 se->expr = build_call_expr_loc_vec (input_location, 6896 gfor_fndecl_sr_kind, args); 6897 se->expr = fold_convert (type, se->expr); 6898} 6899 6900 6901/* Generate code for TRIM (A) intrinsic function. */ 6902 6903static void 6904gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) 6905{ 6906 tree var; 6907 tree len; 6908 tree addr; 6909 tree tmp; 6910 tree cond; 6911 tree fndecl; 6912 tree function; 6913 tree *args; 6914 unsigned int num_args; 6915 6916 num_args = gfc_intrinsic_argument_list_length (expr) + 2; 6917 args = XALLOCAVEC (tree, num_args); 6918 6919 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); 6920 addr = gfc_build_addr_expr (ppvoid_type_node, var); 6921 len = gfc_create_var (gfc_charlen_type_node, "len"); 6922 6923 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); 6924 args[0] = gfc_build_addr_expr (NULL_TREE, len); 6925 args[1] = addr; 6926 6927 if (expr->ts.kind == 1) 6928 function = gfor_fndecl_string_trim; 6929 else if (expr->ts.kind == 4) 6930 function = gfor_fndecl_string_trim_char4; 6931 else 6932 gcc_unreachable (); 6933 6934 fndecl = build_addr (function, current_function_decl); 6935 tmp = build_call_array_loc (input_location, 6936 TREE_TYPE (TREE_TYPE (function)), fndecl, 6937 num_args, args); 6938 gfc_add_expr_to_block (&se->pre, tmp); 6939 6940 /* Free the temporary afterwards, if necessary. */ 6941 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 6942 len, build_int_cst (TREE_TYPE (len), 0)); 6943 tmp = gfc_call_free (var); 6944 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); 6945 gfc_add_expr_to_block (&se->post, tmp); 6946 6947 se->expr = var; 6948 se->string_length = len; 6949} 6950 6951 6952/* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */ 6953 6954static void 6955gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) 6956{ 6957 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type; 6958 tree type, cond, tmp, count, exit_label, n, max, largest; 6959 tree size; 6960 stmtblock_t block, body; 6961 int i; 6962 6963 /* We store in charsize the size of a character. */ 6964 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); 6965 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8); 6966 6967 /* Get the arguments. */ 6968 gfc_conv_intrinsic_function_args (se, expr, args, 3); 6969 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre)); 6970 src = args[1]; 6971 ncopies = gfc_evaluate_now (args[2], &se->pre); 6972 ncopies_type = TREE_TYPE (ncopies); 6973 6974 /* Check that NCOPIES is not negative. */ 6975 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies, 6976 build_int_cst (ncopies_type, 0)); 6977 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, 6978 "Argument NCOPIES of REPEAT intrinsic is negative " 6979 "(its value is %ld)", 6980 fold_convert (long_integer_type_node, ncopies)); 6981 6982 /* If the source length is zero, any non negative value of NCOPIES 6983 is valid, and nothing happens. */ 6984 n = gfc_create_var (ncopies_type, "ncopies"); 6985 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen, 6986 build_int_cst (size_type_node, 0)); 6987 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond, 6988 build_int_cst (ncopies_type, 0), ncopies); 6989 gfc_add_modify (&se->pre, n, tmp); 6990 ncopies = n; 6991 6992 /* Check that ncopies is not too large: ncopies should be less than 6993 (or equal to) MAX / slen, where MAX is the maximal integer of 6994 the gfc_charlen_type_node type. If slen == 0, we need a special 6995 case to avoid the division by zero. */ 6996 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); 6997 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind); 6998 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node, 6999 fold_convert (size_type_node, max), slen); 7000 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type) 7001 ? size_type_node : ncopies_type; 7002 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 7003 fold_convert (largest, ncopies), 7004 fold_convert (largest, max)); 7005 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen, 7006 build_int_cst (size_type_node, 0)); 7007 cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp, 7008 boolean_false_node, cond); 7009 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, 7010 "Argument NCOPIES of REPEAT intrinsic is too large"); 7011 7012 /* Compute the destination length. */ 7013 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node, 7014 fold_convert (gfc_charlen_type_node, slen), 7015 fold_convert (gfc_charlen_type_node, ncopies)); 7016 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl); 7017 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen); 7018 7019 /* Generate the code to do the repeat operation: 7020 for (i = 0; i < ncopies; i++) 7021 memmove (dest + (i * slen * size), src, slen*size); */ 7022 gfc_start_block (&block); 7023 count = gfc_create_var (ncopies_type, "count"); 7024 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0)); 7025 exit_label = gfc_build_label_decl (NULL_TREE); 7026 7027 /* Start the loop body. */ 7028 gfc_start_block (&body); 7029 7030 /* Exit the loop if count >= ncopies. */ 7031 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count, 7032 ncopies); 7033 tmp = build1_v (GOTO_EXPR, exit_label); 7034 TREE_USED (exit_label) = 1; 7035 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, 7036 build_empty_stmt (input_location)); 7037 gfc_add_expr_to_block (&body, tmp); 7038 7039 /* Call memmove (dest + (i*slen*size), src, slen*size). */ 7040 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node, 7041 fold_convert (gfc_charlen_type_node, slen), 7042 fold_convert (gfc_charlen_type_node, count)); 7043 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node, 7044 tmp, fold_convert (gfc_charlen_type_node, size)); 7045 tmp = fold_build_pointer_plus_loc (input_location, 7046 fold_convert (pvoid_type_node, dest), tmp); 7047 tmp = build_call_expr_loc (input_location, 7048 builtin_decl_explicit (BUILT_IN_MEMMOVE), 7049 3, tmp, src, 7050 fold_build2_loc (input_location, MULT_EXPR, 7051 size_type_node, slen, 7052 fold_convert (size_type_node, 7053 size))); 7054 gfc_add_expr_to_block (&body, tmp); 7055 7056 /* Increment count. */ 7057 tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type, 7058 count, build_int_cst (TREE_TYPE (count), 1)); 7059 gfc_add_modify (&body, count, tmp); 7060 7061 /* Build the loop. */ 7062 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body)); 7063 gfc_add_expr_to_block (&block, tmp); 7064 7065 /* Add the exit label. */ 7066 tmp = build1_v (LABEL_EXPR, exit_label); 7067 gfc_add_expr_to_block (&block, tmp); 7068 7069 /* Finish the block. */ 7070 tmp = gfc_finish_block (&block); 7071 gfc_add_expr_to_block (&se->pre, tmp); 7072 7073 /* Set the result value. */ 7074 se->expr = dest; 7075 se->string_length = dlen; 7076} 7077 7078 7079/* Generate code for the IARGC intrinsic. */ 7080 7081static void 7082gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr) 7083{ 7084 tree tmp; 7085 tree fndecl; 7086 tree type; 7087 7088 /* Call the library function. This always returns an INTEGER(4). */ 7089 fndecl = gfor_fndecl_iargc; 7090 tmp = build_call_expr_loc (input_location, 7091 fndecl, 0); 7092 7093 /* Convert it to the required type. */ 7094 type = gfc_typenode_for_spec (&expr->ts); 7095 tmp = fold_convert (type, tmp); 7096 7097 se->expr = tmp; 7098} 7099 7100 7101/* The loc intrinsic returns the address of its argument as 7102 gfc_index_integer_kind integer. */ 7103 7104static void 7105gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) 7106{ 7107 tree temp_var; 7108 gfc_expr *arg_expr; 7109 7110 gcc_assert (!se->ss); 7111 7112 arg_expr = expr->value.function.actual->expr; 7113 if (arg_expr->rank == 0) 7114 gfc_conv_expr_reference (se, arg_expr); 7115 else 7116 gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL); 7117 se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); 7118 7119 /* Create a temporary variable for loc return value. Without this, 7120 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */ 7121 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL); 7122 gfc_add_modify (&se->pre, temp_var, se->expr); 7123 se->expr = temp_var; 7124} 7125 7126 7127/* The following routine generates code for the intrinsic 7128 functions from the ISO_C_BINDING module: 7129 * C_LOC 7130 * C_FUNLOC 7131 * C_ASSOCIATED */ 7132 7133static void 7134conv_isocbinding_function (gfc_se *se, gfc_expr *expr) 7135{ 7136 gfc_actual_arglist *arg = expr->value.function.actual; 7137 7138 if (expr->value.function.isym->id == GFC_ISYM_C_LOC) 7139 { 7140 if (arg->expr->rank == 0) 7141 gfc_conv_expr_reference (se, arg->expr); 7142 else if (gfc_is_simply_contiguous (arg->expr, false)) 7143 gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL); 7144 else 7145 { 7146 gfc_conv_expr_descriptor (se, arg->expr); 7147 se->expr = gfc_conv_descriptor_data_get (se->expr); 7148 } 7149 7150 /* TODO -- the following two lines shouldn't be necessary, but if 7151 they're removed, a bug is exposed later in the code path. 7152 This workaround was thus introduced, but will have to be 7153 removed; please see PR 35150 for details about the issue. */ 7154 se->expr = convert (pvoid_type_node, se->expr); 7155 se->expr = gfc_evaluate_now (se->expr, &se->pre); 7156 } 7157 else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC) 7158 gfc_conv_expr_reference (se, arg->expr); 7159 else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED) 7160 { 7161 gfc_se arg1se; 7162 gfc_se arg2se; 7163 7164 /* Build the addr_expr for the first argument. The argument is 7165 already an *address* so we don't need to set want_pointer in 7166 the gfc_se. */ 7167 gfc_init_se (&arg1se, NULL); 7168 gfc_conv_expr (&arg1se, arg->expr); 7169 gfc_add_block_to_block (&se->pre, &arg1se.pre); 7170 gfc_add_block_to_block (&se->post, &arg1se.post); 7171 7172 /* See if we were given two arguments. */ 7173 if (arg->next->expr == NULL) 7174 /* Only given one arg so generate a null and do a 7175 not-equal comparison against the first arg. */ 7176 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 7177 arg1se.expr, 7178 fold_convert (TREE_TYPE (arg1se.expr), 7179 null_pointer_node)); 7180 else 7181 { 7182 tree eq_expr; 7183 tree not_null_expr; 7184 7185 /* Given two arguments so build the arg2se from second arg. */ 7186 gfc_init_se (&arg2se, NULL); 7187 gfc_conv_expr (&arg2se, arg->next->expr); 7188 gfc_add_block_to_block (&se->pre, &arg2se.pre); 7189 gfc_add_block_to_block (&se->post, &arg2se.post); 7190 7191 /* Generate test to compare that the two args are equal. */ 7192 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 7193 arg1se.expr, arg2se.expr); 7194 /* Generate test to ensure that the first arg is not null. */ 7195 not_null_expr = fold_build2_loc (input_location, NE_EXPR, 7196 boolean_type_node, 7197 arg1se.expr, null_pointer_node); 7198 7199 /* Finally, the generated test must check that both arg1 is not 7200 NULL and that it is equal to the second arg. */ 7201 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, 7202 boolean_type_node, 7203 not_null_expr, eq_expr); 7204 } 7205 } 7206 else 7207 gcc_unreachable (); 7208} 7209 7210 7211/* The following routine generates code for the intrinsic 7212 subroutines from the ISO_C_BINDING module: 7213 * C_F_POINTER 7214 * C_F_PROCPOINTER. */ 7215 7216static tree 7217conv_isocbinding_subroutine (gfc_code *code) 7218{ 7219 gfc_se se; 7220 gfc_se cptrse; 7221 gfc_se fptrse; 7222 gfc_se shapese; 7223 gfc_ss *shape_ss; 7224 tree desc, dim, tmp, stride, offset; 7225 stmtblock_t body, block; 7226 gfc_loopinfo loop; 7227 gfc_actual_arglist *arg = code->ext.actual; 7228 7229 gfc_init_se (&se, NULL); 7230 gfc_init_se (&cptrse, NULL); 7231 gfc_conv_expr (&cptrse, arg->expr); 7232 gfc_add_block_to_block (&se.pre, &cptrse.pre); 7233 gfc_add_block_to_block (&se.post, &cptrse.post); 7234 7235 gfc_init_se (&fptrse, NULL); 7236 if (arg->next->expr->rank == 0) 7237 { 7238 fptrse.want_pointer = 1; 7239 gfc_conv_expr (&fptrse, arg->next->expr); 7240 gfc_add_block_to_block (&se.pre, &fptrse.pre); 7241 gfc_add_block_to_block (&se.post, &fptrse.post); 7242 if (arg->next->expr->symtree->n.sym->attr.proc_pointer 7243 && arg->next->expr->symtree->n.sym->attr.dummy) 7244 fptrse.expr = build_fold_indirect_ref_loc (input_location, 7245 fptrse.expr); 7246 se.expr = fold_build2_loc (input_location, MODIFY_EXPR, 7247 TREE_TYPE (fptrse.expr), 7248 fptrse.expr, 7249 fold_convert (TREE_TYPE (fptrse.expr), 7250 cptrse.expr)); 7251 gfc_add_expr_to_block (&se.pre, se.expr); 7252 gfc_add_block_to_block (&se.pre, &se.post); 7253 return gfc_finish_block (&se.pre); 7254 } 7255 7256 gfc_start_block (&block); 7257 7258 /* Get the descriptor of the Fortran pointer. */ 7259 fptrse.descriptor_only = 1; 7260 gfc_conv_expr_descriptor (&fptrse, arg->next->expr); 7261 gfc_add_block_to_block (&block, &fptrse.pre); 7262 desc = fptrse.expr; 7263 7264 /* Set data value, dtype, and offset. */ 7265 tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)); 7266 gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr)); 7267 gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc), 7268 gfc_get_dtype (TREE_TYPE (desc))); 7269 7270 /* Start scalarization of the bounds, using the shape argument. */ 7271 7272 shape_ss = gfc_walk_expr (arg->next->next->expr); 7273 gcc_assert (shape_ss != gfc_ss_terminator); 7274 gfc_init_se (&shapese, NULL); 7275 7276 gfc_init_loopinfo (&loop); 7277 gfc_add_ss_to_loop (&loop, shape_ss); 7278 gfc_conv_ss_startstride (&loop); 7279 gfc_conv_loop_setup (&loop, &arg->next->expr->where); 7280 gfc_mark_ss_chain_used (shape_ss, 1); 7281 7282 gfc_copy_loopinfo_to_se (&shapese, &loop); 7283 shapese.ss = shape_ss; 7284 7285 stride = gfc_create_var (gfc_array_index_type, "stride"); 7286 offset = gfc_create_var (gfc_array_index_type, "offset"); 7287 gfc_add_modify (&block, stride, gfc_index_one_node); 7288 gfc_add_modify (&block, offset, gfc_index_zero_node); 7289 7290 /* Loop body. */ 7291 gfc_start_scalarized_body (&loop, &body); 7292 7293 dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 7294 loop.loopvar[0], loop.from[0]); 7295 7296 /* Set bounds and stride. */ 7297 gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node); 7298 gfc_conv_descriptor_stride_set (&body, desc, dim, stride); 7299 7300 gfc_conv_expr (&shapese, arg->next->next->expr); 7301 gfc_add_block_to_block (&body, &shapese.pre); 7302 gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr); 7303 gfc_add_block_to_block (&body, &shapese.post); 7304 7305 /* Calculate offset. */ 7306 gfc_add_modify (&body, offset, 7307 fold_build2_loc (input_location, PLUS_EXPR, 7308 gfc_array_index_type, offset, stride)); 7309 /* Update stride. */ 7310 gfc_add_modify (&body, stride, 7311 fold_build2_loc (input_location, MULT_EXPR, 7312 gfc_array_index_type, stride, 7313 fold_convert (gfc_array_index_type, 7314 shapese.expr))); 7315 /* Finish scalarization loop. */ 7316 gfc_trans_scalarizing_loops (&loop, &body); 7317 gfc_add_block_to_block (&block, &loop.pre); 7318 gfc_add_block_to_block (&block, &loop.post); 7319 gfc_add_block_to_block (&block, &fptrse.post); 7320 gfc_cleanup_loop (&loop); 7321 7322 gfc_add_modify (&block, offset, 7323 fold_build1_loc (input_location, NEGATE_EXPR, 7324 gfc_array_index_type, offset)); 7325 gfc_conv_descriptor_offset_set (&block, desc, offset); 7326 7327 gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block)); 7328 gfc_add_block_to_block (&se.pre, &se.post); 7329 return gfc_finish_block (&se.pre); 7330} 7331 7332 7333/* Save and restore floating-point state. */ 7334 7335tree 7336gfc_save_fp_state (stmtblock_t *block) 7337{ 7338 tree type, fpstate, tmp; 7339 7340 type = build_array_type (char_type_node, 7341 build_range_type (size_type_node, size_zero_node, 7342 size_int (GFC_FPE_STATE_BUFFER_SIZE))); 7343 fpstate = gfc_create_var (type, "fpstate"); 7344 fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate); 7345 7346 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry, 7347 1, fpstate); 7348 gfc_add_expr_to_block (block, tmp); 7349 7350 return fpstate; 7351} 7352 7353 7354void 7355gfc_restore_fp_state (stmtblock_t *block, tree fpstate) 7356{ 7357 tree tmp; 7358 7359 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit, 7360 1, fpstate); 7361 gfc_add_expr_to_block (block, tmp); 7362} 7363 7364 7365/* Generate code for arguments of IEEE functions. */ 7366 7367static void 7368conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray, 7369 int nargs) 7370{ 7371 gfc_actual_arglist *actual; 7372 gfc_expr *e; 7373 gfc_se argse; 7374 int arg; 7375 7376 actual = expr->value.function.actual; 7377 for (arg = 0; arg < nargs; arg++, actual = actual->next) 7378 { 7379 gcc_assert (actual); 7380 e = actual->expr; 7381 7382 gfc_init_se (&argse, se); 7383 gfc_conv_expr_val (&argse, e); 7384 7385 gfc_add_block_to_block (&se->pre, &argse.pre); 7386 gfc_add_block_to_block (&se->post, &argse.post); 7387 argarray[arg] = argse.expr; 7388 } 7389} 7390 7391 7392/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE, 7393 and IEEE_UNORDERED, which translate directly to GCC type-generic 7394 built-ins. */ 7395 7396static void 7397conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr, 7398 enum built_in_function code, int nargs) 7399{ 7400 tree args[2]; 7401 gcc_assert ((unsigned) nargs <= sizeof(args)/sizeof(args[0])); 7402 7403 conv_ieee_function_args (se, expr, args, nargs); 7404 se->expr = build_call_expr_loc_array (input_location, 7405 builtin_decl_explicit (code), 7406 nargs, args); 7407 STRIP_TYPE_NOPS (se->expr); 7408 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); 7409} 7410 7411 7412/* Generate code for IEEE_IS_NORMAL intrinsic: 7413 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */ 7414 7415static void 7416conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr) 7417{ 7418 tree arg, isnormal, iszero; 7419 7420 /* Convert arg, evaluate it only once. */ 7421 conv_ieee_function_args (se, expr, &arg, 1); 7422 arg = gfc_evaluate_now (arg, &se->pre); 7423 7424 isnormal = build_call_expr_loc (input_location, 7425 builtin_decl_explicit (BUILT_IN_ISNORMAL), 7426 1, arg); 7427 iszero = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg, 7428 build_real_from_int_cst (TREE_TYPE (arg), 7429 integer_zero_node)); 7430 se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, 7431 boolean_type_node, isnormal, iszero); 7432 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); 7433} 7434 7435 7436/* Generate code for IEEE_IS_NEGATIVE intrinsic: 7437 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */ 7438 7439static void 7440conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr) 7441{ 7442 tree arg, signbit, isnan, decl; 7443 int argprec; 7444 7445 /* Convert arg, evaluate it only once. */ 7446 conv_ieee_function_args (se, expr, &arg, 1); 7447 arg = gfc_evaluate_now (arg, &se->pre); 7448 7449 isnan = build_call_expr_loc (input_location, 7450 builtin_decl_explicit (BUILT_IN_ISNAN), 7451 1, arg); 7452 STRIP_TYPE_NOPS (isnan); 7453 7454 argprec = TYPE_PRECISION (TREE_TYPE (arg)); 7455 decl = builtin_decl_for_precision (BUILT_IN_SIGNBIT, argprec); 7456 signbit = build_call_expr_loc (input_location, decl, 1, arg); 7457 signbit = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 7458 signbit, integer_zero_node); 7459 7460 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, 7461 boolean_type_node, signbit, 7462 fold_build1_loc (input_location, TRUTH_NOT_EXPR, 7463 TREE_TYPE(isnan), isnan)); 7464 7465 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); 7466} 7467 7468 7469/* Generate code for IEEE_LOGB and IEEE_RINT. */ 7470 7471static void 7472conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr, 7473 enum built_in_function code) 7474{ 7475 tree arg, decl, call, fpstate; 7476 int argprec; 7477 7478 conv_ieee_function_args (se, expr, &arg, 1); 7479 argprec = TYPE_PRECISION (TREE_TYPE (arg)); 7480 decl = builtin_decl_for_precision (code, argprec); 7481 7482 /* Save floating-point state. */ 7483 fpstate = gfc_save_fp_state (&se->pre); 7484 7485 /* Make the function call. */ 7486 call = build_call_expr_loc (input_location, decl, 1, arg); 7487 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call); 7488 7489 /* Restore floating-point state. */ 7490 gfc_restore_fp_state (&se->post, fpstate); 7491} 7492 7493 7494/* Generate code for IEEE_REM. */ 7495 7496static void 7497conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr) 7498{ 7499 tree args[2], decl, call, fpstate; 7500 int argprec; 7501 7502 conv_ieee_function_args (se, expr, args, 2); 7503 7504 /* If arguments have unequal size, convert them to the larger. */ 7505 if (TYPE_PRECISION (TREE_TYPE (args[0])) 7506 > TYPE_PRECISION (TREE_TYPE (args[1]))) 7507 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]); 7508 else if (TYPE_PRECISION (TREE_TYPE (args[1])) 7509 > TYPE_PRECISION (TREE_TYPE (args[0]))) 7510 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]); 7511 7512 argprec = TYPE_PRECISION (TREE_TYPE (args[0])); 7513 decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec); 7514 7515 /* Save floating-point state. */ 7516 fpstate = gfc_save_fp_state (&se->pre); 7517 7518 /* Make the function call. */ 7519 call = build_call_expr_loc_array (input_location, decl, 2, args); 7520 se->expr = fold_convert (TREE_TYPE (args[0]), call); 7521 7522 /* Restore floating-point state. */ 7523 gfc_restore_fp_state (&se->post, fpstate); 7524} 7525 7526 7527/* Generate code for IEEE_NEXT_AFTER. */ 7528 7529static void 7530conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr) 7531{ 7532 tree args[2], decl, call, fpstate; 7533 int argprec; 7534 7535 conv_ieee_function_args (se, expr, args, 2); 7536 7537 /* Result has the characteristics of first argument. */ 7538 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]); 7539 argprec = TYPE_PRECISION (TREE_TYPE (args[0])); 7540 decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec); 7541 7542 /* Save floating-point state. */ 7543 fpstate = gfc_save_fp_state (&se->pre); 7544 7545 /* Make the function call. */ 7546 call = build_call_expr_loc_array (input_location, decl, 2, args); 7547 se->expr = fold_convert (TREE_TYPE (args[0]), call); 7548 7549 /* Restore floating-point state. */ 7550 gfc_restore_fp_state (&se->post, fpstate); 7551} 7552 7553 7554/* Generate code for IEEE_SCALB. */ 7555 7556static void 7557conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr) 7558{ 7559 tree args[2], decl, call, huge, type; 7560 int argprec, n; 7561 7562 conv_ieee_function_args (se, expr, args, 2); 7563 7564 /* Result has the characteristics of first argument. */ 7565 argprec = TYPE_PRECISION (TREE_TYPE (args[0])); 7566 decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec); 7567 7568 if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node)) 7569 { 7570 /* We need to fold the integer into the range of a C int. */ 7571 args[1] = gfc_evaluate_now (args[1], &se->pre); 7572 type = TREE_TYPE (args[1]); 7573 7574 n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false); 7575 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, 7576 gfc_c_int_kind); 7577 huge = fold_convert (type, huge); 7578 args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1], 7579 huge); 7580 args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1], 7581 fold_build1_loc (input_location, NEGATE_EXPR, 7582 type, huge)); 7583 } 7584 7585 args[1] = fold_convert (integer_type_node, args[1]); 7586 7587 /* Make the function call. */ 7588 call = build_call_expr_loc_array (input_location, decl, 2, args); 7589 se->expr = fold_convert (TREE_TYPE (args[0]), call); 7590} 7591 7592 7593/* Generate code for IEEE_COPY_SIGN. */ 7594 7595static void 7596conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr) 7597{ 7598 tree args[2], decl, sign; 7599 int argprec; 7600 7601 conv_ieee_function_args (se, expr, args, 2); 7602 7603 /* Get the sign of the second argument. */ 7604 argprec = TYPE_PRECISION (TREE_TYPE (args[1])); 7605 decl = builtin_decl_for_precision (BUILT_IN_SIGNBIT, argprec); 7606 sign = build_call_expr_loc (input_location, decl, 1, args[1]); 7607 sign = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 7608 sign, integer_zero_node); 7609 7610 /* Create a value of one, with the right sign. */ 7611 sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node, 7612 sign, 7613 fold_build1_loc (input_location, NEGATE_EXPR, 7614 integer_type_node, 7615 integer_one_node), 7616 integer_one_node); 7617 args[1] = fold_convert (TREE_TYPE (args[0]), sign); 7618 7619 argprec = TYPE_PRECISION (TREE_TYPE (args[0])); 7620 decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec); 7621 7622 se->expr = build_call_expr_loc_array (input_location, decl, 2, args); 7623} 7624 7625 7626/* Generate code for an intrinsic function from the IEEE_ARITHMETIC 7627 module. */ 7628 7629bool 7630gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr) 7631{ 7632 const char *name = expr->value.function.name; 7633 7634#define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0) 7635 7636 if (STARTS_WITH (name, "_gfortran_ieee_is_nan")) 7637 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1); 7638 else if (STARTS_WITH (name, "_gfortran_ieee_is_finite")) 7639 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1); 7640 else if (STARTS_WITH (name, "_gfortran_ieee_unordered")) 7641 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2); 7642 else if (STARTS_WITH (name, "_gfortran_ieee_is_normal")) 7643 conv_intrinsic_ieee_is_normal (se, expr); 7644 else if (STARTS_WITH (name, "_gfortran_ieee_is_negative")) 7645 conv_intrinsic_ieee_is_negative (se, expr); 7646 else if (STARTS_WITH (name, "_gfortran_ieee_copy_sign")) 7647 conv_intrinsic_ieee_copy_sign (se, expr); 7648 else if (STARTS_WITH (name, "_gfortran_ieee_scalb")) 7649 conv_intrinsic_ieee_scalb (se, expr); 7650 else if (STARTS_WITH (name, "_gfortran_ieee_next_after")) 7651 conv_intrinsic_ieee_next_after (se, expr); 7652 else if (STARTS_WITH (name, "_gfortran_ieee_rem")) 7653 conv_intrinsic_ieee_rem (se, expr); 7654 else if (STARTS_WITH (name, "_gfortran_ieee_logb")) 7655 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB); 7656 else if (STARTS_WITH (name, "_gfortran_ieee_rint")) 7657 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT); 7658 else 7659 /* It is not among the functions we translate directly. We return 7660 false, so a library function call is emitted. */ 7661 return false; 7662 7663#undef STARTS_WITH 7664 7665 return true; 7666} 7667 7668 7669/* Generate code for an intrinsic function. Some map directly to library 7670 calls, others get special handling. In some cases the name of the function 7671 used depends on the type specifiers. */ 7672 7673void 7674gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) 7675{ 7676 const char *name; 7677 int lib, kind; 7678 tree fndecl; 7679 7680 name = &expr->value.function.name[2]; 7681 7682 if (expr->rank > 0) 7683 { 7684 lib = gfc_is_intrinsic_libcall (expr); 7685 if (lib != 0) 7686 { 7687 if (lib == 1) 7688 se->ignore_optional = 1; 7689 7690 switch (expr->value.function.isym->id) 7691 { 7692 case GFC_ISYM_EOSHIFT: 7693 case GFC_ISYM_PACK: 7694 case GFC_ISYM_RESHAPE: 7695 /* For all of those the first argument specifies the type and the 7696 third is optional. */ 7697 conv_generic_with_optional_char_arg (se, expr, 1, 3); 7698 break; 7699 7700 default: 7701 gfc_conv_intrinsic_funcall (se, expr); 7702 break; 7703 } 7704 7705 return; 7706 } 7707 } 7708 7709 switch (expr->value.function.isym->id) 7710 { 7711 case GFC_ISYM_NONE: 7712 gcc_unreachable (); 7713 7714 case GFC_ISYM_REPEAT: 7715 gfc_conv_intrinsic_repeat (se, expr); 7716 break; 7717 7718 case GFC_ISYM_TRIM: 7719 gfc_conv_intrinsic_trim (se, expr); 7720 break; 7721 7722 case GFC_ISYM_SC_KIND: 7723 gfc_conv_intrinsic_sc_kind (se, expr); 7724 break; 7725 7726 case GFC_ISYM_SI_KIND: 7727 gfc_conv_intrinsic_si_kind (se, expr); 7728 break; 7729 7730 case GFC_ISYM_SR_KIND: 7731 gfc_conv_intrinsic_sr_kind (se, expr); 7732 break; 7733 7734 case GFC_ISYM_EXPONENT: 7735 gfc_conv_intrinsic_exponent (se, expr); 7736 break; 7737 7738 case GFC_ISYM_SCAN: 7739 kind = expr->value.function.actual->expr->ts.kind; 7740 if (kind == 1) 7741 fndecl = gfor_fndecl_string_scan; 7742 else if (kind == 4) 7743 fndecl = gfor_fndecl_string_scan_char4; 7744 else 7745 gcc_unreachable (); 7746 7747 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); 7748 break; 7749 7750 case GFC_ISYM_VERIFY: 7751 kind = expr->value.function.actual->expr->ts.kind; 7752 if (kind == 1) 7753 fndecl = gfor_fndecl_string_verify; 7754 else if (kind == 4) 7755 fndecl = gfor_fndecl_string_verify_char4; 7756 else 7757 gcc_unreachable (); 7758 7759 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); 7760 break; 7761 7762 case GFC_ISYM_ALLOCATED: 7763 gfc_conv_allocated (se, expr); 7764 break; 7765 7766 case GFC_ISYM_ASSOCIATED: 7767 gfc_conv_associated(se, expr); 7768 break; 7769 7770 case GFC_ISYM_SAME_TYPE_AS: 7771 gfc_conv_same_type_as (se, expr); 7772 break; 7773 7774 case GFC_ISYM_ABS: 7775 gfc_conv_intrinsic_abs (se, expr); 7776 break; 7777 7778 case GFC_ISYM_ADJUSTL: 7779 if (expr->ts.kind == 1) 7780 fndecl = gfor_fndecl_adjustl; 7781 else if (expr->ts.kind == 4) 7782 fndecl = gfor_fndecl_adjustl_char4; 7783 else 7784 gcc_unreachable (); 7785 7786 gfc_conv_intrinsic_adjust (se, expr, fndecl); 7787 break; 7788 7789 case GFC_ISYM_ADJUSTR: 7790 if (expr->ts.kind == 1) 7791 fndecl = gfor_fndecl_adjustr; 7792 else if (expr->ts.kind == 4) 7793 fndecl = gfor_fndecl_adjustr_char4; 7794 else 7795 gcc_unreachable (); 7796 7797 gfc_conv_intrinsic_adjust (se, expr, fndecl); 7798 break; 7799 7800 case GFC_ISYM_AIMAG: 7801 gfc_conv_intrinsic_imagpart (se, expr); 7802 break; 7803 7804 case GFC_ISYM_AINT: 7805 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC); 7806 break; 7807 7808 case GFC_ISYM_ALL: 7809 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR); 7810 break; 7811 7812 case GFC_ISYM_ANINT: 7813 gfc_conv_intrinsic_aint (se, expr, RND_ROUND); 7814 break; 7815 7816 case GFC_ISYM_AND: 7817 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); 7818 break; 7819 7820 case GFC_ISYM_ANY: 7821 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR); 7822 break; 7823 7824 case GFC_ISYM_BTEST: 7825 gfc_conv_intrinsic_btest (se, expr); 7826 break; 7827 7828 case GFC_ISYM_BGE: 7829 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR); 7830 break; 7831 7832 case GFC_ISYM_BGT: 7833 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR); 7834 break; 7835 7836 case GFC_ISYM_BLE: 7837 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR); 7838 break; 7839 7840 case GFC_ISYM_BLT: 7841 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR); 7842 break; 7843 7844 case GFC_ISYM_C_ASSOCIATED: 7845 case GFC_ISYM_C_FUNLOC: 7846 case GFC_ISYM_C_LOC: 7847 conv_isocbinding_function (se, expr); 7848 break; 7849 7850 case GFC_ISYM_ACHAR: 7851 case GFC_ISYM_CHAR: 7852 gfc_conv_intrinsic_char (se, expr); 7853 break; 7854 7855 case GFC_ISYM_CONVERSION: 7856 case GFC_ISYM_REAL: 7857 case GFC_ISYM_LOGICAL: 7858 case GFC_ISYM_DBLE: 7859 gfc_conv_intrinsic_conversion (se, expr); 7860 break; 7861 7862 /* Integer conversions are handled separately to make sure we get the 7863 correct rounding mode. */ 7864 case GFC_ISYM_INT: 7865 case GFC_ISYM_INT2: 7866 case GFC_ISYM_INT8: 7867 case GFC_ISYM_LONG: 7868 gfc_conv_intrinsic_int (se, expr, RND_TRUNC); 7869 break; 7870 7871 case GFC_ISYM_NINT: 7872 gfc_conv_intrinsic_int (se, expr, RND_ROUND); 7873 break; 7874 7875 case GFC_ISYM_CEILING: 7876 gfc_conv_intrinsic_int (se, expr, RND_CEIL); 7877 break; 7878 7879 case GFC_ISYM_FLOOR: 7880 gfc_conv_intrinsic_int (se, expr, RND_FLOOR); 7881 break; 7882 7883 case GFC_ISYM_MOD: 7884 gfc_conv_intrinsic_mod (se, expr, 0); 7885 break; 7886 7887 case GFC_ISYM_MODULO: 7888 gfc_conv_intrinsic_mod (se, expr, 1); 7889 break; 7890 7891 case GFC_ISYM_CAF_GET: 7892 gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE); 7893 break; 7894 7895 case GFC_ISYM_CMPLX: 7896 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1'); 7897 break; 7898 7899 case GFC_ISYM_COMMAND_ARGUMENT_COUNT: 7900 gfc_conv_intrinsic_iargc (se, expr); 7901 break; 7902 7903 case GFC_ISYM_COMPLEX: 7904 gfc_conv_intrinsic_cmplx (se, expr, 1); 7905 break; 7906 7907 case GFC_ISYM_CONJG: 7908 gfc_conv_intrinsic_conjg (se, expr); 7909 break; 7910 7911 case GFC_ISYM_COUNT: 7912 gfc_conv_intrinsic_count (se, expr); 7913 break; 7914 7915 case GFC_ISYM_CTIME: 7916 gfc_conv_intrinsic_ctime (se, expr); 7917 break; 7918 7919 case GFC_ISYM_DIM: 7920 gfc_conv_intrinsic_dim (se, expr); 7921 break; 7922 7923 case GFC_ISYM_DOT_PRODUCT: 7924 gfc_conv_intrinsic_dot_product (se, expr); 7925 break; 7926 7927 case GFC_ISYM_DPROD: 7928 gfc_conv_intrinsic_dprod (se, expr); 7929 break; 7930 7931 case GFC_ISYM_DSHIFTL: 7932 gfc_conv_intrinsic_dshift (se, expr, true); 7933 break; 7934 7935 case GFC_ISYM_DSHIFTR: 7936 gfc_conv_intrinsic_dshift (se, expr, false); 7937 break; 7938 7939 case GFC_ISYM_FDATE: 7940 gfc_conv_intrinsic_fdate (se, expr); 7941 break; 7942 7943 case GFC_ISYM_FRACTION: 7944 gfc_conv_intrinsic_fraction (se, expr); 7945 break; 7946 7947 case GFC_ISYM_IALL: 7948 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false); 7949 break; 7950 7951 case GFC_ISYM_IAND: 7952 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); 7953 break; 7954 7955 case GFC_ISYM_IANY: 7956 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false); 7957 break; 7958 7959 case GFC_ISYM_IBCLR: 7960 gfc_conv_intrinsic_singlebitop (se, expr, 0); 7961 break; 7962 7963 case GFC_ISYM_IBITS: 7964 gfc_conv_intrinsic_ibits (se, expr); 7965 break; 7966 7967 case GFC_ISYM_IBSET: 7968 gfc_conv_intrinsic_singlebitop (se, expr, 1); 7969 break; 7970 7971 case GFC_ISYM_IACHAR: 7972 case GFC_ISYM_ICHAR: 7973 /* We assume ASCII character sequence. */ 7974 gfc_conv_intrinsic_ichar (se, expr); 7975 break; 7976 7977 case GFC_ISYM_IARGC: 7978 gfc_conv_intrinsic_iargc (se, expr); 7979 break; 7980 7981 case GFC_ISYM_IEOR: 7982 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); 7983 break; 7984 7985 case GFC_ISYM_INDEX: 7986 kind = expr->value.function.actual->expr->ts.kind; 7987 if (kind == 1) 7988 fndecl = gfor_fndecl_string_index; 7989 else if (kind == 4) 7990 fndecl = gfor_fndecl_string_index_char4; 7991 else 7992 gcc_unreachable (); 7993 7994 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); 7995 break; 7996 7997 case GFC_ISYM_IOR: 7998 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); 7999 break; 8000 8001 case GFC_ISYM_IPARITY: 8002 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false); 8003 break; 8004 8005 case GFC_ISYM_IS_IOSTAT_END: 8006 gfc_conv_has_intvalue (se, expr, LIBERROR_END); 8007 break; 8008 8009 case GFC_ISYM_IS_IOSTAT_EOR: 8010 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR); 8011 break; 8012 8013 case GFC_ISYM_ISNAN: 8014 gfc_conv_intrinsic_isnan (se, expr); 8015 break; 8016 8017 case GFC_ISYM_LSHIFT: 8018 gfc_conv_intrinsic_shift (se, expr, false, false); 8019 break; 8020 8021 case GFC_ISYM_RSHIFT: 8022 gfc_conv_intrinsic_shift (se, expr, true, true); 8023 break; 8024 8025 case GFC_ISYM_SHIFTA: 8026 gfc_conv_intrinsic_shift (se, expr, true, true); 8027 break; 8028 8029 case GFC_ISYM_SHIFTL: 8030 gfc_conv_intrinsic_shift (se, expr, false, false); 8031 break; 8032 8033 case GFC_ISYM_SHIFTR: 8034 gfc_conv_intrinsic_shift (se, expr, true, false); 8035 break; 8036 8037 case GFC_ISYM_ISHFT: 8038 gfc_conv_intrinsic_ishft (se, expr); 8039 break; 8040 8041 case GFC_ISYM_ISHFTC: 8042 gfc_conv_intrinsic_ishftc (se, expr); 8043 break; 8044 8045 case GFC_ISYM_LEADZ: 8046 gfc_conv_intrinsic_leadz (se, expr); 8047 break; 8048 8049 case GFC_ISYM_TRAILZ: 8050 gfc_conv_intrinsic_trailz (se, expr); 8051 break; 8052 8053 case GFC_ISYM_POPCNT: 8054 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0); 8055 break; 8056 8057 case GFC_ISYM_POPPAR: 8058 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1); 8059 break; 8060 8061 case GFC_ISYM_LBOUND: 8062 gfc_conv_intrinsic_bound (se, expr, 0); 8063 break; 8064 8065 case GFC_ISYM_LCOBOUND: 8066 conv_intrinsic_cobound (se, expr); 8067 break; 8068 8069 case GFC_ISYM_TRANSPOSE: 8070 /* The scalarizer has already been set up for reversed dimension access 8071 order ; now we just get the argument value normally. */ 8072 gfc_conv_expr (se, expr->value.function.actual->expr); 8073 break; 8074 8075 case GFC_ISYM_LEN: 8076 gfc_conv_intrinsic_len (se, expr); 8077 break; 8078 8079 case GFC_ISYM_LEN_TRIM: 8080 gfc_conv_intrinsic_len_trim (se, expr); 8081 break; 8082 8083 case GFC_ISYM_LGE: 8084 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR); 8085 break; 8086 8087 case GFC_ISYM_LGT: 8088 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR); 8089 break; 8090 8091 case GFC_ISYM_LLE: 8092 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR); 8093 break; 8094 8095 case GFC_ISYM_LLT: 8096 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR); 8097 break; 8098 8099 case GFC_ISYM_MASKL: 8100 gfc_conv_intrinsic_mask (se, expr, 1); 8101 break; 8102 8103 case GFC_ISYM_MASKR: 8104 gfc_conv_intrinsic_mask (se, expr, 0); 8105 break; 8106 8107 case GFC_ISYM_MAX: 8108 if (expr->ts.type == BT_CHARACTER) 8109 gfc_conv_intrinsic_minmax_char (se, expr, 1); 8110 else 8111 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR); 8112 break; 8113 8114 case GFC_ISYM_MAXLOC: 8115 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR); 8116 break; 8117 8118 case GFC_ISYM_MAXVAL: 8119 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR); 8120 break; 8121 8122 case GFC_ISYM_MERGE: 8123 gfc_conv_intrinsic_merge (se, expr); 8124 break; 8125 8126 case GFC_ISYM_MERGE_BITS: 8127 gfc_conv_intrinsic_merge_bits (se, expr); 8128 break; 8129 8130 case GFC_ISYM_MIN: 8131 if (expr->ts.type == BT_CHARACTER) 8132 gfc_conv_intrinsic_minmax_char (se, expr, -1); 8133 else 8134 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR); 8135 break; 8136 8137 case GFC_ISYM_MINLOC: 8138 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR); 8139 break; 8140 8141 case GFC_ISYM_MINVAL: 8142 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR); 8143 break; 8144 8145 case GFC_ISYM_NEAREST: 8146 gfc_conv_intrinsic_nearest (se, expr); 8147 break; 8148 8149 case GFC_ISYM_NORM2: 8150 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true); 8151 break; 8152 8153 case GFC_ISYM_NOT: 8154 gfc_conv_intrinsic_not (se, expr); 8155 break; 8156 8157 case GFC_ISYM_OR: 8158 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); 8159 break; 8160 8161 case GFC_ISYM_PARITY: 8162 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false); 8163 break; 8164 8165 case GFC_ISYM_PRESENT: 8166 gfc_conv_intrinsic_present (se, expr); 8167 break; 8168 8169 case GFC_ISYM_PRODUCT: 8170 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false); 8171 break; 8172 8173 case GFC_ISYM_RANK: 8174 gfc_conv_intrinsic_rank (se, expr); 8175 break; 8176 8177 case GFC_ISYM_RRSPACING: 8178 gfc_conv_intrinsic_rrspacing (se, expr); 8179 break; 8180 8181 case GFC_ISYM_SET_EXPONENT: 8182 gfc_conv_intrinsic_set_exponent (se, expr); 8183 break; 8184 8185 case GFC_ISYM_SCALE: 8186 gfc_conv_intrinsic_scale (se, expr); 8187 break; 8188 8189 case GFC_ISYM_SIGN: 8190 gfc_conv_intrinsic_sign (se, expr); 8191 break; 8192 8193 case GFC_ISYM_SIZE: 8194 gfc_conv_intrinsic_size (se, expr); 8195 break; 8196 8197 case GFC_ISYM_SIZEOF: 8198 case GFC_ISYM_C_SIZEOF: 8199 gfc_conv_intrinsic_sizeof (se, expr); 8200 break; 8201 8202 case GFC_ISYM_STORAGE_SIZE: 8203 gfc_conv_intrinsic_storage_size (se, expr); 8204 break; 8205 8206 case GFC_ISYM_SPACING: 8207 gfc_conv_intrinsic_spacing (se, expr); 8208 break; 8209 8210 case GFC_ISYM_STRIDE: 8211 conv_intrinsic_stride (se, expr); 8212 break; 8213 8214 case GFC_ISYM_SUM: 8215 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false); 8216 break; 8217 8218 case GFC_ISYM_TRANSFER: 8219 if (se->ss && se->ss->info->useflags) 8220 /* Access the previously obtained result. */ 8221 gfc_conv_tmp_array_ref (se); 8222 else 8223 gfc_conv_intrinsic_transfer (se, expr); 8224 break; 8225 8226 case GFC_ISYM_TTYNAM: 8227 gfc_conv_intrinsic_ttynam (se, expr); 8228 break; 8229 8230 case GFC_ISYM_UBOUND: 8231 gfc_conv_intrinsic_bound (se, expr, 1); 8232 break; 8233 8234 case GFC_ISYM_UCOBOUND: 8235 conv_intrinsic_cobound (se, expr); 8236 break; 8237 8238 case GFC_ISYM_XOR: 8239 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); 8240 break; 8241 8242 case GFC_ISYM_LOC: 8243 gfc_conv_intrinsic_loc (se, expr); 8244 break; 8245 8246 case GFC_ISYM_THIS_IMAGE: 8247 /* For num_images() == 1, handle as LCOBOUND. */ 8248 if (expr->value.function.actual->expr 8249 && flag_coarray == GFC_FCOARRAY_SINGLE) 8250 conv_intrinsic_cobound (se, expr); 8251 else 8252 trans_this_image (se, expr); 8253 break; 8254 8255 case GFC_ISYM_IMAGE_INDEX: 8256 trans_image_index (se, expr); 8257 break; 8258 8259 case GFC_ISYM_NUM_IMAGES: 8260 trans_num_images (se, expr); 8261 break; 8262 8263 case GFC_ISYM_ACCESS: 8264 case GFC_ISYM_CHDIR: 8265 case GFC_ISYM_CHMOD: 8266 case GFC_ISYM_DTIME: 8267 case GFC_ISYM_ETIME: 8268 case GFC_ISYM_EXTENDS_TYPE_OF: 8269 case GFC_ISYM_FGET: 8270 case GFC_ISYM_FGETC: 8271 case GFC_ISYM_FNUM: 8272 case GFC_ISYM_FPUT: 8273 case GFC_ISYM_FPUTC: 8274 case GFC_ISYM_FSTAT: 8275 case GFC_ISYM_FTELL: 8276 case GFC_ISYM_GETCWD: 8277 case GFC_ISYM_GETGID: 8278 case GFC_ISYM_GETPID: 8279 case GFC_ISYM_GETUID: 8280 case GFC_ISYM_HOSTNM: 8281 case GFC_ISYM_KILL: 8282 case GFC_ISYM_IERRNO: 8283 case GFC_ISYM_IRAND: 8284 case GFC_ISYM_ISATTY: 8285 case GFC_ISYM_JN2: 8286 case GFC_ISYM_LINK: 8287 case GFC_ISYM_LSTAT: 8288 case GFC_ISYM_MALLOC: 8289 case GFC_ISYM_MATMUL: 8290 case GFC_ISYM_MCLOCK: 8291 case GFC_ISYM_MCLOCK8: 8292 case GFC_ISYM_RAND: 8293 case GFC_ISYM_RENAME: 8294 case GFC_ISYM_SECOND: 8295 case GFC_ISYM_SECNDS: 8296 case GFC_ISYM_SIGNAL: 8297 case GFC_ISYM_STAT: 8298 case GFC_ISYM_SYMLNK: 8299 case GFC_ISYM_SYSTEM: 8300 case GFC_ISYM_TIME: 8301 case GFC_ISYM_TIME8: 8302 case GFC_ISYM_UMASK: 8303 case GFC_ISYM_UNLINK: 8304 case GFC_ISYM_YN2: 8305 gfc_conv_intrinsic_funcall (se, expr); 8306 break; 8307 8308 case GFC_ISYM_EOSHIFT: 8309 case GFC_ISYM_PACK: 8310 case GFC_ISYM_RESHAPE: 8311 /* For those, expr->rank should always be >0 and thus the if above the 8312 switch should have matched. */ 8313 gcc_unreachable (); 8314 break; 8315 8316 default: 8317 gfc_conv_intrinsic_lib_function (se, expr); 8318 break; 8319 } 8320} 8321 8322 8323static gfc_ss * 8324walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr) 8325{ 8326 gfc_ss *arg_ss, *tmp_ss; 8327 gfc_actual_arglist *arg; 8328 8329 arg = expr->value.function.actual; 8330 8331 gcc_assert (arg->expr); 8332 8333 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr); 8334 gcc_assert (arg_ss != gfc_ss_terminator); 8335 8336 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next) 8337 { 8338 if (tmp_ss->info->type != GFC_SS_SCALAR 8339 && tmp_ss->info->type != GFC_SS_REFERENCE) 8340 { 8341 int tmp_dim; 8342 8343 gcc_assert (tmp_ss->dimen == 2); 8344 8345 /* We just invert dimensions. */ 8346 tmp_dim = tmp_ss->dim[0]; 8347 tmp_ss->dim[0] = tmp_ss->dim[1]; 8348 tmp_ss->dim[1] = tmp_dim; 8349 } 8350 8351 /* Stop when tmp_ss points to the last valid element of the chain... */ 8352 if (tmp_ss->next == gfc_ss_terminator) 8353 break; 8354 } 8355 8356 /* ... so that we can attach the rest of the chain to it. */ 8357 tmp_ss->next = ss; 8358 8359 return arg_ss; 8360} 8361 8362 8363/* Move the given dimension of the given gfc_ss list to a nested gfc_ss list. 8364 This has the side effect of reversing the nested list, so there is no 8365 need to call gfc_reverse_ss on it (the given list is assumed not to be 8366 reversed yet). */ 8367 8368static gfc_ss * 8369nest_loop_dimension (gfc_ss *ss, int dim) 8370{ 8371 int ss_dim, i; 8372 gfc_ss *new_ss, *prev_ss = gfc_ss_terminator; 8373 gfc_loopinfo *new_loop; 8374 8375 gcc_assert (ss != gfc_ss_terminator); 8376 8377 for (; ss != gfc_ss_terminator; ss = ss->next) 8378 { 8379 new_ss = gfc_get_ss (); 8380 new_ss->next = prev_ss; 8381 new_ss->parent = ss; 8382 new_ss->info = ss->info; 8383 new_ss->info->refcount++; 8384 if (ss->dimen != 0) 8385 { 8386 gcc_assert (ss->info->type != GFC_SS_SCALAR 8387 && ss->info->type != GFC_SS_REFERENCE); 8388 8389 new_ss->dimen = 1; 8390 new_ss->dim[0] = ss->dim[dim]; 8391 8392 gcc_assert (dim < ss->dimen); 8393 8394 ss_dim = --ss->dimen; 8395 for (i = dim; i < ss_dim; i++) 8396 ss->dim[i] = ss->dim[i + 1]; 8397 8398 ss->dim[ss_dim] = 0; 8399 } 8400 prev_ss = new_ss; 8401 8402 if (ss->nested_ss) 8403 { 8404 ss->nested_ss->parent = new_ss; 8405 new_ss->nested_ss = ss->nested_ss; 8406 } 8407 ss->nested_ss = new_ss; 8408 } 8409 8410 new_loop = gfc_get_loopinfo (); 8411 gfc_init_loopinfo (new_loop); 8412 8413 gcc_assert (prev_ss != NULL); 8414 gcc_assert (prev_ss != gfc_ss_terminator); 8415 gfc_add_ss_to_loop (new_loop, prev_ss); 8416 return new_ss->parent; 8417} 8418 8419 8420/* Create the gfc_ss list for the SUM/PRODUCT arguments when the function 8421 is to be inlined. */ 8422 8423static gfc_ss * 8424walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr) 8425{ 8426 gfc_ss *tmp_ss, *tail, *array_ss; 8427 gfc_actual_arglist *arg1, *arg2, *arg3; 8428 int sum_dim; 8429 bool scalar_mask = false; 8430 8431 /* The rank of the result will be determined later. */ 8432 arg1 = expr->value.function.actual; 8433 arg2 = arg1->next; 8434 arg3 = arg2->next; 8435 gcc_assert (arg3 != NULL); 8436 8437 if (expr->rank == 0) 8438 return ss; 8439 8440 tmp_ss = gfc_ss_terminator; 8441 8442 if (arg3->expr) 8443 { 8444 gfc_ss *mask_ss; 8445 8446 mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr); 8447 if (mask_ss == tmp_ss) 8448 scalar_mask = 1; 8449 8450 tmp_ss = mask_ss; 8451 } 8452 8453 array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr); 8454 gcc_assert (array_ss != tmp_ss); 8455 8456 /* Odd thing: If the mask is scalar, it is used by the frontend after 8457 the array (to make an if around the nested loop). Thus it shall 8458 be after array_ss once the gfc_ss list is reversed. */ 8459 if (scalar_mask) 8460 tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr); 8461 else 8462 tmp_ss = array_ss; 8463 8464 /* "Hide" the dimension on which we will sum in the first arg's scalarization 8465 chain. */ 8466 sum_dim = mpz_get_si (arg2->expr->value.integer) - 1; 8467 tail = nest_loop_dimension (tmp_ss, sum_dim); 8468 tail->next = ss; 8469 8470 return tmp_ss; 8471} 8472 8473 8474static gfc_ss * 8475walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr) 8476{ 8477 8478 switch (expr->value.function.isym->id) 8479 { 8480 case GFC_ISYM_PRODUCT: 8481 case GFC_ISYM_SUM: 8482 return walk_inline_intrinsic_arith (ss, expr); 8483 8484 case GFC_ISYM_TRANSPOSE: 8485 return walk_inline_intrinsic_transpose (ss, expr); 8486 8487 default: 8488 gcc_unreachable (); 8489 } 8490 gcc_unreachable (); 8491} 8492 8493 8494/* This generates code to execute before entering the scalarization loop. 8495 Currently does nothing. */ 8496 8497void 8498gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) 8499{ 8500 switch (ss->info->expr->value.function.isym->id) 8501 { 8502 case GFC_ISYM_UBOUND: 8503 case GFC_ISYM_LBOUND: 8504 case GFC_ISYM_UCOBOUND: 8505 case GFC_ISYM_LCOBOUND: 8506 case GFC_ISYM_THIS_IMAGE: 8507 break; 8508 8509 default: 8510 gcc_unreachable (); 8511 } 8512} 8513 8514 8515/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter 8516 are expanded into code inside the scalarization loop. */ 8517 8518static gfc_ss * 8519gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) 8520{ 8521 if (expr->value.function.actual->expr->ts.type == BT_CLASS) 8522 gfc_add_class_array_ref (expr->value.function.actual->expr); 8523 8524 /* The two argument version returns a scalar. */ 8525 if (expr->value.function.actual->next->expr) 8526 return ss; 8527 8528 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC); 8529} 8530 8531 8532/* Walk an intrinsic array libcall. */ 8533 8534static gfc_ss * 8535gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) 8536{ 8537 gcc_assert (expr->rank > 0); 8538 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION); 8539} 8540 8541 8542/* Return whether the function call expression EXPR will be expanded 8543 inline by gfc_conv_intrinsic_function. */ 8544 8545bool 8546gfc_inline_intrinsic_function_p (gfc_expr *expr) 8547{ 8548 gfc_actual_arglist *args; 8549 8550 if (!expr->value.function.isym) 8551 return false; 8552 8553 switch (expr->value.function.isym->id) 8554 { 8555 case GFC_ISYM_PRODUCT: 8556 case GFC_ISYM_SUM: 8557 /* Disable inline expansion if code size matters. */ 8558 if (optimize_size) 8559 return false; 8560 8561 args = expr->value.function.actual; 8562 /* We need to be able to subset the SUM argument at compile-time. */ 8563 if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT) 8564 return false; 8565 8566 return true; 8567 8568 case GFC_ISYM_TRANSPOSE: 8569 return true; 8570 8571 default: 8572 return false; 8573 } 8574} 8575 8576 8577/* Returns nonzero if the specified intrinsic function call maps directly to 8578 an external library call. Should only be used for functions that return 8579 arrays. */ 8580 8581int 8582gfc_is_intrinsic_libcall (gfc_expr * expr) 8583{ 8584 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym); 8585 gcc_assert (expr->rank > 0); 8586 8587 if (gfc_inline_intrinsic_function_p (expr)) 8588 return 0; 8589 8590 switch (expr->value.function.isym->id) 8591 { 8592 case GFC_ISYM_ALL: 8593 case GFC_ISYM_ANY: 8594 case GFC_ISYM_COUNT: 8595 case GFC_ISYM_JN2: 8596 case GFC_ISYM_IANY: 8597 case GFC_ISYM_IALL: 8598 case GFC_ISYM_IPARITY: 8599 case GFC_ISYM_MATMUL: 8600 case GFC_ISYM_MAXLOC: 8601 case GFC_ISYM_MAXVAL: 8602 case GFC_ISYM_MINLOC: 8603 case GFC_ISYM_MINVAL: 8604 case GFC_ISYM_NORM2: 8605 case GFC_ISYM_PARITY: 8606 case GFC_ISYM_PRODUCT: 8607 case GFC_ISYM_SUM: 8608 case GFC_ISYM_SHAPE: 8609 case GFC_ISYM_SPREAD: 8610 case GFC_ISYM_YN2: 8611 /* Ignore absent optional parameters. */ 8612 return 1; 8613 8614 case GFC_ISYM_RESHAPE: 8615 case GFC_ISYM_CSHIFT: 8616 case GFC_ISYM_EOSHIFT: 8617 case GFC_ISYM_PACK: 8618 case GFC_ISYM_UNPACK: 8619 /* Pass absent optional parameters. */ 8620 return 2; 8621 8622 default: 8623 return 0; 8624 } 8625} 8626 8627/* Walk an intrinsic function. */ 8628gfc_ss * 8629gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, 8630 gfc_intrinsic_sym * isym) 8631{ 8632 gcc_assert (isym); 8633 8634 if (isym->elemental) 8635 return gfc_walk_elemental_function_args (ss, expr->value.function.actual, 8636 NULL, GFC_SS_SCALAR); 8637 8638 if (expr->rank == 0) 8639 return ss; 8640 8641 if (gfc_inline_intrinsic_function_p (expr)) 8642 return walk_inline_intrinsic_function (ss, expr); 8643 8644 if (gfc_is_intrinsic_libcall (expr)) 8645 return gfc_walk_intrinsic_libfunc (ss, expr); 8646 8647 /* Special cases. */ 8648 switch (isym->id) 8649 { 8650 case GFC_ISYM_LBOUND: 8651 case GFC_ISYM_LCOBOUND: 8652 case GFC_ISYM_UBOUND: 8653 case GFC_ISYM_UCOBOUND: 8654 case GFC_ISYM_THIS_IMAGE: 8655 return gfc_walk_intrinsic_bound (ss, expr); 8656 8657 case GFC_ISYM_TRANSFER: 8658 case GFC_ISYM_CAF_GET: 8659 return gfc_walk_intrinsic_libfunc (ss, expr); 8660 8661 default: 8662 /* This probably meant someone forgot to add an intrinsic to the above 8663 list(s) when they implemented it, or something's gone horribly 8664 wrong. */ 8665 gcc_unreachable (); 8666 } 8667} 8668 8669 8670static tree 8671conv_co_collective (gfc_code *code) 8672{ 8673 gfc_se argse; 8674 stmtblock_t block, post_block; 8675 tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len; 8676 gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr; 8677 8678 gfc_start_block (&block); 8679 gfc_init_block (&post_block); 8680 8681 if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE) 8682 { 8683 opr_expr = code->ext.actual->next->expr; 8684 image_idx_expr = code->ext.actual->next->next->expr; 8685 stat_expr = code->ext.actual->next->next->next->expr; 8686 errmsg_expr = code->ext.actual->next->next->next->next->expr; 8687 } 8688 else 8689 { 8690 opr_expr = NULL; 8691 image_idx_expr = code->ext.actual->next->expr; 8692 stat_expr = code->ext.actual->next->next->expr; 8693 errmsg_expr = code->ext.actual->next->next->next->expr; 8694 } 8695 8696 /* stat. */ 8697 if (stat_expr) 8698 { 8699 gfc_init_se (&argse, NULL); 8700 gfc_conv_expr (&argse, stat_expr); 8701 gfc_add_block_to_block (&block, &argse.pre); 8702 gfc_add_block_to_block (&post_block, &argse.post); 8703 stat = argse.expr; 8704 if (flag_coarray != GFC_FCOARRAY_SINGLE) 8705 stat = gfc_build_addr_expr (NULL_TREE, stat); 8706 } 8707 else if (flag_coarray == GFC_FCOARRAY_SINGLE) 8708 stat = NULL_TREE; 8709 else 8710 stat = null_pointer_node; 8711 8712 /* Early exit for GFC_FCOARRAY_SINGLE. */ 8713 if (flag_coarray == GFC_FCOARRAY_SINGLE) 8714 { 8715 if (stat != NULL_TREE) 8716 gfc_add_modify (&block, stat, 8717 fold_convert (TREE_TYPE (stat), integer_zero_node)); 8718 return gfc_finish_block (&block); 8719 } 8720 8721 /* Handle the array. */ 8722 gfc_init_se (&argse, NULL); 8723 if (code->ext.actual->expr->rank == 0) 8724 { 8725 symbol_attribute attr; 8726 gfc_clear_attr (&attr); 8727 gfc_init_se (&argse, NULL); 8728 gfc_conv_expr (&argse, code->ext.actual->expr); 8729 gfc_add_block_to_block (&block, &argse.pre); 8730 gfc_add_block_to_block (&post_block, &argse.post); 8731 array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); 8732 array = gfc_build_addr_expr (NULL_TREE, array); 8733 } 8734 else 8735 { 8736 argse.want_pointer = 1; 8737 gfc_conv_expr_descriptor (&argse, code->ext.actual->expr); 8738 array = argse.expr; 8739 } 8740 gfc_add_block_to_block (&block, &argse.pre); 8741 gfc_add_block_to_block (&post_block, &argse.post); 8742 8743 if (code->ext.actual->expr->ts.type == BT_CHARACTER) 8744 strlen = argse.string_length; 8745 else 8746 strlen = integer_zero_node; 8747 8748 /* image_index. */ 8749 if (image_idx_expr) 8750 { 8751 gfc_init_se (&argse, NULL); 8752 gfc_conv_expr (&argse, image_idx_expr); 8753 gfc_add_block_to_block (&block, &argse.pre); 8754 gfc_add_block_to_block (&post_block, &argse.post); 8755 image_index = fold_convert (integer_type_node, argse.expr); 8756 } 8757 else 8758 image_index = integer_zero_node; 8759 8760 /* errmsg. */ 8761 if (errmsg_expr) 8762 { 8763 gfc_init_se (&argse, NULL); 8764 gfc_conv_expr (&argse, errmsg_expr); 8765 gfc_add_block_to_block (&block, &argse.pre); 8766 gfc_add_block_to_block (&post_block, &argse.post); 8767 errmsg = argse.expr; 8768 errmsg_len = fold_convert (integer_type_node, argse.string_length); 8769 } 8770 else 8771 { 8772 errmsg = null_pointer_node; 8773 errmsg_len = integer_zero_node; 8774 } 8775 8776 /* Generate the function call. */ 8777 switch (code->resolved_isym->id) 8778 { 8779 case GFC_ISYM_CO_BROADCAST: 8780 fndecl = gfor_fndecl_co_broadcast; 8781 break; 8782 case GFC_ISYM_CO_MAX: 8783 fndecl = gfor_fndecl_co_max; 8784 break; 8785 case GFC_ISYM_CO_MIN: 8786 fndecl = gfor_fndecl_co_min; 8787 break; 8788 case GFC_ISYM_CO_REDUCE: 8789 fndecl = gfor_fndecl_co_reduce; 8790 break; 8791 case GFC_ISYM_CO_SUM: 8792 fndecl = gfor_fndecl_co_sum; 8793 break; 8794 default: 8795 gcc_unreachable (); 8796 } 8797 8798 if (code->resolved_isym->id == GFC_ISYM_CO_SUM 8799 || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) 8800 fndecl = build_call_expr_loc (input_location, fndecl, 5, array, 8801 image_index, stat, errmsg, errmsg_len); 8802 else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE) 8803 fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index, 8804 stat, errmsg, strlen, errmsg_len); 8805 else 8806 { 8807 tree opr, opr_flags; 8808 8809 // FIXME: Handle TS29113's bind(C) strings with descriptor. 8810 int opr_flag_int; 8811 if (gfc_is_proc_ptr_comp (opr_expr)) 8812 { 8813 gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface; 8814 opr_flag_int = sym->attr.dimension 8815 || (sym->ts.type == BT_CHARACTER 8816 && !sym->attr.is_bind_c) 8817 ? GFC_CAF_BYREF : 0; 8818 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER 8819 && !sym->attr.is_bind_c 8820 ? GFC_CAF_HIDDENLEN : 0; 8821 opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0; 8822 } 8823 else 8824 { 8825 opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym) 8826 ? GFC_CAF_BYREF : 0; 8827 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER 8828 && !opr_expr->symtree->n.sym->attr.is_bind_c 8829 ? GFC_CAF_HIDDENLEN : 0; 8830 opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value 8831 ? GFC_CAF_ARG_VALUE : 0; 8832 } 8833 opr_flags = build_int_cst (integer_type_node, opr_flag_int); 8834 gfc_conv_expr (&argse, opr_expr); 8835 opr = argse.expr; 8836 fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags, 8837 image_index, stat, errmsg, strlen, errmsg_len); 8838 } 8839 8840 gfc_add_expr_to_block (&block, fndecl); 8841 gfc_add_block_to_block (&block, &post_block); 8842 8843 return gfc_finish_block (&block); 8844} 8845 8846 8847static tree 8848conv_intrinsic_atomic_op (gfc_code *code) 8849{ 8850 gfc_se argse; 8851 tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE; 8852 stmtblock_t block, post_block; 8853 gfc_expr *atom_expr = code->ext.actual->expr; 8854 gfc_expr *stat_expr; 8855 built_in_function fn; 8856 8857 if (atom_expr->expr_type == EXPR_FUNCTION 8858 && atom_expr->value.function.isym 8859 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) 8860 atom_expr = atom_expr->value.function.actual->expr; 8861 8862 gfc_start_block (&block); 8863 gfc_init_block (&post_block); 8864 8865 gfc_init_se (&argse, NULL); 8866 argse.want_pointer = 1; 8867 gfc_conv_expr (&argse, atom_expr); 8868 gfc_add_block_to_block (&block, &argse.pre); 8869 gfc_add_block_to_block (&post_block, &argse.post); 8870 atom = argse.expr; 8871 8872 gfc_init_se (&argse, NULL); 8873 if (flag_coarray == GFC_FCOARRAY_LIB 8874 && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind) 8875 argse.want_pointer = 1; 8876 gfc_conv_expr (&argse, code->ext.actual->next->expr); 8877 gfc_add_block_to_block (&block, &argse.pre); 8878 gfc_add_block_to_block (&post_block, &argse.post); 8879 value = argse.expr; 8880 8881 switch (code->resolved_isym->id) 8882 { 8883 case GFC_ISYM_ATOMIC_ADD: 8884 case GFC_ISYM_ATOMIC_AND: 8885 case GFC_ISYM_ATOMIC_DEF: 8886 case GFC_ISYM_ATOMIC_OR: 8887 case GFC_ISYM_ATOMIC_XOR: 8888 stat_expr = code->ext.actual->next->next->expr; 8889 if (flag_coarray == GFC_FCOARRAY_LIB) 8890 old = null_pointer_node; 8891 break; 8892 default: 8893 gfc_init_se (&argse, NULL); 8894 if (flag_coarray == GFC_FCOARRAY_LIB) 8895 argse.want_pointer = 1; 8896 gfc_conv_expr (&argse, code->ext.actual->next->next->expr); 8897 gfc_add_block_to_block (&block, &argse.pre); 8898 gfc_add_block_to_block (&post_block, &argse.post); 8899 old = argse.expr; 8900 stat_expr = code->ext.actual->next->next->next->expr; 8901 } 8902 8903 /* STAT= */ 8904 if (stat_expr != NULL) 8905 { 8906 gcc_assert (stat_expr->expr_type == EXPR_VARIABLE); 8907 gfc_init_se (&argse, NULL); 8908 if (flag_coarray == GFC_FCOARRAY_LIB) 8909 argse.want_pointer = 1; 8910 gfc_conv_expr_val (&argse, stat_expr); 8911 gfc_add_block_to_block (&block, &argse.pre); 8912 gfc_add_block_to_block (&post_block, &argse.post); 8913 stat = argse.expr; 8914 } 8915 else if (flag_coarray == GFC_FCOARRAY_LIB) 8916 stat = null_pointer_node; 8917 8918 if (flag_coarray == GFC_FCOARRAY_LIB) 8919 { 8920 tree image_index, caf_decl, offset, token; 8921 int op; 8922 8923 switch (code->resolved_isym->id) 8924 { 8925 case GFC_ISYM_ATOMIC_ADD: 8926 case GFC_ISYM_ATOMIC_FETCH_ADD: 8927 op = (int) GFC_CAF_ATOMIC_ADD; 8928 break; 8929 case GFC_ISYM_ATOMIC_AND: 8930 case GFC_ISYM_ATOMIC_FETCH_AND: 8931 op = (int) GFC_CAF_ATOMIC_AND; 8932 break; 8933 case GFC_ISYM_ATOMIC_OR: 8934 case GFC_ISYM_ATOMIC_FETCH_OR: 8935 op = (int) GFC_CAF_ATOMIC_OR; 8936 break; 8937 case GFC_ISYM_ATOMIC_XOR: 8938 case GFC_ISYM_ATOMIC_FETCH_XOR: 8939 op = (int) GFC_CAF_ATOMIC_XOR; 8940 break; 8941 case GFC_ISYM_ATOMIC_DEF: 8942 op = 0; /* Unused. */ 8943 break; 8944 default: 8945 gcc_unreachable (); 8946 } 8947 8948 caf_decl = gfc_get_tree_for_caf_expr (atom_expr); 8949 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) 8950 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); 8951 8952 if (gfc_is_coindexed (atom_expr)) 8953 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl); 8954 else 8955 image_index = integer_zero_node; 8956 8957 if (!POINTER_TYPE_P (TREE_TYPE (value))) 8958 { 8959 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value"); 8960 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value)); 8961 value = gfc_build_addr_expr (NULL_TREE, tmp); 8962 } 8963 8964 gfc_get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr); 8965 8966 if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF) 8967 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7, 8968 token, offset, image_index, value, stat, 8969 build_int_cst (integer_type_node, 8970 (int) atom_expr->ts.type), 8971 build_int_cst (integer_type_node, 8972 (int) atom_expr->ts.kind)); 8973 else 8974 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9, 8975 build_int_cst (integer_type_node, op), 8976 token, offset, image_index, value, old, stat, 8977 build_int_cst (integer_type_node, 8978 (int) atom_expr->ts.type), 8979 build_int_cst (integer_type_node, 8980 (int) atom_expr->ts.kind)); 8981 8982 gfc_add_expr_to_block (&block, tmp); 8983 gfc_add_block_to_block (&block, &post_block); 8984 return gfc_finish_block (&block); 8985 } 8986 8987 8988 switch (code->resolved_isym->id) 8989 { 8990 case GFC_ISYM_ATOMIC_ADD: 8991 case GFC_ISYM_ATOMIC_FETCH_ADD: 8992 fn = BUILT_IN_ATOMIC_FETCH_ADD_N; 8993 break; 8994 case GFC_ISYM_ATOMIC_AND: 8995 case GFC_ISYM_ATOMIC_FETCH_AND: 8996 fn = BUILT_IN_ATOMIC_FETCH_AND_N; 8997 break; 8998 case GFC_ISYM_ATOMIC_DEF: 8999 fn = BUILT_IN_ATOMIC_STORE_N; 9000 break; 9001 case GFC_ISYM_ATOMIC_OR: 9002 case GFC_ISYM_ATOMIC_FETCH_OR: 9003 fn = BUILT_IN_ATOMIC_FETCH_OR_N; 9004 break; 9005 case GFC_ISYM_ATOMIC_XOR: 9006 case GFC_ISYM_ATOMIC_FETCH_XOR: 9007 fn = BUILT_IN_ATOMIC_FETCH_XOR_N; 9008 break; 9009 default: 9010 gcc_unreachable (); 9011 } 9012 9013 tmp = TREE_TYPE (TREE_TYPE (atom)); 9014 fn = (built_in_function) ((int) fn 9015 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) 9016 + 1); 9017 tmp = builtin_decl_explicit (fn); 9018 tree itype = TREE_TYPE (TREE_TYPE (atom)); 9019 tmp = builtin_decl_explicit (fn); 9020 9021 switch (code->resolved_isym->id) 9022 { 9023 case GFC_ISYM_ATOMIC_ADD: 9024 case GFC_ISYM_ATOMIC_AND: 9025 case GFC_ISYM_ATOMIC_DEF: 9026 case GFC_ISYM_ATOMIC_OR: 9027 case GFC_ISYM_ATOMIC_XOR: 9028 tmp = build_call_expr_loc (input_location, tmp, 3, atom, 9029 fold_convert (itype, value), 9030 build_int_cst (NULL, MEMMODEL_RELAXED)); 9031 gfc_add_expr_to_block (&block, tmp); 9032 break; 9033 default: 9034 tmp = build_call_expr_loc (input_location, tmp, 3, atom, 9035 fold_convert (itype, value), 9036 build_int_cst (NULL, MEMMODEL_RELAXED)); 9037 gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp)); 9038 break; 9039 } 9040 9041 if (stat != NULL_TREE) 9042 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0)); 9043 gfc_add_block_to_block (&block, &post_block); 9044 return gfc_finish_block (&block); 9045} 9046 9047 9048static tree 9049conv_intrinsic_atomic_ref (gfc_code *code) 9050{ 9051 gfc_se argse; 9052 tree tmp, atom, value, stat = NULL_TREE; 9053 stmtblock_t block, post_block; 9054 built_in_function fn; 9055 gfc_expr *atom_expr = code->ext.actual->next->expr; 9056 9057 if (atom_expr->expr_type == EXPR_FUNCTION 9058 && atom_expr->value.function.isym 9059 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) 9060 atom_expr = atom_expr->value.function.actual->expr; 9061 9062 gfc_start_block (&block); 9063 gfc_init_block (&post_block); 9064 gfc_init_se (&argse, NULL); 9065 argse.want_pointer = 1; 9066 gfc_conv_expr (&argse, atom_expr); 9067 gfc_add_block_to_block (&block, &argse.pre); 9068 gfc_add_block_to_block (&post_block, &argse.post); 9069 atom = argse.expr; 9070 9071 gfc_init_se (&argse, NULL); 9072 if (flag_coarray == GFC_FCOARRAY_LIB 9073 && code->ext.actual->expr->ts.kind == atom_expr->ts.kind) 9074 argse.want_pointer = 1; 9075 gfc_conv_expr (&argse, code->ext.actual->expr); 9076 gfc_add_block_to_block (&block, &argse.pre); 9077 gfc_add_block_to_block (&post_block, &argse.post); 9078 value = argse.expr; 9079 9080 /* STAT= */ 9081 if (code->ext.actual->next->next->expr != NULL) 9082 { 9083 gcc_assert (code->ext.actual->next->next->expr->expr_type 9084 == EXPR_VARIABLE); 9085 gfc_init_se (&argse, NULL); 9086 if (flag_coarray == GFC_FCOARRAY_LIB) 9087 argse.want_pointer = 1; 9088 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr); 9089 gfc_add_block_to_block (&block, &argse.pre); 9090 gfc_add_block_to_block (&post_block, &argse.post); 9091 stat = argse.expr; 9092 } 9093 else if (flag_coarray == GFC_FCOARRAY_LIB) 9094 stat = null_pointer_node; 9095 9096 if (flag_coarray == GFC_FCOARRAY_LIB) 9097 { 9098 tree image_index, caf_decl, offset, token; 9099 tree orig_value = NULL_TREE, vardecl = NULL_TREE; 9100 9101 caf_decl = gfc_get_tree_for_caf_expr (atom_expr); 9102 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) 9103 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); 9104 9105 if (gfc_is_coindexed (atom_expr)) 9106 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl); 9107 else 9108 image_index = integer_zero_node; 9109 9110 gfc_get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr); 9111 9112 /* Different type, need type conversion. */ 9113 if (!POINTER_TYPE_P (TREE_TYPE (value))) 9114 { 9115 vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value"); 9116 orig_value = value; 9117 value = gfc_build_addr_expr (NULL_TREE, vardecl); 9118 } 9119 9120 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7, 9121 token, offset, image_index, value, stat, 9122 build_int_cst (integer_type_node, 9123 (int) atom_expr->ts.type), 9124 build_int_cst (integer_type_node, 9125 (int) atom_expr->ts.kind)); 9126 gfc_add_expr_to_block (&block, tmp); 9127 if (vardecl != NULL_TREE) 9128 gfc_add_modify (&block, orig_value, 9129 fold_convert (TREE_TYPE (orig_value), vardecl)); 9130 gfc_add_block_to_block (&block, &post_block); 9131 return gfc_finish_block (&block); 9132 } 9133 9134 tmp = TREE_TYPE (TREE_TYPE (atom)); 9135 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N 9136 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) 9137 + 1); 9138 tmp = builtin_decl_explicit (fn); 9139 tmp = build_call_expr_loc (input_location, tmp, 2, atom, 9140 build_int_cst (integer_type_node, 9141 MEMMODEL_RELAXED)); 9142 gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp)); 9143 9144 if (stat != NULL_TREE) 9145 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0)); 9146 gfc_add_block_to_block (&block, &post_block); 9147 return gfc_finish_block (&block); 9148} 9149 9150 9151static tree 9152conv_intrinsic_atomic_cas (gfc_code *code) 9153{ 9154 gfc_se argse; 9155 tree tmp, atom, old, new_val, comp, stat = NULL_TREE; 9156 stmtblock_t block, post_block; 9157 built_in_function fn; 9158 gfc_expr *atom_expr = code->ext.actual->expr; 9159 9160 if (atom_expr->expr_type == EXPR_FUNCTION 9161 && atom_expr->value.function.isym 9162 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) 9163 atom_expr = atom_expr->value.function.actual->expr; 9164 9165 gfc_init_block (&block); 9166 gfc_init_block (&post_block); 9167 gfc_init_se (&argse, NULL); 9168 argse.want_pointer = 1; 9169 gfc_conv_expr (&argse, atom_expr); 9170 atom = argse.expr; 9171 9172 gfc_init_se (&argse, NULL); 9173 if (flag_coarray == GFC_FCOARRAY_LIB) 9174 argse.want_pointer = 1; 9175 gfc_conv_expr (&argse, code->ext.actual->next->expr); 9176 gfc_add_block_to_block (&block, &argse.pre); 9177 gfc_add_block_to_block (&post_block, &argse.post); 9178 old = argse.expr; 9179 9180 gfc_init_se (&argse, NULL); 9181 if (flag_coarray == GFC_FCOARRAY_LIB) 9182 argse.want_pointer = 1; 9183 gfc_conv_expr (&argse, code->ext.actual->next->next->expr); 9184 gfc_add_block_to_block (&block, &argse.pre); 9185 gfc_add_block_to_block (&post_block, &argse.post); 9186 comp = argse.expr; 9187 9188 gfc_init_se (&argse, NULL); 9189 if (flag_coarray == GFC_FCOARRAY_LIB 9190 && code->ext.actual->next->next->next->expr->ts.kind 9191 == atom_expr->ts.kind) 9192 argse.want_pointer = 1; 9193 gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr); 9194 gfc_add_block_to_block (&block, &argse.pre); 9195 gfc_add_block_to_block (&post_block, &argse.post); 9196 new_val = argse.expr; 9197 9198 /* STAT= */ 9199 if (code->ext.actual->next->next->next->next->expr != NULL) 9200 { 9201 gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type 9202 == EXPR_VARIABLE); 9203 gfc_init_se (&argse, NULL); 9204 if (flag_coarray == GFC_FCOARRAY_LIB) 9205 argse.want_pointer = 1; 9206 gfc_conv_expr_val (&argse, 9207 code->ext.actual->next->next->next->next->expr); 9208 gfc_add_block_to_block (&block, &argse.pre); 9209 gfc_add_block_to_block (&post_block, &argse.post); 9210 stat = argse.expr; 9211 } 9212 else if (flag_coarray == GFC_FCOARRAY_LIB) 9213 stat = null_pointer_node; 9214 9215 if (flag_coarray == GFC_FCOARRAY_LIB) 9216 { 9217 tree image_index, caf_decl, offset, token; 9218 9219 caf_decl = gfc_get_tree_for_caf_expr (atom_expr); 9220 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) 9221 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); 9222 9223 if (gfc_is_coindexed (atom_expr)) 9224 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl); 9225 else 9226 image_index = integer_zero_node; 9227 9228 if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old))) 9229 { 9230 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new"); 9231 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val)); 9232 new_val = gfc_build_addr_expr (NULL_TREE, tmp); 9233 } 9234 9235 /* Convert a constant to a pointer. */ 9236 if (!POINTER_TYPE_P (TREE_TYPE (comp))) 9237 { 9238 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp"); 9239 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp)); 9240 comp = gfc_build_addr_expr (NULL_TREE, tmp); 9241 } 9242 9243 gfc_get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr); 9244 9245 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9, 9246 token, offset, image_index, old, comp, new_val, 9247 stat, build_int_cst (integer_type_node, 9248 (int) atom_expr->ts.type), 9249 build_int_cst (integer_type_node, 9250 (int) atom_expr->ts.kind)); 9251 gfc_add_expr_to_block (&block, tmp); 9252 gfc_add_block_to_block (&block, &post_block); 9253 return gfc_finish_block (&block); 9254 } 9255 9256 tmp = TREE_TYPE (TREE_TYPE (atom)); 9257 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N 9258 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) 9259 + 1); 9260 tmp = builtin_decl_explicit (fn); 9261 9262 gfc_add_modify (&block, old, comp); 9263 tmp = build_call_expr_loc (input_location, tmp, 6, atom, 9264 gfc_build_addr_expr (NULL, old), 9265 fold_convert (TREE_TYPE (old), new_val), 9266 boolean_false_node, 9267 build_int_cst (NULL, MEMMODEL_RELAXED), 9268 build_int_cst (NULL, MEMMODEL_RELAXED)); 9269 gfc_add_expr_to_block (&block, tmp); 9270 9271 if (stat != NULL_TREE) 9272 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0)); 9273 gfc_add_block_to_block (&block, &post_block); 9274 return gfc_finish_block (&block); 9275} 9276 9277static tree 9278conv_intrinsic_event_query (gfc_code *code) 9279{ 9280 gfc_se se, argse; 9281 tree stat = NULL_TREE, stat2 = NULL_TREE; 9282 tree count = NULL_TREE, count2 = NULL_TREE; 9283 9284 gfc_expr *event_expr = code->ext.actual->expr; 9285 9286 if (code->ext.actual->next->next->expr) 9287 { 9288 gcc_assert (code->ext.actual->next->next->expr->expr_type 9289 == EXPR_VARIABLE); 9290 gfc_init_se (&argse, NULL); 9291 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr); 9292 stat = argse.expr; 9293 } 9294 else if (flag_coarray == GFC_FCOARRAY_LIB) 9295 stat = null_pointer_node; 9296 9297 if (code->ext.actual->next->expr) 9298 { 9299 gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE); 9300 gfc_init_se (&argse, NULL); 9301 gfc_conv_expr_val (&argse, code->ext.actual->next->expr); 9302 count = argse.expr; 9303 } 9304 9305 gfc_start_block (&se.pre); 9306 if (flag_coarray == GFC_FCOARRAY_LIB) 9307 { 9308 tree tmp, token, image_index; 9309 tree index = size_zero_node; 9310 9311 if (event_expr->expr_type == EXPR_FUNCTION 9312 && event_expr->value.function.isym 9313 && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET) 9314 event_expr = event_expr->value.function.actual->expr; 9315 9316 tree caf_decl = gfc_get_tree_for_caf_expr (event_expr); 9317 9318 if (event_expr->symtree->n.sym->ts.type != BT_DERIVED 9319 || event_expr->symtree->n.sym->ts.u.derived->from_intmod 9320 != INTMOD_ISO_FORTRAN_ENV 9321 || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id 9322 != ISOFORTRAN_EVENT_TYPE) 9323 { 9324 gfc_error ("Sorry, the event component of derived type at %L is not " 9325 "yet supported", &event_expr->where); 9326 return NULL_TREE; 9327 } 9328 9329 if (gfc_is_coindexed (event_expr)) 9330 { 9331 gfc_error ("The event variable at %L shall not be coindexed ", 9332 &event_expr->where); 9333 return NULL_TREE; 9334 } 9335 9336 image_index = integer_zero_node; 9337 9338 gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, event_expr); 9339 9340 /* For arrays, obtain the array index. */ 9341 if (gfc_expr_attr (event_expr).dimension) 9342 { 9343 tree desc, tmp, extent, lbound, ubound; 9344 gfc_array_ref *ar, ar2; 9345 int i; 9346 9347 /* TODO: Extend this, once DT components are supported. */ 9348 ar = &event_expr->ref->u.ar; 9349 ar2 = *ar; 9350 memset (ar, '\0', sizeof (*ar)); 9351 ar->as = ar2.as; 9352 ar->type = AR_FULL; 9353 9354 gfc_init_se (&argse, NULL); 9355 argse.descriptor_only = 1; 9356 gfc_conv_expr_descriptor (&argse, event_expr); 9357 gfc_add_block_to_block (&se.pre, &argse.pre); 9358 desc = argse.expr; 9359 *ar = ar2; 9360 9361 extent = integer_one_node; 9362 for (i = 0; i < ar->dimen; i++) 9363 { 9364 gfc_init_se (&argse, NULL); 9365 gfc_conv_expr_type (&argse, ar->start[i], integer_type_node); 9366 gfc_add_block_to_block (&argse.pre, &argse.pre); 9367 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); 9368 tmp = fold_build2_loc (input_location, MINUS_EXPR, 9369 integer_type_node, argse.expr, 9370 fold_convert(integer_type_node, lbound)); 9371 tmp = fold_build2_loc (input_location, MULT_EXPR, 9372 integer_type_node, extent, tmp); 9373 index = fold_build2_loc (input_location, PLUS_EXPR, 9374 integer_type_node, index, tmp); 9375 if (i < ar->dimen - 1) 9376 { 9377 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); 9378 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); 9379 tmp = fold_convert (integer_type_node, tmp); 9380 extent = fold_build2_loc (input_location, MULT_EXPR, 9381 integer_type_node, extent, tmp); 9382 } 9383 } 9384 } 9385 9386 if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node) 9387 { 9388 count2 = count; 9389 count = gfc_create_var (integer_type_node, "count"); 9390 } 9391 9392 if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) 9393 { 9394 stat2 = stat; 9395 stat = gfc_create_var (integer_type_node, "stat"); 9396 } 9397 9398 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5, 9399 token, index, image_index, count 9400 ? gfc_build_addr_expr (NULL, count) : count, 9401 stat != null_pointer_node 9402 ? gfc_build_addr_expr (NULL, stat) : stat); 9403 gfc_add_expr_to_block (&se.pre, tmp); 9404 9405 if (count2 != NULL_TREE) 9406 gfc_add_modify (&se.pre, count2, 9407 fold_convert (TREE_TYPE (count2), count)); 9408 9409 if (stat2 != NULL_TREE) 9410 gfc_add_modify (&se.pre, stat2, 9411 fold_convert (TREE_TYPE (stat2), stat)); 9412 9413 return gfc_finish_block (&se.pre); 9414 } 9415 9416 gfc_init_se (&argse, NULL); 9417 gfc_conv_expr_val (&argse, code->ext.actual->expr); 9418 gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr)); 9419 9420 if (stat != NULL_TREE) 9421 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); 9422 9423 return gfc_finish_block (&se.pre); 9424} 9425 9426static tree 9427conv_intrinsic_move_alloc (gfc_code *code) 9428{ 9429 stmtblock_t block; 9430 gfc_expr *from_expr, *to_expr; 9431 gfc_expr *to_expr2, *from_expr2 = NULL; 9432 gfc_se from_se, to_se; 9433 tree tmp; 9434 bool coarray; 9435 9436 gfc_start_block (&block); 9437 9438 from_expr = code->ext.actual->expr; 9439 to_expr = code->ext.actual->next->expr; 9440 9441 gfc_init_se (&from_se, NULL); 9442 gfc_init_se (&to_se, NULL); 9443 9444 gcc_assert (from_expr->ts.type != BT_CLASS 9445 || to_expr->ts.type == BT_CLASS); 9446 coarray = gfc_get_corank (from_expr) != 0; 9447 9448 if (from_expr->rank == 0 && !coarray) 9449 { 9450 if (from_expr->ts.type != BT_CLASS) 9451 from_expr2 = from_expr; 9452 else 9453 { 9454 from_expr2 = gfc_copy_expr (from_expr); 9455 gfc_add_data_component (from_expr2); 9456 } 9457 9458 if (to_expr->ts.type != BT_CLASS) 9459 to_expr2 = to_expr; 9460 else 9461 { 9462 to_expr2 = gfc_copy_expr (to_expr); 9463 gfc_add_data_component (to_expr2); 9464 } 9465 9466 from_se.want_pointer = 1; 9467 to_se.want_pointer = 1; 9468 gfc_conv_expr (&from_se, from_expr2); 9469 gfc_conv_expr (&to_se, to_expr2); 9470 gfc_add_block_to_block (&block, &from_se.pre); 9471 gfc_add_block_to_block (&block, &to_se.pre); 9472 9473 /* Deallocate "to". */ 9474 tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true, 9475 to_expr, to_expr->ts); 9476 gfc_add_expr_to_block (&block, tmp); 9477 9478 /* Assign (_data) pointers. */ 9479 gfc_add_modify_loc (input_location, &block, to_se.expr, 9480 fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); 9481 9482 /* Set "from" to NULL. */ 9483 gfc_add_modify_loc (input_location, &block, from_se.expr, 9484 fold_convert (TREE_TYPE (from_se.expr), null_pointer_node)); 9485 9486 gfc_add_block_to_block (&block, &from_se.post); 9487 gfc_add_block_to_block (&block, &to_se.post); 9488 9489 /* Set _vptr. */ 9490 if (to_expr->ts.type == BT_CLASS) 9491 { 9492 gfc_symbol *vtab; 9493 9494 gfc_free_expr (to_expr2); 9495 gfc_init_se (&to_se, NULL); 9496 to_se.want_pointer = 1; 9497 gfc_add_vptr_component (to_expr); 9498 gfc_conv_expr (&to_se, to_expr); 9499 9500 if (from_expr->ts.type == BT_CLASS) 9501 { 9502 if (UNLIMITED_POLY (from_expr)) 9503 vtab = NULL; 9504 else 9505 { 9506 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); 9507 gcc_assert (vtab); 9508 } 9509 9510 gfc_free_expr (from_expr2); 9511 gfc_init_se (&from_se, NULL); 9512 from_se.want_pointer = 1; 9513 gfc_add_vptr_component (from_expr); 9514 gfc_conv_expr (&from_se, from_expr); 9515 gfc_add_modify_loc (input_location, &block, to_se.expr, 9516 fold_convert (TREE_TYPE (to_se.expr), 9517 from_se.expr)); 9518 9519 /* Reset _vptr component to declared type. */ 9520 if (vtab == NULL) 9521 /* Unlimited polymorphic. */ 9522 gfc_add_modify_loc (input_location, &block, from_se.expr, 9523 fold_convert (TREE_TYPE (from_se.expr), 9524 null_pointer_node)); 9525 else 9526 { 9527 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); 9528 gfc_add_modify_loc (input_location, &block, from_se.expr, 9529 fold_convert (TREE_TYPE (from_se.expr), tmp)); 9530 } 9531 } 9532 else 9533 { 9534 vtab = gfc_find_vtab (&from_expr->ts); 9535 gcc_assert (vtab); 9536 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); 9537 gfc_add_modify_loc (input_location, &block, to_se.expr, 9538 fold_convert (TREE_TYPE (to_se.expr), tmp)); 9539 } 9540 } 9541 9542 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) 9543 { 9544 gfc_add_modify_loc (input_location, &block, to_se.string_length, 9545 fold_convert (TREE_TYPE (to_se.string_length), 9546 from_se.string_length)); 9547 if (from_expr->ts.deferred) 9548 gfc_add_modify_loc (input_location, &block, from_se.string_length, 9549 build_int_cst (TREE_TYPE (from_se.string_length), 0)); 9550 } 9551 9552 return gfc_finish_block (&block); 9553 } 9554 9555 /* Update _vptr component. */ 9556 if (to_expr->ts.type == BT_CLASS) 9557 { 9558 gfc_symbol *vtab; 9559 9560 to_se.want_pointer = 1; 9561 to_expr2 = gfc_copy_expr (to_expr); 9562 gfc_add_vptr_component (to_expr2); 9563 gfc_conv_expr (&to_se, to_expr2); 9564 9565 if (from_expr->ts.type == BT_CLASS) 9566 { 9567 if (UNLIMITED_POLY (from_expr)) 9568 vtab = NULL; 9569 else 9570 { 9571 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); 9572 gcc_assert (vtab); 9573 } 9574 9575 from_se.want_pointer = 1; 9576 from_expr2 = gfc_copy_expr (from_expr); 9577 gfc_add_vptr_component (from_expr2); 9578 gfc_conv_expr (&from_se, from_expr2); 9579 gfc_add_modify_loc (input_location, &block, to_se.expr, 9580 fold_convert (TREE_TYPE (to_se.expr), 9581 from_se.expr)); 9582 9583 /* Reset _vptr component to declared type. */ 9584 if (vtab == NULL) 9585 /* Unlimited polymorphic. */ 9586 gfc_add_modify_loc (input_location, &block, from_se.expr, 9587 fold_convert (TREE_TYPE (from_se.expr), 9588 null_pointer_node)); 9589 else 9590 { 9591 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); 9592 gfc_add_modify_loc (input_location, &block, from_se.expr, 9593 fold_convert (TREE_TYPE (from_se.expr), tmp)); 9594 } 9595 } 9596 else 9597 { 9598 vtab = gfc_find_vtab (&from_expr->ts); 9599 gcc_assert (vtab); 9600 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); 9601 gfc_add_modify_loc (input_location, &block, to_se.expr, 9602 fold_convert (TREE_TYPE (to_se.expr), tmp)); 9603 } 9604 9605 gfc_free_expr (to_expr2); 9606 gfc_init_se (&to_se, NULL); 9607 9608 if (from_expr->ts.type == BT_CLASS) 9609 { 9610 gfc_free_expr (from_expr2); 9611 gfc_init_se (&from_se, NULL); 9612 } 9613 } 9614 9615 9616 /* Deallocate "to". */ 9617 if (from_expr->rank == 0) 9618 { 9619 to_se.want_coarray = 1; 9620 from_se.want_coarray = 1; 9621 } 9622 gfc_conv_expr_descriptor (&to_se, to_expr); 9623 gfc_conv_expr_descriptor (&from_se, from_expr); 9624 9625 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC 9626 is an image control "statement", cf. IR F08/0040 in 12-006A. */ 9627 if (coarray && flag_coarray == GFC_FCOARRAY_LIB) 9628 { 9629 tree cond; 9630 9631 tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, 9632 NULL_TREE, NULL_TREE, true, to_expr, 9633 true); 9634 gfc_add_expr_to_block (&block, tmp); 9635 9636 tmp = gfc_conv_descriptor_data_get (to_se.expr); 9637 cond = fold_build2_loc (input_location, EQ_EXPR, 9638 boolean_type_node, tmp, 9639 fold_convert (TREE_TYPE (tmp), 9640 null_pointer_node)); 9641 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, 9642 3, null_pointer_node, null_pointer_node, 9643 build_int_cst (integer_type_node, 0)); 9644 9645 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 9646 tmp, build_empty_stmt (input_location)); 9647 gfc_add_expr_to_block (&block, tmp); 9648 } 9649 else 9650 { 9651 if (to_expr->ts.type == BT_DERIVED 9652 && to_expr->ts.u.derived->attr.alloc_comp) 9653 { 9654 tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived, 9655 to_se.expr, to_expr->rank); 9656 gfc_add_expr_to_block (&block, tmp); 9657 } 9658 9659 tmp = gfc_conv_descriptor_data_get (to_se.expr); 9660 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, 9661 NULL_TREE, true, to_expr, false); 9662 gfc_add_expr_to_block (&block, tmp); 9663 } 9664 9665 /* Move the pointer and update the array descriptor data. */ 9666 gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr); 9667 9668 /* Set "from" to NULL. */ 9669 tmp = gfc_conv_descriptor_data_get (from_se.expr); 9670 gfc_add_modify_loc (input_location, &block, tmp, 9671 fold_convert (TREE_TYPE (tmp), null_pointer_node)); 9672 9673 9674 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) 9675 { 9676 gfc_add_modify_loc (input_location, &block, to_se.string_length, 9677 fold_convert (TREE_TYPE (to_se.string_length), 9678 from_se.string_length)); 9679 if (from_expr->ts.deferred) 9680 gfc_add_modify_loc (input_location, &block, from_se.string_length, 9681 build_int_cst (TREE_TYPE (from_se.string_length), 0)); 9682 } 9683 9684 return gfc_finish_block (&block); 9685} 9686 9687 9688tree 9689gfc_conv_intrinsic_subroutine (gfc_code *code) 9690{ 9691 tree res; 9692 9693 gcc_assert (code->resolved_isym); 9694 9695 switch (code->resolved_isym->id) 9696 { 9697 case GFC_ISYM_MOVE_ALLOC: 9698 res = conv_intrinsic_move_alloc (code); 9699 break; 9700 9701 case GFC_ISYM_ATOMIC_CAS: 9702 res = conv_intrinsic_atomic_cas (code); 9703 break; 9704 9705 case GFC_ISYM_ATOMIC_ADD: 9706 case GFC_ISYM_ATOMIC_AND: 9707 case GFC_ISYM_ATOMIC_DEF: 9708 case GFC_ISYM_ATOMIC_OR: 9709 case GFC_ISYM_ATOMIC_XOR: 9710 case GFC_ISYM_ATOMIC_FETCH_ADD: 9711 case GFC_ISYM_ATOMIC_FETCH_AND: 9712 case GFC_ISYM_ATOMIC_FETCH_OR: 9713 case GFC_ISYM_ATOMIC_FETCH_XOR: 9714 res = conv_intrinsic_atomic_op (code); 9715 break; 9716 9717 case GFC_ISYM_ATOMIC_REF: 9718 res = conv_intrinsic_atomic_ref (code); 9719 break; 9720 9721 case GFC_ISYM_EVENT_QUERY: 9722 res = conv_intrinsic_event_query (code); 9723 break; 9724 9725 case GFC_ISYM_C_F_POINTER: 9726 case GFC_ISYM_C_F_PROCPOINTER: 9727 res = conv_isocbinding_subroutine (code); 9728 break; 9729 9730 case GFC_ISYM_CAF_SEND: 9731 res = conv_caf_send (code); 9732 break; 9733 9734 case GFC_ISYM_CO_BROADCAST: 9735 case GFC_ISYM_CO_MIN: 9736 case GFC_ISYM_CO_MAX: 9737 case GFC_ISYM_CO_REDUCE: 9738 case GFC_ISYM_CO_SUM: 9739 res = conv_co_collective (code); 9740 break; 9741 9742 case GFC_ISYM_SYSTEM_CLOCK: 9743 res = conv_intrinsic_system_clock (code); 9744 break; 9745 9746 default: 9747 res = NULL_TREE; 9748 break; 9749 } 9750 9751 return res; 9752} 9753 9754#include "gt-fortran-trans-intrinsic.h" 9755