* ggc.h (empty_string): Delete.
[official-gcc.git] / gcc / fortran / trans-intrinsic.c
blob3c9e1d5e0370e1e1517c6994f27b3bfb91366c37
1 /* Intrinsic translation
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
24 #include "config.h"
25 #include "system.h"
26 #include "coretypes.h"
27 #include "memmodel.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
29 #include "tree.h"
30 #include "gfortran.h"
31 #include "trans.h"
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "tree-nested.h"
35 #include "stor-layout.h"
36 #include "toplev.h" /* For rest_of_decl_compilation. */
37 #include "arith.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 #include "dependency.h" /* For CAF array alias analysis. */
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 /* This maps Fortran intrinsic math functions to external library or GCC
45 builtin functions. */
46 typedef struct GTY(()) gfc_intrinsic_map_t {
47 /* The explicit enum is required to work around inadequacies in the
48 garbage collection/gengtype parsing mechanism. */
49 enum gfc_isym_id id;
51 /* Enum value from the "language-independent", aka C-centric, part
52 of gcc, or END_BUILTINS of no such value set. */
53 enum built_in_function float_built_in;
54 enum built_in_function double_built_in;
55 enum built_in_function long_double_built_in;
56 enum built_in_function complex_float_built_in;
57 enum built_in_function complex_double_built_in;
58 enum built_in_function complex_long_double_built_in;
60 /* True if the naming pattern is to prepend "c" for complex and
61 append "f" for kind=4. False if the naming pattern is to
62 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
63 bool libm_name;
65 /* True if a complex version of the function exists. */
66 bool complex_available;
68 /* True if the function should be marked const. */
69 bool is_constant;
71 /* The base library name of this function. */
72 const char *name;
74 /* Cache decls created for the various operand types. */
75 tree real4_decl;
76 tree real8_decl;
77 tree real10_decl;
78 tree real16_decl;
79 tree complex4_decl;
80 tree complex8_decl;
81 tree complex10_decl;
82 tree complex16_decl;
84 gfc_intrinsic_map_t;
86 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
87 defines complex variants of all of the entries in mathbuiltins.def
88 except for atan2. */
89 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
90 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
91 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
92 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
93 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
95 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
96 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
97 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
98 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
99 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
101 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
102 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
107 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
108 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
109 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
115 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
116 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
117 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
118 #include "mathbuiltins.def"
120 /* Functions in libgfortran. */
121 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
123 /* End the list. */
124 LIB_FUNCTION (NONE, NULL, false)
127 #undef OTHER_BUILTIN
128 #undef LIB_FUNCTION
129 #undef DEFINE_MATH_BUILTIN
130 #undef DEFINE_MATH_BUILTIN_C
133 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
136 /* Find the correct variant of a given builtin from its argument. */
137 static tree
138 builtin_decl_for_precision (enum built_in_function base_built_in,
139 int precision)
141 enum built_in_function i = END_BUILTINS;
143 gfc_intrinsic_map_t *m;
144 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
147 if (precision == TYPE_PRECISION (float_type_node))
148 i = m->float_built_in;
149 else if (precision == TYPE_PRECISION (double_type_node))
150 i = m->double_built_in;
151 else if (precision == TYPE_PRECISION (long_double_type_node))
152 i = m->long_double_built_in;
153 else if (precision == TYPE_PRECISION (gfc_float128_type_node))
155 /* Special treatment, because it is not exactly a built-in, but
156 a library function. */
157 return m->real16_decl;
160 return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
164 tree
165 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
166 int kind)
168 int i = gfc_validate_kind (BT_REAL, kind, false);
170 if (gfc_real_kinds[i].c_float128)
172 /* For __float128, the story is a bit different, because we return
173 a decl to a library function rather than a built-in. */
174 gfc_intrinsic_map_t *m;
175 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
178 return m->real16_decl;
181 return builtin_decl_for_precision (double_built_in,
182 gfc_real_kinds[i].mode_precision);
186 /* Evaluate the arguments to an intrinsic function. The value
187 of NARGS may be less than the actual number of arguments in EXPR
188 to allow optional "KIND" arguments that are not included in the
189 generated code to be ignored. */
191 static void
192 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
193 tree *argarray, int nargs)
195 gfc_actual_arglist *actual;
196 gfc_expr *e;
197 gfc_intrinsic_arg *formal;
198 gfc_se argse;
199 int curr_arg;
201 formal = expr->value.function.isym->formal;
202 actual = expr->value.function.actual;
204 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
205 actual = actual->next,
206 formal = formal ? formal->next : NULL)
208 gcc_assert (actual);
209 e = actual->expr;
210 /* Skip omitted optional arguments. */
211 if (!e)
213 --curr_arg;
214 continue;
217 /* Evaluate the parameter. This will substitute scalarized
218 references automatically. */
219 gfc_init_se (&argse, se);
221 if (e->ts.type == BT_CHARACTER)
223 gfc_conv_expr (&argse, e);
224 gfc_conv_string_parameter (&argse);
225 argarray[curr_arg++] = argse.string_length;
226 gcc_assert (curr_arg < nargs);
228 else
229 gfc_conv_expr_val (&argse, e);
231 /* If an optional argument is itself an optional dummy argument,
232 check its presence and substitute a null if absent. */
233 if (e->expr_type == EXPR_VARIABLE
234 && e->symtree->n.sym->attr.optional
235 && formal
236 && formal->optional)
237 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
239 gfc_add_block_to_block (&se->pre, &argse.pre);
240 gfc_add_block_to_block (&se->post, &argse.post);
241 argarray[curr_arg] = argse.expr;
245 /* Count the number of actual arguments to the intrinsic function EXPR
246 including any "hidden" string length arguments. */
248 static unsigned int
249 gfc_intrinsic_argument_list_length (gfc_expr *expr)
251 int n = 0;
252 gfc_actual_arglist *actual;
254 for (actual = expr->value.function.actual; actual; actual = actual->next)
256 if (!actual->expr)
257 continue;
259 if (actual->expr->ts.type == BT_CHARACTER)
260 n += 2;
261 else
262 n++;
265 return n;
269 /* Conversions between different types are output by the frontend as
270 intrinsic functions. We implement these directly with inline code. */
272 static void
273 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
275 tree type;
276 tree *args;
277 int nargs;
279 nargs = gfc_intrinsic_argument_list_length (expr);
280 args = XALLOCAVEC (tree, nargs);
282 /* Evaluate all the arguments passed. Whilst we're only interested in the
283 first one here, there are other parts of the front-end that assume this
284 and will trigger an ICE if it's not the case. */
285 type = gfc_typenode_for_spec (&expr->ts);
286 gcc_assert (expr->value.function.actual->expr);
287 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
289 /* Conversion between character kinds involves a call to a library
290 function. */
291 if (expr->ts.type == BT_CHARACTER)
293 tree fndecl, var, addr, tmp;
295 if (expr->ts.kind == 1
296 && expr->value.function.actual->expr->ts.kind == 4)
297 fndecl = gfor_fndecl_convert_char4_to_char1;
298 else if (expr->ts.kind == 4
299 && expr->value.function.actual->expr->ts.kind == 1)
300 fndecl = gfor_fndecl_convert_char1_to_char4;
301 else
302 gcc_unreachable ();
304 /* Create the variable storing the converted value. */
305 type = gfc_get_pchar_type (expr->ts.kind);
306 var = gfc_create_var (type, "str");
307 addr = gfc_build_addr_expr (build_pointer_type (type), var);
309 /* Call the library function that will perform the conversion. */
310 gcc_assert (nargs >= 2);
311 tmp = build_call_expr_loc (input_location,
312 fndecl, 3, addr, args[0], args[1]);
313 gfc_add_expr_to_block (&se->pre, tmp);
315 /* Free the temporary afterwards. */
316 tmp = gfc_call_free (var);
317 gfc_add_expr_to_block (&se->post, tmp);
319 se->expr = var;
320 se->string_length = args[0];
322 return;
325 /* Conversion from complex to non-complex involves taking the real
326 component of the value. */
327 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
328 && expr->ts.type != BT_COMPLEX)
330 tree artype;
332 artype = TREE_TYPE (TREE_TYPE (args[0]));
333 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
334 args[0]);
337 se->expr = convert (type, args[0]);
340 /* This is needed because the gcc backend only implements
341 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
342 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
343 Similarly for CEILING. */
345 static tree
346 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
348 tree tmp;
349 tree cond;
350 tree argtype;
351 tree intval;
353 argtype = TREE_TYPE (arg);
354 arg = gfc_evaluate_now (arg, pblock);
356 intval = convert (type, arg);
357 intval = gfc_evaluate_now (intval, pblock);
359 tmp = convert (argtype, intval);
360 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
361 boolean_type_node, tmp, arg);
363 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
364 intval, build_int_cst (type, 1));
365 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
366 return tmp;
370 /* Round to nearest integer, away from zero. */
372 static tree
373 build_round_expr (tree arg, tree restype)
375 tree argtype;
376 tree fn;
377 int argprec, resprec;
379 argtype = TREE_TYPE (arg);
380 argprec = TYPE_PRECISION (argtype);
381 resprec = TYPE_PRECISION (restype);
383 /* Depending on the type of the result, choose the int intrinsic
384 (iround, available only as a builtin, therefore cannot use it for
385 __float128), long int intrinsic (lround family) or long long
386 intrinsic (llround). We might also need to convert the result
387 afterwards. */
388 if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE)
389 fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
390 else if (resprec <= LONG_TYPE_SIZE)
391 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
392 else if (resprec <= LONG_LONG_TYPE_SIZE)
393 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
394 else
395 gcc_unreachable ();
397 return fold_convert (restype, build_call_expr_loc (input_location,
398 fn, 1, arg));
402 /* Convert a real to an integer using a specific rounding mode.
403 Ideally we would just build the corresponding GENERIC node,
404 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
406 static tree
407 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
408 enum rounding_mode op)
410 switch (op)
412 case RND_FLOOR:
413 return build_fixbound_expr (pblock, arg, type, 0);
415 case RND_CEIL:
416 return build_fixbound_expr (pblock, arg, type, 1);
418 case RND_ROUND:
419 return build_round_expr (arg, type);
421 case RND_TRUNC:
422 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
424 default:
425 gcc_unreachable ();
430 /* Round a real value using the specified rounding mode.
431 We use a temporary integer of that same kind size as the result.
432 Values larger than those that can be represented by this kind are
433 unchanged, as they will not be accurate enough to represent the
434 rounding.
435 huge = HUGE (KIND (a))
436 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
439 static void
440 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
442 tree type;
443 tree itype;
444 tree arg[2];
445 tree tmp;
446 tree cond;
447 tree decl;
448 mpfr_t huge;
449 int n, nargs;
450 int kind;
452 kind = expr->ts.kind;
453 nargs = gfc_intrinsic_argument_list_length (expr);
455 decl = NULL_TREE;
456 /* We have builtin functions for some cases. */
457 switch (op)
459 case RND_ROUND:
460 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
461 break;
463 case RND_TRUNC:
464 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
465 break;
467 default:
468 gcc_unreachable ();
471 /* Evaluate the argument. */
472 gcc_assert (expr->value.function.actual->expr);
473 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
475 /* Use a builtin function if one exists. */
476 if (decl != NULL_TREE)
478 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
479 return;
482 /* This code is probably redundant, but we'll keep it lying around just
483 in case. */
484 type = gfc_typenode_for_spec (&expr->ts);
485 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
487 /* Test if the value is too large to handle sensibly. */
488 gfc_set_model_kind (kind);
489 mpfr_init (huge);
490 n = gfc_validate_kind (BT_INTEGER, kind, false);
491 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
492 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
493 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
494 tmp);
496 mpfr_neg (huge, huge, GFC_RND_MODE);
497 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
498 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
499 tmp);
500 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
501 cond, tmp);
502 itype = gfc_get_int_type (kind);
504 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
505 tmp = convert (type, tmp);
506 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
507 arg[0]);
508 mpfr_clear (huge);
512 /* Convert to an integer using the specified rounding mode. */
514 static void
515 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
517 tree type;
518 tree *args;
519 int nargs;
521 nargs = gfc_intrinsic_argument_list_length (expr);
522 args = XALLOCAVEC (tree, nargs);
524 /* Evaluate the argument, we process all arguments even though we only
525 use the first one for code generation purposes. */
526 type = gfc_typenode_for_spec (&expr->ts);
527 gcc_assert (expr->value.function.actual->expr);
528 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
530 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
532 /* Conversion to a different integer kind. */
533 se->expr = convert (type, args[0]);
535 else
537 /* Conversion from complex to non-complex involves taking the real
538 component of the value. */
539 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
540 && expr->ts.type != BT_COMPLEX)
542 tree artype;
544 artype = TREE_TYPE (TREE_TYPE (args[0]));
545 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
546 args[0]);
549 se->expr = build_fix_expr (&se->pre, args[0], type, op);
554 /* Get the imaginary component of a value. */
556 static void
557 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
559 tree arg;
561 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
562 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
563 TREE_TYPE (TREE_TYPE (arg)), arg);
567 /* Get the complex conjugate of a value. */
569 static void
570 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
572 tree arg;
574 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
575 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
580 static tree
581 define_quad_builtin (const char *name, tree type, bool is_const)
583 tree fndecl;
584 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
585 type);
587 /* Mark the decl as external. */
588 DECL_EXTERNAL (fndecl) = 1;
589 TREE_PUBLIC (fndecl) = 1;
591 /* Mark it __attribute__((const)). */
592 TREE_READONLY (fndecl) = is_const;
594 rest_of_decl_compilation (fndecl, 1, 0);
596 return fndecl;
601 /* Initialize function decls for library functions. The external functions
602 are created as required. Builtin functions are added here. */
604 void
605 gfc_build_intrinsic_lib_fndecls (void)
607 gfc_intrinsic_map_t *m;
608 tree quad_decls[END_BUILTINS + 1];
610 if (gfc_real16_is_float128)
612 /* If we have soft-float types, we create the decls for their
613 C99-like library functions. For now, we only handle __float128
614 q-suffixed functions. */
616 tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
617 tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
619 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
621 type = gfc_float128_type_node;
622 complex_type = gfc_complex_float128_type_node;
623 /* type (*) (type) */
624 func_1 = build_function_type_list (type, type, NULL_TREE);
625 /* int (*) (type) */
626 func_iround = build_function_type_list (integer_type_node,
627 type, NULL_TREE);
628 /* long (*) (type) */
629 func_lround = build_function_type_list (long_integer_type_node,
630 type, NULL_TREE);
631 /* long long (*) (type) */
632 func_llround = build_function_type_list (long_long_integer_type_node,
633 type, NULL_TREE);
634 /* type (*) (type, type) */
635 func_2 = build_function_type_list (type, type, type, NULL_TREE);
636 /* type (*) (type, &int) */
637 func_frexp
638 = build_function_type_list (type,
639 type,
640 build_pointer_type (integer_type_node),
641 NULL_TREE);
642 /* type (*) (type, int) */
643 func_scalbn = build_function_type_list (type,
644 type, integer_type_node, NULL_TREE);
645 /* type (*) (complex type) */
646 func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
647 /* complex type (*) (complex type, complex type) */
648 func_cpow
649 = build_function_type_list (complex_type,
650 complex_type, complex_type, NULL_TREE);
652 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
653 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
654 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
656 /* Only these built-ins are actually needed here. These are used directly
657 from the code, when calling builtin_decl_for_precision() or
658 builtin_decl_for_float_type(). The others are all constructed by
659 gfc_get_intrinsic_lib_fndecl(). */
660 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
661 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
663 #include "mathbuiltins.def"
665 #undef OTHER_BUILTIN
666 #undef LIB_FUNCTION
667 #undef DEFINE_MATH_BUILTIN
668 #undef DEFINE_MATH_BUILTIN_C
670 /* There is one built-in we defined manually, because it gets called
671 with builtin_decl_for_precision() or builtin_decl_for_float_type()
672 even though it is not an OTHER_BUILTIN: it is SQRT. */
673 quad_decls[BUILT_IN_SQRT] = define_quad_builtin ("sqrtq", func_1, true);
677 /* Add GCC builtin functions. */
678 for (m = gfc_intrinsic_map;
679 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
681 if (m->float_built_in != END_BUILTINS)
682 m->real4_decl = builtin_decl_explicit (m->float_built_in);
683 if (m->complex_float_built_in != END_BUILTINS)
684 m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
685 if (m->double_built_in != END_BUILTINS)
686 m->real8_decl = builtin_decl_explicit (m->double_built_in);
687 if (m->complex_double_built_in != END_BUILTINS)
688 m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
690 /* If real(kind=10) exists, it is always long double. */
691 if (m->long_double_built_in != END_BUILTINS)
692 m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
693 if (m->complex_long_double_built_in != END_BUILTINS)
694 m->complex10_decl
695 = builtin_decl_explicit (m->complex_long_double_built_in);
697 if (!gfc_real16_is_float128)
699 if (m->long_double_built_in != END_BUILTINS)
700 m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
701 if (m->complex_long_double_built_in != END_BUILTINS)
702 m->complex16_decl
703 = builtin_decl_explicit (m->complex_long_double_built_in);
705 else if (quad_decls[m->double_built_in] != NULL_TREE)
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m->real16_decl = quad_decls[m->double_built_in];
712 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
714 /* Same thing for the complex ones. */
715 m->complex16_decl = quad_decls[m->double_built_in];
721 /* Create a fndecl for a simple intrinsic library function. */
723 static tree
724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
726 tree type;
727 vec<tree, va_gc> *argtypes;
728 tree fndecl;
729 gfc_actual_arglist *actual;
730 tree *pdecl;
731 gfc_typespec *ts;
732 char name[GFC_MAX_SYMBOL_LEN + 3];
734 ts = &expr->ts;
735 if (ts->type == BT_REAL)
737 switch (ts->kind)
739 case 4:
740 pdecl = &m->real4_decl;
741 break;
742 case 8:
743 pdecl = &m->real8_decl;
744 break;
745 case 10:
746 pdecl = &m->real10_decl;
747 break;
748 case 16:
749 pdecl = &m->real16_decl;
750 break;
751 default:
752 gcc_unreachable ();
755 else if (ts->type == BT_COMPLEX)
757 gcc_assert (m->complex_available);
759 switch (ts->kind)
761 case 4:
762 pdecl = &m->complex4_decl;
763 break;
764 case 8:
765 pdecl = &m->complex8_decl;
766 break;
767 case 10:
768 pdecl = &m->complex10_decl;
769 break;
770 case 16:
771 pdecl = &m->complex16_decl;
772 break;
773 default:
774 gcc_unreachable ();
777 else
778 gcc_unreachable ();
780 if (*pdecl)
781 return *pdecl;
783 if (m->libm_name)
785 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
786 if (gfc_real_kinds[n].c_float)
787 snprintf (name, sizeof (name), "%s%s%s",
788 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
789 else if (gfc_real_kinds[n].c_double)
790 snprintf (name, sizeof (name), "%s%s",
791 ts->type == BT_COMPLEX ? "c" : "", m->name);
792 else if (gfc_real_kinds[n].c_long_double)
793 snprintf (name, sizeof (name), "%s%s%s",
794 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
795 else if (gfc_real_kinds[n].c_float128)
796 snprintf (name, sizeof (name), "%s%s%s",
797 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
798 else
799 gcc_unreachable ();
801 else
803 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
804 ts->type == BT_COMPLEX ? 'c' : 'r',
805 ts->kind);
808 argtypes = NULL;
809 for (actual = expr->value.function.actual; actual; actual = actual->next)
811 type = gfc_typenode_for_spec (&actual->expr->ts);
812 vec_safe_push (argtypes, type);
814 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
815 fndecl = build_decl (input_location,
816 FUNCTION_DECL, get_identifier (name), type);
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl) = 1;
820 TREE_PUBLIC (fndecl) = 1;
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl) = m->is_constant;
825 rest_of_decl_compilation (fndecl, 1, 0);
827 (*pdecl) = fndecl;
828 return fndecl;
832 /* Convert an intrinsic function into an external or builtin call. */
834 static void
835 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
837 gfc_intrinsic_map_t *m;
838 tree fndecl;
839 tree rettype;
840 tree *args;
841 unsigned int num_args;
842 gfc_isym_id id;
844 id = expr->value.function.isym->id;
845 /* Find the entry for this function. */
846 for (m = gfc_intrinsic_map;
847 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
849 if (id == m->id)
850 break;
853 if (m->id == GFC_ISYM_NONE)
855 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
856 expr->value.function.name, id);
859 /* Get the decl and generate the call. */
860 num_args = gfc_intrinsic_argument_list_length (expr);
861 args = XALLOCAVEC (tree, num_args);
863 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
864 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
865 rettype = TREE_TYPE (TREE_TYPE (fndecl));
867 fndecl = build_addr (fndecl);
868 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
876 void
877 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
878 tree a, tree b, stmtblock_t* target)
880 tree cond;
881 tree name;
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
885 return;
887 /* Compare the two string lengths. */
888 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
890 /* Output the runtime-check. */
891 name = gfc_build_cstring_const (intr_name);
892 name = gfc_build_addr_expr (pchar_type_node, name);
893 gfc_trans_runtime_check (true, false, cond, target, where,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node, a),
896 fold_convert (long_integer_type_node, b), name);
900 /* The EXPONENT(X) intrinsic function is translated into
901 int ret;
902 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
903 so that if X is a NaN or infinity, the result is HUGE(0).
906 static void
907 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
909 tree arg, type, res, tmp, frexp, cond, huge;
910 int i;
912 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
913 expr->value.function.actual->expr->ts.kind);
915 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
916 arg = gfc_evaluate_now (arg, &se->pre);
918 i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
919 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
920 cond = build_call_expr_loc (input_location,
921 builtin_decl_explicit (BUILT_IN_ISFINITE),
922 1, arg);
924 res = gfc_create_var (integer_type_node, NULL);
925 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
926 gfc_build_addr_expr (NULL_TREE, res));
927 tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
928 tmp, res);
929 se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
930 cond, tmp, huge);
932 type = gfc_typenode_for_spec (&expr->ts);
933 se->expr = fold_convert (type, se->expr);
937 /* Fill in the following structure
938 struct caf_vector_t {
939 size_t nvec; // size of the vector
940 union {
941 struct {
942 void *vector;
943 int kind;
944 } v;
945 struct {
946 ptrdiff_t lower_bound;
947 ptrdiff_t upper_bound;
948 ptrdiff_t stride;
949 } triplet;
950 } u;
951 } */
953 static void
954 conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
955 tree lower, tree upper, tree stride,
956 tree vector, int kind, tree nvec)
958 tree field, type, tmp;
960 desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
961 type = TREE_TYPE (desc);
963 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
964 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
965 desc, field, NULL_TREE);
966 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
968 /* Access union. */
969 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
970 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
971 desc, field, NULL_TREE);
972 type = TREE_TYPE (desc);
974 /* Access the inner struct. */
975 field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
976 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
977 desc, field, NULL_TREE);
978 type = TREE_TYPE (desc);
980 if (vector != NULL_TREE)
982 /* Set vector and kind. */
983 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
984 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
985 desc, field, NULL_TREE);
986 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
987 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
988 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
989 desc, field, NULL_TREE);
990 gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
992 else
994 /* Set dim.lower/upper/stride. */
995 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
996 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
997 desc, field, NULL_TREE);
998 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
1000 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1001 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1002 desc, field, NULL_TREE);
1003 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
1005 field = gfc_advance_chain (TYPE_FIELDS (type), 2);
1006 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1007 desc, field, NULL_TREE);
1008 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
1013 static tree
1014 conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
1016 gfc_se argse;
1017 tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
1018 tree lbound, ubound, tmp;
1019 int i;
1021 var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
1023 for (i = 0; i < ar->dimen; i++)
1024 switch (ar->dimen_type[i])
1026 case DIMEN_RANGE:
1027 if (ar->end[i])
1029 gfc_init_se (&argse, NULL);
1030 gfc_conv_expr (&argse, ar->end[i]);
1031 gfc_add_block_to_block (block, &argse.pre);
1032 upper = gfc_evaluate_now (argse.expr, block);
1034 else
1035 upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1036 if (ar->stride[i])
1038 gfc_init_se (&argse, NULL);
1039 gfc_conv_expr (&argse, ar->stride[i]);
1040 gfc_add_block_to_block (block, &argse.pre);
1041 stride = gfc_evaluate_now (argse.expr, block);
1043 else
1044 stride = gfc_index_one_node;
1046 /* Fall through. */
1047 case DIMEN_ELEMENT:
1048 if (ar->start[i])
1050 gfc_init_se (&argse, NULL);
1051 gfc_conv_expr (&argse, ar->start[i]);
1052 gfc_add_block_to_block (block, &argse.pre);
1053 lower = gfc_evaluate_now (argse.expr, block);
1055 else
1056 lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1057 if (ar->dimen_type[i] == DIMEN_ELEMENT)
1059 upper = lower;
1060 stride = gfc_index_one_node;
1062 vector = NULL_TREE;
1063 nvec = size_zero_node;
1064 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1065 vector, 0, nvec);
1066 break;
1068 case DIMEN_VECTOR:
1069 gfc_init_se (&argse, NULL);
1070 argse.descriptor_only = 1;
1071 gfc_conv_expr_descriptor (&argse, ar->start[i]);
1072 gfc_add_block_to_block (block, &argse.pre);
1073 vector = argse.expr;
1074 lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
1075 ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
1076 nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1077 tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
1078 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1079 TREE_TYPE (nvec), nvec, tmp);
1080 lower = gfc_index_zero_node;
1081 upper = gfc_index_zero_node;
1082 stride = gfc_index_zero_node;
1083 vector = gfc_conv_descriptor_data_get (vector);
1084 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1085 vector, ar->start[i]->ts.kind, nvec);
1086 break;
1087 default:
1088 gcc_unreachable();
1090 return gfc_build_addr_expr (NULL_TREE, var);
1094 static tree
1095 compute_component_offset (tree field, tree type)
1097 tree tmp;
1098 if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
1099 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
1101 tmp = fold_build2 (TRUNC_DIV_EXPR, type,
1102 DECL_FIELD_BIT_OFFSET (field),
1103 bitsize_unit_node);
1104 return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
1106 else
1107 return DECL_FIELD_OFFSET (field);
1111 static tree
1112 conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
1114 gfc_ref *ref = expr->ref, *last_comp_ref;
1115 tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2,
1116 field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
1117 start, end, stride, vector, nvec;
1118 gfc_se se;
1119 bool ref_static_array = false;
1120 tree last_component_ref_tree = NULL_TREE;
1121 int i, last_type_n;
1123 if (expr->symtree)
1125 last_component_ref_tree = expr->symtree->n.sym->backend_decl;
1126 ref_static_array = !expr->symtree->n.sym->attr.allocatable
1127 && !expr->symtree->n.sym->attr.pointer;
1130 /* Prevent uninit-warning. */
1131 reference_type = NULL_TREE;
1133 /* Skip refs upto the first coarray-ref. */
1134 last_comp_ref = NULL;
1135 while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
1137 /* Remember the type of components skipped. */
1138 if (ref->type == REF_COMPONENT)
1139 last_comp_ref = ref;
1140 ref = ref->next;
1142 /* When a component was skipped, get the type information of the last
1143 component ref, else get the type from the symbol. */
1144 if (last_comp_ref)
1146 last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
1147 last_type_n = last_comp_ref->u.c.component->ts.type;
1149 else
1151 last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
1152 last_type_n = expr->symtree->n.sym->ts.type;
1155 while (ref)
1157 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
1158 && ref->u.ar.dimen == 0)
1160 /* Skip pure coindexes. */
1161 ref = ref->next;
1162 continue;
1164 tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1165 reference_type = TREE_TYPE (tmp);
1167 if (caf_ref == NULL_TREE)
1168 caf_ref = tmp;
1170 /* Construct the chain of refs. */
1171 if (prev_caf_ref != NULL_TREE)
1173 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1174 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1175 TREE_TYPE (field), prev_caf_ref, field,
1176 NULL_TREE);
1177 gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
1178 tmp));
1180 prev_caf_ref = tmp;
1182 switch (ref->type)
1184 case REF_COMPONENT:
1185 last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
1186 last_type_n = ref->u.c.component->ts.type;
1187 /* Set the type of the ref. */
1188 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1189 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1190 TREE_TYPE (field), prev_caf_ref, field,
1191 NULL_TREE);
1192 gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1193 GFC_CAF_REF_COMPONENT));
1195 /* Ref the c in union u. */
1196 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1197 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1198 TREE_TYPE (field), prev_caf_ref, field,
1199 NULL_TREE);
1200 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
1201 inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1202 TREE_TYPE (field), tmp, field,
1203 NULL_TREE);
1205 /* Set the offset. */
1206 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1207 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1208 TREE_TYPE (field), inner_struct, field,
1209 NULL_TREE);
1210 /* Computing the offset is somewhat harder. The bit_offset has to be
1211 taken into account. When the bit_offset in the field_decl is non-
1212 null, divide it by the bitsize_unit and add it to the regular
1213 offset. */
1214 tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
1215 TREE_TYPE (tmp));
1216 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1218 /* Set caf_token_offset. */
1219 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
1220 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1221 TREE_TYPE (field), inner_struct, field,
1222 NULL_TREE);
1223 if ((ref->u.c.component->attr.allocatable
1224 || ref->u.c.component->attr.pointer)
1225 && ref->u.c.component->attr.dimension)
1227 tree arr_desc_token_offset;
1228 /* Get the token from the descriptor. */
1229 arr_desc_token_offset = gfc_advance_chain (
1230 TYPE_FIELDS (TREE_TYPE (ref->u.c.component->backend_decl)),
1231 4 /* CAF_TOKEN_FIELD */);
1232 arr_desc_token_offset
1233 = compute_component_offset (arr_desc_token_offset,
1234 TREE_TYPE (tmp));
1235 tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
1236 TREE_TYPE (tmp2), tmp2,
1237 arr_desc_token_offset);
1239 else if (ref->u.c.component->caf_token)
1240 tmp2 = compute_component_offset (ref->u.c.component->caf_token,
1241 TREE_TYPE (tmp));
1242 else
1243 tmp2 = integer_zero_node;
1244 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1246 /* Remember whether this ref was to a non-allocatable/non-pointer
1247 component so the next array ref can be tailored correctly. */
1248 ref_static_array = !ref->u.c.component->attr.allocatable
1249 && !ref->u.c.component->attr.pointer;
1250 last_component_ref_tree = ref_static_array
1251 ? ref->u.c.component->backend_decl : NULL_TREE;
1252 break;
1253 case REF_ARRAY:
1254 if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
1255 ref_static_array = false;
1256 /* Set the type of the ref. */
1257 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1258 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1259 TREE_TYPE (field), prev_caf_ref, field,
1260 NULL_TREE);
1261 gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1262 ref_static_array
1263 ? GFC_CAF_REF_STATIC_ARRAY
1264 : GFC_CAF_REF_ARRAY));
1266 /* Ref the a in union u. */
1267 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1268 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1269 TREE_TYPE (field), prev_caf_ref, field,
1270 NULL_TREE);
1271 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
1272 inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1273 TREE_TYPE (field), tmp, field,
1274 NULL_TREE);
1276 /* Set the static_array_type in a for static arrays. */
1277 if (ref_static_array)
1279 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
1281 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1282 TREE_TYPE (field), inner_struct, field,
1283 NULL_TREE);
1284 gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
1285 last_type_n));
1287 /* Ref the mode in the inner_struct. */
1288 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1289 mode = fold_build3_loc (input_location, COMPONENT_REF,
1290 TREE_TYPE (field), inner_struct, field,
1291 NULL_TREE);
1292 /* Ref the dim in the inner_struct. */
1293 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
1294 dim_array = fold_build3_loc (input_location, COMPONENT_REF,
1295 TREE_TYPE (field), inner_struct, field,
1296 NULL_TREE);
1297 for (i = 0; i < ref->u.ar.dimen; ++i)
1299 /* Ref dim i. */
1300 dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
1301 dim_type = TREE_TYPE (dim);
1302 mode_rhs = start = end = stride = NULL_TREE;
1303 switch (ref->u.ar.dimen_type[i])
1305 case DIMEN_RANGE:
1306 if (ref->u.ar.end[i])
1308 gfc_init_se (&se, NULL);
1309 gfc_conv_expr (&se, ref->u.ar.end[i]);
1310 gfc_add_block_to_block (block, &se.pre);
1311 if (ref_static_array)
1313 /* Make the index zero-based, when reffing a static
1314 array. */
1315 end = se.expr;
1316 gfc_init_se (&se, NULL);
1317 gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1318 gfc_add_block_to_block (block, &se.pre);
1319 se.expr = fold_build2 (MINUS_EXPR,
1320 gfc_array_index_type,
1321 end, fold_convert (
1322 gfc_array_index_type,
1323 se.expr));
1325 end = gfc_evaluate_now (fold_convert (
1326 gfc_array_index_type,
1327 se.expr),
1328 block);
1330 else if (ref_static_array)
1331 end = fold_build2 (MINUS_EXPR,
1332 gfc_array_index_type,
1333 gfc_conv_array_ubound (
1334 last_component_ref_tree, i),
1335 gfc_conv_array_lbound (
1336 last_component_ref_tree, i));
1337 else
1339 end = NULL_TREE;
1340 mode_rhs = build_int_cst (unsigned_char_type_node,
1341 GFC_CAF_ARR_REF_OPEN_END);
1343 if (ref->u.ar.stride[i])
1345 gfc_init_se (&se, NULL);
1346 gfc_conv_expr (&se, ref->u.ar.stride[i]);
1347 gfc_add_block_to_block (block, &se.pre);
1348 stride = gfc_evaluate_now (fold_convert (
1349 gfc_array_index_type,
1350 se.expr),
1351 block);
1352 if (ref_static_array)
1354 /* Make the index zero-based, when reffing a static
1355 array. */
1356 stride = fold_build2 (MULT_EXPR,
1357 gfc_array_index_type,
1358 gfc_conv_array_stride (
1359 last_component_ref_tree,
1361 stride);
1362 gcc_assert (end != NULL_TREE);
1363 /* Multiply with the product of array's stride and
1364 the step of the ref to a virtual upper bound.
1365 We can not compute the actual upper bound here or
1366 the caflib would compute the extend
1367 incorrectly. */
1368 end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1369 end, gfc_conv_array_stride (
1370 last_component_ref_tree,
1371 i));
1372 end = gfc_evaluate_now (end, block);
1373 stride = gfc_evaluate_now (stride, block);
1376 else if (ref_static_array)
1378 stride = gfc_conv_array_stride (last_component_ref_tree,
1380 end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1381 end, stride);
1382 end = gfc_evaluate_now (end, block);
1384 else
1385 /* Always set a ref stride of one to make caflib's
1386 handling easier. */
1387 stride = gfc_index_one_node;
1389 /* Fall through. */
1390 case DIMEN_ELEMENT:
1391 if (ref->u.ar.start[i])
1393 gfc_init_se (&se, NULL);
1394 gfc_conv_expr (&se, ref->u.ar.start[i]);
1395 gfc_add_block_to_block (block, &se.pre);
1396 if (ref_static_array)
1398 /* Make the index zero-based, when reffing a static
1399 array. */
1400 start = fold_convert (gfc_array_index_type, se.expr);
1401 gfc_init_se (&se, NULL);
1402 gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1403 gfc_add_block_to_block (block, &se.pre);
1404 se.expr = fold_build2 (MINUS_EXPR,
1405 gfc_array_index_type,
1406 start, fold_convert (
1407 gfc_array_index_type,
1408 se.expr));
1409 /* Multiply with the stride. */
1410 se.expr = fold_build2 (MULT_EXPR,
1411 gfc_array_index_type,
1412 se.expr,
1413 gfc_conv_array_stride (
1414 last_component_ref_tree,
1415 i));
1417 start = gfc_evaluate_now (fold_convert (
1418 gfc_array_index_type,
1419 se.expr),
1420 block);
1421 if (mode_rhs == NULL_TREE)
1422 mode_rhs = build_int_cst (unsigned_char_type_node,
1423 ref->u.ar.dimen_type[i]
1424 == DIMEN_ELEMENT
1425 ? GFC_CAF_ARR_REF_SINGLE
1426 : GFC_CAF_ARR_REF_RANGE);
1428 else if (ref_static_array)
1430 start = integer_zero_node;
1431 mode_rhs = build_int_cst (unsigned_char_type_node,
1432 ref->u.ar.start[i] == NULL
1433 ? GFC_CAF_ARR_REF_FULL
1434 : GFC_CAF_ARR_REF_RANGE);
1436 else if (end == NULL_TREE)
1437 mode_rhs = build_int_cst (unsigned_char_type_node,
1438 GFC_CAF_ARR_REF_FULL);
1439 else
1440 mode_rhs = build_int_cst (unsigned_char_type_node,
1441 GFC_CAF_ARR_REF_OPEN_START);
1443 /* Ref the s in dim. */
1444 field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
1445 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1446 TREE_TYPE (field), dim, field,
1447 NULL_TREE);
1449 /* Set start in s. */
1450 if (start != NULL_TREE)
1452 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1454 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1455 TREE_TYPE (field), tmp, field,
1456 NULL_TREE);
1457 gfc_add_modify (block, tmp2,
1458 fold_convert (TREE_TYPE (tmp2), start));
1461 /* Set end in s. */
1462 if (end != NULL_TREE)
1464 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1466 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1467 TREE_TYPE (field), tmp, field,
1468 NULL_TREE);
1469 gfc_add_modify (block, tmp2,
1470 fold_convert (TREE_TYPE (tmp2), end));
1473 /* Set end in s. */
1474 if (stride != NULL_TREE)
1476 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1478 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1479 TREE_TYPE (field), tmp, field,
1480 NULL_TREE);
1481 gfc_add_modify (block, tmp2,
1482 fold_convert (TREE_TYPE (tmp2), stride));
1484 break;
1485 case DIMEN_VECTOR:
1486 /* TODO: In case of static array. */
1487 gcc_assert (!ref_static_array);
1488 mode_rhs = build_int_cst (unsigned_char_type_node,
1489 GFC_CAF_ARR_REF_VECTOR);
1490 gfc_init_se (&se, NULL);
1491 se.descriptor_only = 1;
1492 gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
1493 gfc_add_block_to_block (block, &se.pre);
1494 vector = se.expr;
1495 tmp = gfc_conv_descriptor_lbound_get (vector,
1496 gfc_rank_cst[0]);
1497 tmp2 = gfc_conv_descriptor_ubound_get (vector,
1498 gfc_rank_cst[0]);
1499 nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL);
1500 tmp = gfc_conv_descriptor_stride_get (vector,
1501 gfc_rank_cst[0]);
1502 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1503 TREE_TYPE (nvec), nvec, tmp);
1504 vector = gfc_conv_descriptor_data_get (vector);
1506 /* Ref the v in dim. */
1507 field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
1508 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1509 TREE_TYPE (field), dim, field,
1510 NULL_TREE);
1512 /* Set vector in v. */
1513 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
1514 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1515 TREE_TYPE (field), tmp, field,
1516 NULL_TREE);
1517 gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1518 vector));
1520 /* Set nvec in v. */
1521 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
1522 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1523 TREE_TYPE (field), tmp, field,
1524 NULL_TREE);
1525 gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1526 nvec));
1528 /* Set kind in v. */
1529 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
1530 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1531 TREE_TYPE (field), tmp, field,
1532 NULL_TREE);
1533 gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
1534 ref->u.ar.start[i]->ts.kind));
1535 break;
1536 default:
1537 gcc_unreachable ();
1539 /* Set the mode for dim i. */
1540 tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1541 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
1542 mode_rhs));
1545 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1546 if (i < GFC_MAX_DIMENSIONS)
1548 tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1549 gfc_add_modify (block, tmp,
1550 build_int_cst (unsigned_char_type_node,
1551 GFC_CAF_ARR_REF_NONE));
1553 break;
1554 default:
1555 gcc_unreachable ();
1558 /* Set the size of the current type. */
1559 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
1560 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1561 prev_caf_ref, field, NULL_TREE);
1562 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1563 TYPE_SIZE_UNIT (last_type)));
1565 ref = ref->next;
1568 if (prev_caf_ref != NULL_TREE)
1570 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1571 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1572 prev_caf_ref, field, NULL_TREE);
1573 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1574 null_pointer_node));
1576 return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
1577 : NULL_TREE;
1580 /* Get data from a remote coarray. */
1582 static void
1583 gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
1584 tree may_require_tmp, bool may_realloc,
1585 symbol_attribute *caf_attr)
1587 gfc_expr *array_expr, *tmp_stat;
1588 gfc_se argse;
1589 tree caf_decl, token, offset, image_index, tmp;
1590 tree res_var, dst_var, type, kind, vec, stat;
1591 tree caf_reference;
1592 symbol_attribute caf_attr_store;
1594 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1596 if (se->ss && se->ss->info->useflags)
1598 /* Access the previously obtained result. */
1599 gfc_conv_tmp_array_ref (se);
1600 return;
1603 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1604 array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
1605 type = gfc_typenode_for_spec (&array_expr->ts);
1607 if (caf_attr == NULL)
1609 caf_attr_store = gfc_caf_attr (array_expr);
1610 caf_attr = &caf_attr_store;
1613 res_var = lhs;
1614 dst_var = lhs;
1616 vec = null_pointer_node;
1617 tmp_stat = gfc_find_stat_co (expr);
1619 if (tmp_stat)
1621 gfc_se stat_se;
1622 gfc_init_se (&stat_se, NULL);
1623 gfc_conv_expr_reference (&stat_se, tmp_stat);
1624 stat = stat_se.expr;
1625 gfc_add_block_to_block (&se->pre, &stat_se.pre);
1626 gfc_add_block_to_block (&se->post, &stat_se.post);
1628 else
1629 stat = null_pointer_node;
1631 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1632 is reallocatable or the right-hand side has allocatable components. */
1633 if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
1635 /* Get using caf_get_by_ref. */
1636 caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
1638 if (caf_reference != NULL_TREE)
1640 if (lhs == NULL_TREE)
1642 if (array_expr->ts.type == BT_CHARACTER)
1643 gfc_init_se (&argse, NULL);
1644 if (array_expr->rank == 0)
1646 symbol_attribute attr;
1647 gfc_clear_attr (&attr);
1648 if (array_expr->ts.type == BT_CHARACTER)
1650 res_var = gfc_conv_string_tmp (se,
1651 build_pointer_type (type),
1652 array_expr->ts.u.cl->backend_decl);
1653 argse.string_length = array_expr->ts.u.cl->backend_decl;
1655 else
1656 res_var = gfc_create_var (type, "caf_res");
1657 dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr);
1658 dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1660 else
1662 /* Create temporary. */
1663 if (array_expr->ts.type == BT_CHARACTER)
1664 gfc_conv_expr_descriptor (&argse, array_expr);
1665 may_realloc = gfc_trans_create_temp_array (&se->pre,
1666 &se->post,
1667 se->ss, type,
1668 NULL_TREE, false,
1669 false, false,
1670 &array_expr->where)
1671 == NULL_TREE;
1672 res_var = se->ss->info->data.array.descriptor;
1673 dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1674 if (may_realloc)
1676 tmp = gfc_conv_descriptor_data_get (res_var);
1677 tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
1678 NULL_TREE, NULL_TREE,
1679 NULL_TREE, true,
1680 NULL,
1681 GFC_CAF_COARRAY_NOCOARRAY);
1682 gfc_add_expr_to_block (&se->post, tmp);
1687 kind = build_int_cst (integer_type_node, expr->ts.kind);
1688 if (lhs_kind == NULL_TREE)
1689 lhs_kind = kind;
1691 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1692 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1693 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1694 image_index = gfc_caf_get_image_index (&se->pre, array_expr,
1695 caf_decl);
1696 gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
1697 array_expr);
1699 /* No overlap possible as we have generated a temporary. */
1700 if (lhs == NULL_TREE)
1701 may_require_tmp = boolean_false_node;
1703 /* It guarantees memory consistency within the same segment. */
1704 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1705 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1706 gfc_build_string_const (1, ""), NULL_TREE,
1707 NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE),
1708 NULL_TREE);
1709 ASM_VOLATILE_P (tmp) = 1;
1710 gfc_add_expr_to_block (&se->pre, tmp);
1712 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref,
1713 9, token, image_index, dst_var,
1714 caf_reference, lhs_kind, kind,
1715 may_require_tmp,
1716 may_realloc ? boolean_true_node :
1717 boolean_false_node,
1718 stat);
1720 gfc_add_expr_to_block (&se->pre, tmp);
1722 if (se->ss)
1723 gfc_advance_se_ss_chain (se);
1725 se->expr = res_var;
1726 if (array_expr->ts.type == BT_CHARACTER)
1727 se->string_length = argse.string_length;
1729 return;
1733 gfc_init_se (&argse, NULL);
1734 if (array_expr->rank == 0)
1736 symbol_attribute attr;
1738 gfc_clear_attr (&attr);
1739 gfc_conv_expr (&argse, array_expr);
1741 if (lhs == NULL_TREE)
1743 gfc_clear_attr (&attr);
1744 if (array_expr->ts.type == BT_CHARACTER)
1745 res_var = gfc_conv_string_tmp (se, build_pointer_type (type),
1746 argse.string_length);
1747 else
1748 res_var = gfc_create_var (type, "caf_res");
1749 dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
1750 dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1752 argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
1753 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1755 else
1757 /* If has_vector, pass descriptor for whole array and the
1758 vector bounds separately. */
1759 gfc_array_ref *ar, ar2;
1760 bool has_vector = false;
1762 if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
1764 has_vector = true;
1765 ar = gfc_find_array_ref (expr);
1766 ar2 = *ar;
1767 memset (ar, '\0', sizeof (*ar));
1768 ar->as = ar2.as;
1769 ar->type = AR_FULL;
1771 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1772 gfc_conv_expr_descriptor (&argse, array_expr);
1773 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1774 has the wrong type if component references are done. */
1775 gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
1776 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1777 : array_expr->rank,
1778 type));
1779 if (has_vector)
1781 vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
1782 *ar = ar2;
1785 if (lhs == NULL_TREE)
1787 /* Create temporary. */
1788 for (int n = 0; n < se->ss->loop->dimen; n++)
1789 if (se->loop->to[n] == NULL_TREE)
1791 se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr,
1792 gfc_rank_cst[n]);
1793 se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr,
1794 gfc_rank_cst[n]);
1796 gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
1797 NULL_TREE, false, true, false,
1798 &array_expr->where);
1799 res_var = se->ss->info->data.array.descriptor;
1800 dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1802 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1805 kind = build_int_cst (integer_type_node, expr->ts.kind);
1806 if (lhs_kind == NULL_TREE)
1807 lhs_kind = kind;
1809 gfc_add_block_to_block (&se->pre, &argse.pre);
1810 gfc_add_block_to_block (&se->post, &argse.post);
1812 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1813 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1814 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1815 image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1816 gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
1817 array_expr);
1819 /* No overlap possible as we have generated a temporary. */
1820 if (lhs == NULL_TREE)
1821 may_require_tmp = boolean_false_node;
1823 /* It guarantees memory consistency within the same segment. */
1824 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1825 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1826 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1827 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1828 ASM_VOLATILE_P (tmp) = 1;
1829 gfc_add_expr_to_block (&se->pre, tmp);
1831 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
1832 token, offset, image_index, argse.expr, vec,
1833 dst_var, kind, lhs_kind, may_require_tmp, stat);
1835 gfc_add_expr_to_block (&se->pre, tmp);
1837 if (se->ss)
1838 gfc_advance_se_ss_chain (se);
1840 se->expr = res_var;
1841 if (array_expr->ts.type == BT_CHARACTER)
1842 se->string_length = argse.string_length;
1846 /* Send data to a remote coarray. */
1848 static tree
1849 conv_caf_send (gfc_code *code) {
1850 gfc_expr *lhs_expr, *rhs_expr, *tmp_stat;
1851 gfc_se lhs_se, rhs_se;
1852 stmtblock_t block;
1853 tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
1854 tree may_require_tmp, src_stat, dst_stat;
1855 tree lhs_type = NULL_TREE;
1856 tree vec = null_pointer_node, rhs_vec = null_pointer_node;
1857 symbol_attribute lhs_caf_attr, rhs_caf_attr;
1859 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1861 lhs_expr = code->ext.actual->expr;
1862 rhs_expr = code->ext.actual->next->expr;
1863 may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, false) == 0
1864 ? boolean_false_node : boolean_true_node;
1865 gfc_init_block (&block);
1867 lhs_caf_attr = gfc_caf_attr (lhs_expr);
1868 rhs_caf_attr = gfc_caf_attr (rhs_expr);
1869 src_stat = dst_stat = null_pointer_node;
1871 /* LHS. */
1872 gfc_init_se (&lhs_se, NULL);
1873 if (lhs_expr->rank == 0)
1875 symbol_attribute attr;
1876 gfc_clear_attr (&attr);
1877 gfc_conv_expr (&lhs_se, lhs_expr);
1878 lhs_type = TREE_TYPE (lhs_se.expr);
1879 lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr);
1880 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1882 else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
1883 && lhs_caf_attr.codimension)
1885 lhs_se.want_pointer = 1;
1886 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1887 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1888 has the wrong type if component references are done. */
1889 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1890 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1891 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1892 gfc_get_dtype_rank_type (
1893 gfc_has_vector_subscript (lhs_expr)
1894 ? gfc_find_array_ref (lhs_expr)->dimen
1895 : lhs_expr->rank,
1896 lhs_type));
1898 else
1900 /* If has_vector, pass descriptor for whole array and the
1901 vector bounds separately. */
1902 gfc_array_ref *ar, ar2;
1903 bool has_vector = false;
1905 if (gfc_is_coindexed (lhs_expr) && gfc_has_vector_subscript (lhs_expr))
1907 has_vector = true;
1908 ar = gfc_find_array_ref (lhs_expr);
1909 ar2 = *ar;
1910 memset (ar, '\0', sizeof (*ar));
1911 ar->as = ar2.as;
1912 ar->type = AR_FULL;
1914 lhs_se.want_pointer = 1;
1915 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1916 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1917 has the wrong type if component references are done. */
1918 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1919 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1920 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1921 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1922 : lhs_expr->rank,
1923 lhs_type));
1924 if (has_vector)
1926 vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
1927 *ar = ar2;
1931 lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
1933 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1934 temporary and a loop. */
1935 if (!gfc_is_coindexed (lhs_expr)
1936 && (!lhs_caf_attr.codimension
1937 || !(lhs_expr->rank > 0
1938 && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
1940 bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
1941 gcc_assert (gfc_is_coindexed (rhs_expr));
1942 gfc_init_se (&rhs_se, NULL);
1943 if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
1945 gfc_se scal_se;
1946 gfc_init_se (&scal_se, NULL);
1947 scal_se.want_pointer = 1;
1948 gfc_conv_expr (&scal_se, lhs_expr);
1949 /* Ensure scalar on lhs is allocated. */
1950 gfc_add_block_to_block (&block, &scal_se.pre);
1952 gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
1953 TYPE_SIZE_UNIT (
1954 gfc_typenode_for_spec (&lhs_expr->ts)),
1955 NULL_TREE);
1956 tmp = fold_build2 (EQ_EXPR, boolean_type_node, scal_se.expr,
1957 null_pointer_node);
1958 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1959 tmp, gfc_finish_block (&scal_se.pre),
1960 build_empty_stmt (input_location));
1961 gfc_add_expr_to_block (&block, tmp);
1963 else
1964 lhs_may_realloc = lhs_may_realloc
1965 && gfc_full_array_ref_p (lhs_expr->ref, NULL);
1966 gfc_add_block_to_block (&block, &lhs_se.pre);
1967 gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind,
1968 may_require_tmp, lhs_may_realloc,
1969 &rhs_caf_attr);
1970 gfc_add_block_to_block (&block, &rhs_se.pre);
1971 gfc_add_block_to_block (&block, &rhs_se.post);
1972 gfc_add_block_to_block (&block, &lhs_se.post);
1973 return gfc_finish_block (&block);
1976 gfc_add_block_to_block (&block, &lhs_se.pre);
1978 /* Obtain token, offset and image index for the LHS. */
1979 caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1980 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1981 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1982 image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
1983 tmp = lhs_se.expr;
1984 if (lhs_caf_attr.alloc_comp)
1985 gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
1986 NULL);
1987 else
1988 gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
1989 lhs_expr);
1990 lhs_se.expr = tmp;
1992 /* RHS. */
1993 gfc_init_se (&rhs_se, NULL);
1994 if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
1995 && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
1996 rhs_expr = rhs_expr->value.function.actual->expr;
1997 if (rhs_expr->rank == 0)
1999 symbol_attribute attr;
2000 gfc_clear_attr (&attr);
2001 gfc_conv_expr (&rhs_se, rhs_expr);
2002 rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
2003 rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
2005 else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2006 && rhs_caf_attr.codimension)
2008 tree tmp2;
2009 rhs_se.want_pointer = 1;
2010 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2011 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2012 has the wrong type if component references are done. */
2013 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2014 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2015 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2016 gfc_get_dtype_rank_type (
2017 gfc_has_vector_subscript (rhs_expr)
2018 ? gfc_find_array_ref (rhs_expr)->dimen
2019 : rhs_expr->rank,
2020 tmp2));
2022 else
2024 /* If has_vector, pass descriptor for whole array and the
2025 vector bounds separately. */
2026 gfc_array_ref *ar, ar2;
2027 bool has_vector = false;
2028 tree tmp2;
2030 if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
2032 has_vector = true;
2033 ar = gfc_find_array_ref (rhs_expr);
2034 ar2 = *ar;
2035 memset (ar, '\0', sizeof (*ar));
2036 ar->as = ar2.as;
2037 ar->type = AR_FULL;
2039 rhs_se.want_pointer = 1;
2040 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2041 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2042 has the wrong type if component references are done. */
2043 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2044 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2045 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2046 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2047 : rhs_expr->rank,
2048 tmp2));
2049 if (has_vector)
2051 rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
2052 *ar = ar2;
2056 gfc_add_block_to_block (&block, &rhs_se.pre);
2058 rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
2060 tmp_stat = gfc_find_stat_co (lhs_expr);
2062 if (tmp_stat)
2064 gfc_se stat_se;
2065 gfc_init_se (&stat_se, NULL);
2066 gfc_conv_expr_reference (&stat_se, tmp_stat);
2067 dst_stat = stat_se.expr;
2068 gfc_add_block_to_block (&block, &stat_se.pre);
2069 gfc_add_block_to_block (&block, &stat_se.post);
2072 if (!gfc_is_coindexed (rhs_expr))
2074 if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
2076 tree reference, dst_realloc;
2077 reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2078 dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node
2079 : boolean_false_node;
2080 tmp = build_call_expr_loc (input_location,
2081 gfor_fndecl_caf_send_by_ref,
2082 9, token, image_index, rhs_se.expr,
2083 reference, lhs_kind, rhs_kind,
2084 may_require_tmp, dst_realloc, src_stat);
2086 else
2087 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 10,
2088 token, offset, image_index, lhs_se.expr, vec,
2089 rhs_se.expr, lhs_kind, rhs_kind,
2090 may_require_tmp, src_stat);
2092 else
2094 tree rhs_token, rhs_offset, rhs_image_index;
2096 /* It guarantees memory consistency within the same segment. */
2097 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2098 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2099 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2100 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2101 ASM_VOLATILE_P (tmp) = 1;
2102 gfc_add_expr_to_block (&block, tmp);
2104 caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
2105 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2106 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2107 rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
2108 tmp = rhs_se.expr;
2109 if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2111 tmp_stat = gfc_find_stat_co (lhs_expr);
2113 if (tmp_stat)
2115 gfc_se stat_se;
2116 gfc_init_se (&stat_se, NULL);
2117 gfc_conv_expr_reference (&stat_se, tmp_stat);
2118 src_stat = stat_se.expr;
2119 gfc_add_block_to_block (&block, &stat_se.pre);
2120 gfc_add_block_to_block (&block, &stat_se.post);
2123 gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
2124 NULL_TREE, NULL);
2125 tree lhs_reference, rhs_reference;
2126 lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2127 rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr);
2128 tmp = build_call_expr_loc (input_location,
2129 gfor_fndecl_caf_sendget_by_ref, 11,
2130 token, image_index, lhs_reference,
2131 rhs_token, rhs_image_index, rhs_reference,
2132 lhs_kind, rhs_kind, may_require_tmp,
2133 dst_stat, src_stat);
2135 else
2137 gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
2138 tmp, rhs_expr);
2139 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
2140 14, token, offset, image_index,
2141 lhs_se.expr, vec, rhs_token, rhs_offset,
2142 rhs_image_index, tmp, rhs_vec, lhs_kind,
2143 rhs_kind, may_require_tmp, src_stat);
2146 gfc_add_expr_to_block (&block, tmp);
2147 gfc_add_block_to_block (&block, &lhs_se.post);
2148 gfc_add_block_to_block (&block, &rhs_se.post);
2150 /* It guarantees memory consistency within the same segment. */
2151 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2152 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2153 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2154 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2155 ASM_VOLATILE_P (tmp) = 1;
2156 gfc_add_expr_to_block (&block, tmp);
2158 return gfc_finish_block (&block);
2162 static void
2163 trans_this_image (gfc_se * se, gfc_expr *expr)
2165 stmtblock_t loop;
2166 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
2167 lbound, ubound, extent, ml;
2168 gfc_se argse;
2169 int rank, corank;
2170 gfc_expr *distance = expr->value.function.actual->next->next->expr;
2172 if (expr->value.function.actual->expr
2173 && !gfc_is_coarray (expr->value.function.actual->expr))
2174 distance = expr->value.function.actual->expr;
2176 /* The case -fcoarray=single is handled elsewhere. */
2177 gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
2179 /* Argument-free version: THIS_IMAGE(). */
2180 if (distance || expr->value.function.actual->expr == NULL)
2182 if (distance)
2184 gfc_init_se (&argse, NULL);
2185 gfc_conv_expr_val (&argse, distance);
2186 gfc_add_block_to_block (&se->pre, &argse.pre);
2187 gfc_add_block_to_block (&se->post, &argse.post);
2188 tmp = fold_convert (integer_type_node, argse.expr);
2190 else
2191 tmp = integer_zero_node;
2192 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2193 tmp);
2194 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2195 tmp);
2196 return;
2199 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2201 type = gfc_get_int_type (gfc_default_integer_kind);
2202 corank = gfc_get_corank (expr->value.function.actual->expr);
2203 rank = expr->value.function.actual->expr->rank;
2205 /* Obtain the descriptor of the COARRAY. */
2206 gfc_init_se (&argse, NULL);
2207 argse.want_coarray = 1;
2208 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2209 gfc_add_block_to_block (&se->pre, &argse.pre);
2210 gfc_add_block_to_block (&se->post, &argse.post);
2211 desc = argse.expr;
2213 if (se->ss)
2215 /* Create an implicit second parameter from the loop variable. */
2216 gcc_assert (!expr->value.function.actual->next->expr);
2217 gcc_assert (corank > 0);
2218 gcc_assert (se->loop->dimen == 1);
2219 gcc_assert (se->ss->info->expr == expr);
2221 dim_arg = se->loop->loopvar[0];
2222 dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
2223 gfc_array_index_type, dim_arg,
2224 build_int_cst (TREE_TYPE (dim_arg), 1));
2225 gfc_advance_se_ss_chain (se);
2227 else
2229 /* Use the passed DIM= argument. */
2230 gcc_assert (expr->value.function.actual->next->expr);
2231 gfc_init_se (&argse, NULL);
2232 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
2233 gfc_array_index_type);
2234 gfc_add_block_to_block (&se->pre, &argse.pre);
2235 dim_arg = argse.expr;
2237 if (INTEGER_CST_P (dim_arg))
2239 if (wi::ltu_p (dim_arg, 1)
2240 || wi::gtu_p (dim_arg, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2241 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2242 "dimension index", expr->value.function.isym->name,
2243 &expr->where);
2245 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2247 dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
2248 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2249 dim_arg,
2250 build_int_cst (TREE_TYPE (dim_arg), 1));
2251 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2252 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2253 dim_arg, tmp);
2254 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2255 boolean_type_node, cond, tmp);
2256 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2257 gfc_msg_fault);
2261 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2262 one always has a dim_arg argument.
2264 m = this_image() - 1
2265 if (corank == 1)
2267 sub(1) = m + lcobound(corank)
2268 return;
2270 i = rank
2271 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2272 for (;;)
2274 extent = gfc_extent(i)
2275 ml = m
2276 m = m/extent
2277 if (i >= min_var)
2278 goto exit_label
2281 exit_label:
2282 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2283 : m + lcobound(corank)
2286 /* this_image () - 1. */
2287 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2288 integer_zero_node);
2289 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
2290 fold_convert (type, tmp), build_int_cst (type, 1));
2291 if (corank == 1)
2293 /* sub(1) = m + lcobound(corank). */
2294 lbound = gfc_conv_descriptor_lbound_get (desc,
2295 build_int_cst (TREE_TYPE (gfc_array_index_type),
2296 corank+rank-1));
2297 lbound = fold_convert (type, lbound);
2298 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2300 se->expr = tmp;
2301 return;
2304 m = gfc_create_var (type, NULL);
2305 ml = gfc_create_var (type, NULL);
2306 loop_var = gfc_create_var (integer_type_node, NULL);
2307 min_var = gfc_create_var (integer_type_node, NULL);
2309 /* m = this_image () - 1. */
2310 gfc_add_modify (&se->pre, m, tmp);
2312 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2313 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2314 fold_convert (integer_type_node, dim_arg),
2315 build_int_cst (integer_type_node, rank - 1));
2316 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
2317 build_int_cst (integer_type_node, rank + corank - 2),
2318 tmp);
2319 gfc_add_modify (&se->pre, min_var, tmp);
2321 /* i = rank. */
2322 tmp = build_int_cst (integer_type_node, rank);
2323 gfc_add_modify (&se->pre, loop_var, tmp);
2325 exit_label = gfc_build_label_decl (NULL_TREE);
2326 TREE_USED (exit_label) = 1;
2328 /* Loop body. */
2329 gfc_init_block (&loop);
2331 /* ml = m. */
2332 gfc_add_modify (&loop, ml, m);
2334 /* extent = ... */
2335 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
2336 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
2337 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2338 extent = fold_convert (type, extent);
2340 /* m = m/extent. */
2341 gfc_add_modify (&loop, m,
2342 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2343 m, extent));
2345 /* Exit condition: if (i >= min_var) goto exit_label. */
2346 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
2347 min_var);
2348 tmp = build1_v (GOTO_EXPR, exit_label);
2349 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2350 build_empty_stmt (input_location));
2351 gfc_add_expr_to_block (&loop, tmp);
2353 /* Increment loop variable: i++. */
2354 gfc_add_modify (&loop, loop_var,
2355 fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2356 loop_var,
2357 build_int_cst (integer_type_node, 1)));
2359 /* Making the loop... actually loop! */
2360 tmp = gfc_finish_block (&loop);
2361 tmp = build1_v (LOOP_EXPR, tmp);
2362 gfc_add_expr_to_block (&se->pre, tmp);
2364 /* The exit label. */
2365 tmp = build1_v (LABEL_EXPR, exit_label);
2366 gfc_add_expr_to_block (&se->pre, tmp);
2368 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2369 : m + lcobound(corank) */
2371 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
2372 build_int_cst (TREE_TYPE (dim_arg), corank));
2374 lbound = gfc_conv_descriptor_lbound_get (desc,
2375 fold_build2_loc (input_location, PLUS_EXPR,
2376 gfc_array_index_type, dim_arg,
2377 build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2378 lbound = fold_convert (type, lbound);
2380 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2381 fold_build2_loc (input_location, MULT_EXPR, type,
2382 m, extent));
2383 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2385 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2386 fold_build2_loc (input_location, PLUS_EXPR, type,
2387 m, lbound));
2391 /* Convert a call to image_status. */
2393 static void
2394 conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2396 unsigned int num_args;
2397 tree *args, tmp;
2399 num_args = gfc_intrinsic_argument_list_length (expr);
2400 args = XALLOCAVEC (tree, num_args);
2401 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2402 /* In args[0] the number of the image the status is desired for has to be
2403 given. */
2405 if (flag_coarray == GFC_FCOARRAY_SINGLE)
2407 tree arg;
2408 arg = gfc_evaluate_now (args[0], &se->pre);
2409 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2410 fold_convert (integer_type_node, arg),
2411 integer_one_node);
2412 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2413 tmp, integer_zero_node,
2414 build_int_cst (integer_type_node,
2415 GFC_STAT_STOPPED_IMAGE));
2417 else if (flag_coarray == GFC_FCOARRAY_LIB)
2418 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2419 args[0], build_int_cst (integer_type_node, -1));
2420 else
2421 gcc_unreachable ();
2423 se->expr = tmp;
2427 static void
2428 trans_image_index (gfc_se * se, gfc_expr *expr)
2430 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
2431 tmp, invalid_bound;
2432 gfc_se argse, subse;
2433 int rank, corank, codim;
2435 type = gfc_get_int_type (gfc_default_integer_kind);
2436 corank = gfc_get_corank (expr->value.function.actual->expr);
2437 rank = expr->value.function.actual->expr->rank;
2439 /* Obtain the descriptor of the COARRAY. */
2440 gfc_init_se (&argse, NULL);
2441 argse.want_coarray = 1;
2442 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2443 gfc_add_block_to_block (&se->pre, &argse.pre);
2444 gfc_add_block_to_block (&se->post, &argse.post);
2445 desc = argse.expr;
2447 /* Obtain a handle to the SUB argument. */
2448 gfc_init_se (&subse, NULL);
2449 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2450 gfc_add_block_to_block (&se->pre, &subse.pre);
2451 gfc_add_block_to_block (&se->post, &subse.post);
2452 subdesc = build_fold_indirect_ref_loc (input_location,
2453 gfc_conv_descriptor_data_get (subse.expr));
2455 /* Fortran 2008 does not require that the values remain in the cobounds,
2456 thus we need explicitly check this - and return 0 if they are exceeded. */
2458 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2459 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2460 invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2461 fold_convert (gfc_array_index_type, tmp),
2462 lbound);
2464 for (codim = corank + rank - 2; codim >= rank; codim--)
2466 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2467 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2468 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2469 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2470 fold_convert (gfc_array_index_type, tmp),
2471 lbound);
2472 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2473 boolean_type_node, invalid_bound, cond);
2474 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2475 fold_convert (gfc_array_index_type, tmp),
2476 ubound);
2477 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2478 boolean_type_node, invalid_bound, cond);
2481 invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2483 /* See Fortran 2008, C.10 for the following algorithm. */
2485 /* coindex = sub(corank) - lcobound(n). */
2486 coindex = fold_convert (gfc_array_index_type,
2487 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2488 NULL));
2489 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2490 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2491 fold_convert (gfc_array_index_type, coindex),
2492 lbound);
2494 for (codim = corank + rank - 2; codim >= rank; codim--)
2496 tree extent, ubound;
2498 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2499 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2500 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2501 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2503 /* coindex *= extent. */
2504 coindex = fold_build2_loc (input_location, MULT_EXPR,
2505 gfc_array_index_type, coindex, extent);
2507 /* coindex += sub(codim). */
2508 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2509 coindex = fold_build2_loc (input_location, PLUS_EXPR,
2510 gfc_array_index_type, coindex,
2511 fold_convert (gfc_array_index_type, tmp));
2513 /* coindex -= lbound(codim). */
2514 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2515 coindex = fold_build2_loc (input_location, MINUS_EXPR,
2516 gfc_array_index_type, coindex, lbound);
2519 coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2520 fold_convert(type, coindex),
2521 build_int_cst (type, 1));
2523 /* Return 0 if "coindex" exceeds num_images(). */
2525 if (flag_coarray == GFC_FCOARRAY_SINGLE)
2526 num_images = build_int_cst (type, 1);
2527 else
2529 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2530 integer_zero_node,
2531 build_int_cst (integer_type_node, -1));
2532 num_images = fold_convert (type, tmp);
2535 tmp = gfc_create_var (type, NULL);
2536 gfc_add_modify (&se->pre, tmp, coindex);
2538 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
2539 num_images);
2540 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
2541 cond,
2542 fold_convert (boolean_type_node, invalid_bound));
2543 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2544 build_int_cst (type, 0), tmp);
2548 static void
2549 trans_num_images (gfc_se * se, gfc_expr *expr)
2551 tree tmp, distance, failed;
2552 gfc_se argse;
2554 if (expr->value.function.actual->expr)
2556 gfc_init_se (&argse, NULL);
2557 gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2558 gfc_add_block_to_block (&se->pre, &argse.pre);
2559 gfc_add_block_to_block (&se->post, &argse.post);
2560 distance = fold_convert (integer_type_node, argse.expr);
2562 else
2563 distance = integer_zero_node;
2565 if (expr->value.function.actual->next->expr)
2567 gfc_init_se (&argse, NULL);
2568 gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
2569 gfc_add_block_to_block (&se->pre, &argse.pre);
2570 gfc_add_block_to_block (&se->post, &argse.post);
2571 failed = fold_convert (integer_type_node, argse.expr);
2573 else
2574 failed = build_int_cst (integer_type_node, -1);
2576 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2577 distance, failed);
2578 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2582 static void
2583 gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2585 gfc_se argse;
2587 gfc_init_se (&argse, NULL);
2588 argse.data_not_needed = 1;
2589 argse.descriptor_only = 1;
2591 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2592 gfc_add_block_to_block (&se->pre, &argse.pre);
2593 gfc_add_block_to_block (&se->post, &argse.post);
2595 se->expr = gfc_conv_descriptor_rank (argse.expr);
2599 /* Evaluate a single upper or lower bound. */
2600 /* TODO: bound intrinsic generates way too much unnecessary code. */
2602 static void
2603 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
2605 gfc_actual_arglist *arg;
2606 gfc_actual_arglist *arg2;
2607 tree desc;
2608 tree type;
2609 tree bound;
2610 tree tmp;
2611 tree cond, cond1, cond3, cond4, size;
2612 tree ubound;
2613 tree lbound;
2614 gfc_se argse;
2615 gfc_array_spec * as;
2616 bool assumed_rank_lb_one;
2618 arg = expr->value.function.actual;
2619 arg2 = arg->next;
2621 if (se->ss)
2623 /* Create an implicit second parameter from the loop variable. */
2624 gcc_assert (!arg2->expr);
2625 gcc_assert (se->loop->dimen == 1);
2626 gcc_assert (se->ss->info->expr == expr);
2627 gfc_advance_se_ss_chain (se);
2628 bound = se->loop->loopvar[0];
2629 bound = fold_build2_loc (input_location, MINUS_EXPR,
2630 gfc_array_index_type, bound,
2631 se->loop->from[0]);
2633 else
2635 /* use the passed argument. */
2636 gcc_assert (arg2->expr);
2637 gfc_init_se (&argse, NULL);
2638 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2639 gfc_add_block_to_block (&se->pre, &argse.pre);
2640 bound = argse.expr;
2641 /* Convert from one based to zero based. */
2642 bound = fold_build2_loc (input_location, MINUS_EXPR,
2643 gfc_array_index_type, bound,
2644 gfc_index_one_node);
2647 /* TODO: don't re-evaluate the descriptor on each iteration. */
2648 /* Get a descriptor for the first parameter. */
2649 gfc_init_se (&argse, NULL);
2650 gfc_conv_expr_descriptor (&argse, arg->expr);
2651 gfc_add_block_to_block (&se->pre, &argse.pre);
2652 gfc_add_block_to_block (&se->post, &argse.post);
2654 desc = argse.expr;
2656 as = gfc_get_full_arrayspec_from_expr (arg->expr);
2658 if (INTEGER_CST_P (bound))
2660 if (((!as || as->type != AS_ASSUMED_RANK)
2661 && wi::geu_p (bound, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2662 || wi::gtu_p (bound, GFC_MAX_DIMENSIONS))
2663 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2664 "dimension index", upper ? "UBOUND" : "LBOUND",
2665 &expr->where);
2668 if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2670 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2672 bound = gfc_evaluate_now (bound, &se->pre);
2673 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2674 bound, build_int_cst (TREE_TYPE (bound), 0));
2675 if (as && as->type == AS_ASSUMED_RANK)
2676 tmp = gfc_conv_descriptor_rank (desc);
2677 else
2678 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2679 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
2680 bound, fold_convert(TREE_TYPE (bound), tmp));
2681 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2682 boolean_type_node, cond, tmp);
2683 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2684 gfc_msg_fault);
2688 /* Take care of the lbound shift for assumed-rank arrays, which are
2689 nonallocatable and nonpointers. Those has a lbound of 1. */
2690 assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2691 && ((arg->expr->ts.type != BT_CLASS
2692 && !arg->expr->symtree->n.sym->attr.allocatable
2693 && !arg->expr->symtree->n.sym->attr.pointer)
2694 || (arg->expr->ts.type == BT_CLASS
2695 && !CLASS_DATA (arg->expr)->attr.allocatable
2696 && !CLASS_DATA (arg->expr)->attr.class_pointer));
2698 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2699 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2701 /* 13.14.53: Result value for LBOUND
2703 Case (i): For an array section or for an array expression other than a
2704 whole array or array structure component, LBOUND(ARRAY, DIM)
2705 has the value 1. For a whole array or array structure
2706 component, LBOUND(ARRAY, DIM) has the value:
2707 (a) equal to the lower bound for subscript DIM of ARRAY if
2708 dimension DIM of ARRAY does not have extent zero
2709 or if ARRAY is an assumed-size array of rank DIM,
2710 or (b) 1 otherwise.
2712 13.14.113: Result value for UBOUND
2714 Case (i): For an array section or for an array expression other than a
2715 whole array or array structure component, UBOUND(ARRAY, DIM)
2716 has the value equal to the number of elements in the given
2717 dimension; otherwise, it has a value equal to the upper bound
2718 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2719 not have size zero and has value zero if dimension DIM has
2720 size zero. */
2722 if (!upper && assumed_rank_lb_one)
2723 se->expr = gfc_index_one_node;
2724 else if (as)
2726 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
2728 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
2729 ubound, lbound);
2730 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
2731 stride, gfc_index_zero_node);
2732 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2733 boolean_type_node, cond3, cond1);
2734 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2735 stride, gfc_index_zero_node);
2737 if (upper)
2739 tree cond5;
2740 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2741 boolean_type_node, cond3, cond4);
2742 cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2743 gfc_index_one_node, lbound);
2744 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2745 boolean_type_node, cond4, cond5);
2747 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2748 boolean_type_node, cond, cond5);
2750 if (assumed_rank_lb_one)
2752 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2753 gfc_array_index_type, ubound, lbound);
2754 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2755 gfc_array_index_type, tmp, gfc_index_one_node);
2757 else
2758 tmp = ubound;
2760 se->expr = fold_build3_loc (input_location, COND_EXPR,
2761 gfc_array_index_type, cond,
2762 tmp, gfc_index_zero_node);
2764 else
2766 if (as->type == AS_ASSUMED_SIZE)
2767 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2768 bound, build_int_cst (TREE_TYPE (bound),
2769 arg->expr->rank - 1));
2770 else
2771 cond = boolean_false_node;
2773 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2774 boolean_type_node, cond3, cond4);
2775 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2776 boolean_type_node, cond, cond1);
2778 se->expr = fold_build3_loc (input_location, COND_EXPR,
2779 gfc_array_index_type, cond,
2780 lbound, gfc_index_one_node);
2783 else
2785 if (upper)
2787 size = fold_build2_loc (input_location, MINUS_EXPR,
2788 gfc_array_index_type, ubound, lbound);
2789 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
2790 gfc_array_index_type, size,
2791 gfc_index_one_node);
2792 se->expr = fold_build2_loc (input_location, MAX_EXPR,
2793 gfc_array_index_type, se->expr,
2794 gfc_index_zero_node);
2796 else
2797 se->expr = gfc_index_one_node;
2800 type = gfc_typenode_for_spec (&expr->ts);
2801 se->expr = convert (type, se->expr);
2805 static void
2806 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2808 gfc_actual_arglist *arg;
2809 gfc_actual_arglist *arg2;
2810 gfc_se argse;
2811 tree bound, resbound, resbound2, desc, cond, tmp;
2812 tree type;
2813 int corank;
2815 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2816 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2817 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2819 arg = expr->value.function.actual;
2820 arg2 = arg->next;
2822 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2823 corank = gfc_get_corank (arg->expr);
2825 gfc_init_se (&argse, NULL);
2826 argse.want_coarray = 1;
2828 gfc_conv_expr_descriptor (&argse, arg->expr);
2829 gfc_add_block_to_block (&se->pre, &argse.pre);
2830 gfc_add_block_to_block (&se->post, &argse.post);
2831 desc = argse.expr;
2833 if (se->ss)
2835 /* Create an implicit second parameter from the loop variable. */
2836 gcc_assert (!arg2->expr);
2837 gcc_assert (corank > 0);
2838 gcc_assert (se->loop->dimen == 1);
2839 gcc_assert (se->ss->info->expr == expr);
2841 bound = se->loop->loopvar[0];
2842 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2843 bound, gfc_rank_cst[arg->expr->rank]);
2844 gfc_advance_se_ss_chain (se);
2846 else
2848 /* use the passed argument. */
2849 gcc_assert (arg2->expr);
2850 gfc_init_se (&argse, NULL);
2851 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2852 gfc_add_block_to_block (&se->pre, &argse.pre);
2853 bound = argse.expr;
2855 if (INTEGER_CST_P (bound))
2857 if (wi::ltu_p (bound, 1)
2858 || wi::gtu_p (bound, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2859 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2860 "dimension index", expr->value.function.isym->name,
2861 &expr->where);
2863 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2865 bound = gfc_evaluate_now (bound, &se->pre);
2866 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2867 bound, build_int_cst (TREE_TYPE (bound), 1));
2868 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2869 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2870 bound, tmp);
2871 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2872 boolean_type_node, cond, tmp);
2873 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2874 gfc_msg_fault);
2878 /* Subtract 1 to get to zero based and add dimensions. */
2879 switch (arg->expr->rank)
2881 case 0:
2882 bound = fold_build2_loc (input_location, MINUS_EXPR,
2883 gfc_array_index_type, bound,
2884 gfc_index_one_node);
2885 case 1:
2886 break;
2887 default:
2888 bound = fold_build2_loc (input_location, PLUS_EXPR,
2889 gfc_array_index_type, bound,
2890 gfc_rank_cst[arg->expr->rank - 1]);
2894 resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2896 /* Handle UCOBOUND with special handling of the last codimension. */
2897 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
2899 /* Last codimension: For -fcoarray=single just return
2900 the lcobound - otherwise add
2901 ceiling (real (num_images ()) / real (size)) - 1
2902 = (num_images () + size - 1) / size - 1
2903 = (num_images - 1) / size(),
2904 where size is the product of the extent of all but the last
2905 codimension. */
2907 if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2909 tree cosize;
2911 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
2912 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2913 2, integer_zero_node,
2914 build_int_cst (integer_type_node, -1));
2915 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2916 gfc_array_index_type,
2917 fold_convert (gfc_array_index_type, tmp),
2918 build_int_cst (gfc_array_index_type, 1));
2919 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2920 gfc_array_index_type, tmp,
2921 fold_convert (gfc_array_index_type, cosize));
2922 resbound = fold_build2_loc (input_location, PLUS_EXPR,
2923 gfc_array_index_type, resbound, tmp);
2925 else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2927 /* ubound = lbound + num_images() - 1. */
2928 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2929 2, integer_zero_node,
2930 build_int_cst (integer_type_node, -1));
2931 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2932 gfc_array_index_type,
2933 fold_convert (gfc_array_index_type, tmp),
2934 build_int_cst (gfc_array_index_type, 1));
2935 resbound = fold_build2_loc (input_location, PLUS_EXPR,
2936 gfc_array_index_type, resbound, tmp);
2939 if (corank > 1)
2941 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2942 bound,
2943 build_int_cst (TREE_TYPE (bound),
2944 arg->expr->rank + corank - 1));
2946 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2947 se->expr = fold_build3_loc (input_location, COND_EXPR,
2948 gfc_array_index_type, cond,
2949 resbound, resbound2);
2951 else
2952 se->expr = resbound;
2954 else
2955 se->expr = resbound;
2957 type = gfc_typenode_for_spec (&expr->ts);
2958 se->expr = convert (type, se->expr);
2962 static void
2963 conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2965 gfc_actual_arglist *array_arg;
2966 gfc_actual_arglist *dim_arg;
2967 gfc_se argse;
2968 tree desc, tmp;
2970 array_arg = expr->value.function.actual;
2971 dim_arg = array_arg->next;
2973 gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2975 gfc_init_se (&argse, NULL);
2976 gfc_conv_expr_descriptor (&argse, array_arg->expr);
2977 gfc_add_block_to_block (&se->pre, &argse.pre);
2978 gfc_add_block_to_block (&se->post, &argse.post);
2979 desc = argse.expr;
2981 gcc_assert (dim_arg->expr);
2982 gfc_init_se (&argse, NULL);
2983 gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2984 gfc_add_block_to_block (&se->pre, &argse.pre);
2985 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2986 argse.expr, gfc_index_one_node);
2987 se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2991 static void
2992 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2994 tree arg, cabs;
2996 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2998 switch (expr->value.function.actual->expr->ts.type)
3000 case BT_INTEGER:
3001 case BT_REAL:
3002 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
3003 arg);
3004 break;
3006 case BT_COMPLEX:
3007 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
3008 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
3009 break;
3011 default:
3012 gcc_unreachable ();
3017 /* Create a complex value from one or two real components. */
3019 static void
3020 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
3022 tree real;
3023 tree imag;
3024 tree type;
3025 tree *args;
3026 unsigned int num_args;
3028 num_args = gfc_intrinsic_argument_list_length (expr);
3029 args = XALLOCAVEC (tree, num_args);
3031 type = gfc_typenode_for_spec (&expr->ts);
3032 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3033 real = convert (TREE_TYPE (type), args[0]);
3034 if (both)
3035 imag = convert (TREE_TYPE (type), args[1]);
3036 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
3038 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
3039 TREE_TYPE (TREE_TYPE (args[0])), args[0]);
3040 imag = convert (TREE_TYPE (type), imag);
3042 else
3043 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
3045 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
3049 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3050 MODULO(A, P) = A - FLOOR (A / P) * P
3052 The obvious algorithms above are numerically instable for large
3053 arguments, hence these intrinsics are instead implemented via calls
3054 to the fmod family of functions. It is the responsibility of the
3055 user to ensure that the second argument is non-zero. */
3057 static void
3058 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
3060 tree type;
3061 tree tmp;
3062 tree test;
3063 tree test2;
3064 tree fmod;
3065 tree zero;
3066 tree args[2];
3068 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3070 switch (expr->ts.type)
3072 case BT_INTEGER:
3073 /* Integer case is easy, we've got a builtin op. */
3074 type = TREE_TYPE (args[0]);
3076 if (modulo)
3077 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
3078 args[0], args[1]);
3079 else
3080 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
3081 args[0], args[1]);
3082 break;
3084 case BT_REAL:
3085 fmod = NULL_TREE;
3086 /* Check if we have a builtin fmod. */
3087 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
3089 /* The builtin should always be available. */
3090 gcc_assert (fmod != NULL_TREE);
3092 tmp = build_addr (fmod);
3093 se->expr = build_call_array_loc (input_location,
3094 TREE_TYPE (TREE_TYPE (fmod)),
3095 tmp, 2, args);
3096 if (modulo == 0)
3097 return;
3099 type = TREE_TYPE (args[0]);
3101 args[0] = gfc_evaluate_now (args[0], &se->pre);
3102 args[1] = gfc_evaluate_now (args[1], &se->pre);
3104 /* Definition:
3105 modulo = arg - floor (arg/arg2) * arg2
3107 In order to calculate the result accurately, we use the fmod
3108 function as follows.
3110 res = fmod (arg, arg2);
3111 if (res)
3113 if ((arg < 0) xor (arg2 < 0))
3114 res += arg2;
3116 else
3117 res = copysign (0., arg2);
3119 => As two nested ternary exprs:
3121 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3122 : copysign (0., arg2);
3126 zero = gfc_build_const (type, integer_zero_node);
3127 tmp = gfc_evaluate_now (se->expr, &se->pre);
3128 if (!flag_signed_zeros)
3130 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3131 args[0], zero);
3132 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3133 args[1], zero);
3134 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3135 boolean_type_node, test, test2);
3136 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
3137 tmp, zero);
3138 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3139 boolean_type_node, test, test2);
3140 test = gfc_evaluate_now (test, &se->pre);
3141 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3142 fold_build2_loc (input_location,
3143 PLUS_EXPR,
3144 type, tmp, args[1]),
3145 tmp);
3147 else
3149 tree expr1, copysign, cscall;
3150 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
3151 expr->ts.kind);
3152 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3153 args[0], zero);
3154 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3155 args[1], zero);
3156 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3157 boolean_type_node, test, test2);
3158 expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3159 fold_build2_loc (input_location,
3160 PLUS_EXPR,
3161 type, tmp, args[1]),
3162 tmp);
3163 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
3164 tmp, zero);
3165 cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3166 args[1]);
3167 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3168 expr1, cscall);
3170 return;
3172 default:
3173 gcc_unreachable ();
3177 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3178 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3179 where the right shifts are logical (i.e. 0's are shifted in).
3180 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3181 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3182 DSHIFTL(I,J,0) = I
3183 DSHIFTL(I,J,BITSIZE) = J
3184 DSHIFTR(I,J,0) = J
3185 DSHIFTR(I,J,BITSIZE) = I. */
3187 static void
3188 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3190 tree type, utype, stype, arg1, arg2, shift, res, left, right;
3191 tree args[3], cond, tmp;
3192 int bitsize;
3194 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3196 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3197 type = TREE_TYPE (args[0]);
3198 bitsize = TYPE_PRECISION (type);
3199 utype = unsigned_type_for (type);
3200 stype = TREE_TYPE (args[2]);
3202 arg1 = gfc_evaluate_now (args[0], &se->pre);
3203 arg2 = gfc_evaluate_now (args[1], &se->pre);
3204 shift = gfc_evaluate_now (args[2], &se->pre);
3206 /* The generic case. */
3207 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3208 build_int_cst (stype, bitsize), shift);
3209 left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3210 arg1, dshiftl ? shift : tmp);
3212 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3213 fold_convert (utype, arg2), dshiftl ? tmp : shift);
3214 right = fold_convert (type, right);
3216 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3218 /* Special cases. */
3219 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
3220 build_int_cst (stype, 0));
3221 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3222 dshiftl ? arg1 : arg2, res);
3224 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
3225 build_int_cst (stype, bitsize));
3226 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3227 dshiftl ? arg2 : arg1, res);
3229 se->expr = res;
3233 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3235 static void
3236 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3238 tree val;
3239 tree tmp;
3240 tree type;
3241 tree zero;
3242 tree args[2];
3244 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3245 type = TREE_TYPE (args[0]);
3247 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3248 val = gfc_evaluate_now (val, &se->pre);
3250 zero = gfc_build_const (type, integer_zero_node);
3251 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
3252 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3256 /* SIGN(A, B) is absolute value of A times sign of B.
3257 The real value versions use library functions to ensure the correct
3258 handling of negative zero. Integer case implemented as:
3259 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3262 static void
3263 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3265 tree tmp;
3266 tree type;
3267 tree args[2];
3269 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3270 if (expr->ts.type == BT_REAL)
3272 tree abs;
3274 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3275 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3277 /* We explicitly have to ignore the minus sign. We do so by using
3278 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3279 if (!flag_sign_zero
3280 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3282 tree cond, zero;
3283 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3284 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3285 args[1], zero);
3286 se->expr = fold_build3_loc (input_location, COND_EXPR,
3287 TREE_TYPE (args[0]), cond,
3288 build_call_expr_loc (input_location, abs, 1,
3289 args[0]),
3290 build_call_expr_loc (input_location, tmp, 2,
3291 args[0], args[1]));
3293 else
3294 se->expr = build_call_expr_loc (input_location, tmp, 2,
3295 args[0], args[1]);
3296 return;
3299 /* Having excluded floating point types, we know we are now dealing
3300 with signed integer types. */
3301 type = TREE_TYPE (args[0]);
3303 /* Args[0] is used multiple times below. */
3304 args[0] = gfc_evaluate_now (args[0], &se->pre);
3306 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3307 the signs of A and B are the same, and of all ones if they differ. */
3308 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3309 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3310 build_int_cst (type, TYPE_PRECISION (type) - 1));
3311 tmp = gfc_evaluate_now (tmp, &se->pre);
3313 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3314 is all ones (i.e. -1). */
3315 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3316 fold_build2_loc (input_location, PLUS_EXPR,
3317 type, args[0], tmp), tmp);
3321 /* Test for the presence of an optional argument. */
3323 static void
3324 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3326 gfc_expr *arg;
3328 arg = expr->value.function.actual->expr;
3329 gcc_assert (arg->expr_type == EXPR_VARIABLE);
3330 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3331 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3335 /* Calculate the double precision product of two single precision values. */
3337 static void
3338 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3340 tree type;
3341 tree args[2];
3343 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3345 /* Convert the args to double precision before multiplying. */
3346 type = gfc_typenode_for_spec (&expr->ts);
3347 args[0] = convert (type, args[0]);
3348 args[1] = convert (type, args[1]);
3349 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3350 args[1]);
3354 /* Return a length one character string containing an ascii character. */
3356 static void
3357 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3359 tree arg[2];
3360 tree var;
3361 tree type;
3362 unsigned int num_args;
3364 num_args = gfc_intrinsic_argument_list_length (expr);
3365 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3367 type = gfc_get_char_type (expr->ts.kind);
3368 var = gfc_create_var (type, "char");
3370 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3371 gfc_add_modify (&se->pre, var, arg[0]);
3372 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3373 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3377 static void
3378 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3380 tree var;
3381 tree len;
3382 tree tmp;
3383 tree cond;
3384 tree fndecl;
3385 tree *args;
3386 unsigned int num_args;
3388 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3389 args = XALLOCAVEC (tree, num_args);
3391 var = gfc_create_var (pchar_type_node, "pstr");
3392 len = gfc_create_var (gfc_charlen_type_node, "len");
3394 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3395 args[0] = gfc_build_addr_expr (NULL_TREE, var);
3396 args[1] = gfc_build_addr_expr (NULL_TREE, len);
3398 fndecl = build_addr (gfor_fndecl_ctime);
3399 tmp = build_call_array_loc (input_location,
3400 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3401 fndecl, num_args, args);
3402 gfc_add_expr_to_block (&se->pre, tmp);
3404 /* Free the temporary afterwards, if necessary. */
3405 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
3406 len, build_int_cst (TREE_TYPE (len), 0));
3407 tmp = gfc_call_free (var);
3408 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3409 gfc_add_expr_to_block (&se->post, tmp);
3411 se->expr = var;
3412 se->string_length = len;
3416 static void
3417 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3419 tree var;
3420 tree len;
3421 tree tmp;
3422 tree cond;
3423 tree fndecl;
3424 tree *args;
3425 unsigned int num_args;
3427 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3428 args = XALLOCAVEC (tree, num_args);
3430 var = gfc_create_var (pchar_type_node, "pstr");
3431 len = gfc_create_var (gfc_charlen_type_node, "len");
3433 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3434 args[0] = gfc_build_addr_expr (NULL_TREE, var);
3435 args[1] = gfc_build_addr_expr (NULL_TREE, len);
3437 fndecl = build_addr (gfor_fndecl_fdate);
3438 tmp = build_call_array_loc (input_location,
3439 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3440 fndecl, num_args, args);
3441 gfc_add_expr_to_block (&se->pre, tmp);
3443 /* Free the temporary afterwards, if necessary. */
3444 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
3445 len, build_int_cst (TREE_TYPE (len), 0));
3446 tmp = gfc_call_free (var);
3447 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3448 gfc_add_expr_to_block (&se->post, tmp);
3450 se->expr = var;
3451 se->string_length = len;
3455 /* Generate a direct call to free() for the FREE subroutine. */
3457 static tree
3458 conv_intrinsic_free (gfc_code *code)
3460 stmtblock_t block;
3461 gfc_se argse;
3462 tree arg, call;
3464 gfc_init_se (&argse, NULL);
3465 gfc_conv_expr (&argse, code->ext.actual->expr);
3466 arg = fold_convert (ptr_type_node, argse.expr);
3468 gfc_init_block (&block);
3469 call = build_call_expr_loc (input_location,
3470 builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3471 gfc_add_expr_to_block (&block, call);
3472 return gfc_finish_block (&block);
3476 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3477 conversions. */
3479 static tree
3480 conv_intrinsic_system_clock (gfc_code *code)
3482 stmtblock_t block;
3483 gfc_se count_se, count_rate_se, count_max_se;
3484 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3485 tree tmp;
3486 int least;
3488 gfc_expr *count = code->ext.actual->expr;
3489 gfc_expr *count_rate = code->ext.actual->next->expr;
3490 gfc_expr *count_max = code->ext.actual->next->next->expr;
3492 /* Evaluate our arguments. */
3493 if (count)
3495 gfc_init_se (&count_se, NULL);
3496 gfc_conv_expr (&count_se, count);
3499 if (count_rate)
3501 gfc_init_se (&count_rate_se, NULL);
3502 gfc_conv_expr (&count_rate_se, count_rate);
3505 if (count_max)
3507 gfc_init_se (&count_max_se, NULL);
3508 gfc_conv_expr (&count_max_se, count_max);
3511 /* Find the smallest kind found of the arguments. */
3512 least = 16;
3513 least = (count && count->ts.kind < least) ? count->ts.kind : least;
3514 least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3515 : least;
3516 least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3517 : least;
3519 /* Prepare temporary variables. */
3521 if (count)
3523 if (least >= 8)
3524 arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3525 else if (least == 4)
3526 arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3527 else if (count->ts.kind == 1)
3528 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3529 count->ts.kind);
3530 else
3531 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3532 count->ts.kind);
3535 if (count_rate)
3537 if (least >= 8)
3538 arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3539 else if (least == 4)
3540 arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3541 else
3542 arg2 = integer_zero_node;
3545 if (count_max)
3547 if (least >= 8)
3548 arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3549 else if (least == 4)
3550 arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3551 else
3552 arg3 = integer_zero_node;
3555 /* Make the function call. */
3556 gfc_init_block (&block);
3558 if (least <= 2)
3560 if (least == 1)
3562 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3563 : null_pointer_node;
3564 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3565 : null_pointer_node;
3566 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3567 : null_pointer_node;
3570 if (least == 2)
3572 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3573 : null_pointer_node;
3574 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3575 : null_pointer_node;
3576 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3577 : null_pointer_node;
3580 else
3582 if (least == 4)
3584 tmp = build_call_expr_loc (input_location,
3585 gfor_fndecl_system_clock4, 3,
3586 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3587 : null_pointer_node,
3588 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3589 : null_pointer_node,
3590 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3591 : null_pointer_node);
3592 gfc_add_expr_to_block (&block, tmp);
3594 /* Handle kind>=8, 10, or 16 arguments */
3595 if (least >= 8)
3597 tmp = build_call_expr_loc (input_location,
3598 gfor_fndecl_system_clock8, 3,
3599 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3600 : null_pointer_node,
3601 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3602 : null_pointer_node,
3603 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3604 : null_pointer_node);
3605 gfc_add_expr_to_block (&block, tmp);
3609 /* And store values back if needed. */
3610 if (arg1 && arg1 != count_se.expr)
3611 gfc_add_modify (&block, count_se.expr,
3612 fold_convert (TREE_TYPE (count_se.expr), arg1));
3613 if (arg2 && arg2 != count_rate_se.expr)
3614 gfc_add_modify (&block, count_rate_se.expr,
3615 fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3616 if (arg3 && arg3 != count_max_se.expr)
3617 gfc_add_modify (&block, count_max_se.expr,
3618 fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3620 return gfc_finish_block (&block);
3624 /* Return a character string containing the tty name. */
3626 static void
3627 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3629 tree var;
3630 tree len;
3631 tree tmp;
3632 tree cond;
3633 tree fndecl;
3634 tree *args;
3635 unsigned int num_args;
3637 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3638 args = XALLOCAVEC (tree, num_args);
3640 var = gfc_create_var (pchar_type_node, "pstr");
3641 len = gfc_create_var (gfc_charlen_type_node, "len");
3643 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3644 args[0] = gfc_build_addr_expr (NULL_TREE, var);
3645 args[1] = gfc_build_addr_expr (NULL_TREE, len);
3647 fndecl = build_addr (gfor_fndecl_ttynam);
3648 tmp = build_call_array_loc (input_location,
3649 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3650 fndecl, num_args, args);
3651 gfc_add_expr_to_block (&se->pre, tmp);
3653 /* Free the temporary afterwards, if necessary. */
3654 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
3655 len, build_int_cst (TREE_TYPE (len), 0));
3656 tmp = gfc_call_free (var);
3657 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3658 gfc_add_expr_to_block (&se->post, tmp);
3660 se->expr = var;
3661 se->string_length = len;
3665 /* Get the minimum/maximum value of all the parameters.
3666 minmax (a1, a2, a3, ...)
3668 mvar = a1;
3669 if (a2 .op. mvar || isnan (mvar))
3670 mvar = a2;
3671 if (a3 .op. mvar || isnan (mvar))
3672 mvar = a3;
3674 return mvar
3678 /* TODO: Mismatching types can occur when specific names are used.
3679 These should be handled during resolution. */
3680 static void
3681 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3683 tree tmp;
3684 tree mvar;
3685 tree val;
3686 tree thencase;
3687 tree *args;
3688 tree type;
3689 gfc_actual_arglist *argexpr;
3690 unsigned int i, nargs;
3692 nargs = gfc_intrinsic_argument_list_length (expr);
3693 args = XALLOCAVEC (tree, nargs);
3695 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3696 type = gfc_typenode_for_spec (&expr->ts);
3698 argexpr = expr->value.function.actual;
3699 if (TREE_TYPE (args[0]) != type)
3700 args[0] = convert (type, args[0]);
3701 /* Only evaluate the argument once. */
3702 if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3703 args[0] = gfc_evaluate_now (args[0], &se->pre);
3705 mvar = gfc_create_var (type, "M");
3706 gfc_add_modify (&se->pre, mvar, args[0]);
3707 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
3709 tree cond, isnan;
3711 val = args[i];
3713 /* Handle absent optional arguments by ignoring the comparison. */
3714 if (argexpr->expr->expr_type == EXPR_VARIABLE
3715 && argexpr->expr->symtree->n.sym->attr.optional
3716 && TREE_CODE (val) == INDIRECT_REF)
3717 cond = fold_build2_loc (input_location,
3718 NE_EXPR, boolean_type_node,
3719 TREE_OPERAND (val, 0),
3720 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3721 else
3723 cond = NULL_TREE;
3725 /* Only evaluate the argument once. */
3726 if (!VAR_P (val) && !TREE_CONSTANT (val))
3727 val = gfc_evaluate_now (val, &se->pre);
3730 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
3732 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3733 convert (type, val), mvar);
3735 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3736 __builtin_isnan might be made dependent on that module being loaded,
3737 to help performance of programs that don't rely on IEEE semantics. */
3738 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
3740 isnan = build_call_expr_loc (input_location,
3741 builtin_decl_explicit (BUILT_IN_ISNAN),
3742 1, mvar);
3743 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3744 boolean_type_node, tmp,
3745 fold_convert (boolean_type_node, isnan));
3747 tmp = build3_v (COND_EXPR, tmp, thencase,
3748 build_empty_stmt (input_location));
3750 if (cond != NULL_TREE)
3751 tmp = build3_v (COND_EXPR, cond, tmp,
3752 build_empty_stmt (input_location));
3754 gfc_add_expr_to_block (&se->pre, tmp);
3755 argexpr = argexpr->next;
3757 se->expr = mvar;
3761 /* Generate library calls for MIN and MAX intrinsics for character
3762 variables. */
3763 static void
3764 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3766 tree *args;
3767 tree var, len, fndecl, tmp, cond, function;
3768 unsigned int nargs;
3770 nargs = gfc_intrinsic_argument_list_length (expr);
3771 args = XALLOCAVEC (tree, nargs + 4);
3772 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3774 /* Create the result variables. */
3775 len = gfc_create_var (gfc_charlen_type_node, "len");
3776 args[0] = gfc_build_addr_expr (NULL_TREE, len);
3777 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3778 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3779 args[2] = build_int_cst (integer_type_node, op);
3780 args[3] = build_int_cst (integer_type_node, nargs / 2);
3782 if (expr->ts.kind == 1)
3783 function = gfor_fndecl_string_minmax;
3784 else if (expr->ts.kind == 4)
3785 function = gfor_fndecl_string_minmax_char4;
3786 else
3787 gcc_unreachable ();
3789 /* Make the function call. */
3790 fndecl = build_addr (function);
3791 tmp = build_call_array_loc (input_location,
3792 TREE_TYPE (TREE_TYPE (function)), fndecl,
3793 nargs + 4, args);
3794 gfc_add_expr_to_block (&se->pre, tmp);
3796 /* Free the temporary afterwards, if necessary. */
3797 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
3798 len, build_int_cst (TREE_TYPE (len), 0));
3799 tmp = gfc_call_free (var);
3800 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3801 gfc_add_expr_to_block (&se->post, tmp);
3803 se->expr = var;
3804 se->string_length = len;
3808 /* Create a symbol node for this intrinsic. The symbol from the frontend
3809 has the generic name. */
3811 static gfc_symbol *
3812 gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3814 gfc_symbol *sym;
3816 /* TODO: Add symbols for intrinsic function to the global namespace. */
3817 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3818 sym = gfc_new_symbol (expr->value.function.name, NULL);
3820 sym->ts = expr->ts;
3821 sym->attr.external = 1;
3822 sym->attr.function = 1;
3823 sym->attr.always_explicit = 1;
3824 sym->attr.proc = PROC_INTRINSIC;
3825 sym->attr.flavor = FL_PROCEDURE;
3826 sym->result = sym;
3827 if (expr->rank > 0)
3829 sym->attr.dimension = 1;
3830 sym->as = gfc_get_array_spec ();
3831 sym->as->type = AS_ASSUMED_SHAPE;
3832 sym->as->rank = expr->rank;
3835 gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3836 ignore_optional ? expr->value.function.actual
3837 : NULL);
3839 return sym;
3842 /* Generate a call to an external intrinsic function. */
3843 static void
3844 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3846 gfc_symbol *sym;
3847 vec<tree, va_gc> *append_args;
3849 gcc_assert (!se->ss || se->ss->info->expr == expr);
3851 if (se->ss)
3852 gcc_assert (expr->rank > 0);
3853 else
3854 gcc_assert (expr->rank == 0);
3856 sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
3858 /* Calls to libgfortran_matmul need to be appended special arguments,
3859 to be able to call the BLAS ?gemm functions if required and possible. */
3860 append_args = NULL;
3861 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
3862 && sym->ts.type != BT_LOGICAL)
3864 tree cint = gfc_get_int_type (gfc_c_int_kind);
3866 if (flag_external_blas
3867 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
3868 && (sym->ts.kind == 4 || sym->ts.kind == 8))
3870 tree gemm_fndecl;
3872 if (sym->ts.type == BT_REAL)
3874 if (sym->ts.kind == 4)
3875 gemm_fndecl = gfor_fndecl_sgemm;
3876 else
3877 gemm_fndecl = gfor_fndecl_dgemm;
3879 else
3881 if (sym->ts.kind == 4)
3882 gemm_fndecl = gfor_fndecl_cgemm;
3883 else
3884 gemm_fndecl = gfor_fndecl_zgemm;
3887 vec_alloc (append_args, 3);
3888 append_args->quick_push (build_int_cst (cint, 1));
3889 append_args->quick_push (build_int_cst (cint,
3890 flag_blas_matmul_limit));
3891 append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
3892 gemm_fndecl));
3894 else
3896 vec_alloc (append_args, 3);
3897 append_args->quick_push (build_int_cst (cint, 0));
3898 append_args->quick_push (build_int_cst (cint, 0));
3899 append_args->quick_push (null_pointer_node);
3903 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3904 append_args);
3905 gfc_free_symbol (sym);
3908 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3909 Implemented as
3910 any(a)
3912 forall (i=...)
3913 if (a[i] != 0)
3914 return 1
3915 end forall
3916 return 0
3918 all(a)
3920 forall (i=...)
3921 if (a[i] == 0)
3922 return 0
3923 end forall
3924 return 1
3927 static void
3928 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
3930 tree resvar;
3931 stmtblock_t block;
3932 stmtblock_t body;
3933 tree type;
3934 tree tmp;
3935 tree found;
3936 gfc_loopinfo loop;
3937 gfc_actual_arglist *actual;
3938 gfc_ss *arrayss;
3939 gfc_se arrayse;
3940 tree exit_label;
3942 if (se->ss)
3944 gfc_conv_intrinsic_funcall (se, expr);
3945 return;
3948 actual = expr->value.function.actual;
3949 type = gfc_typenode_for_spec (&expr->ts);
3950 /* Initialize the result. */
3951 resvar = gfc_create_var (type, "test");
3952 if (op == EQ_EXPR)
3953 tmp = convert (type, boolean_true_node);
3954 else
3955 tmp = convert (type, boolean_false_node);
3956 gfc_add_modify (&se->pre, resvar, tmp);
3958 /* Walk the arguments. */
3959 arrayss = gfc_walk_expr (actual->expr);
3960 gcc_assert (arrayss != gfc_ss_terminator);
3962 /* Initialize the scalarizer. */
3963 gfc_init_loopinfo (&loop);
3964 exit_label = gfc_build_label_decl (NULL_TREE);
3965 TREE_USED (exit_label) = 1;
3966 gfc_add_ss_to_loop (&loop, arrayss);
3968 /* Initialize the loop. */
3969 gfc_conv_ss_startstride (&loop);
3970 gfc_conv_loop_setup (&loop, &expr->where);
3972 gfc_mark_ss_chain_used (arrayss, 1);
3973 /* Generate the loop body. */
3974 gfc_start_scalarized_body (&loop, &body);
3976 /* If the condition matches then set the return value. */
3977 gfc_start_block (&block);
3978 if (op == EQ_EXPR)
3979 tmp = convert (type, boolean_false_node);
3980 else
3981 tmp = convert (type, boolean_true_node);
3982 gfc_add_modify (&block, resvar, tmp);
3984 /* And break out of the loop. */
3985 tmp = build1_v (GOTO_EXPR, exit_label);
3986 gfc_add_expr_to_block (&block, tmp);
3988 found = gfc_finish_block (&block);
3990 /* Check this element. */
3991 gfc_init_se (&arrayse, NULL);
3992 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3993 arrayse.ss = arrayss;
3994 gfc_conv_expr_val (&arrayse, actual->expr);
3996 gfc_add_block_to_block (&body, &arrayse.pre);
3997 tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
3998 build_int_cst (TREE_TYPE (arrayse.expr), 0));
3999 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4000 gfc_add_expr_to_block (&body, tmp);
4001 gfc_add_block_to_block (&body, &arrayse.post);
4003 gfc_trans_scalarizing_loops (&loop, &body);
4005 /* Add the exit label. */
4006 tmp = build1_v (LABEL_EXPR, exit_label);
4007 gfc_add_expr_to_block (&loop.pre, tmp);
4009 gfc_add_block_to_block (&se->pre, &loop.pre);
4010 gfc_add_block_to_block (&se->pre, &loop.post);
4011 gfc_cleanup_loop (&loop);
4013 se->expr = resvar;
4016 /* COUNT(A) = Number of true elements in A. */
4017 static void
4018 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4020 tree resvar;
4021 tree type;
4022 stmtblock_t body;
4023 tree tmp;
4024 gfc_loopinfo loop;
4025 gfc_actual_arglist *actual;
4026 gfc_ss *arrayss;
4027 gfc_se arrayse;
4029 if (se->ss)
4031 gfc_conv_intrinsic_funcall (se, expr);
4032 return;
4035 actual = expr->value.function.actual;
4037 type = gfc_typenode_for_spec (&expr->ts);
4038 /* Initialize the result. */
4039 resvar = gfc_create_var (type, "count");
4040 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4042 /* Walk the arguments. */
4043 arrayss = gfc_walk_expr (actual->expr);
4044 gcc_assert (arrayss != gfc_ss_terminator);
4046 /* Initialize the scalarizer. */
4047 gfc_init_loopinfo (&loop);
4048 gfc_add_ss_to_loop (&loop, arrayss);
4050 /* Initialize the loop. */
4051 gfc_conv_ss_startstride (&loop);
4052 gfc_conv_loop_setup (&loop, &expr->where);
4054 gfc_mark_ss_chain_used (arrayss, 1);
4055 /* Generate the loop body. */
4056 gfc_start_scalarized_body (&loop, &body);
4058 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4059 resvar, build_int_cst (TREE_TYPE (resvar), 1));
4060 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4062 gfc_init_se (&arrayse, NULL);
4063 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4064 arrayse.ss = arrayss;
4065 gfc_conv_expr_val (&arrayse, actual->expr);
4066 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4067 build_empty_stmt (input_location));
4069 gfc_add_block_to_block (&body, &arrayse.pre);
4070 gfc_add_expr_to_block (&body, tmp);
4071 gfc_add_block_to_block (&body, &arrayse.post);
4073 gfc_trans_scalarizing_loops (&loop, &body);
4075 gfc_add_block_to_block (&se->pre, &loop.pre);
4076 gfc_add_block_to_block (&se->pre, &loop.post);
4077 gfc_cleanup_loop (&loop);
4079 se->expr = resvar;
4083 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4084 struct and return the corresponding loopinfo. */
4086 static gfc_loopinfo *
4087 enter_nested_loop (gfc_se *se)
4089 se->ss = se->ss->nested_ss;
4090 gcc_assert (se->ss == se->ss->loop->ss);
4092 return se->ss->loop;
4096 /* Inline implementation of the sum and product intrinsics. */
4097 static void
4098 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4099 bool norm2)
4101 tree resvar;
4102 tree scale = NULL_TREE;
4103 tree type;
4104 stmtblock_t body;
4105 stmtblock_t block;
4106 tree tmp;
4107 gfc_loopinfo loop, *ploop;
4108 gfc_actual_arglist *arg_array, *arg_mask;
4109 gfc_ss *arrayss = NULL;
4110 gfc_ss *maskss = NULL;
4111 gfc_se arrayse;
4112 gfc_se maskse;
4113 gfc_se *parent_se;
4114 gfc_expr *arrayexpr;
4115 gfc_expr *maskexpr;
4117 if (expr->rank > 0)
4119 gcc_assert (gfc_inline_intrinsic_function_p (expr));
4120 parent_se = se;
4122 else
4123 parent_se = NULL;
4125 type = gfc_typenode_for_spec (&expr->ts);
4126 /* Initialize the result. */
4127 resvar = gfc_create_var (type, "val");
4128 if (norm2)
4130 /* result = 0.0;
4131 scale = 1.0. */
4132 scale = gfc_create_var (type, "scale");
4133 gfc_add_modify (&se->pre, scale,
4134 gfc_build_const (type, integer_one_node));
4135 tmp = gfc_build_const (type, integer_zero_node);
4137 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4138 tmp = gfc_build_const (type, integer_zero_node);
4139 else if (op == NE_EXPR)
4140 /* PARITY. */
4141 tmp = convert (type, boolean_false_node);
4142 else if (op == BIT_AND_EXPR)
4143 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4144 type, integer_one_node));
4145 else
4146 tmp = gfc_build_const (type, integer_one_node);
4148 gfc_add_modify (&se->pre, resvar, tmp);
4150 arg_array = expr->value.function.actual;
4152 arrayexpr = arg_array->expr;
4154 if (op == NE_EXPR || norm2)
4155 /* PARITY and NORM2. */
4156 maskexpr = NULL;
4157 else
4159 arg_mask = arg_array->next->next;
4160 gcc_assert (arg_mask != NULL);
4161 maskexpr = arg_mask->expr;
4164 if (expr->rank == 0)
4166 /* Walk the arguments. */
4167 arrayss = gfc_walk_expr (arrayexpr);
4168 gcc_assert (arrayss != gfc_ss_terminator);
4170 if (maskexpr && maskexpr->rank > 0)
4172 maskss = gfc_walk_expr (maskexpr);
4173 gcc_assert (maskss != gfc_ss_terminator);
4175 else
4176 maskss = NULL;
4178 /* Initialize the scalarizer. */
4179 gfc_init_loopinfo (&loop);
4180 gfc_add_ss_to_loop (&loop, arrayss);
4181 if (maskexpr && maskexpr->rank > 0)
4182 gfc_add_ss_to_loop (&loop, maskss);
4184 /* Initialize the loop. */
4185 gfc_conv_ss_startstride (&loop);
4186 gfc_conv_loop_setup (&loop, &expr->where);
4188 gfc_mark_ss_chain_used (arrayss, 1);
4189 if (maskexpr && maskexpr->rank > 0)
4190 gfc_mark_ss_chain_used (maskss, 1);
4192 ploop = &loop;
4194 else
4195 /* All the work has been done in the parent loops. */
4196 ploop = enter_nested_loop (se);
4198 gcc_assert (ploop);
4200 /* Generate the loop body. */
4201 gfc_start_scalarized_body (ploop, &body);
4203 /* If we have a mask, only add this element if the mask is set. */
4204 if (maskexpr && maskexpr->rank > 0)
4206 gfc_init_se (&maskse, parent_se);
4207 gfc_copy_loopinfo_to_se (&maskse, ploop);
4208 if (expr->rank == 0)
4209 maskse.ss = maskss;
4210 gfc_conv_expr_val (&maskse, maskexpr);
4211 gfc_add_block_to_block (&body, &maskse.pre);
4213 gfc_start_block (&block);
4215 else
4216 gfc_init_block (&block);
4218 /* Do the actual summation/product. */
4219 gfc_init_se (&arrayse, parent_se);
4220 gfc_copy_loopinfo_to_se (&arrayse, ploop);
4221 if (expr->rank == 0)
4222 arrayse.ss = arrayss;
4223 gfc_conv_expr_val (&arrayse, arrayexpr);
4224 gfc_add_block_to_block (&block, &arrayse.pre);
4226 if (norm2)
4228 /* if (x (i) != 0.0)
4230 absX = abs(x(i))
4231 if (absX > scale)
4233 val = scale/absX;
4234 result = 1.0 + result * val * val;
4235 scale = absX;
4237 else
4239 val = absX/scale;
4240 result += val * val;
4242 } */
4243 tree res1, res2, cond, absX, val;
4244 stmtblock_t ifblock1, ifblock2, ifblock3;
4246 gfc_init_block (&ifblock1);
4248 absX = gfc_create_var (type, "absX");
4249 gfc_add_modify (&ifblock1, absX,
4250 fold_build1_loc (input_location, ABS_EXPR, type,
4251 arrayse.expr));
4252 val = gfc_create_var (type, "val");
4253 gfc_add_expr_to_block (&ifblock1, val);
4255 gfc_init_block (&ifblock2);
4256 gfc_add_modify (&ifblock2, val,
4257 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4258 absX));
4259 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4260 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4261 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4262 gfc_build_const (type, integer_one_node));
4263 gfc_add_modify (&ifblock2, resvar, res1);
4264 gfc_add_modify (&ifblock2, scale, absX);
4265 res1 = gfc_finish_block (&ifblock2);
4267 gfc_init_block (&ifblock3);
4268 gfc_add_modify (&ifblock3, val,
4269 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4270 scale));
4271 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4272 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4273 gfc_add_modify (&ifblock3, resvar, res2);
4274 res2 = gfc_finish_block (&ifblock3);
4276 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
4277 absX, scale);
4278 tmp = build3_v (COND_EXPR, cond, res1, res2);
4279 gfc_add_expr_to_block (&ifblock1, tmp);
4280 tmp = gfc_finish_block (&ifblock1);
4282 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4283 arrayse.expr,
4284 gfc_build_const (type, integer_zero_node));
4286 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4287 gfc_add_expr_to_block (&block, tmp);
4289 else
4291 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4292 gfc_add_modify (&block, resvar, tmp);
4295 gfc_add_block_to_block (&block, &arrayse.post);
4297 if (maskexpr && maskexpr->rank > 0)
4299 /* We enclose the above in if (mask) {...} . */
4301 tmp = gfc_finish_block (&block);
4302 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4303 build_empty_stmt (input_location));
4305 else
4306 tmp = gfc_finish_block (&block);
4307 gfc_add_expr_to_block (&body, tmp);
4309 gfc_trans_scalarizing_loops (ploop, &body);
4311 /* For a scalar mask, enclose the loop in an if statement. */
4312 if (maskexpr && maskexpr->rank == 0)
4314 gfc_init_block (&block);
4315 gfc_add_block_to_block (&block, &ploop->pre);
4316 gfc_add_block_to_block (&block, &ploop->post);
4317 tmp = gfc_finish_block (&block);
4319 if (expr->rank > 0)
4321 tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4322 build_empty_stmt (input_location));
4323 gfc_advance_se_ss_chain (se);
4325 else
4327 gcc_assert (expr->rank == 0);
4328 gfc_init_se (&maskse, NULL);
4329 gfc_conv_expr_val (&maskse, maskexpr);
4330 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4331 build_empty_stmt (input_location));
4334 gfc_add_expr_to_block (&block, tmp);
4335 gfc_add_block_to_block (&se->pre, &block);
4336 gcc_assert (se->post.head == NULL);
4338 else
4340 gfc_add_block_to_block (&se->pre, &ploop->pre);
4341 gfc_add_block_to_block (&se->pre, &ploop->post);
4344 if (expr->rank == 0)
4345 gfc_cleanup_loop (ploop);
4347 if (norm2)
4349 /* result = scale * sqrt(result). */
4350 tree sqrt;
4351 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4352 resvar = build_call_expr_loc (input_location,
4353 sqrt, 1, resvar);
4354 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4357 se->expr = resvar;
4361 /* Inline implementation of the dot_product intrinsic. This function
4362 is based on gfc_conv_intrinsic_arith (the previous function). */
4363 static void
4364 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4366 tree resvar;
4367 tree type;
4368 stmtblock_t body;
4369 stmtblock_t block;
4370 tree tmp;
4371 gfc_loopinfo loop;
4372 gfc_actual_arglist *actual;
4373 gfc_ss *arrayss1, *arrayss2;
4374 gfc_se arrayse1, arrayse2;
4375 gfc_expr *arrayexpr1, *arrayexpr2;
4377 type = gfc_typenode_for_spec (&expr->ts);
4379 /* Initialize the result. */
4380 resvar = gfc_create_var (type, "val");
4381 if (expr->ts.type == BT_LOGICAL)
4382 tmp = build_int_cst (type, 0);
4383 else
4384 tmp = gfc_build_const (type, integer_zero_node);
4386 gfc_add_modify (&se->pre, resvar, tmp);
4388 /* Walk argument #1. */
4389 actual = expr->value.function.actual;
4390 arrayexpr1 = actual->expr;
4391 arrayss1 = gfc_walk_expr (arrayexpr1);
4392 gcc_assert (arrayss1 != gfc_ss_terminator);
4394 /* Walk argument #2. */
4395 actual = actual->next;
4396 arrayexpr2 = actual->expr;
4397 arrayss2 = gfc_walk_expr (arrayexpr2);
4398 gcc_assert (arrayss2 != gfc_ss_terminator);
4400 /* Initialize the scalarizer. */
4401 gfc_init_loopinfo (&loop);
4402 gfc_add_ss_to_loop (&loop, arrayss1);
4403 gfc_add_ss_to_loop (&loop, arrayss2);
4405 /* Initialize the loop. */
4406 gfc_conv_ss_startstride (&loop);
4407 gfc_conv_loop_setup (&loop, &expr->where);
4409 gfc_mark_ss_chain_used (arrayss1, 1);
4410 gfc_mark_ss_chain_used (arrayss2, 1);
4412 /* Generate the loop body. */
4413 gfc_start_scalarized_body (&loop, &body);
4414 gfc_init_block (&block);
4416 /* Make the tree expression for [conjg(]array1[)]. */
4417 gfc_init_se (&arrayse1, NULL);
4418 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4419 arrayse1.ss = arrayss1;
4420 gfc_conv_expr_val (&arrayse1, arrayexpr1);
4421 if (expr->ts.type == BT_COMPLEX)
4422 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4423 arrayse1.expr);
4424 gfc_add_block_to_block (&block, &arrayse1.pre);
4426 /* Make the tree expression for array2. */
4427 gfc_init_se (&arrayse2, NULL);
4428 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4429 arrayse2.ss = arrayss2;
4430 gfc_conv_expr_val (&arrayse2, arrayexpr2);
4431 gfc_add_block_to_block (&block, &arrayse2.pre);
4433 /* Do the actual product and sum. */
4434 if (expr->ts.type == BT_LOGICAL)
4436 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4437 arrayse1.expr, arrayse2.expr);
4438 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4440 else
4442 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4443 arrayse2.expr);
4444 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4446 gfc_add_modify (&block, resvar, tmp);
4448 /* Finish up the loop block and the loop. */
4449 tmp = gfc_finish_block (&block);
4450 gfc_add_expr_to_block (&body, tmp);
4452 gfc_trans_scalarizing_loops (&loop, &body);
4453 gfc_add_block_to_block (&se->pre, &loop.pre);
4454 gfc_add_block_to_block (&se->pre, &loop.post);
4455 gfc_cleanup_loop (&loop);
4457 se->expr = resvar;
4461 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4462 we need to handle. For performance reasons we sometimes create two
4463 loops instead of one, where the second one is much simpler.
4464 Examples for minloc intrinsic:
4465 1) Result is an array, a call is generated
4466 2) Array mask is used and NaNs need to be supported:
4467 limit = Infinity;
4468 pos = 0;
4469 S = from;
4470 while (S <= to) {
4471 if (mask[S]) {
4472 if (pos == 0) pos = S + (1 - from);
4473 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4475 S++;
4477 goto lab2;
4478 lab1:;
4479 while (S <= to) {
4480 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4481 S++;
4483 lab2:;
4484 3) NaNs need to be supported, but it is known at compile time or cheaply
4485 at runtime whether array is nonempty or not:
4486 limit = Infinity;
4487 pos = 0;
4488 S = from;
4489 while (S <= to) {
4490 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4491 S++;
4493 if (from <= to) pos = 1;
4494 goto lab2;
4495 lab1:;
4496 while (S <= to) {
4497 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4498 S++;
4500 lab2:;
4501 4) NaNs aren't supported, array mask is used:
4502 limit = infinities_supported ? Infinity : huge (limit);
4503 pos = 0;
4504 S = from;
4505 while (S <= to) {
4506 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4507 S++;
4509 goto lab2;
4510 lab1:;
4511 while (S <= to) {
4512 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4513 S++;
4515 lab2:;
4516 5) Same without array mask:
4517 limit = infinities_supported ? Infinity : huge (limit);
4518 pos = (from <= to) ? 1 : 0;
4519 S = from;
4520 while (S <= to) {
4521 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4522 S++;
4524 For 3) and 5), if mask is scalar, this all goes into a conditional,
4525 setting pos = 0; in the else branch. */
4527 static void
4528 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
4530 stmtblock_t body;
4531 stmtblock_t block;
4532 stmtblock_t ifblock;
4533 stmtblock_t elseblock;
4534 tree limit;
4535 tree type;
4536 tree tmp;
4537 tree cond;
4538 tree elsetmp;
4539 tree ifbody;
4540 tree offset;
4541 tree nonempty;
4542 tree lab1, lab2;
4543 gfc_loopinfo loop;
4544 gfc_actual_arglist *actual;
4545 gfc_ss *arrayss;
4546 gfc_ss *maskss;
4547 gfc_se arrayse;
4548 gfc_se maskse;
4549 gfc_expr *arrayexpr;
4550 gfc_expr *maskexpr;
4551 tree pos;
4552 int n;
4554 if (se->ss)
4556 gfc_conv_intrinsic_funcall (se, expr);
4557 return;
4560 /* Initialize the result. */
4561 pos = gfc_create_var (gfc_array_index_type, "pos");
4562 offset = gfc_create_var (gfc_array_index_type, "offset");
4563 type = gfc_typenode_for_spec (&expr->ts);
4565 /* Walk the arguments. */
4566 actual = expr->value.function.actual;
4567 arrayexpr = actual->expr;
4568 arrayss = gfc_walk_expr (arrayexpr);
4569 gcc_assert (arrayss != gfc_ss_terminator);
4571 actual = actual->next->next;
4572 gcc_assert (actual);
4573 maskexpr = actual->expr;
4574 nonempty = NULL;
4575 if (maskexpr && maskexpr->rank != 0)
4577 maskss = gfc_walk_expr (maskexpr);
4578 gcc_assert (maskss != gfc_ss_terminator);
4580 else
4582 mpz_t asize;
4583 if (gfc_array_size (arrayexpr, &asize))
4585 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
4586 mpz_clear (asize);
4587 nonempty = fold_build2_loc (input_location, GT_EXPR,
4588 boolean_type_node, nonempty,
4589 gfc_index_zero_node);
4591 maskss = NULL;
4594 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
4595 switch (arrayexpr->ts.type)
4597 case BT_REAL:
4598 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
4599 break;
4601 case BT_INTEGER:
4602 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
4603 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
4604 arrayexpr->ts.kind);
4605 break;
4607 default:
4608 gcc_unreachable ();
4611 /* We start with the most negative possible value for MAXLOC, and the most
4612 positive possible value for MINLOC. The most negative possible value is
4613 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4614 possible value is HUGE in both cases. */
4615 if (op == GT_EXPR)
4616 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
4617 if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
4618 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
4619 build_int_cst (TREE_TYPE (tmp), 1));
4621 gfc_add_modify (&se->pre, limit, tmp);
4623 /* Initialize the scalarizer. */
4624 gfc_init_loopinfo (&loop);
4625 gfc_add_ss_to_loop (&loop, arrayss);
4626 if (maskss)
4627 gfc_add_ss_to_loop (&loop, maskss);
4629 /* Initialize the loop. */
4630 gfc_conv_ss_startstride (&loop);
4632 /* The code generated can have more than one loop in sequence (see the
4633 comment at the function header). This doesn't work well with the
4634 scalarizer, which changes arrays' offset when the scalarization loops
4635 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4636 are currently inlined in the scalar case only (for which loop is of rank
4637 one). As there is no dependency to care about in that case, there is no
4638 temporary, so that we can use the scalarizer temporary code to handle
4639 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4640 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4641 to restore offset.
4642 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4643 should eventually go away. We could either create two loops properly,
4644 or find another way to save/restore the array offsets between the two
4645 loops (without conflicting with temporary management), or use a single
4646 loop minmaxloc implementation. See PR 31067. */
4647 loop.temp_dim = loop.dimen;
4648 gfc_conv_loop_setup (&loop, &expr->where);
4650 gcc_assert (loop.dimen == 1);
4651 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
4652 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
4653 loop.from[0], loop.to[0]);
4655 lab1 = NULL;
4656 lab2 = NULL;
4657 /* Initialize the position to zero, following Fortran 2003. We are free
4658 to do this because Fortran 95 allows the result of an entirely false
4659 mask to be processor dependent. If we know at compile time the array
4660 is non-empty and no MASK is used, we can initialize to 1 to simplify
4661 the inner loop. */
4662 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
4663 gfc_add_modify (&loop.pre, pos,
4664 fold_build3_loc (input_location, COND_EXPR,
4665 gfc_array_index_type,
4666 nonempty, gfc_index_one_node,
4667 gfc_index_zero_node));
4668 else
4670 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
4671 lab1 = gfc_build_label_decl (NULL_TREE);
4672 TREE_USED (lab1) = 1;
4673 lab2 = gfc_build_label_decl (NULL_TREE);
4674 TREE_USED (lab2) = 1;
4677 /* An offset must be added to the loop
4678 counter to obtain the required position. */
4679 gcc_assert (loop.from[0]);
4681 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4682 gfc_index_one_node, loop.from[0]);
4683 gfc_add_modify (&loop.pre, offset, tmp);
4685 gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
4686 if (maskss)
4687 gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
4688 /* Generate the loop body. */
4689 gfc_start_scalarized_body (&loop, &body);
4691 /* If we have a mask, only check this element if the mask is set. */
4692 if (maskss)
4694 gfc_init_se (&maskse, NULL);
4695 gfc_copy_loopinfo_to_se (&maskse, &loop);
4696 maskse.ss = maskss;
4697 gfc_conv_expr_val (&maskse, maskexpr);
4698 gfc_add_block_to_block (&body, &maskse.pre);
4700 gfc_start_block (&block);
4702 else
4703 gfc_init_block (&block);
4705 /* Compare with the current limit. */
4706 gfc_init_se (&arrayse, NULL);
4707 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4708 arrayse.ss = arrayss;
4709 gfc_conv_expr_val (&arrayse, arrayexpr);
4710 gfc_add_block_to_block (&block, &arrayse.pre);
4712 /* We do the following if this is a more extreme value. */
4713 gfc_start_block (&ifblock);
4715 /* Assign the value to the limit... */
4716 gfc_add_modify (&ifblock, limit, arrayse.expr);
4718 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
4720 stmtblock_t ifblock2;
4721 tree ifbody2;
4723 gfc_start_block (&ifblock2);
4724 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4725 loop.loopvar[0], offset);
4726 gfc_add_modify (&ifblock2, pos, tmp);
4727 ifbody2 = gfc_finish_block (&ifblock2);
4728 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
4729 gfc_index_zero_node);
4730 tmp = build3_v (COND_EXPR, cond, ifbody2,
4731 build_empty_stmt (input_location));
4732 gfc_add_expr_to_block (&block, tmp);
4735 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4736 loop.loopvar[0], offset);
4737 gfc_add_modify (&ifblock, pos, tmp);
4739 if (lab1)
4740 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
4742 ifbody = gfc_finish_block (&ifblock);
4744 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
4746 if (lab1)
4747 cond = fold_build2_loc (input_location,
4748 op == GT_EXPR ? GE_EXPR : LE_EXPR,
4749 boolean_type_node, arrayse.expr, limit);
4750 else
4751 cond = fold_build2_loc (input_location, op, boolean_type_node,
4752 arrayse.expr, limit);
4754 ifbody = build3_v (COND_EXPR, cond, ifbody,
4755 build_empty_stmt (input_location));
4757 gfc_add_expr_to_block (&block, ifbody);
4759 if (maskss)
4761 /* We enclose the above in if (mask) {...}. */
4762 tmp = gfc_finish_block (&block);
4764 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4765 build_empty_stmt (input_location));
4767 else
4768 tmp = gfc_finish_block (&block);
4769 gfc_add_expr_to_block (&body, tmp);
4771 if (lab1)
4773 gfc_trans_scalarized_loop_boundary (&loop, &body);
4775 if (HONOR_NANS (DECL_MODE (limit)))
4777 if (nonempty != NULL)
4779 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
4780 tmp = build3_v (COND_EXPR, nonempty, ifbody,
4781 build_empty_stmt (input_location));
4782 gfc_add_expr_to_block (&loop.code[0], tmp);
4786 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
4787 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
4789 /* If we have a mask, only check this element if the mask is set. */
4790 if (maskss)
4792 gfc_init_se (&maskse, NULL);
4793 gfc_copy_loopinfo_to_se (&maskse, &loop);
4794 maskse.ss = maskss;
4795 gfc_conv_expr_val (&maskse, maskexpr);
4796 gfc_add_block_to_block (&body, &maskse.pre);
4798 gfc_start_block (&block);
4800 else
4801 gfc_init_block (&block);
4803 /* Compare with the current limit. */
4804 gfc_init_se (&arrayse, NULL);
4805 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4806 arrayse.ss = arrayss;
4807 gfc_conv_expr_val (&arrayse, arrayexpr);
4808 gfc_add_block_to_block (&block, &arrayse.pre);
4810 /* We do the following if this is a more extreme value. */
4811 gfc_start_block (&ifblock);
4813 /* Assign the value to the limit... */
4814 gfc_add_modify (&ifblock, limit, arrayse.expr);
4816 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4817 loop.loopvar[0], offset);
4818 gfc_add_modify (&ifblock, pos, tmp);
4820 ifbody = gfc_finish_block (&ifblock);
4822 cond = fold_build2_loc (input_location, op, boolean_type_node,
4823 arrayse.expr, limit);
4825 tmp = build3_v (COND_EXPR, cond, ifbody,
4826 build_empty_stmt (input_location));
4827 gfc_add_expr_to_block (&block, tmp);
4829 if (maskss)
4831 /* We enclose the above in if (mask) {...}. */
4832 tmp = gfc_finish_block (&block);
4834 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4835 build_empty_stmt (input_location));
4837 else
4838 tmp = gfc_finish_block (&block);
4839 gfc_add_expr_to_block (&body, tmp);
4840 /* Avoid initializing loopvar[0] again, it should be left where
4841 it finished by the first loop. */
4842 loop.from[0] = loop.loopvar[0];
4845 gfc_trans_scalarizing_loops (&loop, &body);
4847 if (lab2)
4848 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
4850 /* For a scalar mask, enclose the loop in an if statement. */
4851 if (maskexpr && maskss == NULL)
4853 gfc_init_se (&maskse, NULL);
4854 gfc_conv_expr_val (&maskse, maskexpr);
4855 gfc_init_block (&block);
4856 gfc_add_block_to_block (&block, &loop.pre);
4857 gfc_add_block_to_block (&block, &loop.post);
4858 tmp = gfc_finish_block (&block);
4860 /* For the else part of the scalar mask, just initialize
4861 the pos variable the same way as above. */
4863 gfc_init_block (&elseblock);
4864 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
4865 elsetmp = gfc_finish_block (&elseblock);
4867 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
4868 gfc_add_expr_to_block (&block, tmp);
4869 gfc_add_block_to_block (&se->pre, &block);
4871 else
4873 gfc_add_block_to_block (&se->pre, &loop.pre);
4874 gfc_add_block_to_block (&se->pre, &loop.post);
4876 gfc_cleanup_loop (&loop);
4878 se->expr = convert (type, pos);
4881 /* Emit code for minval or maxval intrinsic. There are many different cases
4882 we need to handle. For performance reasons we sometimes create two
4883 loops instead of one, where the second one is much simpler.
4884 Examples for minval intrinsic:
4885 1) Result is an array, a call is generated
4886 2) Array mask is used and NaNs need to be supported, rank 1:
4887 limit = Infinity;
4888 nonempty = false;
4889 S = from;
4890 while (S <= to) {
4891 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4892 S++;
4894 limit = nonempty ? NaN : huge (limit);
4895 lab:
4896 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4897 3) NaNs need to be supported, but it is known at compile time or cheaply
4898 at runtime whether array is nonempty or not, rank 1:
4899 limit = Infinity;
4900 S = from;
4901 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4902 limit = (from <= to) ? NaN : huge (limit);
4903 lab:
4904 while (S <= to) { limit = min (a[S], limit); S++; }
4905 4) Array mask is used and NaNs need to be supported, rank > 1:
4906 limit = Infinity;
4907 nonempty = false;
4908 fast = false;
4909 S1 = from1;
4910 while (S1 <= to1) {
4911 S2 = from2;
4912 while (S2 <= to2) {
4913 if (mask[S1][S2]) {
4914 if (fast) limit = min (a[S1][S2], limit);
4915 else {
4916 nonempty = true;
4917 if (a[S1][S2] <= limit) {
4918 limit = a[S1][S2];
4919 fast = true;
4923 S2++;
4925 S1++;
4927 if (!fast)
4928 limit = nonempty ? NaN : huge (limit);
4929 5) NaNs need to be supported, but it is known at compile time or cheaply
4930 at runtime whether array is nonempty or not, rank > 1:
4931 limit = Infinity;
4932 fast = false;
4933 S1 = from1;
4934 while (S1 <= to1) {
4935 S2 = from2;
4936 while (S2 <= to2) {
4937 if (fast) limit = min (a[S1][S2], limit);
4938 else {
4939 if (a[S1][S2] <= limit) {
4940 limit = a[S1][S2];
4941 fast = true;
4944 S2++;
4946 S1++;
4948 if (!fast)
4949 limit = (nonempty_array) ? NaN : huge (limit);
4950 6) NaNs aren't supported, but infinities are. Array mask is used:
4951 limit = Infinity;
4952 nonempty = false;
4953 S = from;
4954 while (S <= to) {
4955 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4956 S++;
4958 limit = nonempty ? limit : huge (limit);
4959 7) Same without array mask:
4960 limit = Infinity;
4961 S = from;
4962 while (S <= to) { limit = min (a[S], limit); S++; }
4963 limit = (from <= to) ? limit : huge (limit);
4964 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4965 limit = huge (limit);
4966 S = from;
4967 while (S <= to) { limit = min (a[S], limit); S++); }
4969 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4970 with array mask instead).
4971 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4972 setting limit = huge (limit); in the else branch. */
4974 static void
4975 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
4977 tree limit;
4978 tree type;
4979 tree tmp;
4980 tree ifbody;
4981 tree nonempty;
4982 tree nonempty_var;
4983 tree lab;
4984 tree fast;
4985 tree huge_cst = NULL, nan_cst = NULL;
4986 stmtblock_t body;
4987 stmtblock_t block, block2;
4988 gfc_loopinfo loop;
4989 gfc_actual_arglist *actual;
4990 gfc_ss *arrayss;
4991 gfc_ss *maskss;
4992 gfc_se arrayse;
4993 gfc_se maskse;
4994 gfc_expr *arrayexpr;
4995 gfc_expr *maskexpr;
4996 int n;
4998 if (se->ss)
5000 gfc_conv_intrinsic_funcall (se, expr);
5001 return;
5004 type = gfc_typenode_for_spec (&expr->ts);
5005 /* Initialize the result. */
5006 limit = gfc_create_var (type, "limit");
5007 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
5008 switch (expr->ts.type)
5010 case BT_REAL:
5011 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
5012 expr->ts.kind, 0);
5013 if (HONOR_INFINITIES (DECL_MODE (limit)))
5015 REAL_VALUE_TYPE real;
5016 real_inf (&real);
5017 tmp = build_real (type, real);
5019 else
5020 tmp = huge_cst;
5021 if (HONOR_NANS (DECL_MODE (limit)))
5022 nan_cst = gfc_build_nan (type, "");
5023 break;
5025 case BT_INTEGER:
5026 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
5027 break;
5029 default:
5030 gcc_unreachable ();
5033 /* We start with the most negative possible value for MAXVAL, and the most
5034 positive possible value for MINVAL. The most negative possible value is
5035 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5036 possible value is HUGE in both cases. */
5037 if (op == GT_EXPR)
5039 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5040 if (huge_cst)
5041 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
5042 TREE_TYPE (huge_cst), huge_cst);
5045 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
5046 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5047 tmp, build_int_cst (type, 1));
5049 gfc_add_modify (&se->pre, limit, tmp);
5051 /* Walk the arguments. */
5052 actual = expr->value.function.actual;
5053 arrayexpr = actual->expr;
5054 arrayss = gfc_walk_expr (arrayexpr);
5055 gcc_assert (arrayss != gfc_ss_terminator);
5057 actual = actual->next->next;
5058 gcc_assert (actual);
5059 maskexpr = actual->expr;
5060 nonempty = NULL;
5061 if (maskexpr && maskexpr->rank != 0)
5063 maskss = gfc_walk_expr (maskexpr);
5064 gcc_assert (maskss != gfc_ss_terminator);
5066 else
5068 mpz_t asize;
5069 if (gfc_array_size (arrayexpr, &asize))
5071 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5072 mpz_clear (asize);
5073 nonempty = fold_build2_loc (input_location, GT_EXPR,
5074 boolean_type_node, nonempty,
5075 gfc_index_zero_node);
5077 maskss = NULL;
5080 /* Initialize the scalarizer. */
5081 gfc_init_loopinfo (&loop);
5082 gfc_add_ss_to_loop (&loop, arrayss);
5083 if (maskss)
5084 gfc_add_ss_to_loop (&loop, maskss);
5086 /* Initialize the loop. */
5087 gfc_conv_ss_startstride (&loop);
5089 /* The code generated can have more than one loop in sequence (see the
5090 comment at the function header). This doesn't work well with the
5091 scalarizer, which changes arrays' offset when the scalarization loops
5092 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5093 are currently inlined in the scalar case only. As there is no dependency
5094 to care about in that case, there is no temporary, so that we can use the
5095 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5096 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5097 gfc_trans_scalarized_loop_boundary even later to restore offset.
5098 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5099 should eventually go away. We could either create two loops properly,
5100 or find another way to save/restore the array offsets between the two
5101 loops (without conflicting with temporary management), or use a single
5102 loop minmaxval implementation. See PR 31067. */
5103 loop.temp_dim = loop.dimen;
5104 gfc_conv_loop_setup (&loop, &expr->where);
5106 if (nonempty == NULL && maskss == NULL
5107 && loop.dimen == 1 && loop.from[0] && loop.to[0])
5108 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
5109 loop.from[0], loop.to[0]);
5110 nonempty_var = NULL;
5111 if (nonempty == NULL
5112 && (HONOR_INFINITIES (DECL_MODE (limit))
5113 || HONOR_NANS (DECL_MODE (limit))))
5115 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
5116 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
5117 nonempty = nonempty_var;
5119 lab = NULL;
5120 fast = NULL;
5121 if (HONOR_NANS (DECL_MODE (limit)))
5123 if (loop.dimen == 1)
5125 lab = gfc_build_label_decl (NULL_TREE);
5126 TREE_USED (lab) = 1;
5128 else
5130 fast = gfc_create_var (boolean_type_node, "fast");
5131 gfc_add_modify (&se->pre, fast, boolean_false_node);
5135 gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
5136 if (maskss)
5137 gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
5138 /* Generate the loop body. */
5139 gfc_start_scalarized_body (&loop, &body);
5141 /* If we have a mask, only add this element if the mask is set. */
5142 if (maskss)
5144 gfc_init_se (&maskse, NULL);
5145 gfc_copy_loopinfo_to_se (&maskse, &loop);
5146 maskse.ss = maskss;
5147 gfc_conv_expr_val (&maskse, maskexpr);
5148 gfc_add_block_to_block (&body, &maskse.pre);
5150 gfc_start_block (&block);
5152 else
5153 gfc_init_block (&block);
5155 /* Compare with the current limit. */
5156 gfc_init_se (&arrayse, NULL);
5157 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5158 arrayse.ss = arrayss;
5159 gfc_conv_expr_val (&arrayse, arrayexpr);
5160 gfc_add_block_to_block (&block, &arrayse.pre);
5162 gfc_init_block (&block2);
5164 if (nonempty_var)
5165 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
5167 if (HONOR_NANS (DECL_MODE (limit)))
5169 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5170 boolean_type_node, arrayse.expr, limit);
5171 if (lab)
5172 ifbody = build1_v (GOTO_EXPR, lab);
5173 else
5175 stmtblock_t ifblock;
5177 gfc_init_block (&ifblock);
5178 gfc_add_modify (&ifblock, limit, arrayse.expr);
5179 gfc_add_modify (&ifblock, fast, boolean_true_node);
5180 ifbody = gfc_finish_block (&ifblock);
5182 tmp = build3_v (COND_EXPR, tmp, ifbody,
5183 build_empty_stmt (input_location));
5184 gfc_add_expr_to_block (&block2, tmp);
5186 else
5188 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5189 signed zeros. */
5190 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
5192 tmp = fold_build2_loc (input_location, op, boolean_type_node,
5193 arrayse.expr, limit);
5194 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
5195 tmp = build3_v (COND_EXPR, tmp, ifbody,
5196 build_empty_stmt (input_location));
5197 gfc_add_expr_to_block (&block2, tmp);
5199 else
5201 tmp = fold_build2_loc (input_location,
5202 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
5203 type, arrayse.expr, limit);
5204 gfc_add_modify (&block2, limit, tmp);
5208 if (fast)
5210 tree elsebody = gfc_finish_block (&block2);
5212 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5213 signed zeros. */
5214 if (HONOR_NANS (DECL_MODE (limit))
5215 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
5217 tmp = fold_build2_loc (input_location, op, boolean_type_node,
5218 arrayse.expr, limit);
5219 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
5220 ifbody = build3_v (COND_EXPR, tmp, ifbody,
5221 build_empty_stmt (input_location));
5223 else
5225 tmp = fold_build2_loc (input_location,
5226 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
5227 type, arrayse.expr, limit);
5228 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
5230 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
5231 gfc_add_expr_to_block (&block, tmp);
5233 else
5234 gfc_add_block_to_block (&block, &block2);
5236 gfc_add_block_to_block (&block, &arrayse.post);
5238 tmp = gfc_finish_block (&block);
5239 if (maskss)
5240 /* We enclose the above in if (mask) {...}. */
5241 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
5242 build_empty_stmt (input_location));
5243 gfc_add_expr_to_block (&body, tmp);
5245 if (lab)
5247 gfc_trans_scalarized_loop_boundary (&loop, &body);
5249 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
5250 nan_cst, huge_cst);
5251 gfc_add_modify (&loop.code[0], limit, tmp);
5252 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
5254 /* If we have a mask, only add this element if the mask is set. */
5255 if (maskss)
5257 gfc_init_se (&maskse, NULL);
5258 gfc_copy_loopinfo_to_se (&maskse, &loop);
5259 maskse.ss = maskss;
5260 gfc_conv_expr_val (&maskse, maskexpr);
5261 gfc_add_block_to_block (&body, &maskse.pre);
5263 gfc_start_block (&block);
5265 else
5266 gfc_init_block (&block);
5268 /* Compare with the current limit. */
5269 gfc_init_se (&arrayse, NULL);
5270 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5271 arrayse.ss = arrayss;
5272 gfc_conv_expr_val (&arrayse, arrayexpr);
5273 gfc_add_block_to_block (&block, &arrayse.pre);
5275 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5276 signed zeros. */
5277 if (HONOR_NANS (DECL_MODE (limit))
5278 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
5280 tmp = fold_build2_loc (input_location, op, boolean_type_node,
5281 arrayse.expr, limit);
5282 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
5283 tmp = build3_v (COND_EXPR, tmp, ifbody,
5284 build_empty_stmt (input_location));
5285 gfc_add_expr_to_block (&block, tmp);
5287 else
5289 tmp = fold_build2_loc (input_location,
5290 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
5291 type, arrayse.expr, limit);
5292 gfc_add_modify (&block, limit, tmp);
5295 gfc_add_block_to_block (&block, &arrayse.post);
5297 tmp = gfc_finish_block (&block);
5298 if (maskss)
5299 /* We enclose the above in if (mask) {...}. */
5300 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
5301 build_empty_stmt (input_location));
5302 gfc_add_expr_to_block (&body, tmp);
5303 /* Avoid initializing loopvar[0] again, it should be left where
5304 it finished by the first loop. */
5305 loop.from[0] = loop.loopvar[0];
5307 gfc_trans_scalarizing_loops (&loop, &body);
5309 if (fast)
5311 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
5312 nan_cst, huge_cst);
5313 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
5314 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
5315 ifbody);
5316 gfc_add_expr_to_block (&loop.pre, tmp);
5318 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
5320 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
5321 huge_cst);
5322 gfc_add_modify (&loop.pre, limit, tmp);
5325 /* For a scalar mask, enclose the loop in an if statement. */
5326 if (maskexpr && maskss == NULL)
5328 tree else_stmt;
5330 gfc_init_se (&maskse, NULL);
5331 gfc_conv_expr_val (&maskse, maskexpr);
5332 gfc_init_block (&block);
5333 gfc_add_block_to_block (&block, &loop.pre);
5334 gfc_add_block_to_block (&block, &loop.post);
5335 tmp = gfc_finish_block (&block);
5337 if (HONOR_INFINITIES (DECL_MODE (limit)))
5338 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
5339 else
5340 else_stmt = build_empty_stmt (input_location);
5341 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
5342 gfc_add_expr_to_block (&block, tmp);
5343 gfc_add_block_to_block (&se->pre, &block);
5345 else
5347 gfc_add_block_to_block (&se->pre, &loop.pre);
5348 gfc_add_block_to_block (&se->pre, &loop.post);
5351 gfc_cleanup_loop (&loop);
5353 se->expr = limit;
5356 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5357 static void
5358 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
5360 tree args[2];
5361 tree type;
5362 tree tmp;
5364 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5365 type = TREE_TYPE (args[0]);
5367 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
5368 build_int_cst (type, 1), args[1]);
5369 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
5370 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
5371 build_int_cst (type, 0));
5372 type = gfc_typenode_for_spec (&expr->ts);
5373 se->expr = convert (type, tmp);
5377 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5378 static void
5379 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
5381 tree args[2];
5383 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5385 /* Convert both arguments to the unsigned type of the same size. */
5386 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
5387 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
5389 /* If they have unequal type size, convert to the larger one. */
5390 if (TYPE_PRECISION (TREE_TYPE (args[0]))
5391 > TYPE_PRECISION (TREE_TYPE (args[1])))
5392 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
5393 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
5394 > TYPE_PRECISION (TREE_TYPE (args[0])))
5395 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
5397 /* Now, we compare them. */
5398 se->expr = fold_build2_loc (input_location, op, boolean_type_node,
5399 args[0], args[1]);
5403 /* Generate code to perform the specified operation. */
5404 static void
5405 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
5407 tree args[2];
5409 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5410 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
5411 args[0], args[1]);
5414 /* Bitwise not. */
5415 static void
5416 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
5418 tree arg;
5420 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5421 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
5422 TREE_TYPE (arg), arg);
5425 /* Set or clear a single bit. */
5426 static void
5427 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
5429 tree args[2];
5430 tree type;
5431 tree tmp;
5432 enum tree_code op;
5434 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5435 type = TREE_TYPE (args[0]);
5437 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
5438 build_int_cst (type, 1), args[1]);
5439 if (set)
5440 op = BIT_IOR_EXPR;
5441 else
5443 op = BIT_AND_EXPR;
5444 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
5446 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
5449 /* Extract a sequence of bits.
5450 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5451 static void
5452 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
5454 tree args[3];
5455 tree type;
5456 tree tmp;
5457 tree mask;
5459 gfc_conv_intrinsic_function_args (se, expr, args, 3);
5460 type = TREE_TYPE (args[0]);
5462 mask = build_int_cst (type, -1);
5463 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
5464 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
5466 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
5468 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
5471 static void
5472 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
5473 bool arithmetic)
5475 tree args[2], type, num_bits, cond;
5477 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5479 args[0] = gfc_evaluate_now (args[0], &se->pre);
5480 args[1] = gfc_evaluate_now (args[1], &se->pre);
5481 type = TREE_TYPE (args[0]);
5483 if (!arithmetic)
5484 args[0] = fold_convert (unsigned_type_for (type), args[0]);
5485 else
5486 gcc_assert (right_shift);
5488 se->expr = fold_build2_loc (input_location,
5489 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
5490 TREE_TYPE (args[0]), args[0], args[1]);
5492 if (!arithmetic)
5493 se->expr = fold_convert (type, se->expr);
5495 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5496 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5497 special case. */
5498 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
5499 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
5500 args[1], num_bits);
5502 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
5503 build_int_cst (type, 0), se->expr);
5506 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5508 : ((shift >= 0) ? i << shift : i >> -shift)
5509 where all shifts are logical shifts. */
5510 static void
5511 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
5513 tree args[2];
5514 tree type;
5515 tree utype;
5516 tree tmp;
5517 tree width;
5518 tree num_bits;
5519 tree cond;
5520 tree lshift;
5521 tree rshift;
5523 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5525 args[0] = gfc_evaluate_now (args[0], &se->pre);
5526 args[1] = gfc_evaluate_now (args[1], &se->pre);
5528 type = TREE_TYPE (args[0]);
5529 utype = unsigned_type_for (type);
5531 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
5532 args[1]);
5534 /* Left shift if positive. */
5535 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
5537 /* Right shift if negative.
5538 We convert to an unsigned type because we want a logical shift.
5539 The standard doesn't define the case of shifting negative
5540 numbers, and we try to be compatible with other compilers, most
5541 notably g77, here. */
5542 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
5543 utype, convert (utype, args[0]), width));
5545 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
5546 build_int_cst (TREE_TYPE (args[1]), 0));
5547 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
5549 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5550 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5551 special case. */
5552 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
5553 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
5554 num_bits);
5555 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
5556 build_int_cst (type, 0), tmp);
5560 /* Circular shift. AKA rotate or barrel shift. */
5562 static void
5563 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
5565 tree *args;
5566 tree type;
5567 tree tmp;
5568 tree lrot;
5569 tree rrot;
5570 tree zero;
5571 unsigned int num_args;
5573 num_args = gfc_intrinsic_argument_list_length (expr);
5574 args = XALLOCAVEC (tree, num_args);
5576 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
5578 if (num_args == 3)
5580 /* Use a library function for the 3 parameter version. */
5581 tree int4type = gfc_get_int_type (4);
5583 type = TREE_TYPE (args[0]);
5584 /* We convert the first argument to at least 4 bytes, and
5585 convert back afterwards. This removes the need for library
5586 functions for all argument sizes, and function will be
5587 aligned to at least 32 bits, so there's no loss. */
5588 if (expr->ts.kind < 4)
5589 args[0] = convert (int4type, args[0]);
5591 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5592 need loads of library functions. They cannot have values >
5593 BIT_SIZE (I) so the conversion is safe. */
5594 args[1] = convert (int4type, args[1]);
5595 args[2] = convert (int4type, args[2]);
5597 switch (expr->ts.kind)
5599 case 1:
5600 case 2:
5601 case 4:
5602 tmp = gfor_fndecl_math_ishftc4;
5603 break;
5604 case 8:
5605 tmp = gfor_fndecl_math_ishftc8;
5606 break;
5607 case 16:
5608 tmp = gfor_fndecl_math_ishftc16;
5609 break;
5610 default:
5611 gcc_unreachable ();
5613 se->expr = build_call_expr_loc (input_location,
5614 tmp, 3, args[0], args[1], args[2]);
5615 /* Convert the result back to the original type, if we extended
5616 the first argument's width above. */
5617 if (expr->ts.kind < 4)
5618 se->expr = convert (type, se->expr);
5620 return;
5622 type = TREE_TYPE (args[0]);
5624 /* Evaluate arguments only once. */
5625 args[0] = gfc_evaluate_now (args[0], &se->pre);
5626 args[1] = gfc_evaluate_now (args[1], &se->pre);
5628 /* Rotate left if positive. */
5629 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
5631 /* Rotate right if negative. */
5632 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
5633 args[1]);
5634 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
5636 zero = build_int_cst (TREE_TYPE (args[1]), 0);
5637 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
5638 zero);
5639 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
5641 /* Do nothing if shift == 0. */
5642 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
5643 zero);
5644 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
5645 rrot);
5649 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5650 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5652 The conditional expression is necessary because the result of LEADZ(0)
5653 is defined, but the result of __builtin_clz(0) is undefined for most
5654 targets.
5656 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5657 difference in bit size between the argument of LEADZ and the C int. */
5659 static void
5660 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
5662 tree arg;
5663 tree arg_type;
5664 tree cond;
5665 tree result_type;
5666 tree leadz;
5667 tree bit_size;
5668 tree tmp;
5669 tree func;
5670 int s, argsize;
5672 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5673 argsize = TYPE_PRECISION (TREE_TYPE (arg));
5675 /* Which variant of __builtin_clz* should we call? */
5676 if (argsize <= INT_TYPE_SIZE)
5678 arg_type = unsigned_type_node;
5679 func = builtin_decl_explicit (BUILT_IN_CLZ);
5681 else if (argsize <= LONG_TYPE_SIZE)
5683 arg_type = long_unsigned_type_node;
5684 func = builtin_decl_explicit (BUILT_IN_CLZL);
5686 else if (argsize <= LONG_LONG_TYPE_SIZE)
5688 arg_type = long_long_unsigned_type_node;
5689 func = builtin_decl_explicit (BUILT_IN_CLZLL);
5691 else
5693 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
5694 arg_type = gfc_build_uint_type (argsize);
5695 func = NULL_TREE;
5698 /* Convert the actual argument twice: first, to the unsigned type of the
5699 same size; then, to the proper argument type for the built-in
5700 function. But the return type is of the default INTEGER kind. */
5701 arg = fold_convert (gfc_build_uint_type (argsize), arg);
5702 arg = fold_convert (arg_type, arg);
5703 arg = gfc_evaluate_now (arg, &se->pre);
5704 result_type = gfc_get_int_type (gfc_default_integer_kind);
5706 /* Compute LEADZ for the case i .ne. 0. */
5707 if (func)
5709 s = TYPE_PRECISION (arg_type) - argsize;
5710 tmp = fold_convert (result_type,
5711 build_call_expr_loc (input_location, func,
5712 1, arg));
5713 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
5714 tmp, build_int_cst (result_type, s));
5716 else
5718 /* We end up here if the argument type is larger than 'long long'.
5719 We generate this code:
5721 if (x & (ULL_MAX << ULL_SIZE) != 0)
5722 return clzll ((unsigned long long) (x >> ULLSIZE));
5723 else
5724 return ULL_SIZE + clzll ((unsigned long long) x);
5725 where ULL_MAX is the largest value that a ULL_MAX can hold
5726 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5727 is the bit-size of the long long type (64 in this example). */
5728 tree ullsize, ullmax, tmp1, tmp2, btmp;
5730 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
5731 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
5732 long_long_unsigned_type_node,
5733 build_int_cst (long_long_unsigned_type_node,
5734 0));
5736 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
5737 fold_convert (arg_type, ullmax), ullsize);
5738 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
5739 arg, cond);
5740 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5741 cond, build_int_cst (arg_type, 0));
5743 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
5744 arg, ullsize);
5745 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
5746 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
5747 tmp1 = fold_convert (result_type,
5748 build_call_expr_loc (input_location, btmp, 1, tmp1));
5750 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
5751 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
5752 tmp2 = fold_convert (result_type,
5753 build_call_expr_loc (input_location, btmp, 1, tmp2));
5754 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
5755 tmp2, ullsize);
5757 leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
5758 cond, tmp1, tmp2);
5761 /* Build BIT_SIZE. */
5762 bit_size = build_int_cst (result_type, argsize);
5764 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5765 arg, build_int_cst (arg_type, 0));
5766 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
5767 bit_size, leadz);
5771 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5773 The conditional expression is necessary because the result of TRAILZ(0)
5774 is defined, but the result of __builtin_ctz(0) is undefined for most
5775 targets. */
5777 static void
5778 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
5780 tree arg;
5781 tree arg_type;
5782 tree cond;
5783 tree result_type;
5784 tree trailz;
5785 tree bit_size;
5786 tree func;
5787 int argsize;
5789 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5790 argsize = TYPE_PRECISION (TREE_TYPE (arg));
5792 /* Which variant of __builtin_ctz* should we call? */
5793 if (argsize <= INT_TYPE_SIZE)
5795 arg_type = unsigned_type_node;
5796 func = builtin_decl_explicit (BUILT_IN_CTZ);
5798 else if (argsize <= LONG_TYPE_SIZE)
5800 arg_type = long_unsigned_type_node;
5801 func = builtin_decl_explicit (BUILT_IN_CTZL);
5803 else if (argsize <= LONG_LONG_TYPE_SIZE)
5805 arg_type = long_long_unsigned_type_node;
5806 func = builtin_decl_explicit (BUILT_IN_CTZLL);
5808 else
5810 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
5811 arg_type = gfc_build_uint_type (argsize);
5812 func = NULL_TREE;
5815 /* Convert the actual argument twice: first, to the unsigned type of the
5816 same size; then, to the proper argument type for the built-in
5817 function. But the return type is of the default INTEGER kind. */
5818 arg = fold_convert (gfc_build_uint_type (argsize), arg);
5819 arg = fold_convert (arg_type, arg);
5820 arg = gfc_evaluate_now (arg, &se->pre);
5821 result_type = gfc_get_int_type (gfc_default_integer_kind);
5823 /* Compute TRAILZ for the case i .ne. 0. */
5824 if (func)
5825 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
5826 func, 1, arg));
5827 else
5829 /* We end up here if the argument type is larger than 'long long'.
5830 We generate this code:
5832 if ((x & ULL_MAX) == 0)
5833 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5834 else
5835 return ctzll ((unsigned long long) x);
5837 where ULL_MAX is the largest value that a ULL_MAX can hold
5838 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5839 is the bit-size of the long long type (64 in this example). */
5840 tree ullsize, ullmax, tmp1, tmp2, btmp;
5842 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
5843 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
5844 long_long_unsigned_type_node,
5845 build_int_cst (long_long_unsigned_type_node, 0));
5847 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
5848 fold_convert (arg_type, ullmax));
5849 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
5850 build_int_cst (arg_type, 0));
5852 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
5853 arg, ullsize);
5854 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
5855 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
5856 tmp1 = fold_convert (result_type,
5857 build_call_expr_loc (input_location, btmp, 1, tmp1));
5858 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
5859 tmp1, ullsize);
5861 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
5862 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
5863 tmp2 = fold_convert (result_type,
5864 build_call_expr_loc (input_location, btmp, 1, tmp2));
5866 trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
5867 cond, tmp1, tmp2);
5870 /* Build BIT_SIZE. */
5871 bit_size = build_int_cst (result_type, argsize);
5873 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5874 arg, build_int_cst (arg_type, 0));
5875 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
5876 bit_size, trailz);
5879 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5880 for types larger than "long long", we call the long long built-in for
5881 the lower and higher bits and combine the result. */
5883 static void
5884 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
5886 tree arg;
5887 tree arg_type;
5888 tree result_type;
5889 tree func;
5890 int argsize;
5892 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5893 argsize = TYPE_PRECISION (TREE_TYPE (arg));
5894 result_type = gfc_get_int_type (gfc_default_integer_kind);
5896 /* Which variant of the builtin should we call? */
5897 if (argsize <= INT_TYPE_SIZE)
5899 arg_type = unsigned_type_node;
5900 func = builtin_decl_explicit (parity
5901 ? BUILT_IN_PARITY
5902 : BUILT_IN_POPCOUNT);
5904 else if (argsize <= LONG_TYPE_SIZE)
5906 arg_type = long_unsigned_type_node;
5907 func = builtin_decl_explicit (parity
5908 ? BUILT_IN_PARITYL
5909 : BUILT_IN_POPCOUNTL);
5911 else if (argsize <= LONG_LONG_TYPE_SIZE)
5913 arg_type = long_long_unsigned_type_node;
5914 func = builtin_decl_explicit (parity
5915 ? BUILT_IN_PARITYLL
5916 : BUILT_IN_POPCOUNTLL);
5918 else
5920 /* Our argument type is larger than 'long long', which mean none
5921 of the POPCOUNT builtins covers it. We thus call the 'long long'
5922 variant multiple times, and add the results. */
5923 tree utype, arg2, call1, call2;
5925 /* For now, we only cover the case where argsize is twice as large
5926 as 'long long'. */
5927 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
5929 func = builtin_decl_explicit (parity
5930 ? BUILT_IN_PARITYLL
5931 : BUILT_IN_POPCOUNTLL);
5933 /* Convert it to an integer, and store into a variable. */
5934 utype = gfc_build_uint_type (argsize);
5935 arg = fold_convert (utype, arg);
5936 arg = gfc_evaluate_now (arg, &se->pre);
5938 /* Call the builtin twice. */
5939 call1 = build_call_expr_loc (input_location, func, 1,
5940 fold_convert (long_long_unsigned_type_node,
5941 arg));
5943 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
5944 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
5945 call2 = build_call_expr_loc (input_location, func, 1,
5946 fold_convert (long_long_unsigned_type_node,
5947 arg2));
5949 /* Combine the results. */
5950 if (parity)
5951 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
5952 call1, call2);
5953 else
5954 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
5955 call1, call2);
5957 return;
5960 /* Convert the actual argument twice: first, to the unsigned type of the
5961 same size; then, to the proper argument type for the built-in
5962 function. */
5963 arg = fold_convert (gfc_build_uint_type (argsize), arg);
5964 arg = fold_convert (arg_type, arg);
5966 se->expr = fold_convert (result_type,
5967 build_call_expr_loc (input_location, func, 1, arg));
5971 /* Process an intrinsic with unspecified argument-types that has an optional
5972 argument (which could be of type character), e.g. EOSHIFT. For those, we
5973 need to append the string length of the optional argument if it is not
5974 present and the type is really character.
5975 primary specifies the position (starting at 1) of the non-optional argument
5976 specifying the type and optional gives the position of the optional
5977 argument in the arglist. */
5979 static void
5980 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
5981 unsigned primary, unsigned optional)
5983 gfc_actual_arglist* prim_arg;
5984 gfc_actual_arglist* opt_arg;
5985 unsigned cur_pos;
5986 gfc_actual_arglist* arg;
5987 gfc_symbol* sym;
5988 vec<tree, va_gc> *append_args;
5990 /* Find the two arguments given as position. */
5991 cur_pos = 0;
5992 prim_arg = NULL;
5993 opt_arg = NULL;
5994 for (arg = expr->value.function.actual; arg; arg = arg->next)
5996 ++cur_pos;
5998 if (cur_pos == primary)
5999 prim_arg = arg;
6000 if (cur_pos == optional)
6001 opt_arg = arg;
6003 if (cur_pos >= primary && cur_pos >= optional)
6004 break;
6006 gcc_assert (prim_arg);
6007 gcc_assert (prim_arg->expr);
6008 gcc_assert (opt_arg);
6010 /* If we do have type CHARACTER and the optional argument is really absent,
6011 append a dummy 0 as string length. */
6012 append_args = NULL;
6013 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
6015 tree dummy;
6017 dummy = build_int_cst (gfc_charlen_type_node, 0);
6018 vec_alloc (append_args, 1);
6019 append_args->quick_push (dummy);
6022 /* Build the call itself. */
6023 gcc_assert (!se->ignore_optional);
6024 sym = gfc_get_symbol_for_expr (expr, false);
6025 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
6026 append_args);
6027 gfc_free_symbol (sym);
6031 /* The length of a character string. */
6032 static void
6033 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
6035 tree len;
6036 tree type;
6037 tree decl;
6038 gfc_symbol *sym;
6039 gfc_se argse;
6040 gfc_expr *arg;
6042 gcc_assert (!se->ss);
6044 arg = expr->value.function.actual->expr;
6046 type = gfc_typenode_for_spec (&expr->ts);
6047 switch (arg->expr_type)
6049 case EXPR_CONSTANT:
6050 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
6051 break;
6053 case EXPR_ARRAY:
6054 /* Obtain the string length from the function used by
6055 trans-array.c(gfc_trans_array_constructor). */
6056 len = NULL_TREE;
6057 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
6058 break;
6060 case EXPR_VARIABLE:
6061 if (arg->ref == NULL
6062 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
6064 /* This doesn't catch all cases.
6065 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6066 and the surrounding thread. */
6067 sym = arg->symtree->n.sym;
6068 decl = gfc_get_symbol_decl (sym);
6069 if (decl == current_function_decl && sym->attr.function
6070 && (sym->result == sym))
6071 decl = gfc_get_fake_result_decl (sym, 0);
6073 len = sym->ts.u.cl->backend_decl;
6074 gcc_assert (len);
6075 break;
6078 /* Fall through. */
6080 default:
6081 /* Anybody stupid enough to do this deserves inefficient code. */
6082 gfc_init_se (&argse, se);
6083 if (arg->rank == 0)
6084 gfc_conv_expr (&argse, arg);
6085 else
6086 gfc_conv_expr_descriptor (&argse, arg);
6087 gfc_add_block_to_block (&se->pre, &argse.pre);
6088 gfc_add_block_to_block (&se->post, &argse.post);
6089 len = argse.string_length;
6090 break;
6092 se->expr = convert (type, len);
6095 /* The length of a character string not including trailing blanks. */
6096 static void
6097 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
6099 int kind = expr->value.function.actual->expr->ts.kind;
6100 tree args[2], type, fndecl;
6102 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6103 type = gfc_typenode_for_spec (&expr->ts);
6105 if (kind == 1)
6106 fndecl = gfor_fndecl_string_len_trim;
6107 else if (kind == 4)
6108 fndecl = gfor_fndecl_string_len_trim_char4;
6109 else
6110 gcc_unreachable ();
6112 se->expr = build_call_expr_loc (input_location,
6113 fndecl, 2, args[0], args[1]);
6114 se->expr = convert (type, se->expr);
6118 /* Returns the starting position of a substring within a string. */
6120 static void
6121 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
6122 tree function)
6124 tree logical4_type_node = gfc_get_logical_type (4);
6125 tree type;
6126 tree fndecl;
6127 tree *args;
6128 unsigned int num_args;
6130 args = XALLOCAVEC (tree, 5);
6132 /* Get number of arguments; characters count double due to the
6133 string length argument. Kind= is not passed to the library
6134 and thus ignored. */
6135 if (expr->value.function.actual->next->next->expr == NULL)
6136 num_args = 4;
6137 else
6138 num_args = 5;
6140 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6141 type = gfc_typenode_for_spec (&expr->ts);
6143 if (num_args == 4)
6144 args[4] = build_int_cst (logical4_type_node, 0);
6145 else
6146 args[4] = convert (logical4_type_node, args[4]);
6148 fndecl = build_addr (function);
6149 se->expr = build_call_array_loc (input_location,
6150 TREE_TYPE (TREE_TYPE (function)), fndecl,
6151 5, args);
6152 se->expr = convert (type, se->expr);
6156 /* The ascii value for a single character. */
6157 static void
6158 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
6160 tree args[3], type, pchartype;
6161 int nargs;
6163 nargs = gfc_intrinsic_argument_list_length (expr);
6164 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
6165 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
6166 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
6167 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
6168 type = gfc_typenode_for_spec (&expr->ts);
6170 se->expr = build_fold_indirect_ref_loc (input_location,
6171 args[1]);
6172 se->expr = convert (type, se->expr);
6176 /* Intrinsic ISNAN calls __builtin_isnan. */
6178 static void
6179 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
6181 tree arg;
6183 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6184 se->expr = build_call_expr_loc (input_location,
6185 builtin_decl_explicit (BUILT_IN_ISNAN),
6186 1, arg);
6187 STRIP_TYPE_NOPS (se->expr);
6188 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
6192 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6193 their argument against a constant integer value. */
6195 static void
6196 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
6198 tree arg;
6200 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6201 se->expr = fold_build2_loc (input_location, EQ_EXPR,
6202 gfc_typenode_for_spec (&expr->ts),
6203 arg, build_int_cst (TREE_TYPE (arg), value));
6208 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6210 static void
6211 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
6213 tree tsource;
6214 tree fsource;
6215 tree mask;
6216 tree type;
6217 tree len, len2;
6218 tree *args;
6219 unsigned int num_args;
6221 num_args = gfc_intrinsic_argument_list_length (expr);
6222 args = XALLOCAVEC (tree, num_args);
6224 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6225 if (expr->ts.type != BT_CHARACTER)
6227 tsource = args[0];
6228 fsource = args[1];
6229 mask = args[2];
6231 else
6233 /* We do the same as in the non-character case, but the argument
6234 list is different because of the string length arguments. We
6235 also have to set the string length for the result. */
6236 len = args[0];
6237 tsource = args[1];
6238 len2 = args[2];
6239 fsource = args[3];
6240 mask = args[4];
6242 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
6243 &se->pre);
6244 se->string_length = len;
6246 type = TREE_TYPE (tsource);
6247 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
6248 fold_convert (type, fsource));
6252 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6254 static void
6255 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
6257 tree args[3], mask, type;
6259 gfc_conv_intrinsic_function_args (se, expr, args, 3);
6260 mask = gfc_evaluate_now (args[2], &se->pre);
6262 type = TREE_TYPE (args[0]);
6263 gcc_assert (TREE_TYPE (args[1]) == type);
6264 gcc_assert (TREE_TYPE (mask) == type);
6266 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
6267 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
6268 fold_build1_loc (input_location, BIT_NOT_EXPR,
6269 type, mask));
6270 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
6271 args[0], args[1]);
6275 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6276 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6278 static void
6279 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
6281 tree arg, allones, type, utype, res, cond, bitsize;
6282 int i;
6284 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6285 arg = gfc_evaluate_now (arg, &se->pre);
6287 type = gfc_get_int_type (expr->ts.kind);
6288 utype = unsigned_type_for (type);
6290 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
6291 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
6293 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
6294 build_int_cst (utype, 0));
6296 if (left)
6298 /* Left-justified mask. */
6299 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
6300 bitsize, arg);
6301 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
6302 fold_convert (utype, res));
6304 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6305 smaller than type width. */
6306 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
6307 build_int_cst (TREE_TYPE (arg), 0));
6308 res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
6309 build_int_cst (utype, 0), res);
6311 else
6313 /* Right-justified mask. */
6314 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
6315 fold_convert (utype, arg));
6316 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
6318 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6319 strictly smaller than type width. */
6320 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6321 arg, bitsize);
6322 res = fold_build3_loc (input_location, COND_EXPR, utype,
6323 cond, allones, res);
6326 se->expr = fold_convert (type, res);
6330 /* FRACTION (s) is translated into:
6331 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6332 static void
6333 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
6335 tree arg, type, tmp, res, frexp, cond;
6337 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6339 type = gfc_typenode_for_spec (&expr->ts);
6340 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6341 arg = gfc_evaluate_now (arg, &se->pre);
6343 cond = build_call_expr_loc (input_location,
6344 builtin_decl_explicit (BUILT_IN_ISFINITE),
6345 1, arg);
6347 tmp = gfc_create_var (integer_type_node, NULL);
6348 res = build_call_expr_loc (input_location, frexp, 2,
6349 fold_convert (type, arg),
6350 gfc_build_addr_expr (NULL_TREE, tmp));
6351 res = fold_convert (type, res);
6353 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
6354 cond, res, gfc_build_nan (type, ""));
6358 /* NEAREST (s, dir) is translated into
6359 tmp = copysign (HUGE_VAL, dir);
6360 return nextafter (s, tmp);
6362 static void
6363 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
6365 tree args[2], type, tmp, nextafter, copysign, huge_val;
6367 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
6368 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
6370 type = gfc_typenode_for_spec (&expr->ts);
6371 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6373 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
6374 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
6375 fold_convert (type, args[1]));
6376 se->expr = build_call_expr_loc (input_location, nextafter, 2,
6377 fold_convert (type, args[0]), tmp);
6378 se->expr = fold_convert (type, se->expr);
6382 /* SPACING (s) is translated into
6383 int e;
6384 if (!isfinite (s))
6385 res = NaN;
6386 else if (s == 0)
6387 res = tiny;
6388 else
6390 frexp (s, &e);
6391 e = e - prec;
6392 e = MAX_EXPR (e, emin);
6393 res = scalbn (1., e);
6395 return res;
6397 where prec is the precision of s, gfc_real_kinds[k].digits,
6398 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6399 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6401 static void
6402 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
6404 tree arg, type, prec, emin, tiny, res, e;
6405 tree cond, nan, tmp, frexp, scalbn;
6406 int k;
6407 stmtblock_t block;
6409 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
6410 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
6411 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
6412 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
6414 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6415 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6417 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6418 arg = gfc_evaluate_now (arg, &se->pre);
6420 type = gfc_typenode_for_spec (&expr->ts);
6421 e = gfc_create_var (integer_type_node, NULL);
6422 res = gfc_create_var (type, NULL);
6425 /* Build the block for s /= 0. */
6426 gfc_start_block (&block);
6427 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
6428 gfc_build_addr_expr (NULL_TREE, e));
6429 gfc_add_expr_to_block (&block, tmp);
6431 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
6432 prec);
6433 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
6434 integer_type_node, tmp, emin));
6436 tmp = build_call_expr_loc (input_location, scalbn, 2,
6437 build_real_from_int_cst (type, integer_one_node), e);
6438 gfc_add_modify (&block, res, tmp);
6440 /* Finish by building the IF statement for value zero. */
6441 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
6442 build_real_from_int_cst (type, integer_zero_node));
6443 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
6444 gfc_finish_block (&block));
6446 /* And deal with infinities and NaNs. */
6447 cond = build_call_expr_loc (input_location,
6448 builtin_decl_explicit (BUILT_IN_ISFINITE),
6449 1, arg);
6450 nan = gfc_build_nan (type, "");
6451 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
6453 gfc_add_expr_to_block (&se->pre, tmp);
6454 se->expr = res;
6458 /* RRSPACING (s) is translated into
6459 int e;
6460 real x;
6461 x = fabs (s);
6462 if (isfinite (x))
6464 if (x != 0)
6466 frexp (s, &e);
6467 x = scalbn (x, precision - e);
6470 else
6471 x = NaN;
6472 return x;
6474 where precision is gfc_real_kinds[k].digits. */
6476 static void
6477 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
6479 tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
6480 int prec, k;
6481 stmtblock_t block;
6483 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
6484 prec = gfc_real_kinds[k].digits;
6486 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6487 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6488 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
6490 type = gfc_typenode_for_spec (&expr->ts);
6491 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6492 arg = gfc_evaluate_now (arg, &se->pre);
6494 e = gfc_create_var (integer_type_node, NULL);
6495 x = gfc_create_var (type, NULL);
6496 gfc_add_modify (&se->pre, x,
6497 build_call_expr_loc (input_location, fabs, 1, arg));
6500 gfc_start_block (&block);
6501 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
6502 gfc_build_addr_expr (NULL_TREE, e));
6503 gfc_add_expr_to_block (&block, tmp);
6505 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
6506 build_int_cst (integer_type_node, prec), e);
6507 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
6508 gfc_add_modify (&block, x, tmp);
6509 stmt = gfc_finish_block (&block);
6511 /* if (x != 0) */
6512 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
6513 build_real_from_int_cst (type, integer_zero_node));
6514 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
6516 /* And deal with infinities and NaNs. */
6517 cond = build_call_expr_loc (input_location,
6518 builtin_decl_explicit (BUILT_IN_ISFINITE),
6519 1, x);
6520 nan = gfc_build_nan (type, "");
6521 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
6523 gfc_add_expr_to_block (&se->pre, tmp);
6524 se->expr = fold_convert (type, x);
6528 /* SCALE (s, i) is translated into scalbn (s, i). */
6529 static void
6530 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
6532 tree args[2], type, scalbn;
6534 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6536 type = gfc_typenode_for_spec (&expr->ts);
6537 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6538 se->expr = build_call_expr_loc (input_location, scalbn, 2,
6539 fold_convert (type, args[0]),
6540 fold_convert (integer_type_node, args[1]));
6541 se->expr = fold_convert (type, se->expr);
6545 /* SET_EXPONENT (s, i) is translated into
6546 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6547 static void
6548 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
6550 tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
6552 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6553 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6555 type = gfc_typenode_for_spec (&expr->ts);
6556 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6557 args[0] = gfc_evaluate_now (args[0], &se->pre);
6559 tmp = gfc_create_var (integer_type_node, NULL);
6560 tmp = build_call_expr_loc (input_location, frexp, 2,
6561 fold_convert (type, args[0]),
6562 gfc_build_addr_expr (NULL_TREE, tmp));
6563 res = build_call_expr_loc (input_location, scalbn, 2, tmp,
6564 fold_convert (integer_type_node, args[1]));
6565 res = fold_convert (type, res);
6567 /* Call to isfinite */
6568 cond = build_call_expr_loc (input_location,
6569 builtin_decl_explicit (BUILT_IN_ISFINITE),
6570 1, args[0]);
6571 nan = gfc_build_nan (type, "");
6573 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6574 res, nan);
6578 static void
6579 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
6581 gfc_actual_arglist *actual;
6582 tree arg1;
6583 tree type;
6584 tree fncall0;
6585 tree fncall1;
6586 gfc_se argse;
6588 gfc_init_se (&argse, NULL);
6589 actual = expr->value.function.actual;
6591 if (actual->expr->ts.type == BT_CLASS)
6592 gfc_add_class_array_ref (actual->expr);
6594 argse.data_not_needed = 1;
6595 if (gfc_is_alloc_class_array_function (actual->expr))
6597 /* For functions that return a class array conv_expr_descriptor is not
6598 able to get the descriptor right. Therefore this special case. */
6599 gfc_conv_expr_reference (&argse, actual->expr);
6600 argse.expr = gfc_build_addr_expr (NULL_TREE,
6601 gfc_class_data_get (argse.expr));
6603 else
6605 argse.want_pointer = 1;
6606 gfc_conv_expr_descriptor (&argse, actual->expr);
6608 gfc_add_block_to_block (&se->pre, &argse.pre);
6609 gfc_add_block_to_block (&se->post, &argse.post);
6610 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
6612 /* Build the call to size0. */
6613 fncall0 = build_call_expr_loc (input_location,
6614 gfor_fndecl_size0, 1, arg1);
6616 actual = actual->next;
6618 if (actual->expr)
6620 gfc_init_se (&argse, NULL);
6621 gfc_conv_expr_type (&argse, actual->expr,
6622 gfc_array_index_type);
6623 gfc_add_block_to_block (&se->pre, &argse.pre);
6625 /* Unusually, for an intrinsic, size does not exclude
6626 an optional arg2, so we must test for it. */
6627 if (actual->expr->expr_type == EXPR_VARIABLE
6628 && actual->expr->symtree->n.sym->attr.dummy
6629 && actual->expr->symtree->n.sym->attr.optional)
6631 tree tmp;
6632 /* Build the call to size1. */
6633 fncall1 = build_call_expr_loc (input_location,
6634 gfor_fndecl_size1, 2,
6635 arg1, argse.expr);
6637 gfc_init_se (&argse, NULL);
6638 argse.want_pointer = 1;
6639 argse.data_not_needed = 1;
6640 gfc_conv_expr (&argse, actual->expr);
6641 gfc_add_block_to_block (&se->pre, &argse.pre);
6642 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6643 argse.expr, null_pointer_node);
6644 tmp = gfc_evaluate_now (tmp, &se->pre);
6645 se->expr = fold_build3_loc (input_location, COND_EXPR,
6646 pvoid_type_node, tmp, fncall1, fncall0);
6648 else
6650 se->expr = NULL_TREE;
6651 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
6652 gfc_array_index_type,
6653 argse.expr, gfc_index_one_node);
6656 else if (expr->value.function.actual->expr->rank == 1)
6658 argse.expr = gfc_index_zero_node;
6659 se->expr = NULL_TREE;
6661 else
6662 se->expr = fncall0;
6664 if (se->expr == NULL_TREE)
6666 tree ubound, lbound;
6668 arg1 = build_fold_indirect_ref_loc (input_location,
6669 arg1);
6670 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
6671 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
6672 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
6673 gfc_array_index_type, ubound, lbound);
6674 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
6675 gfc_array_index_type,
6676 se->expr, gfc_index_one_node);
6677 se->expr = fold_build2_loc (input_location, MAX_EXPR,
6678 gfc_array_index_type, se->expr,
6679 gfc_index_zero_node);
6682 type = gfc_typenode_for_spec (&expr->ts);
6683 se->expr = convert (type, se->expr);
6687 /* Helper function to compute the size of a character variable,
6688 excluding the terminating null characters. The result has
6689 gfc_array_index_type type. */
6691 tree
6692 size_of_string_in_bytes (int kind, tree string_length)
6694 tree bytesize;
6695 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
6697 bytesize = build_int_cst (gfc_array_index_type,
6698 gfc_character_kinds[i].bit_size / 8);
6700 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6701 bytesize,
6702 fold_convert (gfc_array_index_type, string_length));
6706 static void
6707 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
6709 gfc_expr *arg;
6710 gfc_se argse;
6711 tree source_bytes;
6712 tree tmp;
6713 tree lower;
6714 tree upper;
6715 tree byte_size;
6716 int n;
6718 gfc_init_se (&argse, NULL);
6719 arg = expr->value.function.actual->expr;
6721 if (arg->rank || arg->ts.type == BT_ASSUMED)
6722 gfc_conv_expr_descriptor (&argse, arg);
6723 else
6724 gfc_conv_expr_reference (&argse, arg);
6726 if (arg->ts.type == BT_ASSUMED)
6728 /* This only works if an array descriptor has been passed; thus, extract
6729 the size from the descriptor. */
6730 gcc_assert (TYPE_PRECISION (gfc_array_index_type)
6731 == TYPE_PRECISION (size_type_node));
6732 tmp = arg->symtree->n.sym->backend_decl;
6733 tmp = DECL_LANG_SPECIFIC (tmp)
6734 && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
6735 ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
6736 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
6737 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6738 tmp = fold_convert (size_type_node, gfc_conv_descriptor_dtype (tmp));
6739 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, TREE_TYPE (tmp), tmp,
6740 build_int_cst (TREE_TYPE (tmp),
6741 GFC_DTYPE_SIZE_SHIFT));
6742 byte_size = fold_convert (gfc_array_index_type, tmp);
6744 else if (arg->ts.type == BT_CLASS)
6746 /* Conv_expr_descriptor returns a component_ref to _data component of the
6747 class object. The class object may be a non-pointer object, e.g.
6748 located on the stack, or a memory location pointed to, e.g. a
6749 parameter, i.e., an indirect_ref. */
6750 if (arg->rank < 0
6751 || (arg->rank > 0 && !VAR_P (argse.expr)
6752 && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0))
6753 && GFC_DECL_CLASS (TREE_OPERAND (
6754 TREE_OPERAND (argse.expr, 0), 0)))
6755 || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)))))
6756 byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
6757 else if (arg->rank > 0
6758 || (arg->rank == 0
6759 && arg->ref && arg->ref->type == REF_COMPONENT))
6760 /* The scalarizer added an additional temp. To get the class' vptr
6761 one has to look at the original backend_decl. */
6762 byte_size = gfc_class_vtab_size_get (
6763 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
6764 else
6765 byte_size = gfc_class_vtab_size_get (argse.expr);
6767 else
6769 if (arg->ts.type == BT_CHARACTER)
6770 byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
6771 else
6773 if (arg->rank == 0)
6774 byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
6775 argse.expr));
6776 else
6777 byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
6778 byte_size = fold_convert (gfc_array_index_type,
6779 size_in_bytes (byte_size));
6783 if (arg->rank == 0)
6784 se->expr = byte_size;
6785 else
6787 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
6788 gfc_add_modify (&argse.pre, source_bytes, byte_size);
6790 if (arg->rank == -1)
6792 tree cond, loop_var, exit_label;
6793 stmtblock_t body;
6795 tmp = fold_convert (gfc_array_index_type,
6796 gfc_conv_descriptor_rank (argse.expr));
6797 loop_var = gfc_create_var (gfc_array_index_type, "i");
6798 gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
6799 exit_label = gfc_build_label_decl (NULL_TREE);
6801 /* Create loop:
6802 for (;;)
6804 if (i >= rank)
6805 goto exit;
6806 source_bytes = source_bytes * array.dim[i].extent;
6807 i = i + 1;
6809 exit: */
6810 gfc_start_block (&body);
6811 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6812 loop_var, tmp);
6813 tmp = build1_v (GOTO_EXPR, exit_label);
6814 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
6815 cond, tmp, build_empty_stmt (input_location));
6816 gfc_add_expr_to_block (&body, tmp);
6818 lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
6819 upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
6820 tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
6821 tmp = fold_build2_loc (input_location, MULT_EXPR,
6822 gfc_array_index_type, tmp, source_bytes);
6823 gfc_add_modify (&body, source_bytes, tmp);
6825 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6826 gfc_array_index_type, loop_var,
6827 gfc_index_one_node);
6828 gfc_add_modify_loc (input_location, &body, loop_var, tmp);
6830 tmp = gfc_finish_block (&body);
6832 tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
6833 tmp);
6834 gfc_add_expr_to_block (&argse.pre, tmp);
6836 tmp = build1_v (LABEL_EXPR, exit_label);
6837 gfc_add_expr_to_block (&argse.pre, tmp);
6839 else
6841 /* Obtain the size of the array in bytes. */
6842 for (n = 0; n < arg->rank; n++)
6844 tree idx;
6845 idx = gfc_rank_cst[n];
6846 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
6847 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
6848 tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
6849 tmp = fold_build2_loc (input_location, MULT_EXPR,
6850 gfc_array_index_type, tmp, source_bytes);
6851 gfc_add_modify (&argse.pre, source_bytes, tmp);
6854 se->expr = source_bytes;
6857 gfc_add_block_to_block (&se->pre, &argse.pre);
6861 static void
6862 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
6864 gfc_expr *arg;
6865 gfc_se argse;
6866 tree type, result_type, tmp;
6868 arg = expr->value.function.actual->expr;
6870 gfc_init_se (&argse, NULL);
6871 result_type = gfc_get_int_type (expr->ts.kind);
6873 if (arg->rank == 0)
6875 if (arg->ts.type == BT_CLASS)
6877 gfc_add_vptr_component (arg);
6878 gfc_add_size_component (arg);
6879 gfc_conv_expr (&argse, arg);
6880 tmp = fold_convert (result_type, argse.expr);
6881 goto done;
6884 gfc_conv_expr_reference (&argse, arg);
6885 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
6886 argse.expr));
6888 else
6890 argse.want_pointer = 0;
6891 gfc_conv_expr_descriptor (&argse, arg);
6892 if (arg->ts.type == BT_CLASS)
6894 if (arg->rank > 0)
6895 tmp = gfc_class_vtab_size_get (
6896 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
6897 else
6898 tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
6899 tmp = fold_convert (result_type, tmp);
6900 goto done;
6902 type = gfc_get_element_type (TREE_TYPE (argse.expr));
6905 /* Obtain the argument's word length. */
6906 if (arg->ts.type == BT_CHARACTER)
6907 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
6908 else
6909 tmp = size_in_bytes (type);
6910 tmp = fold_convert (result_type, tmp);
6912 done:
6913 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
6914 build_int_cst (result_type, BITS_PER_UNIT));
6915 gfc_add_block_to_block (&se->pre, &argse.pre);
6919 /* Intrinsic string comparison functions. */
6921 static void
6922 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6924 tree args[4];
6926 gfc_conv_intrinsic_function_args (se, expr, args, 4);
6928 se->expr
6929 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
6930 expr->value.function.actual->expr->ts.kind,
6931 op);
6932 se->expr = fold_build2_loc (input_location, op,
6933 gfc_typenode_for_spec (&expr->ts), se->expr,
6934 build_int_cst (TREE_TYPE (se->expr), 0));
6937 /* Generate a call to the adjustl/adjustr library function. */
6938 static void
6939 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
6941 tree args[3];
6942 tree len;
6943 tree type;
6944 tree var;
6945 tree tmp;
6947 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
6948 len = args[1];
6950 type = TREE_TYPE (args[2]);
6951 var = gfc_conv_string_tmp (se, type, len);
6952 args[0] = var;
6954 tmp = build_call_expr_loc (input_location,
6955 fndecl, 3, args[0], args[1], args[2]);
6956 gfc_add_expr_to_block (&se->pre, tmp);
6957 se->expr = var;
6958 se->string_length = len;
6962 /* Generate code for the TRANSFER intrinsic:
6963 For scalar results:
6964 DEST = TRANSFER (SOURCE, MOLD)
6965 where:
6966 typeof<DEST> = typeof<MOLD>
6967 and:
6968 MOLD is scalar.
6970 For array results:
6971 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6972 where:
6973 typeof<DEST> = typeof<MOLD>
6974 and:
6975 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6976 sizeof (DEST(0) * SIZE). */
6977 static void
6978 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
6980 tree tmp;
6981 tree tmpdecl;
6982 tree ptr;
6983 tree extent;
6984 tree source;
6985 tree source_type;
6986 tree source_bytes;
6987 tree mold_type;
6988 tree dest_word_len;
6989 tree size_words;
6990 tree size_bytes;
6991 tree upper;
6992 tree lower;
6993 tree stmt;
6994 gfc_actual_arglist *arg;
6995 gfc_se argse;
6996 gfc_array_info *info;
6997 stmtblock_t block;
6998 int n;
6999 bool scalar_mold;
7000 gfc_expr *source_expr, *mold_expr;
7002 info = NULL;
7003 if (se->loop)
7004 info = &se->ss->info->data.array;
7006 /* Convert SOURCE. The output from this stage is:-
7007 source_bytes = length of the source in bytes
7008 source = pointer to the source data. */
7009 arg = expr->value.function.actual;
7010 source_expr = arg->expr;
7012 /* Ensure double transfer through LOGICAL preserves all
7013 the needed bits. */
7014 if (arg->expr->expr_type == EXPR_FUNCTION
7015 && arg->expr->value.function.esym == NULL
7016 && arg->expr->value.function.isym != NULL
7017 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
7018 && arg->expr->ts.type == BT_LOGICAL
7019 && expr->ts.type != arg->expr->ts.type)
7020 arg->expr->value.function.name = "__transfer_in_transfer";
7022 gfc_init_se (&argse, NULL);
7024 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
7026 /* Obtain the pointer to source and the length of source in bytes. */
7027 if (arg->expr->rank == 0)
7029 gfc_conv_expr_reference (&argse, arg->expr);
7030 if (arg->expr->ts.type == BT_CLASS)
7031 source = gfc_class_data_get (argse.expr);
7032 else
7033 source = argse.expr;
7035 /* Obtain the source word length. */
7036 switch (arg->expr->ts.type)
7038 case BT_CHARACTER:
7039 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
7040 argse.string_length);
7041 break;
7042 case BT_CLASS:
7043 tmp = gfc_class_vtab_size_get (argse.expr);
7044 break;
7045 default:
7046 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7047 source));
7048 tmp = fold_convert (gfc_array_index_type,
7049 size_in_bytes (source_type));
7050 break;
7053 else
7055 argse.want_pointer = 0;
7056 gfc_conv_expr_descriptor (&argse, arg->expr);
7057 source = gfc_conv_descriptor_data_get (argse.expr);
7058 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
7060 /* Repack the source if not simply contiguous. */
7061 if (!gfc_is_simply_contiguous (arg->expr, false, true))
7063 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
7065 if (warn_array_temporaries)
7066 gfc_warning (OPT_Warray_temporaries,
7067 "Creating array temporary at %L", &expr->where);
7069 source = build_call_expr_loc (input_location,
7070 gfor_fndecl_in_pack, 1, tmp);
7071 source = gfc_evaluate_now (source, &argse.pre);
7073 /* Free the temporary. */
7074 gfc_start_block (&block);
7075 tmp = gfc_call_free (source);
7076 gfc_add_expr_to_block (&block, tmp);
7077 stmt = gfc_finish_block (&block);
7079 /* Clean up if it was repacked. */
7080 gfc_init_block (&block);
7081 tmp = gfc_conv_array_data (argse.expr);
7082 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7083 source, tmp);
7084 tmp = build3_v (COND_EXPR, tmp, stmt,
7085 build_empty_stmt (input_location));
7086 gfc_add_expr_to_block (&block, tmp);
7087 gfc_add_block_to_block (&block, &se->post);
7088 gfc_init_block (&se->post);
7089 gfc_add_block_to_block (&se->post, &block);
7092 /* Obtain the source word length. */
7093 if (arg->expr->ts.type == BT_CHARACTER)
7094 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
7095 argse.string_length);
7096 else
7097 tmp = fold_convert (gfc_array_index_type,
7098 size_in_bytes (source_type));
7100 /* Obtain the size of the array in bytes. */
7101 extent = gfc_create_var (gfc_array_index_type, NULL);
7102 for (n = 0; n < arg->expr->rank; n++)
7104 tree idx;
7105 idx = gfc_rank_cst[n];
7106 gfc_add_modify (&argse.pre, source_bytes, tmp);
7107 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
7108 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
7109 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7110 gfc_array_index_type, upper, lower);
7111 gfc_add_modify (&argse.pre, extent, tmp);
7112 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7113 gfc_array_index_type, extent,
7114 gfc_index_one_node);
7115 tmp = fold_build2_loc (input_location, MULT_EXPR,
7116 gfc_array_index_type, tmp, source_bytes);
7120 gfc_add_modify (&argse.pre, source_bytes, tmp);
7121 gfc_add_block_to_block (&se->pre, &argse.pre);
7122 gfc_add_block_to_block (&se->post, &argse.post);
7124 /* Now convert MOLD. The outputs are:
7125 mold_type = the TREE type of MOLD
7126 dest_word_len = destination word length in bytes. */
7127 arg = arg->next;
7128 mold_expr = arg->expr;
7130 gfc_init_se (&argse, NULL);
7132 scalar_mold = arg->expr->rank == 0;
7134 if (arg->expr->rank == 0)
7136 gfc_conv_expr_reference (&argse, arg->expr);
7137 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7138 argse.expr));
7140 else
7142 gfc_init_se (&argse, NULL);
7143 argse.want_pointer = 0;
7144 gfc_conv_expr_descriptor (&argse, arg->expr);
7145 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
7148 gfc_add_block_to_block (&se->pre, &argse.pre);
7149 gfc_add_block_to_block (&se->post, &argse.post);
7151 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
7153 /* If this TRANSFER is nested in another TRANSFER, use a type
7154 that preserves all bits. */
7155 if (arg->expr->ts.type == BT_LOGICAL)
7156 mold_type = gfc_get_int_type (arg->expr->ts.kind);
7159 /* Obtain the destination word length. */
7160 switch (arg->expr->ts.type)
7162 case BT_CHARACTER:
7163 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
7164 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
7165 break;
7166 case BT_CLASS:
7167 tmp = gfc_class_vtab_size_get (argse.expr);
7168 break;
7169 default:
7170 tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
7171 break;
7173 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
7174 gfc_add_modify (&se->pre, dest_word_len, tmp);
7176 /* Finally convert SIZE, if it is present. */
7177 arg = arg->next;
7178 size_words = gfc_create_var (gfc_array_index_type, NULL);
7180 if (arg->expr)
7182 gfc_init_se (&argse, NULL);
7183 gfc_conv_expr_reference (&argse, arg->expr);
7184 tmp = convert (gfc_array_index_type,
7185 build_fold_indirect_ref_loc (input_location,
7186 argse.expr));
7187 gfc_add_block_to_block (&se->pre, &argse.pre);
7188 gfc_add_block_to_block (&se->post, &argse.post);
7190 else
7191 tmp = NULL_TREE;
7193 /* Separate array and scalar results. */
7194 if (scalar_mold && tmp == NULL_TREE)
7195 goto scalar_transfer;
7197 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
7198 if (tmp != NULL_TREE)
7199 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7200 tmp, dest_word_len);
7201 else
7202 tmp = source_bytes;
7204 gfc_add_modify (&se->pre, size_bytes, tmp);
7205 gfc_add_modify (&se->pre, size_words,
7206 fold_build2_loc (input_location, CEIL_DIV_EXPR,
7207 gfc_array_index_type,
7208 size_bytes, dest_word_len));
7210 /* Evaluate the bounds of the result. If the loop range exists, we have
7211 to check if it is too large. If so, we modify loop->to be consistent
7212 with min(size, size(source)). Otherwise, size is made consistent with
7213 the loop range, so that the right number of bytes is transferred.*/
7214 n = se->loop->order[0];
7215 if (se->loop->to[n] != NULL_TREE)
7217 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7218 se->loop->to[n], se->loop->from[n]);
7219 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7220 tmp, gfc_index_one_node);
7221 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
7222 tmp, size_words);
7223 gfc_add_modify (&se->pre, size_words, tmp);
7224 gfc_add_modify (&se->pre, size_bytes,
7225 fold_build2_loc (input_location, MULT_EXPR,
7226 gfc_array_index_type,
7227 size_words, dest_word_len));
7228 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7229 size_words, se->loop->from[n]);
7230 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7231 upper, gfc_index_one_node);
7233 else
7235 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7236 size_words, gfc_index_one_node);
7237 se->loop->from[n] = gfc_index_zero_node;
7240 se->loop->to[n] = upper;
7242 /* Build a destination descriptor, using the pointer, source, as the
7243 data field. */
7244 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
7245 NULL_TREE, false, true, false, &expr->where);
7247 /* Cast the pointer to the result. */
7248 tmp = gfc_conv_descriptor_data_get (info->descriptor);
7249 tmp = fold_convert (pvoid_type_node, tmp);
7251 /* Use memcpy to do the transfer. */
7253 = build_call_expr_loc (input_location,
7254 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
7255 fold_convert (pvoid_type_node, source),
7256 fold_convert (size_type_node,
7257 fold_build2_loc (input_location,
7258 MIN_EXPR,
7259 gfc_array_index_type,
7260 size_bytes,
7261 source_bytes)));
7262 gfc_add_expr_to_block (&se->pre, tmp);
7264 se->expr = info->descriptor;
7265 if (expr->ts.type == BT_CHARACTER)
7266 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
7268 return;
7270 /* Deal with scalar results. */
7271 scalar_transfer:
7272 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
7273 dest_word_len, source_bytes);
7274 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
7275 extent, gfc_index_zero_node);
7277 if (expr->ts.type == BT_CHARACTER)
7279 tree direct, indirect, free;
7281 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
7282 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
7283 "transfer");
7285 /* If source is longer than the destination, use a pointer to
7286 the source directly. */
7287 gfc_init_block (&block);
7288 gfc_add_modify (&block, tmpdecl, ptr);
7289 direct = gfc_finish_block (&block);
7291 /* Otherwise, allocate a string with the length of the destination
7292 and copy the source into it. */
7293 gfc_init_block (&block);
7294 tmp = gfc_get_pchar_type (expr->ts.kind);
7295 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
7296 gfc_add_modify (&block, tmpdecl,
7297 fold_convert (TREE_TYPE (ptr), tmp));
7298 tmp = build_call_expr_loc (input_location,
7299 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
7300 fold_convert (pvoid_type_node, tmpdecl),
7301 fold_convert (pvoid_type_node, ptr),
7302 fold_convert (size_type_node, extent));
7303 gfc_add_expr_to_block (&block, tmp);
7304 indirect = gfc_finish_block (&block);
7306 /* Wrap it up with the condition. */
7307 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
7308 dest_word_len, source_bytes);
7309 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
7310 gfc_add_expr_to_block (&se->pre, tmp);
7312 /* Free the temporary string, if necessary. */
7313 free = gfc_call_free (tmpdecl);
7314 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
7315 dest_word_len, source_bytes);
7316 tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
7317 gfc_add_expr_to_block (&se->post, tmp);
7319 se->expr = tmpdecl;
7320 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
7322 else
7324 tmpdecl = gfc_create_var (mold_type, "transfer");
7326 ptr = convert (build_pointer_type (mold_type), source);
7328 /* For CLASS results, allocate the needed memory first. */
7329 if (mold_expr->ts.type == BT_CLASS)
7331 tree cdata;
7332 cdata = gfc_class_data_get (tmpdecl);
7333 tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
7334 gfc_add_modify (&se->pre, cdata, tmp);
7337 /* Use memcpy to do the transfer. */
7338 if (mold_expr->ts.type == BT_CLASS)
7339 tmp = gfc_class_data_get (tmpdecl);
7340 else
7341 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
7343 tmp = build_call_expr_loc (input_location,
7344 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
7345 fold_convert (pvoid_type_node, tmp),
7346 fold_convert (pvoid_type_node, ptr),
7347 fold_convert (size_type_node, extent));
7348 gfc_add_expr_to_block (&se->pre, tmp);
7350 /* For CLASS results, set the _vptr. */
7351 if (mold_expr->ts.type == BT_CLASS)
7353 tree vptr;
7354 gfc_symbol *vtab;
7355 vptr = gfc_class_vptr_get (tmpdecl);
7356 vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
7357 gcc_assert (vtab);
7358 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
7359 gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
7362 se->expr = tmpdecl;
7367 /* Generate a call to caf_is_present. */
7369 static tree
7370 trans_caf_is_present (gfc_se *se, gfc_expr *expr)
7372 tree caf_reference, caf_decl, token, image_index;
7374 /* Compile the reference chain. */
7375 caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr);
7376 gcc_assert (caf_reference != NULL_TREE);
7378 caf_decl = gfc_get_tree_for_caf_expr (expr);
7379 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
7380 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
7381 image_index = gfc_caf_get_image_index (&se->pre, expr, caf_decl);
7382 gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
7383 expr);
7385 return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present,
7386 3, token, image_index, caf_reference);
7390 /* Test whether this ref-chain refs this image only. */
7392 static bool
7393 caf_this_image_ref (gfc_ref *ref)
7395 for ( ; ref; ref = ref->next)
7396 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
7397 return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE;
7399 return false;
7403 /* Generate code for the ALLOCATED intrinsic.
7404 Generate inline code that directly check the address of the argument. */
7406 static void
7407 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
7409 gfc_actual_arglist *arg1;
7410 gfc_se arg1se;
7411 tree tmp;
7412 symbol_attribute caf_attr;
7414 gfc_init_se (&arg1se, NULL);
7415 arg1 = expr->value.function.actual;
7417 if (arg1->expr->ts.type == BT_CLASS)
7419 /* Make sure that class array expressions have both a _data
7420 component reference and an array reference.... */
7421 if (CLASS_DATA (arg1->expr)->attr.dimension)
7422 gfc_add_class_array_ref (arg1->expr);
7423 /* .... whilst scalars only need the _data component. */
7424 else
7425 gfc_add_data_component (arg1->expr);
7428 /* When arg1 references an allocatable component in a coarray, then call
7429 the caf-library function caf_is_present (). */
7430 if (flag_coarray == GFC_FCOARRAY_LIB && arg1->expr->expr_type == EXPR_FUNCTION
7431 && arg1->expr->value.function.isym
7432 && arg1->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
7433 caf_attr = gfc_caf_attr (arg1->expr->value.function.actual->expr);
7434 else
7435 gfc_clear_attr (&caf_attr);
7436 if (flag_coarray == GFC_FCOARRAY_LIB && caf_attr.codimension
7437 && !caf_this_image_ref (arg1->expr->value.function.actual->expr->ref))
7438 tmp = trans_caf_is_present (se, arg1->expr->value.function.actual->expr);
7439 else
7441 if (arg1->expr->rank == 0)
7443 /* Allocatable scalar. */
7444 arg1se.want_pointer = 1;
7445 gfc_conv_expr (&arg1se, arg1->expr);
7446 tmp = arg1se.expr;
7448 else
7450 /* Allocatable array. */
7451 arg1se.descriptor_only = 1;
7452 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
7453 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
7456 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
7457 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7459 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
7463 /* Generate code for the ASSOCIATED intrinsic.
7464 If both POINTER and TARGET are arrays, generate a call to library function
7465 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7466 In other cases, generate inline code that directly compare the address of
7467 POINTER with the address of TARGET. */
7469 static void
7470 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
7472 gfc_actual_arglist *arg1;
7473 gfc_actual_arglist *arg2;
7474 gfc_se arg1se;
7475 gfc_se arg2se;
7476 tree tmp2;
7477 tree tmp;
7478 tree nonzero_charlen;
7479 tree nonzero_arraylen;
7480 gfc_ss *ss;
7481 bool scalar;
7483 gfc_init_se (&arg1se, NULL);
7484 gfc_init_se (&arg2se, NULL);
7485 arg1 = expr->value.function.actual;
7486 arg2 = arg1->next;
7488 /* Check whether the expression is a scalar or not; we cannot use
7489 arg1->expr->rank as it can be nonzero for proc pointers. */
7490 ss = gfc_walk_expr (arg1->expr);
7491 scalar = ss == gfc_ss_terminator;
7492 if (!scalar)
7493 gfc_free_ss_chain (ss);
7495 if (!arg2->expr)
7497 /* No optional target. */
7498 if (scalar)
7500 /* A pointer to a scalar. */
7501 arg1se.want_pointer = 1;
7502 gfc_conv_expr (&arg1se, arg1->expr);
7503 if (arg1->expr->symtree->n.sym->attr.proc_pointer
7504 && arg1->expr->symtree->n.sym->attr.dummy)
7505 arg1se.expr = build_fold_indirect_ref_loc (input_location,
7506 arg1se.expr);
7507 if (arg1->expr->ts.type == BT_CLASS)
7509 tmp2 = gfc_class_data_get (arg1se.expr);
7510 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
7511 tmp2 = gfc_conv_descriptor_data_get (tmp2);
7513 else
7514 tmp2 = arg1se.expr;
7516 else
7518 /* A pointer to an array. */
7519 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
7520 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
7522 gfc_add_block_to_block (&se->pre, &arg1se.pre);
7523 gfc_add_block_to_block (&se->post, &arg1se.post);
7524 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
7525 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
7526 se->expr = tmp;
7528 else
7530 /* An optional target. */
7531 if (arg2->expr->ts.type == BT_CLASS)
7532 gfc_add_data_component (arg2->expr);
7534 nonzero_charlen = NULL_TREE;
7535 if (arg1->expr->ts.type == BT_CHARACTER)
7536 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
7537 boolean_type_node,
7538 arg1->expr->ts.u.cl->backend_decl,
7539 integer_zero_node);
7540 if (scalar)
7542 /* A pointer to a scalar. */
7543 arg1se.want_pointer = 1;
7544 gfc_conv_expr (&arg1se, arg1->expr);
7545 if (arg1->expr->symtree->n.sym->attr.proc_pointer
7546 && arg1->expr->symtree->n.sym->attr.dummy)
7547 arg1se.expr = build_fold_indirect_ref_loc (input_location,
7548 arg1se.expr);
7549 if (arg1->expr->ts.type == BT_CLASS)
7550 arg1se.expr = gfc_class_data_get (arg1se.expr);
7552 arg2se.want_pointer = 1;
7553 gfc_conv_expr (&arg2se, arg2->expr);
7554 if (arg2->expr->symtree->n.sym->attr.proc_pointer
7555 && arg2->expr->symtree->n.sym->attr.dummy)
7556 arg2se.expr = build_fold_indirect_ref_loc (input_location,
7557 arg2se.expr);
7558 gfc_add_block_to_block (&se->pre, &arg1se.pre);
7559 gfc_add_block_to_block (&se->post, &arg1se.post);
7560 gfc_add_block_to_block (&se->pre, &arg2se.pre);
7561 gfc_add_block_to_block (&se->post, &arg2se.post);
7562 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7563 arg1se.expr, arg2se.expr);
7564 tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7565 arg1se.expr, null_pointer_node);
7566 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7567 boolean_type_node, tmp, tmp2);
7569 else
7571 /* An array pointer of zero length is not associated if target is
7572 present. */
7573 arg1se.descriptor_only = 1;
7574 gfc_conv_expr_lhs (&arg1se, arg1->expr);
7575 if (arg1->expr->rank == -1)
7577 tmp = gfc_conv_descriptor_rank (arg1se.expr);
7578 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7579 TREE_TYPE (tmp), tmp, gfc_index_one_node);
7581 else
7582 tmp = gfc_rank_cst[arg1->expr->rank - 1];
7583 tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
7584 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
7585 boolean_type_node, tmp,
7586 build_int_cst (TREE_TYPE (tmp), 0));
7588 /* A pointer to an array, call library function _gfor_associated. */
7589 arg1se.want_pointer = 1;
7590 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
7592 arg2se.want_pointer = 1;
7593 gfc_conv_expr_descriptor (&arg2se, arg2->expr);
7594 gfc_add_block_to_block (&se->pre, &arg2se.pre);
7595 gfc_add_block_to_block (&se->post, &arg2se.post);
7596 se->expr = build_call_expr_loc (input_location,
7597 gfor_fndecl_associated, 2,
7598 arg1se.expr, arg2se.expr);
7599 se->expr = convert (boolean_type_node, se->expr);
7600 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7601 boolean_type_node, se->expr,
7602 nonzero_arraylen);
7605 /* If target is present zero character length pointers cannot
7606 be associated. */
7607 if (nonzero_charlen != NULL_TREE)
7608 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7609 boolean_type_node,
7610 se->expr, nonzero_charlen);
7613 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7617 /* Generate code for the SAME_TYPE_AS intrinsic.
7618 Generate inline code that directly checks the vindices. */
7620 static void
7621 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
7623 gfc_expr *a, *b;
7624 gfc_se se1, se2;
7625 tree tmp;
7626 tree conda = NULL_TREE, condb = NULL_TREE;
7628 gfc_init_se (&se1, NULL);
7629 gfc_init_se (&se2, NULL);
7631 a = expr->value.function.actual->expr;
7632 b = expr->value.function.actual->next->expr;
7634 if (UNLIMITED_POLY (a))
7636 tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl);
7637 conda = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7638 tmp, build_int_cst (TREE_TYPE (tmp), 0));
7641 if (UNLIMITED_POLY (b))
7643 tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl);
7644 condb = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7645 tmp, build_int_cst (TREE_TYPE (tmp), 0));
7648 if (a->ts.type == BT_CLASS)
7650 gfc_add_vptr_component (a);
7651 gfc_add_hash_component (a);
7653 else if (a->ts.type == BT_DERIVED)
7654 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7655 a->ts.u.derived->hash_value);
7657 if (b->ts.type == BT_CLASS)
7659 gfc_add_vptr_component (b);
7660 gfc_add_hash_component (b);
7662 else if (b->ts.type == BT_DERIVED)
7663 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7664 b->ts.u.derived->hash_value);
7666 gfc_conv_expr (&se1, a);
7667 gfc_conv_expr (&se2, b);
7669 tmp = fold_build2_loc (input_location, EQ_EXPR,
7670 boolean_type_node, se1.expr,
7671 fold_convert (TREE_TYPE (se1.expr), se2.expr));
7673 if (conda)
7674 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
7675 boolean_type_node, conda, tmp);
7677 if (condb)
7678 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
7679 boolean_type_node, condb, tmp);
7681 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
7685 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
7687 static void
7688 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
7690 tree args[2];
7692 gfc_conv_intrinsic_function_args (se, expr, args, 2);
7693 se->expr = build_call_expr_loc (input_location,
7694 gfor_fndecl_sc_kind, 2, args[0], args[1]);
7695 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7699 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
7701 static void
7702 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
7704 tree arg, type;
7706 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7708 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
7709 type = gfc_get_int_type (4);
7710 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
7712 /* Convert it to the required type. */
7713 type = gfc_typenode_for_spec (&expr->ts);
7714 se->expr = build_call_expr_loc (input_location,
7715 gfor_fndecl_si_kind, 1, arg);
7716 se->expr = fold_convert (type, se->expr);
7720 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
7722 static void
7723 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
7725 gfc_actual_arglist *actual;
7726 tree type;
7727 gfc_se argse;
7728 vec<tree, va_gc> *args = NULL;
7730 for (actual = expr->value.function.actual; actual; actual = actual->next)
7732 gfc_init_se (&argse, se);
7734 /* Pass a NULL pointer for an absent arg. */
7735 if (actual->expr == NULL)
7736 argse.expr = null_pointer_node;
7737 else
7739 gfc_typespec ts;
7740 gfc_clear_ts (&ts);
7742 if (actual->expr->ts.kind != gfc_c_int_kind)
7744 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
7745 ts.type = BT_INTEGER;
7746 ts.kind = gfc_c_int_kind;
7747 gfc_convert_type (actual->expr, &ts, 2);
7749 gfc_conv_expr_reference (&argse, actual->expr);
7752 gfc_add_block_to_block (&se->pre, &argse.pre);
7753 gfc_add_block_to_block (&se->post, &argse.post);
7754 vec_safe_push (args, argse.expr);
7757 /* Convert it to the required type. */
7758 type = gfc_typenode_for_spec (&expr->ts);
7759 se->expr = build_call_expr_loc_vec (input_location,
7760 gfor_fndecl_sr_kind, args);
7761 se->expr = fold_convert (type, se->expr);
7765 /* Generate code for TRIM (A) intrinsic function. */
7767 static void
7768 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
7770 tree var;
7771 tree len;
7772 tree addr;
7773 tree tmp;
7774 tree cond;
7775 tree fndecl;
7776 tree function;
7777 tree *args;
7778 unsigned int num_args;
7780 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
7781 args = XALLOCAVEC (tree, num_args);
7783 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
7784 addr = gfc_build_addr_expr (ppvoid_type_node, var);
7785 len = gfc_create_var (gfc_charlen_type_node, "len");
7787 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
7788 args[0] = gfc_build_addr_expr (NULL_TREE, len);
7789 args[1] = addr;
7791 if (expr->ts.kind == 1)
7792 function = gfor_fndecl_string_trim;
7793 else if (expr->ts.kind == 4)
7794 function = gfor_fndecl_string_trim_char4;
7795 else
7796 gcc_unreachable ();
7798 fndecl = build_addr (function);
7799 tmp = build_call_array_loc (input_location,
7800 TREE_TYPE (TREE_TYPE (function)), fndecl,
7801 num_args, args);
7802 gfc_add_expr_to_block (&se->pre, tmp);
7804 /* Free the temporary afterwards, if necessary. */
7805 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
7806 len, build_int_cst (TREE_TYPE (len), 0));
7807 tmp = gfc_call_free (var);
7808 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
7809 gfc_add_expr_to_block (&se->post, tmp);
7811 se->expr = var;
7812 se->string_length = len;
7816 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
7818 static void
7819 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
7821 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
7822 tree type, cond, tmp, count, exit_label, n, max, largest;
7823 tree size;
7824 stmtblock_t block, body;
7825 int i;
7827 /* We store in charsize the size of a character. */
7828 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
7829 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
7831 /* Get the arguments. */
7832 gfc_conv_intrinsic_function_args (se, expr, args, 3);
7833 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
7834 src = args[1];
7835 ncopies = gfc_evaluate_now (args[2], &se->pre);
7836 ncopies_type = TREE_TYPE (ncopies);
7838 /* Check that NCOPIES is not negative. */
7839 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
7840 build_int_cst (ncopies_type, 0));
7841 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
7842 "Argument NCOPIES of REPEAT intrinsic is negative "
7843 "(its value is %ld)",
7844 fold_convert (long_integer_type_node, ncopies));
7846 /* If the source length is zero, any non negative value of NCOPIES
7847 is valid, and nothing happens. */
7848 n = gfc_create_var (ncopies_type, "ncopies");
7849 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
7850 build_int_cst (size_type_node, 0));
7851 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
7852 build_int_cst (ncopies_type, 0), ncopies);
7853 gfc_add_modify (&se->pre, n, tmp);
7854 ncopies = n;
7856 /* Check that ncopies is not too large: ncopies should be less than
7857 (or equal to) MAX / slen, where MAX is the maximal integer of
7858 the gfc_charlen_type_node type. If slen == 0, we need a special
7859 case to avoid the division by zero. */
7860 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
7861 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
7862 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
7863 fold_convert (size_type_node, max), slen);
7864 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
7865 ? size_type_node : ncopies_type;
7866 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
7867 fold_convert (largest, ncopies),
7868 fold_convert (largest, max));
7869 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
7870 build_int_cst (size_type_node, 0));
7871 cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
7872 boolean_false_node, cond);
7873 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
7874 "Argument NCOPIES of REPEAT intrinsic is too large");
7876 /* Compute the destination length. */
7877 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
7878 fold_convert (gfc_charlen_type_node, slen),
7879 fold_convert (gfc_charlen_type_node, ncopies));
7880 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
7881 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
7883 /* Generate the code to do the repeat operation:
7884 for (i = 0; i < ncopies; i++)
7885 memmove (dest + (i * slen * size), src, slen*size); */
7886 gfc_start_block (&block);
7887 count = gfc_create_var (ncopies_type, "count");
7888 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
7889 exit_label = gfc_build_label_decl (NULL_TREE);
7891 /* Start the loop body. */
7892 gfc_start_block (&body);
7894 /* Exit the loop if count >= ncopies. */
7895 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
7896 ncopies);
7897 tmp = build1_v (GOTO_EXPR, exit_label);
7898 TREE_USED (exit_label) = 1;
7899 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7900 build_empty_stmt (input_location));
7901 gfc_add_expr_to_block (&body, tmp);
7903 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7904 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
7905 fold_convert (gfc_charlen_type_node, slen),
7906 fold_convert (gfc_charlen_type_node, count));
7907 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
7908 tmp, fold_convert (gfc_charlen_type_node, size));
7909 tmp = fold_build_pointer_plus_loc (input_location,
7910 fold_convert (pvoid_type_node, dest), tmp);
7911 tmp = build_call_expr_loc (input_location,
7912 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7913 3, tmp, src,
7914 fold_build2_loc (input_location, MULT_EXPR,
7915 size_type_node, slen,
7916 fold_convert (size_type_node,
7917 size)));
7918 gfc_add_expr_to_block (&body, tmp);
7920 /* Increment count. */
7921 tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
7922 count, build_int_cst (TREE_TYPE (count), 1));
7923 gfc_add_modify (&body, count, tmp);
7925 /* Build the loop. */
7926 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
7927 gfc_add_expr_to_block (&block, tmp);
7929 /* Add the exit label. */
7930 tmp = build1_v (LABEL_EXPR, exit_label);
7931 gfc_add_expr_to_block (&block, tmp);
7933 /* Finish the block. */
7934 tmp = gfc_finish_block (&block);
7935 gfc_add_expr_to_block (&se->pre, tmp);
7937 /* Set the result value. */
7938 se->expr = dest;
7939 se->string_length = dlen;
7943 /* Generate code for the IARGC intrinsic. */
7945 static void
7946 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
7948 tree tmp;
7949 tree fndecl;
7950 tree type;
7952 /* Call the library function. This always returns an INTEGER(4). */
7953 fndecl = gfor_fndecl_iargc;
7954 tmp = build_call_expr_loc (input_location,
7955 fndecl, 0);
7957 /* Convert it to the required type. */
7958 type = gfc_typenode_for_spec (&expr->ts);
7959 tmp = fold_convert (type, tmp);
7961 se->expr = tmp;
7965 /* The loc intrinsic returns the address of its argument as
7966 gfc_index_integer_kind integer. */
7968 static void
7969 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
7971 tree temp_var;
7972 gfc_expr *arg_expr;
7974 gcc_assert (!se->ss);
7976 arg_expr = expr->value.function.actual->expr;
7977 if (arg_expr->rank == 0)
7979 if (arg_expr->ts.type == BT_CLASS)
7980 gfc_add_data_component (arg_expr);
7981 gfc_conv_expr_reference (se, arg_expr);
7983 else
7984 gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
7985 se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
7987 /* Create a temporary variable for loc return value. Without this,
7988 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7989 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
7990 gfc_add_modify (&se->pre, temp_var, se->expr);
7991 se->expr = temp_var;
7995 /* The following routine generates code for the intrinsic
7996 functions from the ISO_C_BINDING module:
7997 * C_LOC
7998 * C_FUNLOC
7999 * C_ASSOCIATED */
8001 static void
8002 conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
8004 gfc_actual_arglist *arg = expr->value.function.actual;
8006 if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
8008 if (arg->expr->rank == 0)
8009 gfc_conv_expr_reference (se, arg->expr);
8010 else if (gfc_is_simply_contiguous (arg->expr, false, false))
8011 gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
8012 else
8014 gfc_conv_expr_descriptor (se, arg->expr);
8015 se->expr = gfc_conv_descriptor_data_get (se->expr);
8018 /* TODO -- the following two lines shouldn't be necessary, but if
8019 they're removed, a bug is exposed later in the code path.
8020 This workaround was thus introduced, but will have to be
8021 removed; please see PR 35150 for details about the issue. */
8022 se->expr = convert (pvoid_type_node, se->expr);
8023 se->expr = gfc_evaluate_now (se->expr, &se->pre);
8025 else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
8026 gfc_conv_expr_reference (se, arg->expr);
8027 else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
8029 gfc_se arg1se;
8030 gfc_se arg2se;
8032 /* Build the addr_expr for the first argument. The argument is
8033 already an *address* so we don't need to set want_pointer in
8034 the gfc_se. */
8035 gfc_init_se (&arg1se, NULL);
8036 gfc_conv_expr (&arg1se, arg->expr);
8037 gfc_add_block_to_block (&se->pre, &arg1se.pre);
8038 gfc_add_block_to_block (&se->post, &arg1se.post);
8040 /* See if we were given two arguments. */
8041 if (arg->next->expr == NULL)
8042 /* Only given one arg so generate a null and do a
8043 not-equal comparison against the first arg. */
8044 se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
8045 arg1se.expr,
8046 fold_convert (TREE_TYPE (arg1se.expr),
8047 null_pointer_node));
8048 else
8050 tree eq_expr;
8051 tree not_null_expr;
8053 /* Given two arguments so build the arg2se from second arg. */
8054 gfc_init_se (&arg2se, NULL);
8055 gfc_conv_expr (&arg2se, arg->next->expr);
8056 gfc_add_block_to_block (&se->pre, &arg2se.pre);
8057 gfc_add_block_to_block (&se->post, &arg2se.post);
8059 /* Generate test to compare that the two args are equal. */
8060 eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8061 arg1se.expr, arg2se.expr);
8062 /* Generate test to ensure that the first arg is not null. */
8063 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
8064 boolean_type_node,
8065 arg1se.expr, null_pointer_node);
8067 /* Finally, the generated test must check that both arg1 is not
8068 NULL and that it is equal to the second arg. */
8069 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8070 boolean_type_node,
8071 not_null_expr, eq_expr);
8074 else
8075 gcc_unreachable ();
8079 /* The following routine generates code for the intrinsic
8080 subroutines from the ISO_C_BINDING module:
8081 * C_F_POINTER
8082 * C_F_PROCPOINTER. */
8084 static tree
8085 conv_isocbinding_subroutine (gfc_code *code)
8087 gfc_se se;
8088 gfc_se cptrse;
8089 gfc_se fptrse;
8090 gfc_se shapese;
8091 gfc_ss *shape_ss;
8092 tree desc, dim, tmp, stride, offset;
8093 stmtblock_t body, block;
8094 gfc_loopinfo loop;
8095 gfc_actual_arglist *arg = code->ext.actual;
8097 gfc_init_se (&se, NULL);
8098 gfc_init_se (&cptrse, NULL);
8099 gfc_conv_expr (&cptrse, arg->expr);
8100 gfc_add_block_to_block (&se.pre, &cptrse.pre);
8101 gfc_add_block_to_block (&se.post, &cptrse.post);
8103 gfc_init_se (&fptrse, NULL);
8104 if (arg->next->expr->rank == 0)
8106 fptrse.want_pointer = 1;
8107 gfc_conv_expr (&fptrse, arg->next->expr);
8108 gfc_add_block_to_block (&se.pre, &fptrse.pre);
8109 gfc_add_block_to_block (&se.post, &fptrse.post);
8110 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
8111 && arg->next->expr->symtree->n.sym->attr.dummy)
8112 fptrse.expr = build_fold_indirect_ref_loc (input_location,
8113 fptrse.expr);
8114 se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
8115 TREE_TYPE (fptrse.expr),
8116 fptrse.expr,
8117 fold_convert (TREE_TYPE (fptrse.expr),
8118 cptrse.expr));
8119 gfc_add_expr_to_block (&se.pre, se.expr);
8120 gfc_add_block_to_block (&se.pre, &se.post);
8121 return gfc_finish_block (&se.pre);
8124 gfc_start_block (&block);
8126 /* Get the descriptor of the Fortran pointer. */
8127 fptrse.descriptor_only = 1;
8128 gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
8129 gfc_add_block_to_block (&block, &fptrse.pre);
8130 desc = fptrse.expr;
8132 /* Set data value, dtype, and offset. */
8133 tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
8134 gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
8135 gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
8136 gfc_get_dtype (TREE_TYPE (desc)));
8138 /* Start scalarization of the bounds, using the shape argument. */
8140 shape_ss = gfc_walk_expr (arg->next->next->expr);
8141 gcc_assert (shape_ss != gfc_ss_terminator);
8142 gfc_init_se (&shapese, NULL);
8144 gfc_init_loopinfo (&loop);
8145 gfc_add_ss_to_loop (&loop, shape_ss);
8146 gfc_conv_ss_startstride (&loop);
8147 gfc_conv_loop_setup (&loop, &arg->next->expr->where);
8148 gfc_mark_ss_chain_used (shape_ss, 1);
8150 gfc_copy_loopinfo_to_se (&shapese, &loop);
8151 shapese.ss = shape_ss;
8153 stride = gfc_create_var (gfc_array_index_type, "stride");
8154 offset = gfc_create_var (gfc_array_index_type, "offset");
8155 gfc_add_modify (&block, stride, gfc_index_one_node);
8156 gfc_add_modify (&block, offset, gfc_index_zero_node);
8158 /* Loop body. */
8159 gfc_start_scalarized_body (&loop, &body);
8161 dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8162 loop.loopvar[0], loop.from[0]);
8164 /* Set bounds and stride. */
8165 gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
8166 gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
8168 gfc_conv_expr (&shapese, arg->next->next->expr);
8169 gfc_add_block_to_block (&body, &shapese.pre);
8170 gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
8171 gfc_add_block_to_block (&body, &shapese.post);
8173 /* Calculate offset. */
8174 gfc_add_modify (&body, offset,
8175 fold_build2_loc (input_location, PLUS_EXPR,
8176 gfc_array_index_type, offset, stride));
8177 /* Update stride. */
8178 gfc_add_modify (&body, stride,
8179 fold_build2_loc (input_location, MULT_EXPR,
8180 gfc_array_index_type, stride,
8181 fold_convert (gfc_array_index_type,
8182 shapese.expr)));
8183 /* Finish scalarization loop. */
8184 gfc_trans_scalarizing_loops (&loop, &body);
8185 gfc_add_block_to_block (&block, &loop.pre);
8186 gfc_add_block_to_block (&block, &loop.post);
8187 gfc_add_block_to_block (&block, &fptrse.post);
8188 gfc_cleanup_loop (&loop);
8190 gfc_add_modify (&block, offset,
8191 fold_build1_loc (input_location, NEGATE_EXPR,
8192 gfc_array_index_type, offset));
8193 gfc_conv_descriptor_offset_set (&block, desc, offset);
8195 gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
8196 gfc_add_block_to_block (&se.pre, &se.post);
8197 return gfc_finish_block (&se.pre);
8201 /* Save and restore floating-point state. */
8203 tree
8204 gfc_save_fp_state (stmtblock_t *block)
8206 tree type, fpstate, tmp;
8208 type = build_array_type (char_type_node,
8209 build_range_type (size_type_node, size_zero_node,
8210 size_int (GFC_FPE_STATE_BUFFER_SIZE)));
8211 fpstate = gfc_create_var (type, "fpstate");
8212 fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
8214 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
8215 1, fpstate);
8216 gfc_add_expr_to_block (block, tmp);
8218 return fpstate;
8222 void
8223 gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
8225 tree tmp;
8227 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
8228 1, fpstate);
8229 gfc_add_expr_to_block (block, tmp);
8233 /* Generate code for arguments of IEEE functions. */
8235 static void
8236 conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
8237 int nargs)
8239 gfc_actual_arglist *actual;
8240 gfc_expr *e;
8241 gfc_se argse;
8242 int arg;
8244 actual = expr->value.function.actual;
8245 for (arg = 0; arg < nargs; arg++, actual = actual->next)
8247 gcc_assert (actual);
8248 e = actual->expr;
8250 gfc_init_se (&argse, se);
8251 gfc_conv_expr_val (&argse, e);
8253 gfc_add_block_to_block (&se->pre, &argse.pre);
8254 gfc_add_block_to_block (&se->post, &argse.post);
8255 argarray[arg] = argse.expr;
8260 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8261 and IEEE_UNORDERED, which translate directly to GCC type-generic
8262 built-ins. */
8264 static void
8265 conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
8266 enum built_in_function code, int nargs)
8268 tree args[2];
8269 gcc_assert ((unsigned) nargs <= sizeof(args)/sizeof(args[0]));
8271 conv_ieee_function_args (se, expr, args, nargs);
8272 se->expr = build_call_expr_loc_array (input_location,
8273 builtin_decl_explicit (code),
8274 nargs, args);
8275 STRIP_TYPE_NOPS (se->expr);
8276 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8280 /* Generate code for IEEE_IS_NORMAL intrinsic:
8281 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8283 static void
8284 conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
8286 tree arg, isnormal, iszero;
8288 /* Convert arg, evaluate it only once. */
8289 conv_ieee_function_args (se, expr, &arg, 1);
8290 arg = gfc_evaluate_now (arg, &se->pre);
8292 isnormal = build_call_expr_loc (input_location,
8293 builtin_decl_explicit (BUILT_IN_ISNORMAL),
8294 1, arg);
8295 iszero = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
8296 build_real_from_int_cst (TREE_TYPE (arg),
8297 integer_zero_node));
8298 se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
8299 boolean_type_node, isnormal, iszero);
8300 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8304 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8305 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8307 static void
8308 conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
8310 tree arg, signbit, isnan;
8312 /* Convert arg, evaluate it only once. */
8313 conv_ieee_function_args (se, expr, &arg, 1);
8314 arg = gfc_evaluate_now (arg, &se->pre);
8316 isnan = build_call_expr_loc (input_location,
8317 builtin_decl_explicit (BUILT_IN_ISNAN),
8318 1, arg);
8319 STRIP_TYPE_NOPS (isnan);
8321 signbit = build_call_expr_loc (input_location,
8322 builtin_decl_explicit (BUILT_IN_SIGNBIT),
8323 1, arg);
8324 signbit = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
8325 signbit, integer_zero_node);
8327 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8328 boolean_type_node, signbit,
8329 fold_build1_loc (input_location, TRUTH_NOT_EXPR,
8330 TREE_TYPE(isnan), isnan));
8332 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8336 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8338 static void
8339 conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
8340 enum built_in_function code)
8342 tree arg, decl, call, fpstate;
8343 int argprec;
8345 conv_ieee_function_args (se, expr, &arg, 1);
8346 argprec = TYPE_PRECISION (TREE_TYPE (arg));
8347 decl = builtin_decl_for_precision (code, argprec);
8349 /* Save floating-point state. */
8350 fpstate = gfc_save_fp_state (&se->pre);
8352 /* Make the function call. */
8353 call = build_call_expr_loc (input_location, decl, 1, arg);
8354 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
8356 /* Restore floating-point state. */
8357 gfc_restore_fp_state (&se->post, fpstate);
8361 /* Generate code for IEEE_REM. */
8363 static void
8364 conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
8366 tree args[2], decl, call, fpstate;
8367 int argprec;
8369 conv_ieee_function_args (se, expr, args, 2);
8371 /* If arguments have unequal size, convert them to the larger. */
8372 if (TYPE_PRECISION (TREE_TYPE (args[0]))
8373 > TYPE_PRECISION (TREE_TYPE (args[1])))
8374 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
8375 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
8376 > TYPE_PRECISION (TREE_TYPE (args[0])))
8377 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
8379 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8380 decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
8382 /* Save floating-point state. */
8383 fpstate = gfc_save_fp_state (&se->pre);
8385 /* Make the function call. */
8386 call = build_call_expr_loc_array (input_location, decl, 2, args);
8387 se->expr = fold_convert (TREE_TYPE (args[0]), call);
8389 /* Restore floating-point state. */
8390 gfc_restore_fp_state (&se->post, fpstate);
8394 /* Generate code for IEEE_NEXT_AFTER. */
8396 static void
8397 conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
8399 tree args[2], decl, call, fpstate;
8400 int argprec;
8402 conv_ieee_function_args (se, expr, args, 2);
8404 /* Result has the characteristics of first argument. */
8405 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
8406 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8407 decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
8409 /* Save floating-point state. */
8410 fpstate = gfc_save_fp_state (&se->pre);
8412 /* Make the function call. */
8413 call = build_call_expr_loc_array (input_location, decl, 2, args);
8414 se->expr = fold_convert (TREE_TYPE (args[0]), call);
8416 /* Restore floating-point state. */
8417 gfc_restore_fp_state (&se->post, fpstate);
8421 /* Generate code for IEEE_SCALB. */
8423 static void
8424 conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
8426 tree args[2], decl, call, huge, type;
8427 int argprec, n;
8429 conv_ieee_function_args (se, expr, args, 2);
8431 /* Result has the characteristics of first argument. */
8432 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8433 decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
8435 if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
8437 /* We need to fold the integer into the range of a C int. */
8438 args[1] = gfc_evaluate_now (args[1], &se->pre);
8439 type = TREE_TYPE (args[1]);
8441 n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
8442 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
8443 gfc_c_int_kind);
8444 huge = fold_convert (type, huge);
8445 args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
8446 huge);
8447 args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
8448 fold_build1_loc (input_location, NEGATE_EXPR,
8449 type, huge));
8452 args[1] = fold_convert (integer_type_node, args[1]);
8454 /* Make the function call. */
8455 call = build_call_expr_loc_array (input_location, decl, 2, args);
8456 se->expr = fold_convert (TREE_TYPE (args[0]), call);
8460 /* Generate code for IEEE_COPY_SIGN. */
8462 static void
8463 conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
8465 tree args[2], decl, sign;
8466 int argprec;
8468 conv_ieee_function_args (se, expr, args, 2);
8470 /* Get the sign of the second argument. */
8471 sign = build_call_expr_loc (input_location,
8472 builtin_decl_explicit (BUILT_IN_SIGNBIT),
8473 1, args[1]);
8474 sign = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
8475 sign, integer_zero_node);
8477 /* Create a value of one, with the right sign. */
8478 sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
8479 sign,
8480 fold_build1_loc (input_location, NEGATE_EXPR,
8481 integer_type_node,
8482 integer_one_node),
8483 integer_one_node);
8484 args[1] = fold_convert (TREE_TYPE (args[0]), sign);
8486 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8487 decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
8489 se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
8493 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8494 module. */
8496 bool
8497 gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
8499 const char *name = expr->value.function.name;
8501 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8503 if (STARTS_WITH (name, "_gfortran_ieee_is_nan"))
8504 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
8505 else if (STARTS_WITH (name, "_gfortran_ieee_is_finite"))
8506 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
8507 else if (STARTS_WITH (name, "_gfortran_ieee_unordered"))
8508 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
8509 else if (STARTS_WITH (name, "_gfortran_ieee_is_normal"))
8510 conv_intrinsic_ieee_is_normal (se, expr);
8511 else if (STARTS_WITH (name, "_gfortran_ieee_is_negative"))
8512 conv_intrinsic_ieee_is_negative (se, expr);
8513 else if (STARTS_WITH (name, "_gfortran_ieee_copy_sign"))
8514 conv_intrinsic_ieee_copy_sign (se, expr);
8515 else if (STARTS_WITH (name, "_gfortran_ieee_scalb"))
8516 conv_intrinsic_ieee_scalb (se, expr);
8517 else if (STARTS_WITH (name, "_gfortran_ieee_next_after"))
8518 conv_intrinsic_ieee_next_after (se, expr);
8519 else if (STARTS_WITH (name, "_gfortran_ieee_rem"))
8520 conv_intrinsic_ieee_rem (se, expr);
8521 else if (STARTS_WITH (name, "_gfortran_ieee_logb"))
8522 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
8523 else if (STARTS_WITH (name, "_gfortran_ieee_rint"))
8524 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
8525 else
8526 /* It is not among the functions we translate directly. We return
8527 false, so a library function call is emitted. */
8528 return false;
8530 #undef STARTS_WITH
8532 return true;
8536 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8538 static void
8539 gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
8541 tree arg, res, restype;
8543 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8544 arg = fold_convert (size_type_node, arg);
8545 res = build_call_expr_loc (input_location,
8546 builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
8547 restype = gfc_typenode_for_spec (&expr->ts);
8548 se->expr = fold_convert (restype, res);
8552 /* Generate code for an intrinsic function. Some map directly to library
8553 calls, others get special handling. In some cases the name of the function
8554 used depends on the type specifiers. */
8556 void
8557 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
8559 const char *name;
8560 int lib, kind;
8561 tree fndecl;
8563 name = &expr->value.function.name[2];
8565 if (expr->rank > 0)
8567 lib = gfc_is_intrinsic_libcall (expr);
8568 if (lib != 0)
8570 if (lib == 1)
8571 se->ignore_optional = 1;
8573 switch (expr->value.function.isym->id)
8575 case GFC_ISYM_EOSHIFT:
8576 case GFC_ISYM_PACK:
8577 case GFC_ISYM_RESHAPE:
8578 /* For all of those the first argument specifies the type and the
8579 third is optional. */
8580 conv_generic_with_optional_char_arg (se, expr, 1, 3);
8581 break;
8583 default:
8584 gfc_conv_intrinsic_funcall (se, expr);
8585 break;
8588 return;
8592 switch (expr->value.function.isym->id)
8594 case GFC_ISYM_NONE:
8595 gcc_unreachable ();
8597 case GFC_ISYM_REPEAT:
8598 gfc_conv_intrinsic_repeat (se, expr);
8599 break;
8601 case GFC_ISYM_TRIM:
8602 gfc_conv_intrinsic_trim (se, expr);
8603 break;
8605 case GFC_ISYM_SC_KIND:
8606 gfc_conv_intrinsic_sc_kind (se, expr);
8607 break;
8609 case GFC_ISYM_SI_KIND:
8610 gfc_conv_intrinsic_si_kind (se, expr);
8611 break;
8613 case GFC_ISYM_SR_KIND:
8614 gfc_conv_intrinsic_sr_kind (se, expr);
8615 break;
8617 case GFC_ISYM_EXPONENT:
8618 gfc_conv_intrinsic_exponent (se, expr);
8619 break;
8621 case GFC_ISYM_SCAN:
8622 kind = expr->value.function.actual->expr->ts.kind;
8623 if (kind == 1)
8624 fndecl = gfor_fndecl_string_scan;
8625 else if (kind == 4)
8626 fndecl = gfor_fndecl_string_scan_char4;
8627 else
8628 gcc_unreachable ();
8630 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
8631 break;
8633 case GFC_ISYM_VERIFY:
8634 kind = expr->value.function.actual->expr->ts.kind;
8635 if (kind == 1)
8636 fndecl = gfor_fndecl_string_verify;
8637 else if (kind == 4)
8638 fndecl = gfor_fndecl_string_verify_char4;
8639 else
8640 gcc_unreachable ();
8642 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
8643 break;
8645 case GFC_ISYM_ALLOCATED:
8646 gfc_conv_allocated (se, expr);
8647 break;
8649 case GFC_ISYM_ASSOCIATED:
8650 gfc_conv_associated(se, expr);
8651 break;
8653 case GFC_ISYM_SAME_TYPE_AS:
8654 gfc_conv_same_type_as (se, expr);
8655 break;
8657 case GFC_ISYM_ABS:
8658 gfc_conv_intrinsic_abs (se, expr);
8659 break;
8661 case GFC_ISYM_ADJUSTL:
8662 if (expr->ts.kind == 1)
8663 fndecl = gfor_fndecl_adjustl;
8664 else if (expr->ts.kind == 4)
8665 fndecl = gfor_fndecl_adjustl_char4;
8666 else
8667 gcc_unreachable ();
8669 gfc_conv_intrinsic_adjust (se, expr, fndecl);
8670 break;
8672 case GFC_ISYM_ADJUSTR:
8673 if (expr->ts.kind == 1)
8674 fndecl = gfor_fndecl_adjustr;
8675 else if (expr->ts.kind == 4)
8676 fndecl = gfor_fndecl_adjustr_char4;
8677 else
8678 gcc_unreachable ();
8680 gfc_conv_intrinsic_adjust (se, expr, fndecl);
8681 break;
8683 case GFC_ISYM_AIMAG:
8684 gfc_conv_intrinsic_imagpart (se, expr);
8685 break;
8687 case GFC_ISYM_AINT:
8688 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
8689 break;
8691 case GFC_ISYM_ALL:
8692 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
8693 break;
8695 case GFC_ISYM_ANINT:
8696 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
8697 break;
8699 case GFC_ISYM_AND:
8700 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
8701 break;
8703 case GFC_ISYM_ANY:
8704 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
8705 break;
8707 case GFC_ISYM_BTEST:
8708 gfc_conv_intrinsic_btest (se, expr);
8709 break;
8711 case GFC_ISYM_BGE:
8712 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
8713 break;
8715 case GFC_ISYM_BGT:
8716 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
8717 break;
8719 case GFC_ISYM_BLE:
8720 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
8721 break;
8723 case GFC_ISYM_BLT:
8724 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
8725 break;
8727 case GFC_ISYM_C_ASSOCIATED:
8728 case GFC_ISYM_C_FUNLOC:
8729 case GFC_ISYM_C_LOC:
8730 conv_isocbinding_function (se, expr);
8731 break;
8733 case GFC_ISYM_ACHAR:
8734 case GFC_ISYM_CHAR:
8735 gfc_conv_intrinsic_char (se, expr);
8736 break;
8738 case GFC_ISYM_CONVERSION:
8739 case GFC_ISYM_REAL:
8740 case GFC_ISYM_LOGICAL:
8741 case GFC_ISYM_DBLE:
8742 gfc_conv_intrinsic_conversion (se, expr);
8743 break;
8745 /* Integer conversions are handled separately to make sure we get the
8746 correct rounding mode. */
8747 case GFC_ISYM_INT:
8748 case GFC_ISYM_INT2:
8749 case GFC_ISYM_INT8:
8750 case GFC_ISYM_LONG:
8751 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
8752 break;
8754 case GFC_ISYM_NINT:
8755 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
8756 break;
8758 case GFC_ISYM_CEILING:
8759 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
8760 break;
8762 case GFC_ISYM_FLOOR:
8763 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
8764 break;
8766 case GFC_ISYM_MOD:
8767 gfc_conv_intrinsic_mod (se, expr, 0);
8768 break;
8770 case GFC_ISYM_MODULO:
8771 gfc_conv_intrinsic_mod (se, expr, 1);
8772 break;
8774 case GFC_ISYM_CAF_GET:
8775 gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE,
8776 false, NULL);
8777 break;
8779 case GFC_ISYM_CMPLX:
8780 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
8781 break;
8783 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
8784 gfc_conv_intrinsic_iargc (se, expr);
8785 break;
8787 case GFC_ISYM_COMPLEX:
8788 gfc_conv_intrinsic_cmplx (se, expr, 1);
8789 break;
8791 case GFC_ISYM_CONJG:
8792 gfc_conv_intrinsic_conjg (se, expr);
8793 break;
8795 case GFC_ISYM_COUNT:
8796 gfc_conv_intrinsic_count (se, expr);
8797 break;
8799 case GFC_ISYM_CTIME:
8800 gfc_conv_intrinsic_ctime (se, expr);
8801 break;
8803 case GFC_ISYM_DIM:
8804 gfc_conv_intrinsic_dim (se, expr);
8805 break;
8807 case GFC_ISYM_DOT_PRODUCT:
8808 gfc_conv_intrinsic_dot_product (se, expr);
8809 break;
8811 case GFC_ISYM_DPROD:
8812 gfc_conv_intrinsic_dprod (se, expr);
8813 break;
8815 case GFC_ISYM_DSHIFTL:
8816 gfc_conv_intrinsic_dshift (se, expr, true);
8817 break;
8819 case GFC_ISYM_DSHIFTR:
8820 gfc_conv_intrinsic_dshift (se, expr, false);
8821 break;
8823 case GFC_ISYM_FDATE:
8824 gfc_conv_intrinsic_fdate (se, expr);
8825 break;
8827 case GFC_ISYM_FRACTION:
8828 gfc_conv_intrinsic_fraction (se, expr);
8829 break;
8831 case GFC_ISYM_IALL:
8832 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
8833 break;
8835 case GFC_ISYM_IAND:
8836 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
8837 break;
8839 case GFC_ISYM_IANY:
8840 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
8841 break;
8843 case GFC_ISYM_IBCLR:
8844 gfc_conv_intrinsic_singlebitop (se, expr, 0);
8845 break;
8847 case GFC_ISYM_IBITS:
8848 gfc_conv_intrinsic_ibits (se, expr);
8849 break;
8851 case GFC_ISYM_IBSET:
8852 gfc_conv_intrinsic_singlebitop (se, expr, 1);
8853 break;
8855 case GFC_ISYM_IACHAR:
8856 case GFC_ISYM_ICHAR:
8857 /* We assume ASCII character sequence. */
8858 gfc_conv_intrinsic_ichar (se, expr);
8859 break;
8861 case GFC_ISYM_IARGC:
8862 gfc_conv_intrinsic_iargc (se, expr);
8863 break;
8865 case GFC_ISYM_IEOR:
8866 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
8867 break;
8869 case GFC_ISYM_INDEX:
8870 kind = expr->value.function.actual->expr->ts.kind;
8871 if (kind == 1)
8872 fndecl = gfor_fndecl_string_index;
8873 else if (kind == 4)
8874 fndecl = gfor_fndecl_string_index_char4;
8875 else
8876 gcc_unreachable ();
8878 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
8879 break;
8881 case GFC_ISYM_IOR:
8882 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
8883 break;
8885 case GFC_ISYM_IPARITY:
8886 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
8887 break;
8889 case GFC_ISYM_IS_IOSTAT_END:
8890 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
8891 break;
8893 case GFC_ISYM_IS_IOSTAT_EOR:
8894 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
8895 break;
8897 case GFC_ISYM_ISNAN:
8898 gfc_conv_intrinsic_isnan (se, expr);
8899 break;
8901 case GFC_ISYM_LSHIFT:
8902 gfc_conv_intrinsic_shift (se, expr, false, false);
8903 break;
8905 case GFC_ISYM_RSHIFT:
8906 gfc_conv_intrinsic_shift (se, expr, true, true);
8907 break;
8909 case GFC_ISYM_SHIFTA:
8910 gfc_conv_intrinsic_shift (se, expr, true, true);
8911 break;
8913 case GFC_ISYM_SHIFTL:
8914 gfc_conv_intrinsic_shift (se, expr, false, false);
8915 break;
8917 case GFC_ISYM_SHIFTR:
8918 gfc_conv_intrinsic_shift (se, expr, true, false);
8919 break;
8921 case GFC_ISYM_ISHFT:
8922 gfc_conv_intrinsic_ishft (se, expr);
8923 break;
8925 case GFC_ISYM_ISHFTC:
8926 gfc_conv_intrinsic_ishftc (se, expr);
8927 break;
8929 case GFC_ISYM_LEADZ:
8930 gfc_conv_intrinsic_leadz (se, expr);
8931 break;
8933 case GFC_ISYM_TRAILZ:
8934 gfc_conv_intrinsic_trailz (se, expr);
8935 break;
8937 case GFC_ISYM_POPCNT:
8938 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
8939 break;
8941 case GFC_ISYM_POPPAR:
8942 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
8943 break;
8945 case GFC_ISYM_LBOUND:
8946 gfc_conv_intrinsic_bound (se, expr, 0);
8947 break;
8949 case GFC_ISYM_LCOBOUND:
8950 conv_intrinsic_cobound (se, expr);
8951 break;
8953 case GFC_ISYM_TRANSPOSE:
8954 /* The scalarizer has already been set up for reversed dimension access
8955 order ; now we just get the argument value normally. */
8956 gfc_conv_expr (se, expr->value.function.actual->expr);
8957 break;
8959 case GFC_ISYM_LEN:
8960 gfc_conv_intrinsic_len (se, expr);
8961 break;
8963 case GFC_ISYM_LEN_TRIM:
8964 gfc_conv_intrinsic_len_trim (se, expr);
8965 break;
8967 case GFC_ISYM_LGE:
8968 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
8969 break;
8971 case GFC_ISYM_LGT:
8972 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
8973 break;
8975 case GFC_ISYM_LLE:
8976 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
8977 break;
8979 case GFC_ISYM_LLT:
8980 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
8981 break;
8983 case GFC_ISYM_MALLOC:
8984 gfc_conv_intrinsic_malloc (se, expr);
8985 break;
8987 case GFC_ISYM_MASKL:
8988 gfc_conv_intrinsic_mask (se, expr, 1);
8989 break;
8991 case GFC_ISYM_MASKR:
8992 gfc_conv_intrinsic_mask (se, expr, 0);
8993 break;
8995 case GFC_ISYM_MAX:
8996 if (expr->ts.type == BT_CHARACTER)
8997 gfc_conv_intrinsic_minmax_char (se, expr, 1);
8998 else
8999 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
9000 break;
9002 case GFC_ISYM_MAXLOC:
9003 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
9004 break;
9006 case GFC_ISYM_MAXVAL:
9007 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
9008 break;
9010 case GFC_ISYM_MERGE:
9011 gfc_conv_intrinsic_merge (se, expr);
9012 break;
9014 case GFC_ISYM_MERGE_BITS:
9015 gfc_conv_intrinsic_merge_bits (se, expr);
9016 break;
9018 case GFC_ISYM_MIN:
9019 if (expr->ts.type == BT_CHARACTER)
9020 gfc_conv_intrinsic_minmax_char (se, expr, -1);
9021 else
9022 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
9023 break;
9025 case GFC_ISYM_MINLOC:
9026 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
9027 break;
9029 case GFC_ISYM_MINVAL:
9030 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
9031 break;
9033 case GFC_ISYM_NEAREST:
9034 gfc_conv_intrinsic_nearest (se, expr);
9035 break;
9037 case GFC_ISYM_NORM2:
9038 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
9039 break;
9041 case GFC_ISYM_NOT:
9042 gfc_conv_intrinsic_not (se, expr);
9043 break;
9045 case GFC_ISYM_OR:
9046 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
9047 break;
9049 case GFC_ISYM_PARITY:
9050 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
9051 break;
9053 case GFC_ISYM_PRESENT:
9054 gfc_conv_intrinsic_present (se, expr);
9055 break;
9057 case GFC_ISYM_PRODUCT:
9058 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
9059 break;
9061 case GFC_ISYM_RANK:
9062 gfc_conv_intrinsic_rank (se, expr);
9063 break;
9065 case GFC_ISYM_RRSPACING:
9066 gfc_conv_intrinsic_rrspacing (se, expr);
9067 break;
9069 case GFC_ISYM_SET_EXPONENT:
9070 gfc_conv_intrinsic_set_exponent (se, expr);
9071 break;
9073 case GFC_ISYM_SCALE:
9074 gfc_conv_intrinsic_scale (se, expr);
9075 break;
9077 case GFC_ISYM_SIGN:
9078 gfc_conv_intrinsic_sign (se, expr);
9079 break;
9081 case GFC_ISYM_SIZE:
9082 gfc_conv_intrinsic_size (se, expr);
9083 break;
9085 case GFC_ISYM_SIZEOF:
9086 case GFC_ISYM_C_SIZEOF:
9087 gfc_conv_intrinsic_sizeof (se, expr);
9088 break;
9090 case GFC_ISYM_STORAGE_SIZE:
9091 gfc_conv_intrinsic_storage_size (se, expr);
9092 break;
9094 case GFC_ISYM_SPACING:
9095 gfc_conv_intrinsic_spacing (se, expr);
9096 break;
9098 case GFC_ISYM_STRIDE:
9099 conv_intrinsic_stride (se, expr);
9100 break;
9102 case GFC_ISYM_SUM:
9103 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
9104 break;
9106 case GFC_ISYM_TRANSFER:
9107 if (se->ss && se->ss->info->useflags)
9108 /* Access the previously obtained result. */
9109 gfc_conv_tmp_array_ref (se);
9110 else
9111 gfc_conv_intrinsic_transfer (se, expr);
9112 break;
9114 case GFC_ISYM_TTYNAM:
9115 gfc_conv_intrinsic_ttynam (se, expr);
9116 break;
9118 case GFC_ISYM_UBOUND:
9119 gfc_conv_intrinsic_bound (se, expr, 1);
9120 break;
9122 case GFC_ISYM_UCOBOUND:
9123 conv_intrinsic_cobound (se, expr);
9124 break;
9126 case GFC_ISYM_XOR:
9127 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
9128 break;
9130 case GFC_ISYM_LOC:
9131 gfc_conv_intrinsic_loc (se, expr);
9132 break;
9134 case GFC_ISYM_THIS_IMAGE:
9135 /* For num_images() == 1, handle as LCOBOUND. */
9136 if (expr->value.function.actual->expr
9137 && flag_coarray == GFC_FCOARRAY_SINGLE)
9138 conv_intrinsic_cobound (se, expr);
9139 else
9140 trans_this_image (se, expr);
9141 break;
9143 case GFC_ISYM_IMAGE_INDEX:
9144 trans_image_index (se, expr);
9145 break;
9147 case GFC_ISYM_IMAGE_STATUS:
9148 conv_intrinsic_image_status (se, expr);
9149 break;
9151 case GFC_ISYM_NUM_IMAGES:
9152 trans_num_images (se, expr);
9153 break;
9155 case GFC_ISYM_ACCESS:
9156 case GFC_ISYM_CHDIR:
9157 case GFC_ISYM_CHMOD:
9158 case GFC_ISYM_DTIME:
9159 case GFC_ISYM_ETIME:
9160 case GFC_ISYM_EXTENDS_TYPE_OF:
9161 case GFC_ISYM_FGET:
9162 case GFC_ISYM_FGETC:
9163 case GFC_ISYM_FNUM:
9164 case GFC_ISYM_FPUT:
9165 case GFC_ISYM_FPUTC:
9166 case GFC_ISYM_FSTAT:
9167 case GFC_ISYM_FTELL:
9168 case GFC_ISYM_GETCWD:
9169 case GFC_ISYM_GETGID:
9170 case GFC_ISYM_GETPID:
9171 case GFC_ISYM_GETUID:
9172 case GFC_ISYM_HOSTNM:
9173 case GFC_ISYM_KILL:
9174 case GFC_ISYM_IERRNO:
9175 case GFC_ISYM_IRAND:
9176 case GFC_ISYM_ISATTY:
9177 case GFC_ISYM_JN2:
9178 case GFC_ISYM_LINK:
9179 case GFC_ISYM_LSTAT:
9180 case GFC_ISYM_MATMUL:
9181 case GFC_ISYM_MCLOCK:
9182 case GFC_ISYM_MCLOCK8:
9183 case GFC_ISYM_RAND:
9184 case GFC_ISYM_RENAME:
9185 case GFC_ISYM_SECOND:
9186 case GFC_ISYM_SECNDS:
9187 case GFC_ISYM_SIGNAL:
9188 case GFC_ISYM_STAT:
9189 case GFC_ISYM_SYMLNK:
9190 case GFC_ISYM_SYSTEM:
9191 case GFC_ISYM_TIME:
9192 case GFC_ISYM_TIME8:
9193 case GFC_ISYM_UMASK:
9194 case GFC_ISYM_UNLINK:
9195 case GFC_ISYM_YN2:
9196 gfc_conv_intrinsic_funcall (se, expr);
9197 break;
9199 case GFC_ISYM_EOSHIFT:
9200 case GFC_ISYM_PACK:
9201 case GFC_ISYM_RESHAPE:
9202 /* For those, expr->rank should always be >0 and thus the if above the
9203 switch should have matched. */
9204 gcc_unreachable ();
9205 break;
9207 default:
9208 gfc_conv_intrinsic_lib_function (se, expr);
9209 break;
9214 static gfc_ss *
9215 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
9217 gfc_ss *arg_ss, *tmp_ss;
9218 gfc_actual_arglist *arg;
9220 arg = expr->value.function.actual;
9222 gcc_assert (arg->expr);
9224 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
9225 gcc_assert (arg_ss != gfc_ss_terminator);
9227 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
9229 if (tmp_ss->info->type != GFC_SS_SCALAR
9230 && tmp_ss->info->type != GFC_SS_REFERENCE)
9232 gcc_assert (tmp_ss->dimen == 2);
9234 /* We just invert dimensions. */
9235 std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
9238 /* Stop when tmp_ss points to the last valid element of the chain... */
9239 if (tmp_ss->next == gfc_ss_terminator)
9240 break;
9243 /* ... so that we can attach the rest of the chain to it. */
9244 tmp_ss->next = ss;
9246 return arg_ss;
9250 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9251 This has the side effect of reversing the nested list, so there is no
9252 need to call gfc_reverse_ss on it (the given list is assumed not to be
9253 reversed yet). */
9255 static gfc_ss *
9256 nest_loop_dimension (gfc_ss *ss, int dim)
9258 int ss_dim, i;
9259 gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
9260 gfc_loopinfo *new_loop;
9262 gcc_assert (ss != gfc_ss_terminator);
9264 for (; ss != gfc_ss_terminator; ss = ss->next)
9266 new_ss = gfc_get_ss ();
9267 new_ss->next = prev_ss;
9268 new_ss->parent = ss;
9269 new_ss->info = ss->info;
9270 new_ss->info->refcount++;
9271 if (ss->dimen != 0)
9273 gcc_assert (ss->info->type != GFC_SS_SCALAR
9274 && ss->info->type != GFC_SS_REFERENCE);
9276 new_ss->dimen = 1;
9277 new_ss->dim[0] = ss->dim[dim];
9279 gcc_assert (dim < ss->dimen);
9281 ss_dim = --ss->dimen;
9282 for (i = dim; i < ss_dim; i++)
9283 ss->dim[i] = ss->dim[i + 1];
9285 ss->dim[ss_dim] = 0;
9287 prev_ss = new_ss;
9289 if (ss->nested_ss)
9291 ss->nested_ss->parent = new_ss;
9292 new_ss->nested_ss = ss->nested_ss;
9294 ss->nested_ss = new_ss;
9297 new_loop = gfc_get_loopinfo ();
9298 gfc_init_loopinfo (new_loop);
9300 gcc_assert (prev_ss != NULL);
9301 gcc_assert (prev_ss != gfc_ss_terminator);
9302 gfc_add_ss_to_loop (new_loop, prev_ss);
9303 return new_ss->parent;
9307 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9308 is to be inlined. */
9310 static gfc_ss *
9311 walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
9313 gfc_ss *tmp_ss, *tail, *array_ss;
9314 gfc_actual_arglist *arg1, *arg2, *arg3;
9315 int sum_dim;
9316 bool scalar_mask = false;
9318 /* The rank of the result will be determined later. */
9319 arg1 = expr->value.function.actual;
9320 arg2 = arg1->next;
9321 arg3 = arg2->next;
9322 gcc_assert (arg3 != NULL);
9324 if (expr->rank == 0)
9325 return ss;
9327 tmp_ss = gfc_ss_terminator;
9329 if (arg3->expr)
9331 gfc_ss *mask_ss;
9333 mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
9334 if (mask_ss == tmp_ss)
9335 scalar_mask = 1;
9337 tmp_ss = mask_ss;
9340 array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
9341 gcc_assert (array_ss != tmp_ss);
9343 /* Odd thing: If the mask is scalar, it is used by the frontend after
9344 the array (to make an if around the nested loop). Thus it shall
9345 be after array_ss once the gfc_ss list is reversed. */
9346 if (scalar_mask)
9347 tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
9348 else
9349 tmp_ss = array_ss;
9351 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9352 chain. */
9353 sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
9354 tail = nest_loop_dimension (tmp_ss, sum_dim);
9355 tail->next = ss;
9357 return tmp_ss;
9361 static gfc_ss *
9362 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
9365 switch (expr->value.function.isym->id)
9367 case GFC_ISYM_PRODUCT:
9368 case GFC_ISYM_SUM:
9369 return walk_inline_intrinsic_arith (ss, expr);
9371 case GFC_ISYM_TRANSPOSE:
9372 return walk_inline_intrinsic_transpose (ss, expr);
9374 default:
9375 gcc_unreachable ();
9377 gcc_unreachable ();
9381 /* This generates code to execute before entering the scalarization loop.
9382 Currently does nothing. */
9384 void
9385 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
9387 switch (ss->info->expr->value.function.isym->id)
9389 case GFC_ISYM_UBOUND:
9390 case GFC_ISYM_LBOUND:
9391 case GFC_ISYM_UCOBOUND:
9392 case GFC_ISYM_LCOBOUND:
9393 case GFC_ISYM_THIS_IMAGE:
9394 break;
9396 default:
9397 gcc_unreachable ();
9402 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9403 are expanded into code inside the scalarization loop. */
9405 static gfc_ss *
9406 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
9408 if (expr->value.function.actual->expr->ts.type == BT_CLASS)
9409 gfc_add_class_array_ref (expr->value.function.actual->expr);
9411 /* The two argument version returns a scalar. */
9412 if (expr->value.function.actual->next->expr)
9413 return ss;
9415 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
9419 /* Walk an intrinsic array libcall. */
9421 static gfc_ss *
9422 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
9424 gcc_assert (expr->rank > 0);
9425 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
9429 /* Return whether the function call expression EXPR will be expanded
9430 inline by gfc_conv_intrinsic_function. */
9432 bool
9433 gfc_inline_intrinsic_function_p (gfc_expr *expr)
9435 gfc_actual_arglist *args;
9437 if (!expr->value.function.isym)
9438 return false;
9440 switch (expr->value.function.isym->id)
9442 case GFC_ISYM_PRODUCT:
9443 case GFC_ISYM_SUM:
9444 /* Disable inline expansion if code size matters. */
9445 if (optimize_size)
9446 return false;
9448 args = expr->value.function.actual;
9449 /* We need to be able to subset the SUM argument at compile-time. */
9450 if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT)
9451 return false;
9453 return true;
9455 case GFC_ISYM_TRANSPOSE:
9456 return true;
9458 default:
9459 return false;
9464 /* Returns nonzero if the specified intrinsic function call maps directly to
9465 an external library call. Should only be used for functions that return
9466 arrays. */
9469 gfc_is_intrinsic_libcall (gfc_expr * expr)
9471 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
9472 gcc_assert (expr->rank > 0);
9474 if (gfc_inline_intrinsic_function_p (expr))
9475 return 0;
9477 switch (expr->value.function.isym->id)
9479 case GFC_ISYM_ALL:
9480 case GFC_ISYM_ANY:
9481 case GFC_ISYM_COUNT:
9482 case GFC_ISYM_JN2:
9483 case GFC_ISYM_IANY:
9484 case GFC_ISYM_IALL:
9485 case GFC_ISYM_IPARITY:
9486 case GFC_ISYM_MATMUL:
9487 case GFC_ISYM_MAXLOC:
9488 case GFC_ISYM_MAXVAL:
9489 case GFC_ISYM_MINLOC:
9490 case GFC_ISYM_MINVAL:
9491 case GFC_ISYM_NORM2:
9492 case GFC_ISYM_PARITY:
9493 case GFC_ISYM_PRODUCT:
9494 case GFC_ISYM_SUM:
9495 case GFC_ISYM_SHAPE:
9496 case GFC_ISYM_SPREAD:
9497 case GFC_ISYM_YN2:
9498 /* Ignore absent optional parameters. */
9499 return 1;
9501 case GFC_ISYM_CSHIFT:
9502 case GFC_ISYM_EOSHIFT:
9503 case GFC_ISYM_FAILED_IMAGES:
9504 case GFC_ISYM_STOPPED_IMAGES:
9505 case GFC_ISYM_PACK:
9506 case GFC_ISYM_RESHAPE:
9507 case GFC_ISYM_UNPACK:
9508 /* Pass absent optional parameters. */
9509 return 2;
9511 default:
9512 return 0;
9516 /* Walk an intrinsic function. */
9517 gfc_ss *
9518 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
9519 gfc_intrinsic_sym * isym)
9521 gcc_assert (isym);
9523 if (isym->elemental)
9524 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
9525 NULL, GFC_SS_SCALAR);
9527 if (expr->rank == 0)
9528 return ss;
9530 if (gfc_inline_intrinsic_function_p (expr))
9531 return walk_inline_intrinsic_function (ss, expr);
9533 if (gfc_is_intrinsic_libcall (expr))
9534 return gfc_walk_intrinsic_libfunc (ss, expr);
9536 /* Special cases. */
9537 switch (isym->id)
9539 case GFC_ISYM_LBOUND:
9540 case GFC_ISYM_LCOBOUND:
9541 case GFC_ISYM_UBOUND:
9542 case GFC_ISYM_UCOBOUND:
9543 case GFC_ISYM_THIS_IMAGE:
9544 return gfc_walk_intrinsic_bound (ss, expr);
9546 case GFC_ISYM_TRANSFER:
9547 case GFC_ISYM_CAF_GET:
9548 return gfc_walk_intrinsic_libfunc (ss, expr);
9550 default:
9551 /* This probably meant someone forgot to add an intrinsic to the above
9552 list(s) when they implemented it, or something's gone horribly
9553 wrong. */
9554 gcc_unreachable ();
9559 static tree
9560 conv_co_collective (gfc_code *code)
9562 gfc_se argse;
9563 stmtblock_t block, post_block;
9564 tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len;
9565 gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
9567 gfc_start_block (&block);
9568 gfc_init_block (&post_block);
9570 if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
9572 opr_expr = code->ext.actual->next->expr;
9573 image_idx_expr = code->ext.actual->next->next->expr;
9574 stat_expr = code->ext.actual->next->next->next->expr;
9575 errmsg_expr = code->ext.actual->next->next->next->next->expr;
9577 else
9579 opr_expr = NULL;
9580 image_idx_expr = code->ext.actual->next->expr;
9581 stat_expr = code->ext.actual->next->next->expr;
9582 errmsg_expr = code->ext.actual->next->next->next->expr;
9585 /* stat. */
9586 if (stat_expr)
9588 gfc_init_se (&argse, NULL);
9589 gfc_conv_expr (&argse, stat_expr);
9590 gfc_add_block_to_block (&block, &argse.pre);
9591 gfc_add_block_to_block (&post_block, &argse.post);
9592 stat = argse.expr;
9593 if (flag_coarray != GFC_FCOARRAY_SINGLE)
9594 stat = gfc_build_addr_expr (NULL_TREE, stat);
9596 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
9597 stat = NULL_TREE;
9598 else
9599 stat = null_pointer_node;
9601 /* Early exit for GFC_FCOARRAY_SINGLE. */
9602 if (flag_coarray == GFC_FCOARRAY_SINGLE)
9604 if (stat != NULL_TREE)
9605 gfc_add_modify (&block, stat,
9606 fold_convert (TREE_TYPE (stat), integer_zero_node));
9607 return gfc_finish_block (&block);
9610 /* Handle the array. */
9611 gfc_init_se (&argse, NULL);
9612 if (code->ext.actual->expr->rank == 0)
9614 symbol_attribute attr;
9615 gfc_clear_attr (&attr);
9616 gfc_init_se (&argse, NULL);
9617 gfc_conv_expr (&argse, code->ext.actual->expr);
9618 gfc_add_block_to_block (&block, &argse.pre);
9619 gfc_add_block_to_block (&post_block, &argse.post);
9620 array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
9621 array = gfc_build_addr_expr (NULL_TREE, array);
9623 else
9625 argse.want_pointer = 1;
9626 gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
9627 array = argse.expr;
9629 gfc_add_block_to_block (&block, &argse.pre);
9630 gfc_add_block_to_block (&post_block, &argse.post);
9632 if (code->ext.actual->expr->ts.type == BT_CHARACTER)
9633 strlen = argse.string_length;
9634 else
9635 strlen = integer_zero_node;
9637 /* image_index. */
9638 if (image_idx_expr)
9640 gfc_init_se (&argse, NULL);
9641 gfc_conv_expr (&argse, image_idx_expr);
9642 gfc_add_block_to_block (&block, &argse.pre);
9643 gfc_add_block_to_block (&post_block, &argse.post);
9644 image_index = fold_convert (integer_type_node, argse.expr);
9646 else
9647 image_index = integer_zero_node;
9649 /* errmsg. */
9650 if (errmsg_expr)
9652 gfc_init_se (&argse, NULL);
9653 gfc_conv_expr (&argse, errmsg_expr);
9654 gfc_add_block_to_block (&block, &argse.pre);
9655 gfc_add_block_to_block (&post_block, &argse.post);
9656 errmsg = argse.expr;
9657 errmsg_len = fold_convert (integer_type_node, argse.string_length);
9659 else
9661 errmsg = null_pointer_node;
9662 errmsg_len = integer_zero_node;
9665 /* Generate the function call. */
9666 switch (code->resolved_isym->id)
9668 case GFC_ISYM_CO_BROADCAST:
9669 fndecl = gfor_fndecl_co_broadcast;
9670 break;
9671 case GFC_ISYM_CO_MAX:
9672 fndecl = gfor_fndecl_co_max;
9673 break;
9674 case GFC_ISYM_CO_MIN:
9675 fndecl = gfor_fndecl_co_min;
9676 break;
9677 case GFC_ISYM_CO_REDUCE:
9678 fndecl = gfor_fndecl_co_reduce;
9679 break;
9680 case GFC_ISYM_CO_SUM:
9681 fndecl = gfor_fndecl_co_sum;
9682 break;
9683 default:
9684 gcc_unreachable ();
9687 if (code->resolved_isym->id == GFC_ISYM_CO_SUM
9688 || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
9689 fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
9690 image_index, stat, errmsg, errmsg_len);
9691 else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
9692 fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index,
9693 stat, errmsg, strlen, errmsg_len);
9694 else
9696 tree opr, opr_flags;
9698 // FIXME: Handle TS29113's bind(C) strings with descriptor.
9699 int opr_flag_int;
9700 if (gfc_is_proc_ptr_comp (opr_expr))
9702 gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
9703 opr_flag_int = sym->attr.dimension
9704 || (sym->ts.type == BT_CHARACTER
9705 && !sym->attr.is_bind_c)
9706 ? GFC_CAF_BYREF : 0;
9707 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
9708 && !sym->attr.is_bind_c
9709 ? GFC_CAF_HIDDENLEN : 0;
9710 opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0;
9712 else
9714 opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
9715 ? GFC_CAF_BYREF : 0;
9716 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
9717 && !opr_expr->symtree->n.sym->attr.is_bind_c
9718 ? GFC_CAF_HIDDENLEN : 0;
9719 opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
9720 ? GFC_CAF_ARG_VALUE : 0;
9722 opr_flags = build_int_cst (integer_type_node, opr_flag_int);
9723 gfc_conv_expr (&argse, opr_expr);
9724 opr = argse.expr;
9725 fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags,
9726 image_index, stat, errmsg, strlen, errmsg_len);
9729 gfc_add_expr_to_block (&block, fndecl);
9730 gfc_add_block_to_block (&block, &post_block);
9732 return gfc_finish_block (&block);
9736 static tree
9737 conv_intrinsic_atomic_op (gfc_code *code)
9739 gfc_se argse;
9740 tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
9741 stmtblock_t block, post_block;
9742 gfc_expr *atom_expr = code->ext.actual->expr;
9743 gfc_expr *stat_expr;
9744 built_in_function fn;
9746 if (atom_expr->expr_type == EXPR_FUNCTION
9747 && atom_expr->value.function.isym
9748 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
9749 atom_expr = atom_expr->value.function.actual->expr;
9751 gfc_start_block (&block);
9752 gfc_init_block (&post_block);
9754 gfc_init_se (&argse, NULL);
9755 argse.want_pointer = 1;
9756 gfc_conv_expr (&argse, atom_expr);
9757 gfc_add_block_to_block (&block, &argse.pre);
9758 gfc_add_block_to_block (&post_block, &argse.post);
9759 atom = argse.expr;
9761 gfc_init_se (&argse, NULL);
9762 if (flag_coarray == GFC_FCOARRAY_LIB
9763 && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
9764 argse.want_pointer = 1;
9765 gfc_conv_expr (&argse, code->ext.actual->next->expr);
9766 gfc_add_block_to_block (&block, &argse.pre);
9767 gfc_add_block_to_block (&post_block, &argse.post);
9768 value = argse.expr;
9770 switch (code->resolved_isym->id)
9772 case GFC_ISYM_ATOMIC_ADD:
9773 case GFC_ISYM_ATOMIC_AND:
9774 case GFC_ISYM_ATOMIC_DEF:
9775 case GFC_ISYM_ATOMIC_OR:
9776 case GFC_ISYM_ATOMIC_XOR:
9777 stat_expr = code->ext.actual->next->next->expr;
9778 if (flag_coarray == GFC_FCOARRAY_LIB)
9779 old = null_pointer_node;
9780 break;
9781 default:
9782 gfc_init_se (&argse, NULL);
9783 if (flag_coarray == GFC_FCOARRAY_LIB)
9784 argse.want_pointer = 1;
9785 gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
9786 gfc_add_block_to_block (&block, &argse.pre);
9787 gfc_add_block_to_block (&post_block, &argse.post);
9788 old = argse.expr;
9789 stat_expr = code->ext.actual->next->next->next->expr;
9792 /* STAT= */
9793 if (stat_expr != NULL)
9795 gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
9796 gfc_init_se (&argse, NULL);
9797 if (flag_coarray == GFC_FCOARRAY_LIB)
9798 argse.want_pointer = 1;
9799 gfc_conv_expr_val (&argse, stat_expr);
9800 gfc_add_block_to_block (&block, &argse.pre);
9801 gfc_add_block_to_block (&post_block, &argse.post);
9802 stat = argse.expr;
9804 else if (flag_coarray == GFC_FCOARRAY_LIB)
9805 stat = null_pointer_node;
9807 if (flag_coarray == GFC_FCOARRAY_LIB)
9809 tree image_index, caf_decl, offset, token;
9810 int op;
9812 switch (code->resolved_isym->id)
9814 case GFC_ISYM_ATOMIC_ADD:
9815 case GFC_ISYM_ATOMIC_FETCH_ADD:
9816 op = (int) GFC_CAF_ATOMIC_ADD;
9817 break;
9818 case GFC_ISYM_ATOMIC_AND:
9819 case GFC_ISYM_ATOMIC_FETCH_AND:
9820 op = (int) GFC_CAF_ATOMIC_AND;
9821 break;
9822 case GFC_ISYM_ATOMIC_OR:
9823 case GFC_ISYM_ATOMIC_FETCH_OR:
9824 op = (int) GFC_CAF_ATOMIC_OR;
9825 break;
9826 case GFC_ISYM_ATOMIC_XOR:
9827 case GFC_ISYM_ATOMIC_FETCH_XOR:
9828 op = (int) GFC_CAF_ATOMIC_XOR;
9829 break;
9830 case GFC_ISYM_ATOMIC_DEF:
9831 op = 0; /* Unused. */
9832 break;
9833 default:
9834 gcc_unreachable ();
9837 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
9838 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
9839 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
9841 if (gfc_is_coindexed (atom_expr))
9842 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
9843 else
9844 image_index = integer_zero_node;
9846 if (!POINTER_TYPE_P (TREE_TYPE (value)))
9848 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
9849 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
9850 value = gfc_build_addr_expr (NULL_TREE, tmp);
9853 gfc_init_se (&argse, NULL);
9854 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
9855 atom_expr);
9857 gfc_add_block_to_block (&block, &argse.pre);
9858 if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
9859 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
9860 token, offset, image_index, value, stat,
9861 build_int_cst (integer_type_node,
9862 (int) atom_expr->ts.type),
9863 build_int_cst (integer_type_node,
9864 (int) atom_expr->ts.kind));
9865 else
9866 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
9867 build_int_cst (integer_type_node, op),
9868 token, offset, image_index, value, old, stat,
9869 build_int_cst (integer_type_node,
9870 (int) atom_expr->ts.type),
9871 build_int_cst (integer_type_node,
9872 (int) atom_expr->ts.kind));
9874 gfc_add_expr_to_block (&block, tmp);
9875 gfc_add_block_to_block (&block, &argse.post);
9876 gfc_add_block_to_block (&block, &post_block);
9877 return gfc_finish_block (&block);
9881 switch (code->resolved_isym->id)
9883 case GFC_ISYM_ATOMIC_ADD:
9884 case GFC_ISYM_ATOMIC_FETCH_ADD:
9885 fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
9886 break;
9887 case GFC_ISYM_ATOMIC_AND:
9888 case GFC_ISYM_ATOMIC_FETCH_AND:
9889 fn = BUILT_IN_ATOMIC_FETCH_AND_N;
9890 break;
9891 case GFC_ISYM_ATOMIC_DEF:
9892 fn = BUILT_IN_ATOMIC_STORE_N;
9893 break;
9894 case GFC_ISYM_ATOMIC_OR:
9895 case GFC_ISYM_ATOMIC_FETCH_OR:
9896 fn = BUILT_IN_ATOMIC_FETCH_OR_N;
9897 break;
9898 case GFC_ISYM_ATOMIC_XOR:
9899 case GFC_ISYM_ATOMIC_FETCH_XOR:
9900 fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
9901 break;
9902 default:
9903 gcc_unreachable ();
9906 tmp = TREE_TYPE (TREE_TYPE (atom));
9907 fn = (built_in_function) ((int) fn
9908 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
9909 + 1);
9910 tmp = builtin_decl_explicit (fn);
9911 tree itype = TREE_TYPE (TREE_TYPE (atom));
9912 tmp = builtin_decl_explicit (fn);
9914 switch (code->resolved_isym->id)
9916 case GFC_ISYM_ATOMIC_ADD:
9917 case GFC_ISYM_ATOMIC_AND:
9918 case GFC_ISYM_ATOMIC_DEF:
9919 case GFC_ISYM_ATOMIC_OR:
9920 case GFC_ISYM_ATOMIC_XOR:
9921 tmp = build_call_expr_loc (input_location, tmp, 3, atom,
9922 fold_convert (itype, value),
9923 build_int_cst (NULL, MEMMODEL_RELAXED));
9924 gfc_add_expr_to_block (&block, tmp);
9925 break;
9926 default:
9927 tmp = build_call_expr_loc (input_location, tmp, 3, atom,
9928 fold_convert (itype, value),
9929 build_int_cst (NULL, MEMMODEL_RELAXED));
9930 gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
9931 break;
9934 if (stat != NULL_TREE)
9935 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
9936 gfc_add_block_to_block (&block, &post_block);
9937 return gfc_finish_block (&block);
9941 static tree
9942 conv_intrinsic_atomic_ref (gfc_code *code)
9944 gfc_se argse;
9945 tree tmp, atom, value, stat = NULL_TREE;
9946 stmtblock_t block, post_block;
9947 built_in_function fn;
9948 gfc_expr *atom_expr = code->ext.actual->next->expr;
9950 if (atom_expr->expr_type == EXPR_FUNCTION
9951 && atom_expr->value.function.isym
9952 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
9953 atom_expr = atom_expr->value.function.actual->expr;
9955 gfc_start_block (&block);
9956 gfc_init_block (&post_block);
9957 gfc_init_se (&argse, NULL);
9958 argse.want_pointer = 1;
9959 gfc_conv_expr (&argse, atom_expr);
9960 gfc_add_block_to_block (&block, &argse.pre);
9961 gfc_add_block_to_block (&post_block, &argse.post);
9962 atom = argse.expr;
9964 gfc_init_se (&argse, NULL);
9965 if (flag_coarray == GFC_FCOARRAY_LIB
9966 && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
9967 argse.want_pointer = 1;
9968 gfc_conv_expr (&argse, code->ext.actual->expr);
9969 gfc_add_block_to_block (&block, &argse.pre);
9970 gfc_add_block_to_block (&post_block, &argse.post);
9971 value = argse.expr;
9973 /* STAT= */
9974 if (code->ext.actual->next->next->expr != NULL)
9976 gcc_assert (code->ext.actual->next->next->expr->expr_type
9977 == EXPR_VARIABLE);
9978 gfc_init_se (&argse, NULL);
9979 if (flag_coarray == GFC_FCOARRAY_LIB)
9980 argse.want_pointer = 1;
9981 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
9982 gfc_add_block_to_block (&block, &argse.pre);
9983 gfc_add_block_to_block (&post_block, &argse.post);
9984 stat = argse.expr;
9986 else if (flag_coarray == GFC_FCOARRAY_LIB)
9987 stat = null_pointer_node;
9989 if (flag_coarray == GFC_FCOARRAY_LIB)
9991 tree image_index, caf_decl, offset, token;
9992 tree orig_value = NULL_TREE, vardecl = NULL_TREE;
9994 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
9995 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
9996 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
9998 if (gfc_is_coindexed (atom_expr))
9999 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
10000 else
10001 image_index = integer_zero_node;
10003 gfc_init_se (&argse, NULL);
10004 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
10005 atom_expr);
10006 gfc_add_block_to_block (&block, &argse.pre);
10008 /* Different type, need type conversion. */
10009 if (!POINTER_TYPE_P (TREE_TYPE (value)))
10011 vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
10012 orig_value = value;
10013 value = gfc_build_addr_expr (NULL_TREE, vardecl);
10016 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
10017 token, offset, image_index, value, stat,
10018 build_int_cst (integer_type_node,
10019 (int) atom_expr->ts.type),
10020 build_int_cst (integer_type_node,
10021 (int) atom_expr->ts.kind));
10022 gfc_add_expr_to_block (&block, tmp);
10023 if (vardecl != NULL_TREE)
10024 gfc_add_modify (&block, orig_value,
10025 fold_convert (TREE_TYPE (orig_value), vardecl));
10026 gfc_add_block_to_block (&block, &argse.post);
10027 gfc_add_block_to_block (&block, &post_block);
10028 return gfc_finish_block (&block);
10031 tmp = TREE_TYPE (TREE_TYPE (atom));
10032 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
10033 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
10034 + 1);
10035 tmp = builtin_decl_explicit (fn);
10036 tmp = build_call_expr_loc (input_location, tmp, 2, atom,
10037 build_int_cst (integer_type_node,
10038 MEMMODEL_RELAXED));
10039 gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
10041 if (stat != NULL_TREE)
10042 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
10043 gfc_add_block_to_block (&block, &post_block);
10044 return gfc_finish_block (&block);
10048 static tree
10049 conv_intrinsic_atomic_cas (gfc_code *code)
10051 gfc_se argse;
10052 tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
10053 stmtblock_t block, post_block;
10054 built_in_function fn;
10055 gfc_expr *atom_expr = code->ext.actual->expr;
10057 if (atom_expr->expr_type == EXPR_FUNCTION
10058 && atom_expr->value.function.isym
10059 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
10060 atom_expr = atom_expr->value.function.actual->expr;
10062 gfc_init_block (&block);
10063 gfc_init_block (&post_block);
10064 gfc_init_se (&argse, NULL);
10065 argse.want_pointer = 1;
10066 gfc_conv_expr (&argse, atom_expr);
10067 atom = argse.expr;
10069 gfc_init_se (&argse, NULL);
10070 if (flag_coarray == GFC_FCOARRAY_LIB)
10071 argse.want_pointer = 1;
10072 gfc_conv_expr (&argse, code->ext.actual->next->expr);
10073 gfc_add_block_to_block (&block, &argse.pre);
10074 gfc_add_block_to_block (&post_block, &argse.post);
10075 old = argse.expr;
10077 gfc_init_se (&argse, NULL);
10078 if (flag_coarray == GFC_FCOARRAY_LIB)
10079 argse.want_pointer = 1;
10080 gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
10081 gfc_add_block_to_block (&block, &argse.pre);
10082 gfc_add_block_to_block (&post_block, &argse.post);
10083 comp = argse.expr;
10085 gfc_init_se (&argse, NULL);
10086 if (flag_coarray == GFC_FCOARRAY_LIB
10087 && code->ext.actual->next->next->next->expr->ts.kind
10088 == atom_expr->ts.kind)
10089 argse.want_pointer = 1;
10090 gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
10091 gfc_add_block_to_block (&block, &argse.pre);
10092 gfc_add_block_to_block (&post_block, &argse.post);
10093 new_val = argse.expr;
10095 /* STAT= */
10096 if (code->ext.actual->next->next->next->next->expr != NULL)
10098 gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
10099 == EXPR_VARIABLE);
10100 gfc_init_se (&argse, NULL);
10101 if (flag_coarray == GFC_FCOARRAY_LIB)
10102 argse.want_pointer = 1;
10103 gfc_conv_expr_val (&argse,
10104 code->ext.actual->next->next->next->next->expr);
10105 gfc_add_block_to_block (&block, &argse.pre);
10106 gfc_add_block_to_block (&post_block, &argse.post);
10107 stat = argse.expr;
10109 else if (flag_coarray == GFC_FCOARRAY_LIB)
10110 stat = null_pointer_node;
10112 if (flag_coarray == GFC_FCOARRAY_LIB)
10114 tree image_index, caf_decl, offset, token;
10116 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
10117 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
10118 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
10120 if (gfc_is_coindexed (atom_expr))
10121 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
10122 else
10123 image_index = integer_zero_node;
10125 if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
10127 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
10128 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
10129 new_val = gfc_build_addr_expr (NULL_TREE, tmp);
10132 /* Convert a constant to a pointer. */
10133 if (!POINTER_TYPE_P (TREE_TYPE (comp)))
10135 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp");
10136 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp));
10137 comp = gfc_build_addr_expr (NULL_TREE, tmp);
10140 gfc_init_se (&argse, NULL);
10141 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
10142 atom_expr);
10143 gfc_add_block_to_block (&block, &argse.pre);
10145 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
10146 token, offset, image_index, old, comp, new_val,
10147 stat, build_int_cst (integer_type_node,
10148 (int) atom_expr->ts.type),
10149 build_int_cst (integer_type_node,
10150 (int) atom_expr->ts.kind));
10151 gfc_add_expr_to_block (&block, tmp);
10152 gfc_add_block_to_block (&block, &argse.post);
10153 gfc_add_block_to_block (&block, &post_block);
10154 return gfc_finish_block (&block);
10157 tmp = TREE_TYPE (TREE_TYPE (atom));
10158 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10159 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
10160 + 1);
10161 tmp = builtin_decl_explicit (fn);
10163 gfc_add_modify (&block, old, comp);
10164 tmp = build_call_expr_loc (input_location, tmp, 6, atom,
10165 gfc_build_addr_expr (NULL, old),
10166 fold_convert (TREE_TYPE (old), new_val),
10167 boolean_false_node,
10168 build_int_cst (NULL, MEMMODEL_RELAXED),
10169 build_int_cst (NULL, MEMMODEL_RELAXED));
10170 gfc_add_expr_to_block (&block, tmp);
10172 if (stat != NULL_TREE)
10173 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
10174 gfc_add_block_to_block (&block, &post_block);
10175 return gfc_finish_block (&block);
10178 static tree
10179 conv_intrinsic_event_query (gfc_code *code)
10181 gfc_se se, argse;
10182 tree stat = NULL_TREE, stat2 = NULL_TREE;
10183 tree count = NULL_TREE, count2 = NULL_TREE;
10185 gfc_expr *event_expr = code->ext.actual->expr;
10187 if (code->ext.actual->next->next->expr)
10189 gcc_assert (code->ext.actual->next->next->expr->expr_type
10190 == EXPR_VARIABLE);
10191 gfc_init_se (&argse, NULL);
10192 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
10193 stat = argse.expr;
10195 else if (flag_coarray == GFC_FCOARRAY_LIB)
10196 stat = null_pointer_node;
10198 if (code->ext.actual->next->expr)
10200 gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
10201 gfc_init_se (&argse, NULL);
10202 gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
10203 count = argse.expr;
10206 gfc_start_block (&se.pre);
10207 if (flag_coarray == GFC_FCOARRAY_LIB)
10209 tree tmp, token, image_index;
10210 tree index = size_zero_node;
10212 if (event_expr->expr_type == EXPR_FUNCTION
10213 && event_expr->value.function.isym
10214 && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
10215 event_expr = event_expr->value.function.actual->expr;
10217 tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
10219 if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
10220 || event_expr->symtree->n.sym->ts.u.derived->from_intmod
10221 != INTMOD_ISO_FORTRAN_ENV
10222 || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
10223 != ISOFORTRAN_EVENT_TYPE)
10225 gfc_error ("Sorry, the event component of derived type at %L is not "
10226 "yet supported", &event_expr->where);
10227 return NULL_TREE;
10230 if (gfc_is_coindexed (event_expr))
10232 gfc_error ("The event variable at %L shall not be coindexed",
10233 &event_expr->where);
10234 return NULL_TREE;
10237 image_index = integer_zero_node;
10239 gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
10240 event_expr);
10242 /* For arrays, obtain the array index. */
10243 if (gfc_expr_attr (event_expr).dimension)
10245 tree desc, tmp, extent, lbound, ubound;
10246 gfc_array_ref *ar, ar2;
10247 int i;
10249 /* TODO: Extend this, once DT components are supported. */
10250 ar = &event_expr->ref->u.ar;
10251 ar2 = *ar;
10252 memset (ar, '\0', sizeof (*ar));
10253 ar->as = ar2.as;
10254 ar->type = AR_FULL;
10256 gfc_init_se (&argse, NULL);
10257 argse.descriptor_only = 1;
10258 gfc_conv_expr_descriptor (&argse, event_expr);
10259 gfc_add_block_to_block (&se.pre, &argse.pre);
10260 desc = argse.expr;
10261 *ar = ar2;
10263 extent = integer_one_node;
10264 for (i = 0; i < ar->dimen; i++)
10266 gfc_init_se (&argse, NULL);
10267 gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
10268 gfc_add_block_to_block (&argse.pre, &argse.pre);
10269 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
10270 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10271 integer_type_node, argse.expr,
10272 fold_convert(integer_type_node, lbound));
10273 tmp = fold_build2_loc (input_location, MULT_EXPR,
10274 integer_type_node, extent, tmp);
10275 index = fold_build2_loc (input_location, PLUS_EXPR,
10276 integer_type_node, index, tmp);
10277 if (i < ar->dimen - 1)
10279 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
10280 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
10281 tmp = fold_convert (integer_type_node, tmp);
10282 extent = fold_build2_loc (input_location, MULT_EXPR,
10283 integer_type_node, extent, tmp);
10288 if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
10290 count2 = count;
10291 count = gfc_create_var (integer_type_node, "count");
10294 if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
10296 stat2 = stat;
10297 stat = gfc_create_var (integer_type_node, "stat");
10300 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
10301 token, index, image_index, count
10302 ? gfc_build_addr_expr (NULL, count) : count,
10303 stat != null_pointer_node
10304 ? gfc_build_addr_expr (NULL, stat) : stat);
10305 gfc_add_expr_to_block (&se.pre, tmp);
10307 if (count2 != NULL_TREE)
10308 gfc_add_modify (&se.pre, count2,
10309 fold_convert (TREE_TYPE (count2), count));
10311 if (stat2 != NULL_TREE)
10312 gfc_add_modify (&se.pre, stat2,
10313 fold_convert (TREE_TYPE (stat2), stat));
10315 return gfc_finish_block (&se.pre);
10318 gfc_init_se (&argse, NULL);
10319 gfc_conv_expr_val (&argse, code->ext.actual->expr);
10320 gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
10322 if (stat != NULL_TREE)
10323 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
10325 return gfc_finish_block (&se.pre);
10328 static tree
10329 conv_intrinsic_move_alloc (gfc_code *code)
10331 stmtblock_t block;
10332 gfc_expr *from_expr, *to_expr;
10333 gfc_expr *to_expr2, *from_expr2 = NULL;
10334 gfc_se from_se, to_se;
10335 tree tmp;
10336 bool coarray;
10338 gfc_start_block (&block);
10340 from_expr = code->ext.actual->expr;
10341 to_expr = code->ext.actual->next->expr;
10343 gfc_init_se (&from_se, NULL);
10344 gfc_init_se (&to_se, NULL);
10346 gcc_assert (from_expr->ts.type != BT_CLASS
10347 || to_expr->ts.type == BT_CLASS);
10348 coarray = gfc_get_corank (from_expr) != 0;
10350 if (from_expr->rank == 0 && !coarray)
10352 if (from_expr->ts.type != BT_CLASS)
10353 from_expr2 = from_expr;
10354 else
10356 from_expr2 = gfc_copy_expr (from_expr);
10357 gfc_add_data_component (from_expr2);
10360 if (to_expr->ts.type != BT_CLASS)
10361 to_expr2 = to_expr;
10362 else
10364 to_expr2 = gfc_copy_expr (to_expr);
10365 gfc_add_data_component (to_expr2);
10368 from_se.want_pointer = 1;
10369 to_se.want_pointer = 1;
10370 gfc_conv_expr (&from_se, from_expr2);
10371 gfc_conv_expr (&to_se, to_expr2);
10372 gfc_add_block_to_block (&block, &from_se.pre);
10373 gfc_add_block_to_block (&block, &to_se.pre);
10375 /* Deallocate "to". */
10376 tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE,
10377 true, to_expr, to_expr->ts);
10378 gfc_add_expr_to_block (&block, tmp);
10380 /* Assign (_data) pointers. */
10381 gfc_add_modify_loc (input_location, &block, to_se.expr,
10382 fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
10384 /* Set "from" to NULL. */
10385 gfc_add_modify_loc (input_location, &block, from_se.expr,
10386 fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
10388 gfc_add_block_to_block (&block, &from_se.post);
10389 gfc_add_block_to_block (&block, &to_se.post);
10391 /* Set _vptr. */
10392 if (to_expr->ts.type == BT_CLASS)
10394 gfc_symbol *vtab;
10396 gfc_free_expr (to_expr2);
10397 gfc_init_se (&to_se, NULL);
10398 to_se.want_pointer = 1;
10399 gfc_add_vptr_component (to_expr);
10400 gfc_conv_expr (&to_se, to_expr);
10402 if (from_expr->ts.type == BT_CLASS)
10404 if (UNLIMITED_POLY (from_expr))
10405 vtab = NULL;
10406 else
10408 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
10409 gcc_assert (vtab);
10412 gfc_free_expr (from_expr2);
10413 gfc_init_se (&from_se, NULL);
10414 from_se.want_pointer = 1;
10415 gfc_add_vptr_component (from_expr);
10416 gfc_conv_expr (&from_se, from_expr);
10417 gfc_add_modify_loc (input_location, &block, to_se.expr,
10418 fold_convert (TREE_TYPE (to_se.expr),
10419 from_se.expr));
10421 /* Reset _vptr component to declared type. */
10422 if (vtab == NULL)
10423 /* Unlimited polymorphic. */
10424 gfc_add_modify_loc (input_location, &block, from_se.expr,
10425 fold_convert (TREE_TYPE (from_se.expr),
10426 null_pointer_node));
10427 else
10429 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10430 gfc_add_modify_loc (input_location, &block, from_se.expr,
10431 fold_convert (TREE_TYPE (from_se.expr), tmp));
10434 else
10436 vtab = gfc_find_vtab (&from_expr->ts);
10437 gcc_assert (vtab);
10438 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10439 gfc_add_modify_loc (input_location, &block, to_se.expr,
10440 fold_convert (TREE_TYPE (to_se.expr), tmp));
10444 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
10446 gfc_add_modify_loc (input_location, &block, to_se.string_length,
10447 fold_convert (TREE_TYPE (to_se.string_length),
10448 from_se.string_length));
10449 if (from_expr->ts.deferred)
10450 gfc_add_modify_loc (input_location, &block, from_se.string_length,
10451 build_int_cst (TREE_TYPE (from_se.string_length), 0));
10454 return gfc_finish_block (&block);
10457 /* Update _vptr component. */
10458 if (to_expr->ts.type == BT_CLASS)
10460 gfc_symbol *vtab;
10462 to_se.want_pointer = 1;
10463 to_expr2 = gfc_copy_expr (to_expr);
10464 gfc_add_vptr_component (to_expr2);
10465 gfc_conv_expr (&to_se, to_expr2);
10467 if (from_expr->ts.type == BT_CLASS)
10469 if (UNLIMITED_POLY (from_expr))
10470 vtab = NULL;
10471 else
10473 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
10474 gcc_assert (vtab);
10477 from_se.want_pointer = 1;
10478 from_expr2 = gfc_copy_expr (from_expr);
10479 gfc_add_vptr_component (from_expr2);
10480 gfc_conv_expr (&from_se, from_expr2);
10481 gfc_add_modify_loc (input_location, &block, to_se.expr,
10482 fold_convert (TREE_TYPE (to_se.expr),
10483 from_se.expr));
10485 /* Reset _vptr component to declared type. */
10486 if (vtab == NULL)
10487 /* Unlimited polymorphic. */
10488 gfc_add_modify_loc (input_location, &block, from_se.expr,
10489 fold_convert (TREE_TYPE (from_se.expr),
10490 null_pointer_node));
10491 else
10493 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10494 gfc_add_modify_loc (input_location, &block, from_se.expr,
10495 fold_convert (TREE_TYPE (from_se.expr), tmp));
10498 else
10500 vtab = gfc_find_vtab (&from_expr->ts);
10501 gcc_assert (vtab);
10502 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10503 gfc_add_modify_loc (input_location, &block, to_se.expr,
10504 fold_convert (TREE_TYPE (to_se.expr), tmp));
10507 gfc_free_expr (to_expr2);
10508 gfc_init_se (&to_se, NULL);
10510 if (from_expr->ts.type == BT_CLASS)
10512 gfc_free_expr (from_expr2);
10513 gfc_init_se (&from_se, NULL);
10518 /* Deallocate "to". */
10519 if (from_expr->rank == 0)
10521 to_se.want_coarray = 1;
10522 from_se.want_coarray = 1;
10524 gfc_conv_expr_descriptor (&to_se, to_expr);
10525 gfc_conv_expr_descriptor (&from_se, from_expr);
10527 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10528 is an image control "statement", cf. IR F08/0040 in 12-006A. */
10529 if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
10531 tree cond;
10533 tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
10534 NULL_TREE, NULL_TREE, true, to_expr,
10535 GFC_CAF_COARRAY_DEALLOCATE_ONLY);
10536 gfc_add_expr_to_block (&block, tmp);
10538 tmp = gfc_conv_descriptor_data_get (to_se.expr);
10539 cond = fold_build2_loc (input_location, EQ_EXPR,
10540 boolean_type_node, tmp,
10541 fold_convert (TREE_TYPE (tmp),
10542 null_pointer_node));
10543 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
10544 3, null_pointer_node, null_pointer_node,
10545 build_int_cst (integer_type_node, 0));
10547 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
10548 tmp, build_empty_stmt (input_location));
10549 gfc_add_expr_to_block (&block, tmp);
10551 else
10553 if (to_expr->ts.type == BT_DERIVED
10554 && to_expr->ts.u.derived->attr.alloc_comp)
10556 tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
10557 to_se.expr, to_expr->rank);
10558 gfc_add_expr_to_block (&block, tmp);
10561 tmp = gfc_conv_descriptor_data_get (to_se.expr);
10562 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
10563 NULL_TREE, true, to_expr,
10564 GFC_CAF_COARRAY_NOCOARRAY);
10565 gfc_add_expr_to_block (&block, tmp);
10568 /* Move the pointer and update the array descriptor data. */
10569 gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
10571 /* Set "from" to NULL. */
10572 tmp = gfc_conv_descriptor_data_get (from_se.expr);
10573 gfc_add_modify_loc (input_location, &block, tmp,
10574 fold_convert (TREE_TYPE (tmp), null_pointer_node));
10577 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
10579 gfc_add_modify_loc (input_location, &block, to_se.string_length,
10580 fold_convert (TREE_TYPE (to_se.string_length),
10581 from_se.string_length));
10582 if (from_expr->ts.deferred)
10583 gfc_add_modify_loc (input_location, &block, from_se.string_length,
10584 build_int_cst (TREE_TYPE (from_se.string_length), 0));
10587 return gfc_finish_block (&block);
10591 tree
10592 gfc_conv_intrinsic_subroutine (gfc_code *code)
10594 tree res;
10596 gcc_assert (code->resolved_isym);
10598 switch (code->resolved_isym->id)
10600 case GFC_ISYM_MOVE_ALLOC:
10601 res = conv_intrinsic_move_alloc (code);
10602 break;
10604 case GFC_ISYM_ATOMIC_CAS:
10605 res = conv_intrinsic_atomic_cas (code);
10606 break;
10608 case GFC_ISYM_ATOMIC_ADD:
10609 case GFC_ISYM_ATOMIC_AND:
10610 case GFC_ISYM_ATOMIC_DEF:
10611 case GFC_ISYM_ATOMIC_OR:
10612 case GFC_ISYM_ATOMIC_XOR:
10613 case GFC_ISYM_ATOMIC_FETCH_ADD:
10614 case GFC_ISYM_ATOMIC_FETCH_AND:
10615 case GFC_ISYM_ATOMIC_FETCH_OR:
10616 case GFC_ISYM_ATOMIC_FETCH_XOR:
10617 res = conv_intrinsic_atomic_op (code);
10618 break;
10620 case GFC_ISYM_ATOMIC_REF:
10621 res = conv_intrinsic_atomic_ref (code);
10622 break;
10624 case GFC_ISYM_EVENT_QUERY:
10625 res = conv_intrinsic_event_query (code);
10626 break;
10628 case GFC_ISYM_C_F_POINTER:
10629 case GFC_ISYM_C_F_PROCPOINTER:
10630 res = conv_isocbinding_subroutine (code);
10631 break;
10633 case GFC_ISYM_CAF_SEND:
10634 res = conv_caf_send (code);
10635 break;
10637 case GFC_ISYM_CO_BROADCAST:
10638 case GFC_ISYM_CO_MIN:
10639 case GFC_ISYM_CO_MAX:
10640 case GFC_ISYM_CO_REDUCE:
10641 case GFC_ISYM_CO_SUM:
10642 res = conv_co_collective (code);
10643 break;
10645 case GFC_ISYM_FREE:
10646 res = conv_intrinsic_free (code);
10647 break;
10649 case GFC_ISYM_SYSTEM_CLOCK:
10650 res = conv_intrinsic_system_clock (code);
10651 break;
10653 default:
10654 res = NULL_TREE;
10655 break;
10658 return res;
10661 #include "gt-fortran-trans-intrinsic.h"