1 /* Intrinsic translation
2 Copyright (C) 2002-2019 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
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
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. */
26 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "internal-fn.h"
35 #include "tree-nested.h"
36 #include "stor-layout.h"
37 #include "toplev.h" /* For rest_of_decl_compilation. */
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 #include "dependency.h" /* For CAF array alias analysis. */
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
45 /* This maps Fortran intrinsic math functions to external library or GCC
47 typedef struct GTY(()) gfc_intrinsic_map_t
{
48 /* The explicit enum is required to work around inadequacies in the
49 garbage collection/gengtype parsing mechanism. */
52 /* Enum value from the "language-independent", aka C-centric, part
53 of gcc, or END_BUILTINS of no such value set. */
54 enum built_in_function float_built_in
;
55 enum built_in_function double_built_in
;
56 enum built_in_function long_double_built_in
;
57 enum built_in_function complex_float_built_in
;
58 enum built_in_function complex_double_built_in
;
59 enum built_in_function complex_long_double_built_in
;
61 /* True if the naming pattern is to prepend "c" for complex and
62 append "f" for kind=4. False if the naming pattern is to
63 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 /* True if a complex version of the function exists. */
67 bool complex_available
;
69 /* True if the function should be marked const. */
72 /* The base library name of this function. */
75 /* Cache decls created for the various operand types. */
87 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
88 defines complex variants of all of the entries in mathbuiltins.def
90 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
91 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
92 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
93 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
94 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
96 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
97 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
98 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
99 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
100 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
102 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
108 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
109 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
110 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
116 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
117 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
118 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
119 #include "mathbuiltins.def"
121 /* Functions in libgfortran. */
122 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
125 LIB_FUNCTION (NONE
, NULL
, false)
130 #undef DEFINE_MATH_BUILTIN
131 #undef DEFINE_MATH_BUILTIN_C
134 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
137 /* Find the correct variant of a given builtin from its argument. */
139 builtin_decl_for_precision (enum built_in_function base_built_in
,
142 enum built_in_function i
= END_BUILTINS
;
144 gfc_intrinsic_map_t
*m
;
145 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
148 if (precision
== TYPE_PRECISION (float_type_node
))
149 i
= m
->float_built_in
;
150 else if (precision
== TYPE_PRECISION (double_type_node
))
151 i
= m
->double_built_in
;
152 else if (precision
== TYPE_PRECISION (long_double_type_node
))
153 i
= m
->long_double_built_in
;
154 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m
->real16_decl
;
161 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
169 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
171 if (gfc_real_kinds
[i
].c_float128
)
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t
*m
;
176 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
179 return m
->real16_decl
;
182 return builtin_decl_for_precision (double_built_in
,
183 gfc_real_kinds
[i
].mode_precision
);
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
193 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
194 tree
*argarray
, int nargs
)
196 gfc_actual_arglist
*actual
;
198 gfc_intrinsic_arg
*formal
;
202 formal
= expr
->value
.function
.isym
->formal
;
203 actual
= expr
->value
.function
.actual
;
205 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
206 actual
= actual
->next
,
207 formal
= formal
? formal
->next
: NULL
)
211 /* Skip omitted optional arguments. */
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse
, se
);
222 if (e
->ts
.type
== BT_CHARACTER
)
224 gfc_conv_expr (&argse
, e
);
225 gfc_conv_string_parameter (&argse
);
226 argarray
[curr_arg
++] = argse
.string_length
;
227 gcc_assert (curr_arg
< nargs
);
230 gfc_conv_expr_val (&argse
, e
);
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e
->expr_type
== EXPR_VARIABLE
235 && e
->symtree
->n
.sym
->attr
.optional
238 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
240 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
241 gfc_add_block_to_block (&se
->post
, &argse
.post
);
242 argarray
[curr_arg
] = argse
.expr
;
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
250 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
253 gfc_actual_arglist
*actual
;
255 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
260 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
274 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
280 nargs
= gfc_intrinsic_argument_list_length (expr
);
281 args
= XALLOCAVEC (tree
, nargs
);
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type
= gfc_typenode_for_spec (&expr
->ts
);
287 gcc_assert (expr
->value
.function
.actual
->expr
);
288 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
290 /* Conversion between character kinds involves a call to a library
292 if (expr
->ts
.type
== BT_CHARACTER
)
294 tree fndecl
, var
, addr
, tmp
;
296 if (expr
->ts
.kind
== 1
297 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
298 fndecl
= gfor_fndecl_convert_char4_to_char1
;
299 else if (expr
->ts
.kind
== 4
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
301 fndecl
= gfor_fndecl_convert_char1_to_char4
;
305 /* Create the variable storing the converted value. */
306 type
= gfc_get_pchar_type (expr
->ts
.kind
);
307 var
= gfc_create_var (type
, "str");
308 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs
>= 2);
312 tmp
= build_call_expr_loc (input_location
,
313 fndecl
, 3, addr
, args
[0], args
[1]);
314 gfc_add_expr_to_block (&se
->pre
, tmp
);
316 /* Free the temporary afterwards. */
317 tmp
= gfc_call_free (var
);
318 gfc_add_expr_to_block (&se
->post
, tmp
);
321 se
->string_length
= args
[0];
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
329 && expr
->ts
.type
!= BT_COMPLEX
)
333 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
334 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
338 se
->expr
= convert (type
, args
[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
354 argtype
= TREE_TYPE (arg
);
355 arg
= gfc_evaluate_now (arg
, pblock
);
357 intval
= convert (type
, arg
);
358 intval
= gfc_evaluate_now (intval
, pblock
);
360 tmp
= convert (argtype
, intval
);
361 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
362 logical_type_node
, tmp
, arg
);
364 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
365 intval
, build_int_cst (type
, 1));
366 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg
, tree restype
)
378 int argprec
, resprec
;
380 argtype
= TREE_TYPE (arg
);
381 argprec
= TYPE_PRECISION (argtype
);
382 resprec
= TYPE_PRECISION (restype
);
384 /* Depending on the type of the result, choose the int intrinsic
385 (iround, available only as a builtin, therefore cannot use it for
386 __float128), long int intrinsic (lround family) or long long
387 intrinsic (llround). We might also need to convert the result
389 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
390 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
391 else if (resprec
<= LONG_TYPE_SIZE
)
392 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
393 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
394 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
398 return fold_convert (restype
, build_call_expr_loc (input_location
,
403 /* Convert a real to an integer using a specific rounding mode.
404 Ideally we would just build the corresponding GENERIC node,
405 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
408 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
409 enum rounding_mode op
)
414 return build_fixbound_expr (pblock
, arg
, type
, 0);
417 return build_fixbound_expr (pblock
, arg
, type
, 1);
420 return build_round_expr (arg
, type
);
423 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
431 /* Round a real value using the specified rounding mode.
432 We use a temporary integer of that same kind size as the result.
433 Values larger than those that can be represented by this kind are
434 unchanged, as they will not be accurate enough to represent the
436 huge = HUGE (KIND (a))
437 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
441 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
453 kind
= expr
->ts
.kind
;
454 nargs
= gfc_intrinsic_argument_list_length (expr
);
457 /* We have builtin functions for some cases. */
461 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
465 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
472 /* Evaluate the argument. */
473 gcc_assert (expr
->value
.function
.actual
->expr
);
474 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
476 /* Use a builtin function if one exists. */
477 if (decl
!= NULL_TREE
)
479 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
483 /* This code is probably redundant, but we'll keep it lying around just
485 type
= gfc_typenode_for_spec (&expr
->ts
);
486 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
488 /* Test if the value is too large to handle sensibly. */
489 gfc_set_model_kind (kind
);
491 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
492 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
493 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
494 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, arg
[0],
497 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
498 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
499 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, arg
[0],
501 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, logical_type_node
,
503 itype
= gfc_get_int_type (kind
);
505 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
506 tmp
= convert (type
, tmp
);
507 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
513 /* Convert to an integer using the specified rounding mode. */
516 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
522 nargs
= gfc_intrinsic_argument_list_length (expr
);
523 args
= XALLOCAVEC (tree
, nargs
);
525 /* Evaluate the argument, we process all arguments even though we only
526 use the first one for code generation purposes. */
527 type
= gfc_typenode_for_spec (&expr
->ts
);
528 gcc_assert (expr
->value
.function
.actual
->expr
);
529 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
531 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
533 /* Conversion to a different integer kind. */
534 se
->expr
= convert (type
, args
[0]);
538 /* Conversion from complex to non-complex involves taking the real
539 component of the value. */
540 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
541 && expr
->ts
.type
!= BT_COMPLEX
)
545 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
546 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
550 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
555 /* Get the imaginary component of a value. */
558 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
562 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
563 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
564 TREE_TYPE (TREE_TYPE (arg
)), arg
);
568 /* Get the complex conjugate of a value. */
571 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
575 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
576 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
582 define_quad_builtin (const char *name
, tree type
, bool is_const
)
585 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
588 /* Mark the decl as external. */
589 DECL_EXTERNAL (fndecl
) = 1;
590 TREE_PUBLIC (fndecl
) = 1;
592 /* Mark it __attribute__((const)). */
593 TREE_READONLY (fndecl
) = is_const
;
595 rest_of_decl_compilation (fndecl
, 1, 0);
600 /* Add SIMD attribute for FNDECL built-in if the built-in
601 name is in VECTORIZED_BUILTINS. */
604 add_simd_flag_for_built_in (tree fndecl
)
606 if (gfc_vectorized_builtins
== NULL
607 || fndecl
== NULL_TREE
)
610 const char *name
= IDENTIFIER_POINTER (DECL_NAME (fndecl
));
611 int *clauses
= gfc_vectorized_builtins
->get (name
);
614 for (unsigned i
= 0; i
< 3; i
++)
615 if (*clauses
& (1 << i
))
617 gfc_simd_clause simd_type
= (gfc_simd_clause
)*clauses
;
618 tree omp_clause
= NULL_TREE
;
619 if (simd_type
== SIMD_NONE
)
620 ; /* No SIMD clause. */
624 = (simd_type
== SIMD_INBRANCH
625 ? OMP_CLAUSE_INBRANCH
: OMP_CLAUSE_NOTINBRANCH
);
626 omp_clause
= build_omp_clause (UNKNOWN_LOCATION
, code
);
627 omp_clause
= build_tree_list (NULL_TREE
, omp_clause
);
630 DECL_ATTRIBUTES (fndecl
)
631 = tree_cons (get_identifier ("omp declare simd"), omp_clause
,
632 DECL_ATTRIBUTES (fndecl
));
637 /* Set SIMD attribute to all built-in functions that are mentioned
638 in gfc_vectorized_builtins vector. */
641 gfc_adjust_builtins (void)
643 gfc_intrinsic_map_t
*m
;
644 for (m
= gfc_intrinsic_map
;
645 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
647 add_simd_flag_for_built_in (m
->real4_decl
);
648 add_simd_flag_for_built_in (m
->complex4_decl
);
649 add_simd_flag_for_built_in (m
->real8_decl
);
650 add_simd_flag_for_built_in (m
->complex8_decl
);
651 add_simd_flag_for_built_in (m
->real10_decl
);
652 add_simd_flag_for_built_in (m
->complex10_decl
);
653 add_simd_flag_for_built_in (m
->real16_decl
);
654 add_simd_flag_for_built_in (m
->complex16_decl
);
655 add_simd_flag_for_built_in (m
->real16_decl
);
656 add_simd_flag_for_built_in (m
->complex16_decl
);
659 /* Release all strings. */
660 if (gfc_vectorized_builtins
!= NULL
)
662 for (hash_map
<nofree_string_hash
, int>::iterator it
663 = gfc_vectorized_builtins
->begin ();
664 it
!= gfc_vectorized_builtins
->end (); ++it
)
665 free (CONST_CAST (char *, (*it
).first
));
667 delete gfc_vectorized_builtins
;
668 gfc_vectorized_builtins
= NULL
;
672 /* Initialize function decls for library functions. The external functions
673 are created as required. Builtin functions are added here. */
676 gfc_build_intrinsic_lib_fndecls (void)
678 gfc_intrinsic_map_t
*m
;
679 tree quad_decls
[END_BUILTINS
+ 1];
681 if (gfc_real16_is_float128
)
683 /* If we have soft-float types, we create the decls for their
684 C99-like library functions. For now, we only handle __float128
685 q-suffixed functions. */
687 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
688 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
690 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
692 type
= gfc_float128_type_node
;
693 complex_type
= gfc_complex_float128_type_node
;
694 /* type (*) (type) */
695 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
697 func_iround
= build_function_type_list (integer_type_node
,
699 /* long (*) (type) */
700 func_lround
= build_function_type_list (long_integer_type_node
,
702 /* long long (*) (type) */
703 func_llround
= build_function_type_list (long_long_integer_type_node
,
705 /* type (*) (type, type) */
706 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
707 /* type (*) (type, &int) */
709 = build_function_type_list (type
,
711 build_pointer_type (integer_type_node
),
713 /* type (*) (type, int) */
714 func_scalbn
= build_function_type_list (type
,
715 type
, integer_type_node
, NULL_TREE
);
716 /* type (*) (complex type) */
717 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
718 /* complex type (*) (complex type, complex type) */
720 = build_function_type_list (complex_type
,
721 complex_type
, complex_type
, NULL_TREE
);
723 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
724 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
725 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
727 /* Only these built-ins are actually needed here. These are used directly
728 from the code, when calling builtin_decl_for_precision() or
729 builtin_decl_for_float_type(). The others are all constructed by
730 gfc_get_intrinsic_lib_fndecl(). */
731 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
732 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
734 #include "mathbuiltins.def"
738 #undef DEFINE_MATH_BUILTIN
739 #undef DEFINE_MATH_BUILTIN_C
741 /* There is one built-in we defined manually, because it gets called
742 with builtin_decl_for_precision() or builtin_decl_for_float_type()
743 even though it is not an OTHER_BUILTIN: it is SQRT. */
744 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
748 /* Add GCC builtin functions. */
749 for (m
= gfc_intrinsic_map
;
750 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
752 if (m
->float_built_in
!= END_BUILTINS
)
753 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
754 if (m
->complex_float_built_in
!= END_BUILTINS
)
755 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
756 if (m
->double_built_in
!= END_BUILTINS
)
757 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
758 if (m
->complex_double_built_in
!= END_BUILTINS
)
759 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
761 /* If real(kind=10) exists, it is always long double. */
762 if (m
->long_double_built_in
!= END_BUILTINS
)
763 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
764 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
766 = builtin_decl_explicit (m
->complex_long_double_built_in
);
768 if (!gfc_real16_is_float128
)
770 if (m
->long_double_built_in
!= END_BUILTINS
)
771 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
772 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
774 = builtin_decl_explicit (m
->complex_long_double_built_in
);
776 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
778 /* Quad-precision function calls are constructed when first
779 needed by builtin_decl_for_precision(), except for those
780 that will be used directly (define by OTHER_BUILTIN). */
781 m
->real16_decl
= quad_decls
[m
->double_built_in
];
783 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
785 /* Same thing for the complex ones. */
786 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
792 /* Create a fndecl for a simple intrinsic library function. */
795 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
798 vec
<tree
, va_gc
> *argtypes
;
800 gfc_actual_arglist
*actual
;
803 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
806 if (ts
->type
== BT_REAL
)
811 pdecl
= &m
->real4_decl
;
814 pdecl
= &m
->real8_decl
;
817 pdecl
= &m
->real10_decl
;
820 pdecl
= &m
->real16_decl
;
826 else if (ts
->type
== BT_COMPLEX
)
828 gcc_assert (m
->complex_available
);
833 pdecl
= &m
->complex4_decl
;
836 pdecl
= &m
->complex8_decl
;
839 pdecl
= &m
->complex10_decl
;
842 pdecl
= &m
->complex16_decl
;
856 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
857 if (gfc_real_kinds
[n
].c_float
)
858 snprintf (name
, sizeof (name
), "%s%s%s",
859 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
860 else if (gfc_real_kinds
[n
].c_double
)
861 snprintf (name
, sizeof (name
), "%s%s",
862 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
863 else if (gfc_real_kinds
[n
].c_long_double
)
864 snprintf (name
, sizeof (name
), "%s%s%s",
865 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
866 else if (gfc_real_kinds
[n
].c_float128
)
867 snprintf (name
, sizeof (name
), "%s%s%s",
868 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
874 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
875 ts
->type
== BT_COMPLEX
? 'c' : 'r',
880 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
882 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
883 vec_safe_push (argtypes
, type
);
885 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
886 fndecl
= build_decl (input_location
,
887 FUNCTION_DECL
, get_identifier (name
), type
);
889 /* Mark the decl as external. */
890 DECL_EXTERNAL (fndecl
) = 1;
891 TREE_PUBLIC (fndecl
) = 1;
893 /* Mark it __attribute__((const)), if possible. */
894 TREE_READONLY (fndecl
) = m
->is_constant
;
896 rest_of_decl_compilation (fndecl
, 1, 0);
903 /* Convert an intrinsic function into an external or builtin call. */
906 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
908 gfc_intrinsic_map_t
*m
;
912 unsigned int num_args
;
915 id
= expr
->value
.function
.isym
->id
;
916 /* Find the entry for this function. */
917 for (m
= gfc_intrinsic_map
;
918 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
924 if (m
->id
== GFC_ISYM_NONE
)
926 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
927 expr
->value
.function
.name
, id
);
930 /* Get the decl and generate the call. */
931 num_args
= gfc_intrinsic_argument_list_length (expr
);
932 args
= XALLOCAVEC (tree
, num_args
);
934 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
935 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
936 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
938 fndecl
= build_addr (fndecl
);
939 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
943 /* If bounds-checking is enabled, create code to verify at runtime that the
944 string lengths for both expressions are the same (needed for e.g. MERGE).
945 If bounds-checking is not enabled, does nothing. */
948 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
949 tree a
, tree b
, stmtblock_t
* target
)
954 /* If bounds-checking is disabled, do nothing. */
955 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
958 /* Compare the two string lengths. */
959 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, a
, b
);
961 /* Output the runtime-check. */
962 name
= gfc_build_cstring_const (intr_name
);
963 name
= gfc_build_addr_expr (pchar_type_node
, name
);
964 gfc_trans_runtime_check (true, false, cond
, target
, where
,
965 "Unequal character lengths (%ld/%ld) in %s",
966 fold_convert (long_integer_type_node
, a
),
967 fold_convert (long_integer_type_node
, b
), name
);
971 /* The EXPONENT(X) intrinsic function is translated into
973 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
974 so that if X is a NaN or infinity, the result is HUGE(0).
978 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
980 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
983 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
984 expr
->value
.function
.actual
->expr
->ts
.kind
);
986 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
987 arg
= gfc_evaluate_now (arg
, &se
->pre
);
989 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
990 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
991 cond
= build_call_expr_loc (input_location
,
992 builtin_decl_explicit (BUILT_IN_ISFINITE
),
995 res
= gfc_create_var (integer_type_node
, NULL
);
996 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
997 gfc_build_addr_expr (NULL_TREE
, res
));
998 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
1000 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
1003 type
= gfc_typenode_for_spec (&expr
->ts
);
1004 se
->expr
= fold_convert (type
, se
->expr
);
1008 /* Fill in the following structure
1009 struct caf_vector_t {
1010 size_t nvec; // size of the vector
1017 ptrdiff_t lower_bound;
1018 ptrdiff_t upper_bound;
1025 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
1026 tree lower
, tree upper
, tree stride
,
1027 tree vector
, int kind
, tree nvec
)
1029 tree field
, type
, tmp
;
1031 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
1032 type
= TREE_TYPE (desc
);
1034 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1035 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1036 desc
, field
, NULL_TREE
);
1037 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
1040 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1041 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1042 desc
, field
, NULL_TREE
);
1043 type
= TREE_TYPE (desc
);
1045 /* Access the inner struct. */
1046 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
1047 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1048 desc
, field
, NULL_TREE
);
1049 type
= TREE_TYPE (desc
);
1051 if (vector
!= NULL_TREE
)
1053 /* Set vector and kind. */
1054 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1055 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1056 desc
, field
, NULL_TREE
);
1057 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
1058 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1059 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1060 desc
, field
, NULL_TREE
);
1061 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
1065 /* Set dim.lower/upper/stride. */
1066 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1067 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1068 desc
, field
, NULL_TREE
);
1069 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1071 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1072 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1073 desc
, field
, NULL_TREE
);
1074 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1076 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1077 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1078 desc
, field
, NULL_TREE
);
1079 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1085 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1088 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1089 tree lbound
, ubound
, tmp
;
1092 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1094 for (i
= 0; i
< ar
->dimen
; i
++)
1095 switch (ar
->dimen_type
[i
])
1100 gfc_init_se (&argse
, NULL
);
1101 gfc_conv_expr (&argse
, ar
->end
[i
]);
1102 gfc_add_block_to_block (block
, &argse
.pre
);
1103 upper
= gfc_evaluate_now (argse
.expr
, block
);
1106 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1109 gfc_init_se (&argse
, NULL
);
1110 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1111 gfc_add_block_to_block (block
, &argse
.pre
);
1112 stride
= gfc_evaluate_now (argse
.expr
, block
);
1115 stride
= gfc_index_one_node
;
1121 gfc_init_se (&argse
, NULL
);
1122 gfc_conv_expr (&argse
, ar
->start
[i
]);
1123 gfc_add_block_to_block (block
, &argse
.pre
);
1124 lower
= gfc_evaluate_now (argse
.expr
, block
);
1127 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1128 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1131 stride
= gfc_index_one_node
;
1134 nvec
= size_zero_node
;
1135 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1140 gfc_init_se (&argse
, NULL
);
1141 argse
.descriptor_only
= 1;
1142 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1143 gfc_add_block_to_block (block
, &argse
.pre
);
1144 vector
= argse
.expr
;
1145 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1146 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1147 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1148 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1149 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1150 TREE_TYPE (nvec
), nvec
, tmp
);
1151 lower
= gfc_index_zero_node
;
1152 upper
= gfc_index_zero_node
;
1153 stride
= gfc_index_zero_node
;
1154 vector
= gfc_conv_descriptor_data_get (vector
);
1155 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1156 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1161 return gfc_build_addr_expr (NULL_TREE
, var
);
1166 compute_component_offset (tree field
, tree type
)
1169 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1170 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1172 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1173 DECL_FIELD_BIT_OFFSET (field
),
1175 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1178 return DECL_FIELD_OFFSET (field
);
1183 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1185 gfc_ref
*ref
= expr
->ref
, *last_comp_ref
;
1186 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1187 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1188 start
, end
, stride
, vector
, nvec
;
1190 bool ref_static_array
= false;
1191 tree last_component_ref_tree
= NULL_TREE
;
1196 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1197 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
1198 && !expr
->symtree
->n
.sym
->attr
.pointer
;
1201 /* Prevent uninit-warning. */
1202 reference_type
= NULL_TREE
;
1204 /* Skip refs upto the first coarray-ref. */
1205 last_comp_ref
= NULL
;
1206 while (ref
&& (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
== 0))
1208 /* Remember the type of components skipped. */
1209 if (ref
->type
== REF_COMPONENT
)
1210 last_comp_ref
= ref
;
1213 /* When a component was skipped, get the type information of the last
1214 component ref, else get the type from the symbol. */
1217 last_type
= gfc_typenode_for_spec (&last_comp_ref
->u
.c
.component
->ts
);
1218 last_type_n
= last_comp_ref
->u
.c
.component
->ts
.type
;
1222 last_type
= gfc_typenode_for_spec (&expr
->symtree
->n
.sym
->ts
);
1223 last_type_n
= expr
->symtree
->n
.sym
->ts
.type
;
1228 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0
1229 && ref
->u
.ar
.dimen
== 0)
1231 /* Skip pure coindexes. */
1235 tmp
= gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1236 reference_type
= TREE_TYPE (tmp
);
1238 if (caf_ref
== NULL_TREE
)
1241 /* Construct the chain of refs. */
1242 if (prev_caf_ref
!= NULL_TREE
)
1244 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1245 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1246 TREE_TYPE (field
), prev_caf_ref
, field
,
1248 gfc_add_modify (block
, tmp2
, gfc_build_addr_expr (TREE_TYPE (field
),
1256 last_type
= gfc_typenode_for_spec (&ref
->u
.c
.component
->ts
);
1257 last_type_n
= ref
->u
.c
.component
->ts
.type
;
1258 /* Set the type of the ref. */
1259 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1260 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1261 TREE_TYPE (field
), prev_caf_ref
, field
,
1263 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1264 GFC_CAF_REF_COMPONENT
));
1266 /* Ref the c 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
,
1271 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 0);
1272 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1273 TREE_TYPE (field
), tmp
, field
,
1276 /* Set the offset. */
1277 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1278 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1279 TREE_TYPE (field
), inner_struct
, field
,
1281 /* Computing the offset is somewhat harder. The bit_offset has to be
1282 taken into account. When the bit_offset in the field_decl is non-
1283 null, divide it by the bitsize_unit and add it to the regular
1285 tmp2
= compute_component_offset (ref
->u
.c
.component
->backend_decl
,
1287 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1289 /* Set caf_token_offset. */
1290 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 1);
1291 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1292 TREE_TYPE (field
), inner_struct
, field
,
1294 if ((ref
->u
.c
.component
->attr
.allocatable
1295 || ref
->u
.c
.component
->attr
.pointer
)
1296 && ref
->u
.c
.component
->attr
.dimension
)
1298 tree arr_desc_token_offset
;
1299 /* Get the token field from the descriptor. */
1300 arr_desc_token_offset
= TREE_OPERAND (
1301 gfc_conv_descriptor_token (ref
->u
.c
.component
->backend_decl
), 1);
1302 arr_desc_token_offset
1303 = compute_component_offset (arr_desc_token_offset
,
1305 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
,
1306 TREE_TYPE (tmp2
), tmp2
,
1307 arr_desc_token_offset
);
1309 else if (ref
->u
.c
.component
->caf_token
)
1310 tmp2
= compute_component_offset (ref
->u
.c
.component
->caf_token
,
1313 tmp2
= integer_zero_node
;
1314 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1316 /* Remember whether this ref was to a non-allocatable/non-pointer
1317 component so the next array ref can be tailored correctly. */
1318 ref_static_array
= !ref
->u
.c
.component
->attr
.allocatable
1319 && !ref
->u
.c
.component
->attr
.pointer
;
1320 last_component_ref_tree
= ref_static_array
1321 ? ref
->u
.c
.component
->backend_decl
: NULL_TREE
;
1324 if (ref_static_array
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
)
1325 ref_static_array
= false;
1326 /* Set the type of the ref. */
1327 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1328 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1329 TREE_TYPE (field
), prev_caf_ref
, field
,
1331 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1333 ? GFC_CAF_REF_STATIC_ARRAY
1334 : GFC_CAF_REF_ARRAY
));
1336 /* Ref the a in union u. */
1337 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1338 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1339 TREE_TYPE (field
), prev_caf_ref
, field
,
1341 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 1);
1342 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1343 TREE_TYPE (field
), tmp
, field
,
1346 /* Set the static_array_type in a for static arrays. */
1347 if (ref_static_array
)
1349 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)),
1351 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1352 TREE_TYPE (field
), inner_struct
, field
,
1354 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (tmp
),
1357 /* Ref the mode in the inner_struct. */
1358 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1359 mode
= fold_build3_loc (input_location
, COMPONENT_REF
,
1360 TREE_TYPE (field
), inner_struct
, field
,
1362 /* Ref the dim in the inner_struct. */
1363 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 2);
1364 dim_array
= fold_build3_loc (input_location
, COMPONENT_REF
,
1365 TREE_TYPE (field
), inner_struct
, field
,
1367 for (i
= 0; i
< ref
->u
.ar
.dimen
; ++i
)
1370 dim
= gfc_build_array_ref (dim_array
, gfc_rank_cst
[i
], NULL_TREE
);
1371 dim_type
= TREE_TYPE (dim
);
1372 mode_rhs
= start
= end
= stride
= NULL_TREE
;
1373 switch (ref
->u
.ar
.dimen_type
[i
])
1376 if (ref
->u
.ar
.end
[i
])
1378 gfc_init_se (&se
, NULL
);
1379 gfc_conv_expr (&se
, ref
->u
.ar
.end
[i
]);
1380 gfc_add_block_to_block (block
, &se
.pre
);
1381 if (ref_static_array
)
1383 /* Make the index zero-based, when reffing a static
1386 gfc_init_se (&se
, NULL
);
1387 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1388 gfc_add_block_to_block (block
, &se
.pre
);
1389 se
.expr
= fold_build2 (MINUS_EXPR
,
1390 gfc_array_index_type
,
1392 gfc_array_index_type
,
1395 end
= gfc_evaluate_now (fold_convert (
1396 gfc_array_index_type
,
1400 else if (ref_static_array
)
1401 end
= fold_build2 (MINUS_EXPR
,
1402 gfc_array_index_type
,
1403 gfc_conv_array_ubound (
1404 last_component_ref_tree
, i
),
1405 gfc_conv_array_lbound (
1406 last_component_ref_tree
, i
));
1410 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1411 GFC_CAF_ARR_REF_OPEN_END
);
1413 if (ref
->u
.ar
.stride
[i
])
1415 gfc_init_se (&se
, NULL
);
1416 gfc_conv_expr (&se
, ref
->u
.ar
.stride
[i
]);
1417 gfc_add_block_to_block (block
, &se
.pre
);
1418 stride
= gfc_evaluate_now (fold_convert (
1419 gfc_array_index_type
,
1422 if (ref_static_array
)
1424 /* Make the index zero-based, when reffing a static
1426 stride
= fold_build2 (MULT_EXPR
,
1427 gfc_array_index_type
,
1428 gfc_conv_array_stride (
1429 last_component_ref_tree
,
1432 gcc_assert (end
!= NULL_TREE
);
1433 /* Multiply with the product of array's stride and
1434 the step of the ref to a virtual upper bound.
1435 We can not compute the actual upper bound here or
1436 the caflib would compute the extend
1438 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1439 end
, gfc_conv_array_stride (
1440 last_component_ref_tree
,
1442 end
= gfc_evaluate_now (end
, block
);
1443 stride
= gfc_evaluate_now (stride
, block
);
1446 else if (ref_static_array
)
1448 stride
= gfc_conv_array_stride (last_component_ref_tree
,
1450 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1452 end
= gfc_evaluate_now (end
, block
);
1455 /* Always set a ref stride of one to make caflib's
1457 stride
= gfc_index_one_node
;
1461 if (ref
->u
.ar
.start
[i
])
1463 gfc_init_se (&se
, NULL
);
1464 gfc_conv_expr (&se
, ref
->u
.ar
.start
[i
]);
1465 gfc_add_block_to_block (block
, &se
.pre
);
1466 if (ref_static_array
)
1468 /* Make the index zero-based, when reffing a static
1470 start
= fold_convert (gfc_array_index_type
, se
.expr
);
1471 gfc_init_se (&se
, NULL
);
1472 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1473 gfc_add_block_to_block (block
, &se
.pre
);
1474 se
.expr
= fold_build2 (MINUS_EXPR
,
1475 gfc_array_index_type
,
1476 start
, fold_convert (
1477 gfc_array_index_type
,
1479 /* Multiply with the stride. */
1480 se
.expr
= fold_build2 (MULT_EXPR
,
1481 gfc_array_index_type
,
1483 gfc_conv_array_stride (
1484 last_component_ref_tree
,
1487 start
= gfc_evaluate_now (fold_convert (
1488 gfc_array_index_type
,
1491 if (mode_rhs
== NULL_TREE
)
1492 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1493 ref
->u
.ar
.dimen_type
[i
]
1495 ? GFC_CAF_ARR_REF_SINGLE
1496 : GFC_CAF_ARR_REF_RANGE
);
1498 else if (ref_static_array
)
1500 start
= integer_zero_node
;
1501 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1502 ref
->u
.ar
.start
[i
] == NULL
1503 ? GFC_CAF_ARR_REF_FULL
1504 : GFC_CAF_ARR_REF_RANGE
);
1506 else if (end
== NULL_TREE
)
1507 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1508 GFC_CAF_ARR_REF_FULL
);
1510 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1511 GFC_CAF_ARR_REF_OPEN_START
);
1513 /* Ref the s in dim. */
1514 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 0);
1515 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1516 TREE_TYPE (field
), dim
, field
,
1519 /* Set start in s. */
1520 if (start
!= NULL_TREE
)
1522 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1524 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1525 TREE_TYPE (field
), tmp
, field
,
1527 gfc_add_modify (block
, tmp2
,
1528 fold_convert (TREE_TYPE (tmp2
), start
));
1532 if (end
!= NULL_TREE
)
1534 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1536 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1537 TREE_TYPE (field
), tmp
, field
,
1539 gfc_add_modify (block
, tmp2
,
1540 fold_convert (TREE_TYPE (tmp2
), end
));
1544 if (stride
!= NULL_TREE
)
1546 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1548 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1549 TREE_TYPE (field
), tmp
, field
,
1551 gfc_add_modify (block
, tmp2
,
1552 fold_convert (TREE_TYPE (tmp2
), stride
));
1556 /* TODO: In case of static array. */
1557 gcc_assert (!ref_static_array
);
1558 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1559 GFC_CAF_ARR_REF_VECTOR
);
1560 gfc_init_se (&se
, NULL
);
1561 se
.descriptor_only
= 1;
1562 gfc_conv_expr_descriptor (&se
, ref
->u
.ar
.start
[i
]);
1563 gfc_add_block_to_block (block
, &se
.pre
);
1565 tmp
= gfc_conv_descriptor_lbound_get (vector
,
1567 tmp2
= gfc_conv_descriptor_ubound_get (vector
,
1569 nvec
= gfc_conv_array_extent_dim (tmp
, tmp2
, NULL
);
1570 tmp
= gfc_conv_descriptor_stride_get (vector
,
1572 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1573 TREE_TYPE (nvec
), nvec
, tmp
);
1574 vector
= gfc_conv_descriptor_data_get (vector
);
1576 /* Ref the v in dim. */
1577 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 1);
1578 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1579 TREE_TYPE (field
), dim
, field
,
1582 /* Set vector in v. */
1583 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 0);
1584 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1585 TREE_TYPE (field
), tmp
, field
,
1587 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1590 /* Set nvec in v. */
1591 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 1);
1592 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1593 TREE_TYPE (field
), tmp
, field
,
1595 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1598 /* Set kind in v. */
1599 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 2);
1600 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1601 TREE_TYPE (field
), tmp
, field
,
1603 gfc_add_modify (block
, tmp2
, build_int_cst (integer_type_node
,
1604 ref
->u
.ar
.start
[i
]->ts
.kind
));
1609 /* Set the mode for dim i. */
1610 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1611 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
),
1615 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1616 if (i
< GFC_MAX_DIMENSIONS
)
1618 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1619 gfc_add_modify (block
, tmp
,
1620 build_int_cst (unsigned_char_type_node
,
1621 GFC_CAF_ARR_REF_NONE
));
1628 /* Set the size of the current type. */
1629 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 2);
1630 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1631 prev_caf_ref
, field
, NULL_TREE
);
1632 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1633 TYPE_SIZE_UNIT (last_type
)));
1638 if (prev_caf_ref
!= NULL_TREE
)
1640 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1641 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1642 prev_caf_ref
, field
, NULL_TREE
);
1643 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1644 null_pointer_node
));
1646 return caf_ref
!= NULL_TREE
? gfc_build_addr_expr (NULL_TREE
, caf_ref
)
1650 /* Get data from a remote coarray. */
1653 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1654 tree may_require_tmp
, bool may_realloc
,
1655 symbol_attribute
*caf_attr
)
1657 gfc_expr
*array_expr
, *tmp_stat
;
1659 tree caf_decl
, token
, offset
, image_index
, tmp
;
1660 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
1662 symbol_attribute caf_attr_store
;
1664 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1666 if (se
->ss
&& se
->ss
->info
->useflags
)
1668 /* Access the previously obtained result. */
1669 gfc_conv_tmp_array_ref (se
);
1673 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1674 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1675 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1677 if (caf_attr
== NULL
)
1679 caf_attr_store
= gfc_caf_attr (array_expr
);
1680 caf_attr
= &caf_attr_store
;
1686 vec
= null_pointer_node
;
1687 tmp_stat
= gfc_find_stat_co (expr
);
1692 gfc_init_se (&stat_se
, NULL
);
1693 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1694 stat
= stat_se
.expr
;
1695 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1696 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1699 stat
= null_pointer_node
;
1701 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1702 is reallocatable or the right-hand side has allocatable components. */
1703 if (caf_attr
->alloc_comp
|| caf_attr
->pointer_comp
|| may_realloc
)
1705 /* Get using caf_get_by_ref. */
1706 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, array_expr
);
1708 if (caf_reference
!= NULL_TREE
)
1710 if (lhs
== NULL_TREE
)
1712 if (array_expr
->ts
.type
== BT_CHARACTER
)
1713 gfc_init_se (&argse
, NULL
);
1714 if (array_expr
->rank
== 0)
1716 symbol_attribute attr
;
1717 gfc_clear_attr (&attr
);
1718 if (array_expr
->ts
.type
== BT_CHARACTER
)
1720 res_var
= gfc_conv_string_tmp (se
,
1721 build_pointer_type (type
),
1722 array_expr
->ts
.u
.cl
->backend_decl
);
1723 argse
.string_length
= array_expr
->ts
.u
.cl
->backend_decl
;
1726 res_var
= gfc_create_var (type
, "caf_res");
1727 dst_var
= gfc_conv_scalar_to_descriptor (se
, res_var
, attr
);
1728 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1732 /* Create temporary. */
1733 if (array_expr
->ts
.type
== BT_CHARACTER
)
1734 gfc_conv_expr_descriptor (&argse
, array_expr
);
1735 may_realloc
= gfc_trans_create_temp_array (&se
->pre
,
1742 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1743 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1746 tmp
= gfc_conv_descriptor_data_get (res_var
);
1747 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
,
1748 NULL_TREE
, NULL_TREE
,
1751 GFC_CAF_COARRAY_NOCOARRAY
);
1752 gfc_add_expr_to_block (&se
->post
, tmp
);
1757 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1758 if (lhs_kind
== NULL_TREE
)
1761 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1762 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1763 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1764 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1766 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1769 /* No overlap possible as we have generated a temporary. */
1770 if (lhs
== NULL_TREE
)
1771 may_require_tmp
= boolean_false_node
;
1773 /* It guarantees memory consistency within the same segment. */
1774 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1775 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1776 gfc_build_string_const (1, ""), NULL_TREE
,
1777 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1779 ASM_VOLATILE_P (tmp
) = 1;
1780 gfc_add_expr_to_block (&se
->pre
, tmp
);
1782 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1783 10, token
, image_index
, dst_var
,
1784 caf_reference
, lhs_kind
, kind
,
1786 may_realloc
? boolean_true_node
:
1788 stat
, build_int_cst (integer_type_node
,
1789 array_expr
->ts
.type
));
1791 gfc_add_expr_to_block (&se
->pre
, tmp
);
1794 gfc_advance_se_ss_chain (se
);
1797 if (array_expr
->ts
.type
== BT_CHARACTER
)
1798 se
->string_length
= argse
.string_length
;
1804 gfc_init_se (&argse
, NULL
);
1805 if (array_expr
->rank
== 0)
1807 symbol_attribute attr
;
1809 gfc_clear_attr (&attr
);
1810 gfc_conv_expr (&argse
, array_expr
);
1812 if (lhs
== NULL_TREE
)
1814 gfc_clear_attr (&attr
);
1815 if (array_expr
->ts
.type
== BT_CHARACTER
)
1816 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1817 argse
.string_length
);
1819 res_var
= gfc_create_var (type
, "caf_res");
1820 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1821 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1823 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1824 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1828 /* If has_vector, pass descriptor for whole array and the
1829 vector bounds separately. */
1830 gfc_array_ref
*ar
, ar2
;
1831 bool has_vector
= false;
1833 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1836 ar
= gfc_find_array_ref (expr
);
1838 memset (ar
, '\0', sizeof (*ar
));
1842 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1843 gfc_conv_expr_descriptor (&argse
, array_expr
);
1844 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1845 has the wrong type if component references are done. */
1846 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1847 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1852 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1856 if (lhs
== NULL_TREE
)
1858 /* Create temporary. */
1859 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1860 if (se
->loop
->to
[n
] == NULL_TREE
)
1862 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1864 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1867 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1868 NULL_TREE
, false, true, false,
1869 &array_expr
->where
);
1870 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1871 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1873 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1876 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1877 if (lhs_kind
== NULL_TREE
)
1880 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1881 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1883 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1884 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1885 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1886 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1887 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1890 /* No overlap possible as we have generated a temporary. */
1891 if (lhs
== NULL_TREE
)
1892 may_require_tmp
= boolean_false_node
;
1894 /* It guarantees memory consistency within the same segment. */
1895 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1896 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1897 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1898 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1899 ASM_VOLATILE_P (tmp
) = 1;
1900 gfc_add_expr_to_block (&se
->pre
, tmp
);
1902 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1903 token
, offset
, image_index
, argse
.expr
, vec
,
1904 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1906 gfc_add_expr_to_block (&se
->pre
, tmp
);
1909 gfc_advance_se_ss_chain (se
);
1912 if (array_expr
->ts
.type
== BT_CHARACTER
)
1913 se
->string_length
= argse
.string_length
;
1917 /* Send data to a remote coarray. */
1920 conv_caf_send (gfc_code
*code
) {
1921 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
, *tmp_team
;
1922 gfc_se lhs_se
, rhs_se
;
1924 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1925 tree may_require_tmp
, src_stat
, dst_stat
, dst_team
;
1926 tree lhs_type
= NULL_TREE
;
1927 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1928 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1930 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1932 lhs_expr
= code
->ext
.actual
->expr
;
1933 rhs_expr
= code
->ext
.actual
->next
->expr
;
1934 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, true) == 0
1935 ? boolean_false_node
: boolean_true_node
;
1936 gfc_init_block (&block
);
1938 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1939 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1940 src_stat
= dst_stat
= null_pointer_node
;
1941 dst_team
= null_pointer_node
;
1944 gfc_init_se (&lhs_se
, NULL
);
1945 if (lhs_expr
->rank
== 0)
1947 if (lhs_expr
->ts
.type
== BT_CHARACTER
&& lhs_expr
->ts
.deferred
)
1949 lhs_se
.expr
= gfc_get_tree_for_caf_expr (lhs_expr
);
1950 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1954 symbol_attribute attr
;
1955 gfc_clear_attr (&attr
);
1956 gfc_conv_expr (&lhs_se
, lhs_expr
);
1957 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1958 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
,
1960 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1963 else if ((lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
1964 && lhs_caf_attr
.codimension
)
1966 lhs_se
.want_pointer
= 1;
1967 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1968 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1969 has the wrong type if component references are done. */
1970 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1971 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1972 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1973 gfc_get_dtype_rank_type (
1974 gfc_has_vector_subscript (lhs_expr
)
1975 ? gfc_find_array_ref (lhs_expr
)->dimen
1981 bool has_vector
= gfc_has_vector_subscript (lhs_expr
);
1983 if (gfc_is_coindexed (lhs_expr
) || !has_vector
)
1985 /* If has_vector, pass descriptor for whole array and the
1986 vector bounds separately. */
1987 gfc_array_ref
*ar
, ar2
;
1988 bool has_tmp_lhs_array
= false;
1991 has_tmp_lhs_array
= true;
1992 ar
= gfc_find_array_ref (lhs_expr
);
1994 memset (ar
, '\0', sizeof (*ar
));
1998 lhs_se
.want_pointer
= 1;
1999 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
2000 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
2001 that has the wrong type if component references are done. */
2002 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
2003 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
2004 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2005 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2008 if (has_tmp_lhs_array
)
2010 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
2016 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
2017 indexed array expression. This is rewritten to:
2019 tmp_array = arr2[...]
2020 arr1 ([...]) = tmp_array
2022 because using the standard gfc_conv_expr (lhs_expr) did the
2023 assignment with lhs and rhs exchanged. */
2025 gfc_ss
*lss_for_tmparray
, *lss_real
;
2029 tree tmparr_desc
, src
;
2030 tree index
= gfc_index_zero_node
;
2031 tree stride
= gfc_index_zero_node
;
2034 /* Walk both sides of the assignment, once to get the shape of the
2035 temporary array to create right. */
2036 lss_for_tmparray
= gfc_walk_expr (lhs_expr
);
2037 /* And a second time to be able to create an assignment of the
2038 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
2039 the tree in the descriptor with the one for the temporary
2041 lss_real
= gfc_walk_expr (lhs_expr
);
2042 gfc_init_loopinfo (&loop
);
2043 gfc_add_ss_to_loop (&loop
, lss_for_tmparray
);
2044 gfc_add_ss_to_loop (&loop
, lss_real
);
2045 gfc_conv_ss_startstride (&loop
);
2046 gfc_conv_loop_setup (&loop
, &lhs_expr
->where
);
2047 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
2048 gfc_trans_create_temp_array (&lhs_se
.pre
, &lhs_se
.post
,
2049 lss_for_tmparray
, lhs_type
, NULL_TREE
,
2052 tmparr_desc
= lss_for_tmparray
->info
->data
.array
.descriptor
;
2053 gfc_start_scalarized_body (&loop
, &body
);
2054 gfc_init_se (&se
, NULL
);
2055 gfc_copy_loopinfo_to_se (&se
, &loop
);
2057 gfc_conv_expr (&se
, lhs_expr
);
2058 gfc_add_block_to_block (&body
, &se
.pre
);
2060 /* Walk over all indexes of the loop. */
2061 for (n
= loop
.dimen
- 1; n
> 0; --n
)
2063 tmp
= loop
.loopvar
[n
];
2064 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2065 gfc_array_index_type
, tmp
, loop
.from
[n
]);
2066 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2067 gfc_array_index_type
, tmp
, index
);
2069 stride
= fold_build2_loc (input_location
, MINUS_EXPR
,
2070 gfc_array_index_type
,
2071 loop
.to
[n
- 1], loop
.from
[n
- 1]);
2072 stride
= fold_build2_loc (input_location
, PLUS_EXPR
,
2073 gfc_array_index_type
,
2074 stride
, gfc_index_one_node
);
2076 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2077 gfc_array_index_type
, tmp
, stride
);
2080 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2081 gfc_array_index_type
,
2082 index
, loop
.from
[0]);
2084 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2085 gfc_array_index_type
,
2086 loop
.loopvar
[0], index
);
2088 src
= build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc
));
2089 src
= gfc_build_array_ref (src
, index
, NULL
);
2090 /* Now create the assignment of lhs_expr = tmp_array. */
2091 gfc_add_modify (&body
, se
.expr
, src
);
2092 gfc_add_block_to_block (&body
, &se
.post
);
2093 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, tmparr_desc
);
2094 gfc_trans_scalarizing_loops (&loop
, &body
);
2095 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2096 gfc_add_expr_to_block (&lhs_se
.post
, gfc_finish_block (&loop
.pre
));
2097 gfc_free_ss (lss_for_tmparray
);
2098 gfc_free_ss (lss_real
);
2102 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
2104 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2105 temporary and a loop. */
2106 if (!gfc_is_coindexed (lhs_expr
)
2107 && (!lhs_caf_attr
.codimension
2108 || !(lhs_expr
->rank
> 0
2109 && (lhs_caf_attr
.allocatable
|| lhs_caf_attr
.pointer
))))
2111 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
2112 gcc_assert (gfc_is_coindexed (rhs_expr
));
2113 gfc_init_se (&rhs_se
, NULL
);
2114 if (lhs_expr
->rank
== 0 && lhs_caf_attr
.allocatable
)
2117 gfc_init_se (&scal_se
, NULL
);
2118 scal_se
.want_pointer
= 1;
2119 gfc_conv_expr (&scal_se
, lhs_expr
);
2120 /* Ensure scalar on lhs is allocated. */
2121 gfc_add_block_to_block (&block
, &scal_se
.pre
);
2123 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
2125 gfc_typenode_for_spec (&lhs_expr
->ts
)),
2127 tmp
= fold_build2 (EQ_EXPR
, logical_type_node
, scal_se
.expr
,
2129 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2130 tmp
, gfc_finish_block (&scal_se
.pre
),
2131 build_empty_stmt (input_location
));
2132 gfc_add_expr_to_block (&block
, tmp
);
2135 lhs_may_realloc
= lhs_may_realloc
2136 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
2137 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2138 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
2139 may_require_tmp
, lhs_may_realloc
,
2141 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2142 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2143 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2144 return gfc_finish_block (&block
);
2147 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2149 /* Obtain token, offset and image index for the LHS. */
2150 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
2151 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2152 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2153 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
2155 if (lhs_caf_attr
.alloc_comp
)
2156 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
2159 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
2164 gfc_init_se (&rhs_se
, NULL
);
2165 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
2166 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2167 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
2168 if (rhs_expr
->rank
== 0)
2170 symbol_attribute attr
;
2171 gfc_clear_attr (&attr
);
2172 gfc_conv_expr (&rhs_se
, rhs_expr
);
2173 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
2174 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2176 else if ((rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2177 && rhs_caf_attr
.codimension
)
2180 rhs_se
.want_pointer
= 1;
2181 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2182 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2183 has the wrong type if component references are done. */
2184 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2185 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2186 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2187 gfc_get_dtype_rank_type (
2188 gfc_has_vector_subscript (rhs_expr
)
2189 ? gfc_find_array_ref (rhs_expr
)->dimen
2195 /* If has_vector, pass descriptor for whole array and the
2196 vector bounds separately. */
2197 gfc_array_ref
*ar
, ar2
;
2198 bool has_vector
= false;
2201 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2204 ar
= gfc_find_array_ref (rhs_expr
);
2206 memset (ar
, '\0', sizeof (*ar
));
2210 rhs_se
.want_pointer
= 1;
2211 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2212 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2213 has the wrong type if component references are done. */
2214 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2215 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2216 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2217 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2222 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2227 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2229 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2231 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2236 gfc_init_se (&stat_se
, NULL
);
2237 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2238 dst_stat
= stat_se
.expr
;
2239 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2240 gfc_add_block_to_block (&block
, &stat_se
.post
);
2243 tmp_team
= gfc_find_team_co (lhs_expr
);
2248 gfc_init_se (&team_se
, NULL
);
2249 gfc_conv_expr_reference (&team_se
, tmp_team
);
2250 dst_team
= team_se
.expr
;
2251 gfc_add_block_to_block (&block
, &team_se
.pre
);
2252 gfc_add_block_to_block (&block
, &team_se
.post
);
2255 if (!gfc_is_coindexed (rhs_expr
))
2257 if (lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
2259 tree reference
, dst_realloc
;
2260 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2261 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2262 : boolean_false_node
;
2263 tmp
= build_call_expr_loc (input_location
,
2264 gfor_fndecl_caf_send_by_ref
,
2265 10, token
, image_index
, rhs_se
.expr
,
2266 reference
, lhs_kind
, rhs_kind
,
2267 may_require_tmp
, dst_realloc
, src_stat
,
2268 build_int_cst (integer_type_node
,
2269 lhs_expr
->ts
.type
));
2272 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 11,
2273 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2274 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2275 may_require_tmp
, src_stat
, dst_team
);
2279 tree rhs_token
, rhs_offset
, rhs_image_index
;
2281 /* It guarantees memory consistency within the same segment. */
2282 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2283 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2284 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2285 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2286 ASM_VOLATILE_P (tmp
) = 1;
2287 gfc_add_expr_to_block (&block
, tmp
);
2289 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2290 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2291 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2292 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2294 if (rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2296 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2301 gfc_init_se (&stat_se
, NULL
);
2302 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2303 src_stat
= stat_se
.expr
;
2304 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2305 gfc_add_block_to_block (&block
, &stat_se
.post
);
2308 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2310 tree lhs_reference
, rhs_reference
;
2311 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2312 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2313 tmp
= build_call_expr_loc (input_location
,
2314 gfor_fndecl_caf_sendget_by_ref
, 13,
2315 token
, image_index
, lhs_reference
,
2316 rhs_token
, rhs_image_index
, rhs_reference
,
2317 lhs_kind
, rhs_kind
, may_require_tmp
,
2319 build_int_cst (integer_type_node
,
2321 build_int_cst (integer_type_node
,
2322 rhs_expr
->ts
.type
));
2326 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2328 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2329 14, token
, offset
, image_index
,
2330 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2331 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2332 rhs_kind
, may_require_tmp
, src_stat
);
2335 gfc_add_expr_to_block (&block
, tmp
);
2336 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2337 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2339 /* It guarantees memory consistency within the same segment. */
2340 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2341 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2342 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2343 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2344 ASM_VOLATILE_P (tmp
) = 1;
2345 gfc_add_expr_to_block (&block
, tmp
);
2347 return gfc_finish_block (&block
);
2352 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2355 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2356 lbound
, ubound
, extent
, ml
;
2359 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2361 if (expr
->value
.function
.actual
->expr
2362 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2363 distance
= expr
->value
.function
.actual
->expr
;
2365 /* The case -fcoarray=single is handled elsewhere. */
2366 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2368 /* Argument-free version: THIS_IMAGE(). */
2369 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2373 gfc_init_se (&argse
, NULL
);
2374 gfc_conv_expr_val (&argse
, distance
);
2375 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2376 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2377 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2380 tmp
= integer_zero_node
;
2381 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2383 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2388 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2390 type
= gfc_get_int_type (gfc_default_integer_kind
);
2391 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2392 rank
= expr
->value
.function
.actual
->expr
->rank
;
2394 /* Obtain the descriptor of the COARRAY. */
2395 gfc_init_se (&argse
, NULL
);
2396 argse
.want_coarray
= 1;
2397 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2398 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2399 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2404 /* Create an implicit second parameter from the loop variable. */
2405 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2406 gcc_assert (corank
> 0);
2407 gcc_assert (se
->loop
->dimen
== 1);
2408 gcc_assert (se
->ss
->info
->expr
== expr
);
2410 dim_arg
= se
->loop
->loopvar
[0];
2411 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2412 gfc_array_index_type
, dim_arg
,
2413 build_int_cst (TREE_TYPE (dim_arg
), 1));
2414 gfc_advance_se_ss_chain (se
);
2418 /* Use the passed DIM= argument. */
2419 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2420 gfc_init_se (&argse
, NULL
);
2421 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2422 gfc_array_index_type
);
2423 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2424 dim_arg
= argse
.expr
;
2426 if (INTEGER_CST_P (dim_arg
))
2428 if (wi::ltu_p (wi::to_wide (dim_arg
), 1)
2429 || wi::gtu_p (wi::to_wide (dim_arg
),
2430 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2431 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2432 "dimension index", expr
->value
.function
.isym
->name
,
2435 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2437 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2438 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2440 build_int_cst (TREE_TYPE (dim_arg
), 1));
2441 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2442 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2444 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2445 logical_type_node
, cond
, tmp
);
2446 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2451 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2452 one always has a dim_arg argument.
2454 m = this_image() - 1
2457 sub(1) = m + lcobound(corank)
2461 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2464 extent = gfc_extent(i)
2472 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2473 : m + lcobound(corank)
2476 /* this_image () - 1. */
2477 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2479 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2480 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2483 /* sub(1) = m + lcobound(corank). */
2484 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2485 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2487 lbound
= fold_convert (type
, lbound
);
2488 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2494 m
= gfc_create_var (type
, NULL
);
2495 ml
= gfc_create_var (type
, NULL
);
2496 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2497 min_var
= gfc_create_var (integer_type_node
, NULL
);
2499 /* m = this_image () - 1. */
2500 gfc_add_modify (&se
->pre
, m
, tmp
);
2502 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2503 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2504 fold_convert (integer_type_node
, dim_arg
),
2505 build_int_cst (integer_type_node
, rank
- 1));
2506 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2507 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2509 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2512 tmp
= build_int_cst (integer_type_node
, rank
);
2513 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2515 exit_label
= gfc_build_label_decl (NULL_TREE
);
2516 TREE_USED (exit_label
) = 1;
2519 gfc_init_block (&loop
);
2522 gfc_add_modify (&loop
, ml
, m
);
2525 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2526 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2527 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2528 extent
= fold_convert (type
, extent
);
2531 gfc_add_modify (&loop
, m
,
2532 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2535 /* Exit condition: if (i >= min_var) goto exit_label. */
2536 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, loop_var
,
2538 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2539 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2540 build_empty_stmt (input_location
));
2541 gfc_add_expr_to_block (&loop
, tmp
);
2543 /* Increment loop variable: i++. */
2544 gfc_add_modify (&loop
, loop_var
,
2545 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2547 build_int_cst (integer_type_node
, 1)));
2549 /* Making the loop... actually loop! */
2550 tmp
= gfc_finish_block (&loop
);
2551 tmp
= build1_v (LOOP_EXPR
, tmp
);
2552 gfc_add_expr_to_block (&se
->pre
, tmp
);
2554 /* The exit label. */
2555 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2556 gfc_add_expr_to_block (&se
->pre
, tmp
);
2558 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2559 : m + lcobound(corank) */
2561 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, dim_arg
,
2562 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2564 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2565 fold_build2_loc (input_location
, PLUS_EXPR
,
2566 gfc_array_index_type
, dim_arg
,
2567 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2568 lbound
= fold_convert (type
, lbound
);
2570 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2571 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2573 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2575 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2576 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2581 /* Convert a call to image_status. */
2584 conv_intrinsic_image_status (gfc_se
*se
, gfc_expr
*expr
)
2586 unsigned int num_args
;
2589 num_args
= gfc_intrinsic_argument_list_length (expr
);
2590 args
= XALLOCAVEC (tree
, num_args
);
2591 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2592 /* In args[0] the number of the image the status is desired for has to be
2595 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2598 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2599 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2600 fold_convert (integer_type_node
, arg
),
2602 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2603 tmp
, integer_zero_node
,
2604 build_int_cst (integer_type_node
,
2605 GFC_STAT_STOPPED_IMAGE
));
2607 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2608 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_image_status
, 2,
2609 args
[0], build_int_cst (integer_type_node
, -1));
2617 conv_intrinsic_team_number (gfc_se
*se
, gfc_expr
*expr
)
2619 unsigned int num_args
;
2623 num_args
= gfc_intrinsic_argument_list_length (expr
);
2624 args
= XALLOCAVEC (tree
, num_args
);
2625 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2628 GFC_FCOARRAY_SINGLE
&& expr
->value
.function
.actual
->expr
)
2632 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2633 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2634 fold_convert (integer_type_node
, arg
),
2636 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2637 tmp
, integer_zero_node
,
2638 build_int_cst (integer_type_node
,
2639 GFC_STAT_STOPPED_IMAGE
));
2641 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2643 // the value -1 represents that no team has been created yet
2644 tmp
= build_int_cst (integer_type_node
, -1);
2646 else if (flag_coarray
== GFC_FCOARRAY_LIB
&& expr
->value
.function
.actual
->expr
)
2647 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2648 args
[0], build_int_cst (integer_type_node
, -1));
2649 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2650 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2651 integer_zero_node
, build_int_cst (integer_type_node
, -1));
2660 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2662 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2664 gfc_se argse
, subse
;
2665 int rank
, corank
, codim
;
2667 type
= gfc_get_int_type (gfc_default_integer_kind
);
2668 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2669 rank
= expr
->value
.function
.actual
->expr
->rank
;
2671 /* Obtain the descriptor of the COARRAY. */
2672 gfc_init_se (&argse
, NULL
);
2673 argse
.want_coarray
= 1;
2674 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2675 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2676 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2679 /* Obtain a handle to the SUB argument. */
2680 gfc_init_se (&subse
, NULL
);
2681 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2682 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2683 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2684 subdesc
= build_fold_indirect_ref_loc (input_location
,
2685 gfc_conv_descriptor_data_get (subse
.expr
));
2687 /* Fortran 2008 does not require that the values remain in the cobounds,
2688 thus we need explicitly check this - and return 0 if they are exceeded. */
2690 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2691 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2692 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2693 fold_convert (gfc_array_index_type
, tmp
),
2696 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2698 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2699 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2700 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2701 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2702 fold_convert (gfc_array_index_type
, tmp
),
2704 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2705 logical_type_node
, invalid_bound
, cond
);
2706 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2707 fold_convert (gfc_array_index_type
, tmp
),
2709 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2710 logical_type_node
, invalid_bound
, cond
);
2713 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2715 /* See Fortran 2008, C.10 for the following algorithm. */
2717 /* coindex = sub(corank) - lcobound(n). */
2718 coindex
= fold_convert (gfc_array_index_type
,
2719 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2721 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2722 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2723 fold_convert (gfc_array_index_type
, coindex
),
2726 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2728 tree extent
, ubound
;
2730 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2731 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2732 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2733 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2735 /* coindex *= extent. */
2736 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2737 gfc_array_index_type
, coindex
, extent
);
2739 /* coindex += sub(codim). */
2740 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2741 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2742 gfc_array_index_type
, coindex
,
2743 fold_convert (gfc_array_index_type
, tmp
));
2745 /* coindex -= lbound(codim). */
2746 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2747 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2748 gfc_array_index_type
, coindex
, lbound
);
2751 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2752 fold_convert(type
, coindex
),
2753 build_int_cst (type
, 1));
2755 /* Return 0 if "coindex" exceeds num_images(). */
2757 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2758 num_images
= build_int_cst (type
, 1);
2761 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2763 build_int_cst (integer_type_node
, -1));
2764 num_images
= fold_convert (type
, tmp
);
2767 tmp
= gfc_create_var (type
, NULL
);
2768 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2770 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, tmp
,
2772 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
2774 fold_convert (logical_type_node
, invalid_bound
));
2775 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2776 build_int_cst (type
, 0), tmp
);
2780 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2782 tree tmp
, distance
, failed
;
2785 if (expr
->value
.function
.actual
->expr
)
2787 gfc_init_se (&argse
, NULL
);
2788 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2789 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2790 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2791 distance
= fold_convert (integer_type_node
, argse
.expr
);
2794 distance
= integer_zero_node
;
2796 if (expr
->value
.function
.actual
->next
->expr
)
2798 gfc_init_se (&argse
, NULL
);
2799 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2800 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2801 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2802 failed
= fold_convert (integer_type_node
, argse
.expr
);
2805 failed
= build_int_cst (integer_type_node
, -1);
2806 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2808 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2813 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2817 gfc_init_se (&argse
, NULL
);
2818 argse
.data_not_needed
= 1;
2819 argse
.descriptor_only
= 1;
2821 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2822 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2823 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2825 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2826 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2832 gfc_conv_intrinsic_is_contiguous (gfc_se
* se
, gfc_expr
* expr
)
2837 tree desc
, tmp
, stride
, extent
, cond
;
2842 arg
= expr
->value
.function
.actual
->expr
;
2844 if (arg
->ts
.type
== BT_CLASS
)
2845 gfc_add_class_array_ref (arg
);
2847 ss
= gfc_walk_expr (arg
);
2848 gcc_assert (ss
!= gfc_ss_terminator
);
2849 gfc_init_se (&argse
, NULL
);
2850 argse
.data_not_needed
= 1;
2851 gfc_conv_expr_descriptor (&argse
, arg
);
2853 as
= gfc_get_full_arrayspec_from_expr (arg
);
2855 /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2856 Note in addition that zero-sized arrays don't count as contiguous. */
2858 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2860 /* Build the call to is_contiguous0. */
2861 argse
.want_pointer
= 1;
2862 gfc_conv_expr_descriptor (&argse
, arg
);
2863 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2864 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2865 desc
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2866 fncall0
= build_call_expr_loc (input_location
,
2867 gfor_fndecl_is_contiguous0
, 1, desc
);
2869 se
->expr
= convert (logical_type_node
, se
->expr
);
2873 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2874 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2875 desc
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2877 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[0]);
2878 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2879 stride
, build_int_cst (TREE_TYPE (stride
), 1));
2881 for (i
= 0; i
< expr
->value
.function
.actual
->expr
->rank
- 1; i
++)
2883 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2884 extent
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2885 extent
= fold_build2_loc (input_location
, MINUS_EXPR
,
2886 gfc_array_index_type
, extent
, tmp
);
2887 extent
= fold_build2_loc (input_location
, PLUS_EXPR
,
2888 gfc_array_index_type
, extent
,
2889 gfc_index_one_node
);
2890 tmp
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[i
]);
2891 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2893 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[i
+1]);
2894 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2896 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2897 boolean_type_node
, cond
, tmp
);
2899 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), cond
);
2904 /* Evaluate a single upper or lower bound. */
2905 /* TODO: bound intrinsic generates way too much unnecessary code. */
2908 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2910 gfc_actual_arglist
*arg
;
2911 gfc_actual_arglist
*arg2
;
2916 tree cond
, cond1
, cond3
, cond4
, size
;
2920 gfc_array_spec
* as
;
2921 bool assumed_rank_lb_one
;
2923 arg
= expr
->value
.function
.actual
;
2928 /* Create an implicit second parameter from the loop variable. */
2929 gcc_assert (!arg2
->expr
);
2930 gcc_assert (se
->loop
->dimen
== 1);
2931 gcc_assert (se
->ss
->info
->expr
== expr
);
2932 gfc_advance_se_ss_chain (se
);
2933 bound
= se
->loop
->loopvar
[0];
2934 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2935 gfc_array_index_type
, bound
,
2940 /* use the passed argument. */
2941 gcc_assert (arg2
->expr
);
2942 gfc_init_se (&argse
, NULL
);
2943 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2944 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2946 /* Convert from one based to zero based. */
2947 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2948 gfc_array_index_type
, bound
,
2949 gfc_index_one_node
);
2952 /* TODO: don't re-evaluate the descriptor on each iteration. */
2953 /* Get a descriptor for the first parameter. */
2954 gfc_init_se (&argse
, NULL
);
2955 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2956 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2957 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2961 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2963 if (INTEGER_CST_P (bound
))
2965 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2966 && wi::geu_p (wi::to_wide (bound
),
2967 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2968 || wi::gtu_p (wi::to_wide (bound
), GFC_MAX_DIMENSIONS
))
2969 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2970 "dimension index", upper
? "UBOUND" : "LBOUND",
2974 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
2976 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2978 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2979 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2980 bound
, build_int_cst (TREE_TYPE (bound
), 0));
2981 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2982 tmp
= gfc_conv_descriptor_rank (desc
);
2984 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
2985 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2986 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
2987 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2988 logical_type_node
, cond
, tmp
);
2989 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2994 /* Take care of the lbound shift for assumed-rank arrays, which are
2995 nonallocatable and nonpointers. Those has a lbound of 1. */
2996 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
2997 && ((arg
->expr
->ts
.type
!= BT_CLASS
2998 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
2999 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
3000 || (arg
->expr
->ts
.type
== BT_CLASS
3001 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
3002 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
3004 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3005 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3007 /* 13.14.53: Result value for LBOUND
3009 Case (i): For an array section or for an array expression other than a
3010 whole array or array structure component, LBOUND(ARRAY, DIM)
3011 has the value 1. For a whole array or array structure
3012 component, LBOUND(ARRAY, DIM) has the value:
3013 (a) equal to the lower bound for subscript DIM of ARRAY if
3014 dimension DIM of ARRAY does not have extent zero
3015 or if ARRAY is an assumed-size array of rank DIM,
3018 13.14.113: Result value for UBOUND
3020 Case (i): For an array section or for an array expression other than a
3021 whole array or array structure component, UBOUND(ARRAY, DIM)
3022 has the value equal to the number of elements in the given
3023 dimension; otherwise, it has a value equal to the upper bound
3024 for subscript DIM of ARRAY if dimension DIM of ARRAY does
3025 not have size zero and has value zero if dimension DIM has
3028 if (!upper
&& assumed_rank_lb_one
)
3029 se
->expr
= gfc_index_one_node
;
3032 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
3034 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3036 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3037 stride
, gfc_index_zero_node
);
3038 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3039 logical_type_node
, cond3
, cond1
);
3040 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3041 stride
, gfc_index_zero_node
);
3046 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3047 logical_type_node
, cond3
, cond4
);
3048 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3049 gfc_index_one_node
, lbound
);
3050 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3051 logical_type_node
, cond4
, cond5
);
3053 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3054 logical_type_node
, cond
, cond5
);
3056 if (assumed_rank_lb_one
)
3058 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3059 gfc_array_index_type
, ubound
, lbound
);
3060 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3061 gfc_array_index_type
, tmp
, gfc_index_one_node
);
3066 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3067 gfc_array_index_type
, cond
,
3068 tmp
, gfc_index_zero_node
);
3072 if (as
->type
== AS_ASSUMED_SIZE
)
3073 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3074 bound
, build_int_cst (TREE_TYPE (bound
),
3075 arg
->expr
->rank
- 1));
3077 cond
= logical_false_node
;
3079 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3080 logical_type_node
, cond3
, cond4
);
3081 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3082 logical_type_node
, cond
, cond1
);
3084 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3085 gfc_array_index_type
, cond
,
3086 lbound
, gfc_index_one_node
);
3093 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
3094 gfc_array_index_type
, ubound
, lbound
);
3095 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
3096 gfc_array_index_type
, size
,
3097 gfc_index_one_node
);
3098 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
3099 gfc_array_index_type
, se
->expr
,
3100 gfc_index_zero_node
);
3103 se
->expr
= gfc_index_one_node
;
3106 type
= gfc_typenode_for_spec (&expr
->ts
);
3107 se
->expr
= convert (type
, se
->expr
);
3112 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
3114 gfc_actual_arglist
*arg
;
3115 gfc_actual_arglist
*arg2
;
3117 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
3121 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
3122 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
3123 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
3125 arg
= expr
->value
.function
.actual
;
3128 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
3129 corank
= gfc_get_corank (arg
->expr
);
3131 gfc_init_se (&argse
, NULL
);
3132 argse
.want_coarray
= 1;
3134 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
3135 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3136 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3141 /* Create an implicit second parameter from the loop variable. */
3142 gcc_assert (!arg2
->expr
);
3143 gcc_assert (corank
> 0);
3144 gcc_assert (se
->loop
->dimen
== 1);
3145 gcc_assert (se
->ss
->info
->expr
== expr
);
3147 bound
= se
->loop
->loopvar
[0];
3148 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3149 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
3150 gfc_advance_se_ss_chain (se
);
3154 /* use the passed argument. */
3155 gcc_assert (arg2
->expr
);
3156 gfc_init_se (&argse
, NULL
);
3157 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
3158 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3161 if (INTEGER_CST_P (bound
))
3163 if (wi::ltu_p (wi::to_wide (bound
), 1)
3164 || wi::gtu_p (wi::to_wide (bound
),
3165 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
3166 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3167 "dimension index", expr
->value
.function
.isym
->name
,
3170 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3172 bound
= gfc_evaluate_now (bound
, &se
->pre
);
3173 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3174 bound
, build_int_cst (TREE_TYPE (bound
), 1));
3175 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
3176 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3178 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3179 logical_type_node
, cond
, tmp
);
3180 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
3185 /* Subtract 1 to get to zero based and add dimensions. */
3186 switch (arg
->expr
->rank
)
3189 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
3190 gfc_array_index_type
, bound
,
3191 gfc_index_one_node
);
3195 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3196 gfc_array_index_type
, bound
,
3197 gfc_rank_cst
[arg
->expr
->rank
- 1]);
3201 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3203 /* Handle UCOBOUND with special handling of the last codimension. */
3204 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
3206 /* Last codimension: For -fcoarray=single just return
3207 the lcobound - otherwise add
3208 ceiling (real (num_images ()) / real (size)) - 1
3209 = (num_images () + size - 1) / size - 1
3210 = (num_images - 1) / size(),
3211 where size is the product of the extent of all but the last
3214 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
3218 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
3219 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3220 2, integer_zero_node
,
3221 build_int_cst (integer_type_node
, -1));
3222 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3223 gfc_array_index_type
,
3224 fold_convert (gfc_array_index_type
, tmp
),
3225 build_int_cst (gfc_array_index_type
, 1));
3226 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
3227 gfc_array_index_type
, tmp
,
3228 fold_convert (gfc_array_index_type
, cosize
));
3229 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3230 gfc_array_index_type
, resbound
, tmp
);
3232 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
3234 /* ubound = lbound + num_images() - 1. */
3235 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3236 2, integer_zero_node
,
3237 build_int_cst (integer_type_node
, -1));
3238 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3239 gfc_array_index_type
,
3240 fold_convert (gfc_array_index_type
, tmp
),
3241 build_int_cst (gfc_array_index_type
, 1));
3242 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3243 gfc_array_index_type
, resbound
, tmp
);
3248 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3250 build_int_cst (TREE_TYPE (bound
),
3251 arg
->expr
->rank
+ corank
- 1));
3253 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3254 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3255 gfc_array_index_type
, cond
,
3256 resbound
, resbound2
);
3259 se
->expr
= resbound
;
3262 se
->expr
= resbound
;
3264 type
= gfc_typenode_for_spec (&expr
->ts
);
3265 se
->expr
= convert (type
, se
->expr
);
3270 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
3272 gfc_actual_arglist
*array_arg
;
3273 gfc_actual_arglist
*dim_arg
;
3277 array_arg
= expr
->value
.function
.actual
;
3278 dim_arg
= array_arg
->next
;
3280 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
3282 gfc_init_se (&argse
, NULL
);
3283 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
3284 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3285 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3288 gcc_assert (dim_arg
->expr
);
3289 gfc_init_se (&argse
, NULL
);
3290 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
3291 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3292 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3293 argse
.expr
, gfc_index_one_node
);
3294 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
3298 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
3302 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3304 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
3308 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
3313 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
3314 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
3323 /* Create a complex value from one or two real components. */
3326 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
3332 unsigned int num_args
;
3334 num_args
= gfc_intrinsic_argument_list_length (expr
);
3335 args
= XALLOCAVEC (tree
, num_args
);
3337 type
= gfc_typenode_for_spec (&expr
->ts
);
3338 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3339 real
= convert (TREE_TYPE (type
), args
[0]);
3341 imag
= convert (TREE_TYPE (type
), args
[1]);
3342 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
3344 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
3345 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
3346 imag
= convert (TREE_TYPE (type
), imag
);
3349 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3351 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3355 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3356 MODULO(A, P) = A - FLOOR (A / P) * P
3358 The obvious algorithms above are numerically instable for large
3359 arguments, hence these intrinsics are instead implemented via calls
3360 to the fmod family of functions. It is the responsibility of the
3361 user to ensure that the second argument is non-zero. */
3364 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3374 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3376 switch (expr
->ts
.type
)
3379 /* Integer case is easy, we've got a builtin op. */
3380 type
= TREE_TYPE (args
[0]);
3383 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3386 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3392 /* Check if we have a builtin fmod. */
3393 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3395 /* The builtin should always be available. */
3396 gcc_assert (fmod
!= NULL_TREE
);
3398 tmp
= build_addr (fmod
);
3399 se
->expr
= build_call_array_loc (input_location
,
3400 TREE_TYPE (TREE_TYPE (fmod
)),
3405 type
= TREE_TYPE (args
[0]);
3407 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3408 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3411 modulo = arg - floor (arg/arg2) * arg2
3413 In order to calculate the result accurately, we use the fmod
3414 function as follows.
3416 res = fmod (arg, arg2);
3419 if ((arg < 0) xor (arg2 < 0))
3423 res = copysign (0., arg2);
3425 => As two nested ternary exprs:
3427 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3428 : copysign (0., arg2);
3432 zero
= gfc_build_const (type
, integer_zero_node
);
3433 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3434 if (!flag_signed_zeros
)
3436 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3438 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3440 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3441 logical_type_node
, test
, test2
);
3442 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3444 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3445 logical_type_node
, test
, test2
);
3446 test
= gfc_evaluate_now (test
, &se
->pre
);
3447 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3448 fold_build2_loc (input_location
,
3450 type
, tmp
, args
[1]),
3455 tree expr1
, copysign
, cscall
;
3456 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3458 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3460 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3462 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3463 logical_type_node
, test
, test2
);
3464 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3465 fold_build2_loc (input_location
,
3467 type
, tmp
, args
[1]),
3469 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3471 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3473 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3483 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3484 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3485 where the right shifts are logical (i.e. 0's are shifted in).
3486 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3487 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3489 DSHIFTL(I,J,BITSIZE) = J
3491 DSHIFTR(I,J,BITSIZE) = I. */
3494 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3496 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3497 tree args
[3], cond
, tmp
;
3500 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3502 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3503 type
= TREE_TYPE (args
[0]);
3504 bitsize
= TYPE_PRECISION (type
);
3505 utype
= unsigned_type_for (type
);
3506 stype
= TREE_TYPE (args
[2]);
3508 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3509 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3510 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3512 /* The generic case. */
3513 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3514 build_int_cst (stype
, bitsize
), shift
);
3515 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3516 arg1
, dshiftl
? shift
: tmp
);
3518 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3519 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3520 right
= fold_convert (type
, right
);
3522 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3524 /* Special cases. */
3525 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3526 build_int_cst (stype
, 0));
3527 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3528 dshiftl
? arg1
: arg2
, res
);
3530 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3531 build_int_cst (stype
, bitsize
));
3532 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3533 dshiftl
? arg2
: arg1
, res
);
3539 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3542 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3550 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3551 type
= TREE_TYPE (args
[0]);
3553 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3554 val
= gfc_evaluate_now (val
, &se
->pre
);
3556 zero
= gfc_build_const (type
, integer_zero_node
);
3557 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, val
, zero
);
3558 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3562 /* SIGN(A, B) is absolute value of A times sign of B.
3563 The real value versions use library functions to ensure the correct
3564 handling of negative zero. Integer case implemented as:
3565 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3569 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3575 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3576 if (expr
->ts
.type
== BT_REAL
)
3580 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3581 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3583 /* We explicitly have to ignore the minus sign. We do so by using
3584 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3586 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3589 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3590 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3592 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3593 TREE_TYPE (args
[0]), cond
,
3594 build_call_expr_loc (input_location
, abs
, 1,
3596 build_call_expr_loc (input_location
, tmp
, 2,
3600 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3605 /* Having excluded floating point types, we know we are now dealing
3606 with signed integer types. */
3607 type
= TREE_TYPE (args
[0]);
3609 /* Args[0] is used multiple times below. */
3610 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3612 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3613 the signs of A and B are the same, and of all ones if they differ. */
3614 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3615 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3616 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3617 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3619 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3620 is all ones (i.e. -1). */
3621 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3622 fold_build2_loc (input_location
, PLUS_EXPR
,
3623 type
, args
[0], tmp
), tmp
);
3627 /* Test for the presence of an optional argument. */
3630 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3634 arg
= expr
->value
.function
.actual
->expr
;
3635 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3636 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3637 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3641 /* Calculate the double precision product of two single precision values. */
3644 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3649 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3651 /* Convert the args to double precision before multiplying. */
3652 type
= gfc_typenode_for_spec (&expr
->ts
);
3653 args
[0] = convert (type
, args
[0]);
3654 args
[1] = convert (type
, args
[1]);
3655 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3660 /* Return a length one character string containing an ascii character. */
3663 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3668 unsigned int num_args
;
3670 num_args
= gfc_intrinsic_argument_list_length (expr
);
3671 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3673 type
= gfc_get_char_type (expr
->ts
.kind
);
3674 var
= gfc_create_var (type
, "char");
3676 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3677 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3678 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3679 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3684 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3692 unsigned int num_args
;
3694 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3695 args
= XALLOCAVEC (tree
, num_args
);
3697 var
= gfc_create_var (pchar_type_node
, "pstr");
3698 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3700 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3701 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3702 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3704 fndecl
= build_addr (gfor_fndecl_ctime
);
3705 tmp
= build_call_array_loc (input_location
,
3706 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3707 fndecl
, num_args
, args
);
3708 gfc_add_expr_to_block (&se
->pre
, tmp
);
3710 /* Free the temporary afterwards, if necessary. */
3711 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3712 len
, build_int_cst (TREE_TYPE (len
), 0));
3713 tmp
= gfc_call_free (var
);
3714 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3715 gfc_add_expr_to_block (&se
->post
, tmp
);
3718 se
->string_length
= len
;
3723 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3731 unsigned int num_args
;
3733 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3734 args
= XALLOCAVEC (tree
, num_args
);
3736 var
= gfc_create_var (pchar_type_node
, "pstr");
3737 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3739 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3740 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3741 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3743 fndecl
= build_addr (gfor_fndecl_fdate
);
3744 tmp
= build_call_array_loc (input_location
,
3745 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3746 fndecl
, num_args
, args
);
3747 gfc_add_expr_to_block (&se
->pre
, tmp
);
3749 /* Free the temporary afterwards, if necessary. */
3750 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3751 len
, build_int_cst (TREE_TYPE (len
), 0));
3752 tmp
= gfc_call_free (var
);
3753 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3754 gfc_add_expr_to_block (&se
->post
, tmp
);
3757 se
->string_length
= len
;
3761 /* Generate a direct call to free() for the FREE subroutine. */
3764 conv_intrinsic_free (gfc_code
*code
)
3770 gfc_init_se (&argse
, NULL
);
3771 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3772 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3774 gfc_init_block (&block
);
3775 call
= build_call_expr_loc (input_location
,
3776 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3777 gfc_add_expr_to_block (&block
, call
);
3778 return gfc_finish_block (&block
);
3782 /* Call the RANDOM_INIT library subroutine with a hidden argument for
3783 handling seeding on coarray images. */
3786 conv_intrinsic_random_init (gfc_code
*code
)
3790 tree arg1
, arg2
, arg3
, tmp
;
3791 tree logical4_type_node
= gfc_get_logical_type (4);
3793 /* Make the function call. */
3794 gfc_init_block (&block
);
3795 gfc_init_se (&se
, NULL
);
3797 /* Convert REPEATABLE to a LOGICAL(4) entity. */
3798 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
3799 gfc_add_block_to_block (&block
, &se
.pre
);
3800 arg1
= fold_convert (logical4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3801 gfc_add_block_to_block (&block
, &se
.post
);
3803 /* Convert IMAGE_DISTINCT to a LOGICAL(4) entity. */
3804 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
3805 gfc_add_block_to_block (&block
, &se
.pre
);
3806 arg2
= fold_convert (logical4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3807 gfc_add_block_to_block (&block
, &se
.post
);
3809 /* Create the hidden argument. For non-coarray codes and -fcoarray=single,
3810 simply set this to 0. For -fcoarray=lib, generate a call to
3811 THIS_IMAGE() without arguments. */
3812 arg3
= build_int_cst (gfc_get_int_type (4), 0);
3813 if (flag_coarray
== GFC_FCOARRAY_LIB
)
3815 arg3
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
,
3817 se
.expr
= fold_convert (gfc_get_int_type (4), arg3
);
3820 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_random_init
, 3,
3822 gfc_add_expr_to_block (&block
, tmp
);
3824 return gfc_finish_block (&block
);
3828 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3832 conv_intrinsic_system_clock (gfc_code
*code
)
3835 gfc_se count_se
, count_rate_se
, count_max_se
;
3836 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3840 gfc_expr
*count
= code
->ext
.actual
->expr
;
3841 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3842 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3844 /* Evaluate our arguments. */
3847 gfc_init_se (&count_se
, NULL
);
3848 gfc_conv_expr (&count_se
, count
);
3853 gfc_init_se (&count_rate_se
, NULL
);
3854 gfc_conv_expr (&count_rate_se
, count_rate
);
3859 gfc_init_se (&count_max_se
, NULL
);
3860 gfc_conv_expr (&count_max_se
, count_max
);
3863 /* Find the smallest kind found of the arguments. */
3865 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3866 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3868 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3871 /* Prepare temporary variables. */
3876 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3877 else if (least
== 4)
3878 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3879 else if (count
->ts
.kind
== 1)
3880 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3883 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3890 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3891 else if (least
== 4)
3892 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3894 arg2
= integer_zero_node
;
3900 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3901 else if (least
== 4)
3902 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3904 arg3
= integer_zero_node
;
3907 /* Make the function call. */
3908 gfc_init_block (&block
);
3914 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3915 : null_pointer_node
;
3916 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3917 : null_pointer_node
;
3918 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3919 : null_pointer_node
;
3924 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3925 : null_pointer_node
;
3926 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3927 : null_pointer_node
;
3928 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3929 : null_pointer_node
;
3936 tmp
= build_call_expr_loc (input_location
,
3937 gfor_fndecl_system_clock4
, 3,
3938 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3939 : null_pointer_node
,
3940 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3941 : null_pointer_node
,
3942 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3943 : null_pointer_node
);
3944 gfc_add_expr_to_block (&block
, tmp
);
3946 /* Handle kind>=8, 10, or 16 arguments */
3949 tmp
= build_call_expr_loc (input_location
,
3950 gfor_fndecl_system_clock8
, 3,
3951 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3952 : null_pointer_node
,
3953 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3954 : null_pointer_node
,
3955 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3956 : null_pointer_node
);
3957 gfc_add_expr_to_block (&block
, tmp
);
3961 /* And store values back if needed. */
3962 if (arg1
&& arg1
!= count_se
.expr
)
3963 gfc_add_modify (&block
, count_se
.expr
,
3964 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
3965 if (arg2
&& arg2
!= count_rate_se
.expr
)
3966 gfc_add_modify (&block
, count_rate_se
.expr
,
3967 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
3968 if (arg3
&& arg3
!= count_max_se
.expr
)
3969 gfc_add_modify (&block
, count_max_se
.expr
,
3970 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
3972 return gfc_finish_block (&block
);
3976 /* Return a character string containing the tty name. */
3979 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
3987 unsigned int num_args
;
3989 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3990 args
= XALLOCAVEC (tree
, num_args
);
3992 var
= gfc_create_var (pchar_type_node
, "pstr");
3993 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3995 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3996 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3997 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3999 fndecl
= build_addr (gfor_fndecl_ttynam
);
4000 tmp
= build_call_array_loc (input_location
,
4001 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
4002 fndecl
, num_args
, args
);
4003 gfc_add_expr_to_block (&se
->pre
, tmp
);
4005 /* Free the temporary afterwards, if necessary. */
4006 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4007 len
, build_int_cst (TREE_TYPE (len
), 0));
4008 tmp
= gfc_call_free (var
);
4009 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4010 gfc_add_expr_to_block (&se
->post
, tmp
);
4013 se
->string_length
= len
;
4017 /* Get the minimum/maximum value of all the parameters.
4018 minmax (a1, a2, a3, ...)
4021 mvar = COMP (mvar, a2)
4022 mvar = COMP (mvar, a3)
4026 Where COMP is MIN/MAX_EXPR for integral types or when we don't
4027 care about NaNs, or IFN_FMIN/MAX when the target has support for
4028 fast NaN-honouring min/max. When neither holds expand a sequence
4029 of explicit comparisons. */
4031 /* TODO: Mismatching types can occur when specific names are used.
4032 These should be handled during resolution. */
4034 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4041 gfc_actual_arglist
*argexpr
;
4042 unsigned int i
, nargs
;
4044 nargs
= gfc_intrinsic_argument_list_length (expr
);
4045 args
= XALLOCAVEC (tree
, nargs
);
4047 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
4048 type
= gfc_typenode_for_spec (&expr
->ts
);
4050 argexpr
= expr
->value
.function
.actual
;
4051 if (TREE_TYPE (args
[0]) != type
)
4052 args
[0] = convert (type
, args
[0]);
4053 /* Only evaluate the argument once. */
4054 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
4055 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4057 mvar
= gfc_create_var (type
, "M");
4058 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
4060 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++, argexpr
= argexpr
->next
)
4062 tree cond
= NULL_TREE
;
4065 /* Handle absent optional arguments by ignoring the comparison. */
4066 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
4067 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
4068 && TREE_CODE (val
) == INDIRECT_REF
)
4070 cond
= fold_build2_loc (input_location
,
4071 NE_EXPR
, logical_type_node
,
4072 TREE_OPERAND (val
, 0),
4073 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
4075 else if (!VAR_P (val
) && !TREE_CONSTANT (val
))
4076 /* Only evaluate the argument once. */
4077 val
= gfc_evaluate_now (val
, &se
->pre
);
4080 /* For floating point types, the question is what MAX(a, NaN) or
4081 MIN(a, NaN) should return (where "a" is a normal number).
4082 There are valid usecase for returning either one, but the
4083 Fortran standard doesn't specify which one should be chosen.
4084 Also, there is no consensus among other tested compilers. In
4085 short, it's a mess. So lets just do whatever is fastest. */
4086 tree_code code
= op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
;
4087 calc
= fold_build2_loc (input_location
, code
, type
,
4088 convert (type
, val
), mvar
);
4089 tmp
= build2_v (MODIFY_EXPR
, mvar
, calc
);
4091 if (cond
!= NULL_TREE
)
4092 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
4093 build_empty_stmt (input_location
));
4094 gfc_add_expr_to_block (&se
->pre
, tmp
);
4100 /* Generate library calls for MIN and MAX intrinsics for character
4103 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
4106 tree var
, len
, fndecl
, tmp
, cond
, function
;
4109 nargs
= gfc_intrinsic_argument_list_length (expr
);
4110 args
= XALLOCAVEC (tree
, nargs
+ 4);
4111 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
4113 /* Create the result variables. */
4114 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4115 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
4116 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
4117 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
4118 args
[2] = build_int_cst (integer_type_node
, op
);
4119 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
4121 if (expr
->ts
.kind
== 1)
4122 function
= gfor_fndecl_string_minmax
;
4123 else if (expr
->ts
.kind
== 4)
4124 function
= gfor_fndecl_string_minmax_char4
;
4128 /* Make the function call. */
4129 fndecl
= build_addr (function
);
4130 tmp
= build_call_array_loc (input_location
,
4131 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4133 gfc_add_expr_to_block (&se
->pre
, tmp
);
4135 /* Free the temporary afterwards, if necessary. */
4136 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4137 len
, build_int_cst (TREE_TYPE (len
), 0));
4138 tmp
= gfc_call_free (var
);
4139 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4140 gfc_add_expr_to_block (&se
->post
, tmp
);
4143 se
->string_length
= len
;
4147 /* Create a symbol node for this intrinsic. The symbol from the frontend
4148 has the generic name. */
4151 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
4155 /* TODO: Add symbols for intrinsic function to the global namespace. */
4156 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
4157 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
4160 sym
->attr
.external
= 1;
4161 sym
->attr
.function
= 1;
4162 sym
->attr
.always_explicit
= 1;
4163 sym
->attr
.proc
= PROC_INTRINSIC
;
4164 sym
->attr
.flavor
= FL_PROCEDURE
;
4168 sym
->attr
.dimension
= 1;
4169 sym
->as
= gfc_get_array_spec ();
4170 sym
->as
->type
= AS_ASSUMED_SHAPE
;
4171 sym
->as
->rank
= expr
->rank
;
4174 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
4175 ignore_optional
? expr
->value
.function
.actual
4181 /* Generate a call to an external intrinsic function. */
4183 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
4186 vec
<tree
, va_gc
> *append_args
;
4188 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
4191 gcc_assert (expr
->rank
> 0);
4193 gcc_assert (expr
->rank
== 0);
4195 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
4197 /* Calls to libgfortran_matmul need to be appended special arguments,
4198 to be able to call the BLAS ?gemm functions if required and possible. */
4200 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
4201 && !expr
->external_blas
4202 && sym
->ts
.type
!= BT_LOGICAL
)
4204 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
4206 if (flag_external_blas
4207 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
4208 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
4212 if (sym
->ts
.type
== BT_REAL
)
4214 if (sym
->ts
.kind
== 4)
4215 gemm_fndecl
= gfor_fndecl_sgemm
;
4217 gemm_fndecl
= gfor_fndecl_dgemm
;
4221 if (sym
->ts
.kind
== 4)
4222 gemm_fndecl
= gfor_fndecl_cgemm
;
4224 gemm_fndecl
= gfor_fndecl_zgemm
;
4227 vec_alloc (append_args
, 3);
4228 append_args
->quick_push (build_int_cst (cint
, 1));
4229 append_args
->quick_push (build_int_cst (cint
,
4230 flag_blas_matmul_limit
));
4231 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
4236 vec_alloc (append_args
, 3);
4237 append_args
->quick_push (build_int_cst (cint
, 0));
4238 append_args
->quick_push (build_int_cst (cint
, 0));
4239 append_args
->quick_push (null_pointer_node
);
4243 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4245 gfc_free_symbol (sym
);
4248 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4268 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4277 gfc_actual_arglist
*actual
;
4284 gfc_conv_intrinsic_funcall (se
, expr
);
4288 actual
= expr
->value
.function
.actual
;
4289 type
= gfc_typenode_for_spec (&expr
->ts
);
4290 /* Initialize the result. */
4291 resvar
= gfc_create_var (type
, "test");
4293 tmp
= convert (type
, boolean_true_node
);
4295 tmp
= convert (type
, boolean_false_node
);
4296 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4298 /* Walk the arguments. */
4299 arrayss
= gfc_walk_expr (actual
->expr
);
4300 gcc_assert (arrayss
!= gfc_ss_terminator
);
4302 /* Initialize the scalarizer. */
4303 gfc_init_loopinfo (&loop
);
4304 exit_label
= gfc_build_label_decl (NULL_TREE
);
4305 TREE_USED (exit_label
) = 1;
4306 gfc_add_ss_to_loop (&loop
, arrayss
);
4308 /* Initialize the loop. */
4309 gfc_conv_ss_startstride (&loop
);
4310 gfc_conv_loop_setup (&loop
, &expr
->where
);
4312 gfc_mark_ss_chain_used (arrayss
, 1);
4313 /* Generate the loop body. */
4314 gfc_start_scalarized_body (&loop
, &body
);
4316 /* If the condition matches then set the return value. */
4317 gfc_start_block (&block
);
4319 tmp
= convert (type
, boolean_false_node
);
4321 tmp
= convert (type
, boolean_true_node
);
4322 gfc_add_modify (&block
, resvar
, tmp
);
4324 /* And break out of the loop. */
4325 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4326 gfc_add_expr_to_block (&block
, tmp
);
4328 found
= gfc_finish_block (&block
);
4330 /* Check this element. */
4331 gfc_init_se (&arrayse
, NULL
);
4332 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4333 arrayse
.ss
= arrayss
;
4334 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4336 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4337 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
, arrayse
.expr
,
4338 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
4339 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
4340 gfc_add_expr_to_block (&body
, tmp
);
4341 gfc_add_block_to_block (&body
, &arrayse
.post
);
4343 gfc_trans_scalarizing_loops (&loop
, &body
);
4345 /* Add the exit label. */
4346 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4347 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4349 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4350 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4351 gfc_cleanup_loop (&loop
);
4356 /* COUNT(A) = Number of true elements in A. */
4358 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4365 gfc_actual_arglist
*actual
;
4371 gfc_conv_intrinsic_funcall (se
, expr
);
4375 actual
= expr
->value
.function
.actual
;
4377 type
= gfc_typenode_for_spec (&expr
->ts
);
4378 /* Initialize the result. */
4379 resvar
= gfc_create_var (type
, "count");
4380 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4382 /* Walk the arguments. */
4383 arrayss
= gfc_walk_expr (actual
->expr
);
4384 gcc_assert (arrayss
!= gfc_ss_terminator
);
4386 /* Initialize the scalarizer. */
4387 gfc_init_loopinfo (&loop
);
4388 gfc_add_ss_to_loop (&loop
, arrayss
);
4390 /* Initialize the loop. */
4391 gfc_conv_ss_startstride (&loop
);
4392 gfc_conv_loop_setup (&loop
, &expr
->where
);
4394 gfc_mark_ss_chain_used (arrayss
, 1);
4395 /* Generate the loop body. */
4396 gfc_start_scalarized_body (&loop
, &body
);
4398 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4399 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4400 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4402 gfc_init_se (&arrayse
, NULL
);
4403 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4404 arrayse
.ss
= arrayss
;
4405 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4406 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4407 build_empty_stmt (input_location
));
4409 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4410 gfc_add_expr_to_block (&body
, tmp
);
4411 gfc_add_block_to_block (&body
, &arrayse
.post
);
4413 gfc_trans_scalarizing_loops (&loop
, &body
);
4415 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4416 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4417 gfc_cleanup_loop (&loop
);
4423 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4424 struct and return the corresponding loopinfo. */
4426 static gfc_loopinfo
*
4427 enter_nested_loop (gfc_se
*se
)
4429 se
->ss
= se
->ss
->nested_ss
;
4430 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4432 return se
->ss
->loop
;
4435 /* Build the condition for a mask, which may be optional. */
4438 conv_mask_condition (gfc_se
*maskse
, gfc_expr
*maskexpr
,
4446 type
= TREE_TYPE (maskse
->expr
);
4447 present
= gfc_conv_expr_present (maskexpr
->symtree
->n
.sym
);
4448 present
= convert (type
, present
);
4449 present
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, type
,
4451 return fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4452 type
, present
, maskse
->expr
);
4455 return maskse
->expr
;
4458 /* Inline implementation of the sum and product intrinsics. */
4460 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4464 tree scale
= NULL_TREE
;
4469 gfc_loopinfo loop
, *ploop
;
4470 gfc_actual_arglist
*arg_array
, *arg_mask
;
4471 gfc_ss
*arrayss
= NULL
;
4472 gfc_ss
*maskss
= NULL
;
4476 gfc_expr
*arrayexpr
;
4482 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4488 type
= gfc_typenode_for_spec (&expr
->ts
);
4489 /* Initialize the result. */
4490 resvar
= gfc_create_var (type
, "val");
4495 scale
= gfc_create_var (type
, "scale");
4496 gfc_add_modify (&se
->pre
, scale
,
4497 gfc_build_const (type
, integer_one_node
));
4498 tmp
= gfc_build_const (type
, integer_zero_node
);
4500 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4501 tmp
= gfc_build_const (type
, integer_zero_node
);
4502 else if (op
== NE_EXPR
)
4504 tmp
= convert (type
, boolean_false_node
);
4505 else if (op
== BIT_AND_EXPR
)
4506 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4507 type
, integer_one_node
));
4509 tmp
= gfc_build_const (type
, integer_one_node
);
4511 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4513 arg_array
= expr
->value
.function
.actual
;
4515 arrayexpr
= arg_array
->expr
;
4517 if (op
== NE_EXPR
|| norm2
)
4519 /* PARITY and NORM2. */
4521 optional_mask
= false;
4525 arg_mask
= arg_array
->next
->next
;
4526 gcc_assert (arg_mask
!= NULL
);
4527 maskexpr
= arg_mask
->expr
;
4528 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
4529 && maskexpr
->symtree
->n
.sym
->attr
.dummy
4530 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
4533 if (expr
->rank
== 0)
4535 /* Walk the arguments. */
4536 arrayss
= gfc_walk_expr (arrayexpr
);
4537 gcc_assert (arrayss
!= gfc_ss_terminator
);
4539 if (maskexpr
&& maskexpr
->rank
> 0)
4541 maskss
= gfc_walk_expr (maskexpr
);
4542 gcc_assert (maskss
!= gfc_ss_terminator
);
4547 /* Initialize the scalarizer. */
4548 gfc_init_loopinfo (&loop
);
4550 /* We add the mask first because the number of iterations is
4551 taken from the last ss, and this breaks if an absent
4552 optional argument is used for mask. */
4554 if (maskexpr
&& maskexpr
->rank
> 0)
4555 gfc_add_ss_to_loop (&loop
, maskss
);
4556 gfc_add_ss_to_loop (&loop
, arrayss
);
4558 /* Initialize the loop. */
4559 gfc_conv_ss_startstride (&loop
);
4560 gfc_conv_loop_setup (&loop
, &expr
->where
);
4562 if (maskexpr
&& maskexpr
->rank
> 0)
4563 gfc_mark_ss_chain_used (maskss
, 1);
4564 gfc_mark_ss_chain_used (arrayss
, 1);
4569 /* All the work has been done in the parent loops. */
4570 ploop
= enter_nested_loop (se
);
4574 /* Generate the loop body. */
4575 gfc_start_scalarized_body (ploop
, &body
);
4577 /* If we have a mask, only add this element if the mask is set. */
4578 if (maskexpr
&& maskexpr
->rank
> 0)
4580 gfc_init_se (&maskse
, parent_se
);
4581 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4582 if (expr
->rank
== 0)
4584 gfc_conv_expr_val (&maskse
, maskexpr
);
4585 gfc_add_block_to_block (&body
, &maskse
.pre
);
4587 gfc_start_block (&block
);
4590 gfc_init_block (&block
);
4592 /* Do the actual summation/product. */
4593 gfc_init_se (&arrayse
, parent_se
);
4594 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4595 if (expr
->rank
== 0)
4596 arrayse
.ss
= arrayss
;
4597 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4598 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4602 /* if (x (i) != 0.0)
4608 result = 1.0 + result * val * val;
4614 result += val * val;
4617 tree res1
, res2
, cond
, absX
, val
;
4618 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4620 gfc_init_block (&ifblock1
);
4622 absX
= gfc_create_var (type
, "absX");
4623 gfc_add_modify (&ifblock1
, absX
,
4624 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4626 val
= gfc_create_var (type
, "val");
4627 gfc_add_expr_to_block (&ifblock1
, val
);
4629 gfc_init_block (&ifblock2
);
4630 gfc_add_modify (&ifblock2
, val
,
4631 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4633 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4634 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4635 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4636 gfc_build_const (type
, integer_one_node
));
4637 gfc_add_modify (&ifblock2
, resvar
, res1
);
4638 gfc_add_modify (&ifblock2
, scale
, absX
);
4639 res1
= gfc_finish_block (&ifblock2
);
4641 gfc_init_block (&ifblock3
);
4642 gfc_add_modify (&ifblock3
, val
,
4643 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4645 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4646 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4647 gfc_add_modify (&ifblock3
, resvar
, res2
);
4648 res2
= gfc_finish_block (&ifblock3
);
4650 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4652 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4653 gfc_add_expr_to_block (&ifblock1
, tmp
);
4654 tmp
= gfc_finish_block (&ifblock1
);
4656 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
4658 gfc_build_const (type
, integer_zero_node
));
4660 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4661 gfc_add_expr_to_block (&block
, tmp
);
4665 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4666 gfc_add_modify (&block
, resvar
, tmp
);
4669 gfc_add_block_to_block (&block
, &arrayse
.post
);
4671 if (maskexpr
&& maskexpr
->rank
> 0)
4673 /* We enclose the above in if (mask) {...} . If the mask is an
4674 optional argument, generate
4675 IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4677 tmp
= gfc_finish_block (&block
);
4678 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
4679 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
4680 build_empty_stmt (input_location
));
4683 tmp
= gfc_finish_block (&block
);
4684 gfc_add_expr_to_block (&body
, tmp
);
4686 gfc_trans_scalarizing_loops (ploop
, &body
);
4688 /* For a scalar mask, enclose the loop in an if statement. */
4689 if (maskexpr
&& maskexpr
->rank
== 0)
4691 gfc_init_block (&block
);
4692 gfc_add_block_to_block (&block
, &ploop
->pre
);
4693 gfc_add_block_to_block (&block
, &ploop
->post
);
4694 tmp
= gfc_finish_block (&block
);
4698 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4699 build_empty_stmt (input_location
));
4700 gfc_advance_se_ss_chain (se
);
4706 gcc_assert (expr
->rank
== 0);
4707 gfc_init_se (&maskse
, NULL
);
4708 gfc_conv_expr_val (&maskse
, maskexpr
);
4709 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
4710 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
4711 build_empty_stmt (input_location
));
4714 gfc_add_expr_to_block (&block
, tmp
);
4715 gfc_add_block_to_block (&se
->pre
, &block
);
4716 gcc_assert (se
->post
.head
== NULL
);
4720 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4721 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4724 if (expr
->rank
== 0)
4725 gfc_cleanup_loop (ploop
);
4729 /* result = scale * sqrt(result). */
4731 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4732 resvar
= build_call_expr_loc (input_location
,
4734 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4741 /* Inline implementation of the dot_product intrinsic. This function
4742 is based on gfc_conv_intrinsic_arith (the previous function). */
4744 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4752 gfc_actual_arglist
*actual
;
4753 gfc_ss
*arrayss1
, *arrayss2
;
4754 gfc_se arrayse1
, arrayse2
;
4755 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4757 type
= gfc_typenode_for_spec (&expr
->ts
);
4759 /* Initialize the result. */
4760 resvar
= gfc_create_var (type
, "val");
4761 if (expr
->ts
.type
== BT_LOGICAL
)
4762 tmp
= build_int_cst (type
, 0);
4764 tmp
= gfc_build_const (type
, integer_zero_node
);
4766 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4768 /* Walk argument #1. */
4769 actual
= expr
->value
.function
.actual
;
4770 arrayexpr1
= actual
->expr
;
4771 arrayss1
= gfc_walk_expr (arrayexpr1
);
4772 gcc_assert (arrayss1
!= gfc_ss_terminator
);
4774 /* Walk argument #2. */
4775 actual
= actual
->next
;
4776 arrayexpr2
= actual
->expr
;
4777 arrayss2
= gfc_walk_expr (arrayexpr2
);
4778 gcc_assert (arrayss2
!= gfc_ss_terminator
);
4780 /* Initialize the scalarizer. */
4781 gfc_init_loopinfo (&loop
);
4782 gfc_add_ss_to_loop (&loop
, arrayss1
);
4783 gfc_add_ss_to_loop (&loop
, arrayss2
);
4785 /* Initialize the loop. */
4786 gfc_conv_ss_startstride (&loop
);
4787 gfc_conv_loop_setup (&loop
, &expr
->where
);
4789 gfc_mark_ss_chain_used (arrayss1
, 1);
4790 gfc_mark_ss_chain_used (arrayss2
, 1);
4792 /* Generate the loop body. */
4793 gfc_start_scalarized_body (&loop
, &body
);
4794 gfc_init_block (&block
);
4796 /* Make the tree expression for [conjg(]array1[)]. */
4797 gfc_init_se (&arrayse1
, NULL
);
4798 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
4799 arrayse1
.ss
= arrayss1
;
4800 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
4801 if (expr
->ts
.type
== BT_COMPLEX
)
4802 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
4804 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
4806 /* Make the tree expression for array2. */
4807 gfc_init_se (&arrayse2
, NULL
);
4808 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
4809 arrayse2
.ss
= arrayss2
;
4810 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
4811 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
4813 /* Do the actual product and sum. */
4814 if (expr
->ts
.type
== BT_LOGICAL
)
4816 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
4817 arrayse1
.expr
, arrayse2
.expr
);
4818 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
4822 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
4824 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
4826 gfc_add_modify (&block
, resvar
, tmp
);
4828 /* Finish up the loop block and the loop. */
4829 tmp
= gfc_finish_block (&block
);
4830 gfc_add_expr_to_block (&body
, tmp
);
4832 gfc_trans_scalarizing_loops (&loop
, &body
);
4833 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4834 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4835 gfc_cleanup_loop (&loop
);
4841 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4842 we need to handle. For performance reasons we sometimes create two
4843 loops instead of one, where the second one is much simpler.
4844 Examples for minloc intrinsic:
4845 1) Result is an array, a call is generated
4846 2) Array mask is used and NaNs need to be supported:
4852 if (pos == 0) pos = S + (1 - from);
4853 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4860 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4864 3) NaNs need to be supported, but it is known at compile time or cheaply
4865 at runtime whether array is nonempty or not:
4870 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4873 if (from <= to) pos = 1;
4877 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4881 4) NaNs aren't supported, array mask is used:
4882 limit = infinities_supported ? Infinity : huge (limit);
4886 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4892 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4896 5) Same without array mask:
4897 limit = infinities_supported ? Infinity : huge (limit);
4898 pos = (from <= to) ? 1 : 0;
4901 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4904 For 3) and 5), if mask is scalar, this all goes into a conditional,
4905 setting pos = 0; in the else branch.
4907 Since we now also support the BACK argument, instead of using
4908 if (a[S] < limit), we now use
4911 cond = a[S] <= limit;
4913 cond = a[S] < limit;
4917 The optimizer is smart enough to move the condition out of the loop.
4918 The are now marked as unlikely to for further speedup. */
4921 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4925 stmtblock_t ifblock
;
4926 stmtblock_t elseblock
;
4938 gfc_actual_arglist
*actual
;
4943 gfc_expr
*arrayexpr
;
4951 actual
= expr
->value
.function
.actual
;
4953 /* The last argument, BACK, is passed by value. Ensure that
4954 by setting its name to %VAL. */
4955 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
4957 if (a
->next
== NULL
)
4963 gfc_conv_intrinsic_funcall (se
, expr
);
4967 arrayexpr
= actual
->expr
;
4969 /* Special case for character maxloc. Remove unneeded actual
4970 arguments, then call a library function. */
4972 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
4974 gfc_actual_arglist
*a
, *b
;
4979 if (b
->expr
== NULL
|| strcmp (b
->name
, "dim") == 0)
4983 gfc_free_actual_arglist (b
);
4988 gfc_conv_intrinsic_funcall (se
, expr
);
4992 /* Initialize the result. */
4993 pos
= gfc_create_var (gfc_array_index_type
, "pos");
4994 offset
= gfc_create_var (gfc_array_index_type
, "offset");
4995 type
= gfc_typenode_for_spec (&expr
->ts
);
4997 /* Walk the arguments. */
4998 arrayss
= gfc_walk_expr (arrayexpr
);
4999 gcc_assert (arrayss
!= gfc_ss_terminator
);
5001 actual
= actual
->next
->next
;
5002 gcc_assert (actual
);
5003 maskexpr
= actual
->expr
;
5004 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5005 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5006 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5007 backexpr
= actual
->next
->next
->expr
;
5009 if (maskexpr
&& maskexpr
->rank
!= 0)
5011 maskss
= gfc_walk_expr (maskexpr
);
5012 gcc_assert (maskss
!= gfc_ss_terminator
);
5017 if (gfc_array_size (arrayexpr
, &asize
))
5019 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5021 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5022 logical_type_node
, nonempty
,
5023 gfc_index_zero_node
);
5028 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
5029 switch (arrayexpr
->ts
.type
)
5032 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
5036 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
5037 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
5038 arrayexpr
->ts
.kind
);
5045 /* We start with the most negative possible value for MAXLOC, and the most
5046 positive possible value for MINLOC. The most negative possible value is
5047 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5048 possible value is HUGE in both cases. */
5050 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5051 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
5052 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
5053 build_int_cst (TREE_TYPE (tmp
), 1));
5055 gfc_add_modify (&se
->pre
, limit
, tmp
);
5057 /* Initialize the scalarizer. */
5058 gfc_init_loopinfo (&loop
);
5060 /* We add the mask first because the number of iterations is taken
5061 from the last ss, and this breaks if an absent optional argument
5062 is used for mask. */
5065 gfc_add_ss_to_loop (&loop
, maskss
);
5067 gfc_add_ss_to_loop (&loop
, arrayss
);
5069 /* Initialize the loop. */
5070 gfc_conv_ss_startstride (&loop
);
5072 /* The code generated can have more than one loop in sequence (see the
5073 comment at the function header). This doesn't work well with the
5074 scalarizer, which changes arrays' offset when the scalarization loops
5075 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
5076 are currently inlined in the scalar case only (for which loop is of rank
5077 one). As there is no dependency to care about in that case, there is no
5078 temporary, so that we can use the scalarizer temporary code to handle
5079 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
5080 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
5082 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
5083 should eventually go away. We could either create two loops properly,
5084 or find another way to save/restore the array offsets between the two
5085 loops (without conflicting with temporary management), or use a single
5086 loop minmaxloc implementation. See PR 31067. */
5087 loop
.temp_dim
= loop
.dimen
;
5088 gfc_conv_loop_setup (&loop
, &expr
->where
);
5090 gcc_assert (loop
.dimen
== 1);
5091 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
5092 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5093 loop
.from
[0], loop
.to
[0]);
5097 /* Initialize the position to zero, following Fortran 2003. We are free
5098 to do this because Fortran 95 allows the result of an entirely false
5099 mask to be processor dependent. If we know at compile time the array
5100 is non-empty and no MASK is used, we can initialize to 1 to simplify
5102 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
5103 gfc_add_modify (&loop
.pre
, pos
,
5104 fold_build3_loc (input_location
, COND_EXPR
,
5105 gfc_array_index_type
,
5106 nonempty
, gfc_index_one_node
,
5107 gfc_index_zero_node
));
5110 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
5111 lab1
= gfc_build_label_decl (NULL_TREE
);
5112 TREE_USED (lab1
) = 1;
5113 lab2
= gfc_build_label_decl (NULL_TREE
);
5114 TREE_USED (lab2
) = 1;
5117 /* An offset must be added to the loop
5118 counter to obtain the required position. */
5119 gcc_assert (loop
.from
[0]);
5121 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5122 gfc_index_one_node
, loop
.from
[0]);
5123 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5125 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
5127 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
5128 /* Generate the loop body. */
5129 gfc_start_scalarized_body (&loop
, &body
);
5131 /* If we have a mask, only check this element if the mask is set. */
5134 gfc_init_se (&maskse
, NULL
);
5135 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5137 gfc_conv_expr_val (&maskse
, maskexpr
);
5138 gfc_add_block_to_block (&body
, &maskse
.pre
);
5140 gfc_start_block (&block
);
5143 gfc_init_block (&block
);
5145 /* Compare with the current limit. */
5146 gfc_init_se (&arrayse
, NULL
);
5147 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5148 arrayse
.ss
= arrayss
;
5149 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5150 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5152 gfc_init_se (&backse
, NULL
);
5153 gfc_conv_expr_val (&backse
, backexpr
);
5154 gfc_add_block_to_block (&block
, &backse
.pre
);
5156 /* We do the following if this is a more extreme value. */
5157 gfc_start_block (&ifblock
);
5159 /* Assign the value to the limit... */
5160 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5162 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
5164 stmtblock_t ifblock2
;
5167 gfc_start_block (&ifblock2
);
5168 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5169 loop
.loopvar
[0], offset
);
5170 gfc_add_modify (&ifblock2
, pos
, tmp
);
5171 ifbody2
= gfc_finish_block (&ifblock2
);
5172 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pos
,
5173 gfc_index_zero_node
);
5174 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
5175 build_empty_stmt (input_location
));
5176 gfc_add_expr_to_block (&block
, tmp
);
5179 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5180 loop
.loopvar
[0], offset
);
5181 gfc_add_modify (&ifblock
, pos
, tmp
);
5184 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
5186 ifbody
= gfc_finish_block (&ifblock
);
5188 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
5191 cond
= fold_build2_loc (input_location
,
5192 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5193 logical_type_node
, arrayse
.expr
, limit
);
5196 tree ifbody2
, elsebody2
;
5198 /* We switch to > or >= depending on the value of the BACK argument. */
5199 cond
= gfc_create_var (logical_type_node
, "cond");
5201 gfc_start_block (&ifblock
);
5202 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5203 logical_type_node
, arrayse
.expr
, limit
);
5205 gfc_add_modify (&ifblock
, cond
, b_if
);
5206 ifbody2
= gfc_finish_block (&ifblock
);
5208 gfc_start_block (&elseblock
);
5209 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5210 arrayse
.expr
, limit
);
5212 gfc_add_modify (&elseblock
, cond
, b_else
);
5213 elsebody2
= gfc_finish_block (&elseblock
);
5215 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5216 backse
.expr
, ifbody2
, elsebody2
);
5218 gfc_add_expr_to_block (&block
, tmp
);
5221 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5222 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
5223 build_empty_stmt (input_location
));
5225 gfc_add_expr_to_block (&block
, ifbody
);
5229 /* We enclose the above in if (mask) {...}. If the mask is an
5230 optional argument, generate IF (.NOT. PRESENT(MASK)
5234 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5235 tmp
= gfc_finish_block (&block
);
5236 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5237 build_empty_stmt (input_location
));
5240 tmp
= gfc_finish_block (&block
);
5241 gfc_add_expr_to_block (&body
, tmp
);
5245 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5247 if (HONOR_NANS (DECL_MODE (limit
)))
5249 if (nonempty
!= NULL
)
5251 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
5252 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
5253 build_empty_stmt (input_location
));
5254 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
5258 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
5259 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
5261 /* If we have a mask, only check this element if the mask is set. */
5264 gfc_init_se (&maskse
, NULL
);
5265 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5267 gfc_conv_expr_val (&maskse
, maskexpr
);
5268 gfc_add_block_to_block (&body
, &maskse
.pre
);
5270 gfc_start_block (&block
);
5273 gfc_init_block (&block
);
5275 /* Compare with the current limit. */
5276 gfc_init_se (&arrayse
, NULL
);
5277 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5278 arrayse
.ss
= arrayss
;
5279 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5280 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5282 /* We do the following if this is a more extreme value. */
5283 gfc_start_block (&ifblock
);
5285 /* Assign the value to the limit... */
5286 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5288 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5289 loop
.loopvar
[0], offset
);
5290 gfc_add_modify (&ifblock
, pos
, tmp
);
5292 ifbody
= gfc_finish_block (&ifblock
);
5294 /* We switch to > or >= depending on the value of the BACK argument. */
5296 tree ifbody2
, elsebody2
;
5298 cond
= gfc_create_var (logical_type_node
, "cond");
5300 gfc_start_block (&ifblock
);
5301 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5302 logical_type_node
, arrayse
.expr
, limit
);
5304 gfc_add_modify (&ifblock
, cond
, b_if
);
5305 ifbody2
= gfc_finish_block (&ifblock
);
5307 gfc_start_block (&elseblock
);
5308 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5309 arrayse
.expr
, limit
);
5311 gfc_add_modify (&elseblock
, cond
, b_else
);
5312 elsebody2
= gfc_finish_block (&elseblock
);
5314 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5315 backse
.expr
, ifbody2
, elsebody2
);
5318 gfc_add_expr_to_block (&block
, tmp
);
5319 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5320 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
5321 build_empty_stmt (input_location
));
5323 gfc_add_expr_to_block (&block
, tmp
);
5327 /* We enclose the above in if (mask) {...}. If the mask is
5328 an optional argument, generate IF (.NOT. PRESENT(MASK)
5332 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5333 tmp
= gfc_finish_block (&block
);
5334 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5335 build_empty_stmt (input_location
));
5338 tmp
= gfc_finish_block (&block
);
5339 gfc_add_expr_to_block (&body
, tmp
);
5340 /* Avoid initializing loopvar[0] again, it should be left where
5341 it finished by the first loop. */
5342 loop
.from
[0] = loop
.loopvar
[0];
5345 gfc_trans_scalarizing_loops (&loop
, &body
);
5348 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
5350 /* For a scalar mask, enclose the loop in an if statement. */
5351 if (maskexpr
&& maskss
== NULL
)
5355 gfc_init_se (&maskse
, NULL
);
5356 gfc_conv_expr_val (&maskse
, maskexpr
);
5357 gfc_init_block (&block
);
5358 gfc_add_block_to_block (&block
, &loop
.pre
);
5359 gfc_add_block_to_block (&block
, &loop
.post
);
5360 tmp
= gfc_finish_block (&block
);
5362 /* For the else part of the scalar mask, just initialize
5363 the pos variable the same way as above. */
5365 gfc_init_block (&elseblock
);
5366 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
5367 elsetmp
= gfc_finish_block (&elseblock
);
5368 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5369 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
, elsetmp
);
5370 gfc_add_expr_to_block (&block
, tmp
);
5371 gfc_add_block_to_block (&se
->pre
, &block
);
5375 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5376 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5378 gfc_cleanup_loop (&loop
);
5380 se
->expr
= convert (type
, pos
);
5383 /* Emit code for findloc. */
5386 gfc_conv_intrinsic_findloc (gfc_se
*se
, gfc_expr
*expr
)
5388 gfc_actual_arglist
*array_arg
, *value_arg
, *dim_arg
, *mask_arg
,
5389 *kind_arg
, *back_arg
;
5390 gfc_expr
*value_expr
;
5395 stmtblock_t loopblock
;
5399 tree forward_branch
;
5414 array_arg
= expr
->value
.function
.actual
;
5415 value_arg
= array_arg
->next
;
5416 dim_arg
= value_arg
->next
;
5417 mask_arg
= dim_arg
->next
;
5418 kind_arg
= mask_arg
->next
;
5419 back_arg
= kind_arg
->next
;
5421 /* Remove kind and set ikind. */
5424 ikind
= mpz_get_si (kind_arg
->expr
->value
.integer
);
5425 gfc_free_expr (kind_arg
->expr
);
5426 kind_arg
->expr
= NULL
;
5429 ikind
= gfc_default_integer_kind
;
5431 value_expr
= value_arg
->expr
;
5433 /* Unless it's a string, pass VALUE by value. */
5434 if (value_expr
->ts
.type
!= BT_CHARACTER
)
5435 value_arg
->name
= "%VAL";
5437 /* Pass BACK argument by value. */
5438 back_arg
->name
= "%VAL";
5440 /* Call the library if we have a character function or if
5442 if (se
->ss
|| array_arg
->expr
->ts
.type
== BT_CHARACTER
)
5444 se
->ignore_optional
= 1;
5445 if (expr
->rank
== 0)
5447 /* Remove dim argument. */
5448 gfc_free_expr (dim_arg
->expr
);
5449 dim_arg
->expr
= NULL
;
5451 gfc_conv_intrinsic_funcall (se
, expr
);
5455 type
= gfc_get_int_type (ikind
);
5457 /* Initialize the result. */
5458 resvar
= gfc_create_var (gfc_array_index_type
, "pos");
5459 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (gfc_array_index_type
, 0));
5460 offset
= gfc_create_var (gfc_array_index_type
, "offset");
5462 maskexpr
= mask_arg
->expr
;
5463 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5464 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5465 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5467 /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5469 for (i
= 0 ; i
< 2; i
++)
5471 /* Walk the arguments. */
5472 arrayss
= gfc_walk_expr (array_arg
->expr
);
5473 gcc_assert (arrayss
!= gfc_ss_terminator
);
5475 if (maskexpr
&& maskexpr
->rank
!= 0)
5477 maskss
= gfc_walk_expr (maskexpr
);
5478 gcc_assert (maskss
!= gfc_ss_terminator
);
5483 /* Initialize the scalarizer. */
5484 gfc_init_loopinfo (&loop
);
5485 exit_label
= gfc_build_label_decl (NULL_TREE
);
5486 TREE_USED (exit_label
) = 1;
5488 /* We add the mask first because the number of iterations is
5489 taken from the last ss, and this breaks if an absent
5490 optional argument is used for mask. */
5493 gfc_add_ss_to_loop (&loop
, maskss
);
5494 gfc_add_ss_to_loop (&loop
, arrayss
);
5496 /* Initialize the loop. */
5497 gfc_conv_ss_startstride (&loop
);
5498 gfc_conv_loop_setup (&loop
, &expr
->where
);
5500 /* Calculate the offset. */
5501 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5502 gfc_index_one_node
, loop
.from
[0]);
5503 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5505 gfc_mark_ss_chain_used (arrayss
, 1);
5507 gfc_mark_ss_chain_used (maskss
, 1);
5509 /* The first loop is for BACK=.true. */
5511 loop
.reverse
[0] = GFC_REVERSE_SET
;
5513 /* Generate the loop body. */
5514 gfc_start_scalarized_body (&loop
, &body
);
5516 /* If we have an array mask, only add the element if it is
5520 gfc_init_se (&maskse
, NULL
);
5521 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5523 gfc_conv_expr_val (&maskse
, maskexpr
);
5524 gfc_add_block_to_block (&body
, &maskse
.pre
);
5527 /* If the condition matches then set the return value. */
5528 gfc_start_block (&block
);
5530 /* Add the offset. */
5531 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5533 loop
.loopvar
[0], offset
);
5534 gfc_add_modify (&block
, resvar
, tmp
);
5535 /* And break out of the loop. */
5536 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5537 gfc_add_expr_to_block (&block
, tmp
);
5539 found
= gfc_finish_block (&block
);
5541 /* Check this element. */
5542 gfc_init_se (&arrayse
, NULL
);
5543 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5544 arrayse
.ss
= arrayss
;
5545 gfc_conv_expr_val (&arrayse
, array_arg
->expr
);
5546 gfc_add_block_to_block (&body
, &arrayse
.pre
);
5548 gfc_init_se (&valuese
, NULL
);
5549 gfc_conv_expr_val (&valuese
, value_arg
->expr
);
5550 gfc_add_block_to_block (&body
, &valuese
.pre
);
5552 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5553 arrayse
.expr
, valuese
.expr
);
5555 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
5558 /* We enclose the above in if (mask) {...}. If the mask is
5559 an optional argument, generate IF (.NOT. PRESENT(MASK)
5563 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5564 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5565 build_empty_stmt (input_location
));
5568 gfc_add_expr_to_block (&body
, tmp
);
5569 gfc_add_block_to_block (&body
, &arrayse
.post
);
5571 gfc_trans_scalarizing_loops (&loop
, &body
);
5573 /* Add the exit label. */
5574 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5575 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5576 gfc_start_block (&loopblock
);
5577 gfc_add_block_to_block (&loopblock
, &loop
.pre
);
5578 gfc_add_block_to_block (&loopblock
, &loop
.post
);
5580 forward_branch
= gfc_finish_block (&loopblock
);
5582 back_branch
= gfc_finish_block (&loopblock
);
5584 gfc_cleanup_loop (&loop
);
5587 /* Enclose the two loops in an IF statement. */
5589 gfc_init_se (&backse
, NULL
);
5590 gfc_conv_expr_val (&backse
, back_arg
->expr
);
5591 gfc_add_block_to_block (&se
->pre
, &backse
.pre
);
5592 tmp
= build3_v (COND_EXPR
, backse
.expr
, forward_branch
, back_branch
);
5594 /* For a scalar mask, enclose the loop in an if statement. */
5595 if (maskexpr
&& maskss
== NULL
)
5600 gfc_init_se (&maskse
, NULL
);
5601 gfc_conv_expr_val (&maskse
, maskexpr
);
5602 gfc_init_block (&block
);
5603 gfc_add_expr_to_block (&block
, maskse
.expr
);
5604 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5605 if_stmt
= build3_v (COND_EXPR
, ifmask
, tmp
,
5606 build_empty_stmt (input_location
));
5607 gfc_add_expr_to_block (&block
, if_stmt
);
5608 tmp
= gfc_finish_block (&block
);
5611 gfc_add_expr_to_block (&se
->pre
, tmp
);
5612 se
->expr
= convert (type
, resvar
);
5616 /* Emit code for minval or maxval intrinsic. There are many different cases
5617 we need to handle. For performance reasons we sometimes create two
5618 loops instead of one, where the second one is much simpler.
5619 Examples for minval intrinsic:
5620 1) Result is an array, a call is generated
5621 2) Array mask is used and NaNs need to be supported, rank 1:
5626 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
5629 limit = nonempty ? NaN : huge (limit);
5631 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
5632 3) NaNs need to be supported, but it is known at compile time or cheaply
5633 at runtime whether array is nonempty or not, rank 1:
5636 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
5637 limit = (from <= to) ? NaN : huge (limit);
5639 while (S <= to) { limit = min (a[S], limit); S++; }
5640 4) Array mask is used and NaNs need to be supported, rank > 1:
5649 if (fast) limit = min (a[S1][S2], limit);
5652 if (a[S1][S2] <= limit) {
5663 limit = nonempty ? NaN : huge (limit);
5664 5) NaNs need to be supported, but it is known at compile time or cheaply
5665 at runtime whether array is nonempty or not, rank > 1:
5672 if (fast) limit = min (a[S1][S2], limit);
5674 if (a[S1][S2] <= limit) {
5684 limit = (nonempty_array) ? NaN : huge (limit);
5685 6) NaNs aren't supported, but infinities are. Array mask is used:
5690 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
5693 limit = nonempty ? limit : huge (limit);
5694 7) Same without array mask:
5697 while (S <= to) { limit = min (a[S], limit); S++; }
5698 limit = (from <= to) ? limit : huge (limit);
5699 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
5700 limit = huge (limit);
5702 while (S <= to) { limit = min (a[S], limit); S++); }
5704 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
5705 with array mask instead).
5706 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
5707 setting limit = huge (limit); in the else branch. */
5710 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5720 tree huge_cst
= NULL
, nan_cst
= NULL
;
5722 stmtblock_t block
, block2
;
5724 gfc_actual_arglist
*actual
;
5729 gfc_expr
*arrayexpr
;
5736 gfc_conv_intrinsic_funcall (se
, expr
);
5740 actual
= expr
->value
.function
.actual
;
5741 arrayexpr
= actual
->expr
;
5743 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5745 gfc_actual_arglist
*a2
, *a3
;
5746 a2
= actual
->next
; /* dim */
5747 a3
= a2
->next
; /* mask */
5748 if (a2
->expr
== NULL
|| expr
->rank
== 0)
5750 if (a3
->expr
== NULL
)
5751 actual
->next
= NULL
;
5757 gfc_free_actual_arglist (a2
);
5760 if (a3
->expr
== NULL
)
5763 gfc_free_actual_arglist (a3
);
5765 gfc_conv_intrinsic_funcall (se
, expr
);
5768 type
= gfc_typenode_for_spec (&expr
->ts
);
5769 /* Initialize the result. */
5770 limit
= gfc_create_var (type
, "limit");
5771 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
5772 switch (expr
->ts
.type
)
5775 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
5777 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5779 REAL_VALUE_TYPE real
;
5781 tmp
= build_real (type
, real
);
5785 if (HONOR_NANS (DECL_MODE (limit
)))
5786 nan_cst
= gfc_build_nan (type
, "");
5790 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
5797 /* We start with the most negative possible value for MAXVAL, and the most
5798 positive possible value for MINVAL. The most negative possible value is
5799 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5800 possible value is HUGE in both cases. */
5803 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5805 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
5806 TREE_TYPE (huge_cst
), huge_cst
);
5809 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
5810 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5811 tmp
, build_int_cst (type
, 1));
5813 gfc_add_modify (&se
->pre
, limit
, tmp
);
5815 /* Walk the arguments. */
5816 arrayss
= gfc_walk_expr (arrayexpr
);
5817 gcc_assert (arrayss
!= gfc_ss_terminator
);
5819 actual
= actual
->next
->next
;
5820 gcc_assert (actual
);
5821 maskexpr
= actual
->expr
;
5822 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5823 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5824 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5826 if (maskexpr
&& maskexpr
->rank
!= 0)
5828 maskss
= gfc_walk_expr (maskexpr
);
5829 gcc_assert (maskss
!= gfc_ss_terminator
);
5834 if (gfc_array_size (arrayexpr
, &asize
))
5836 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5838 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5839 logical_type_node
, nonempty
,
5840 gfc_index_zero_node
);
5845 /* Initialize the scalarizer. */
5846 gfc_init_loopinfo (&loop
);
5848 /* We add the mask first because the number of iterations is taken
5849 from the last ss, and this breaks if an absent optional argument
5850 is used for mask. */
5853 gfc_add_ss_to_loop (&loop
, maskss
);
5854 gfc_add_ss_to_loop (&loop
, arrayss
);
5856 /* Initialize the loop. */
5857 gfc_conv_ss_startstride (&loop
);
5859 /* The code generated can have more than one loop in sequence (see the
5860 comment at the function header). This doesn't work well with the
5861 scalarizer, which changes arrays' offset when the scalarization loops
5862 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5863 are currently inlined in the scalar case only. As there is no dependency
5864 to care about in that case, there is no temporary, so that we can use the
5865 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5866 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5867 gfc_trans_scalarized_loop_boundary even later to restore offset.
5868 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5869 should eventually go away. We could either create two loops properly,
5870 or find another way to save/restore the array offsets between the two
5871 loops (without conflicting with temporary management), or use a single
5872 loop minmaxval implementation. See PR 31067. */
5873 loop
.temp_dim
= loop
.dimen
;
5874 gfc_conv_loop_setup (&loop
, &expr
->where
);
5876 if (nonempty
== NULL
&& maskss
== NULL
5877 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5878 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5879 loop
.from
[0], loop
.to
[0]);
5880 nonempty_var
= NULL
;
5881 if (nonempty
== NULL
5882 && (HONOR_INFINITIES (DECL_MODE (limit
))
5883 || HONOR_NANS (DECL_MODE (limit
))))
5885 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
5886 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
5887 nonempty
= nonempty_var
;
5891 if (HONOR_NANS (DECL_MODE (limit
)))
5893 if (loop
.dimen
== 1)
5895 lab
= gfc_build_label_decl (NULL_TREE
);
5896 TREE_USED (lab
) = 1;
5900 fast
= gfc_create_var (logical_type_node
, "fast");
5901 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
5905 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5907 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5908 /* Generate the loop body. */
5909 gfc_start_scalarized_body (&loop
, &body
);
5911 /* If we have a mask, only add this element if the mask is set. */
5914 gfc_init_se (&maskse
, NULL
);
5915 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5917 gfc_conv_expr_val (&maskse
, maskexpr
);
5918 gfc_add_block_to_block (&body
, &maskse
.pre
);
5920 gfc_start_block (&block
);
5923 gfc_init_block (&block
);
5925 /* Compare with the current limit. */
5926 gfc_init_se (&arrayse
, NULL
);
5927 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5928 arrayse
.ss
= arrayss
;
5929 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5930 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5932 gfc_init_block (&block2
);
5935 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
5937 if (HONOR_NANS (DECL_MODE (limit
)))
5939 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5940 logical_type_node
, arrayse
.expr
, limit
);
5942 ifbody
= build1_v (GOTO_EXPR
, lab
);
5945 stmtblock_t ifblock
;
5947 gfc_init_block (&ifblock
);
5948 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5949 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
5950 ifbody
= gfc_finish_block (&ifblock
);
5952 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5953 build_empty_stmt (input_location
));
5954 gfc_add_expr_to_block (&block2
, tmp
);
5958 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5960 tmp
= fold_build2_loc (input_location
,
5961 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5962 type
, arrayse
.expr
, limit
);
5963 gfc_add_modify (&block2
, limit
, tmp
);
5968 tree elsebody
= gfc_finish_block (&block2
);
5970 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5972 if (HONOR_NANS (DECL_MODE (limit
)))
5974 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5975 arrayse
.expr
, limit
);
5976 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5977 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5978 build_empty_stmt (input_location
));
5982 tmp
= fold_build2_loc (input_location
,
5983 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5984 type
, arrayse
.expr
, limit
);
5985 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5987 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5988 gfc_add_expr_to_block (&block
, tmp
);
5991 gfc_add_block_to_block (&block
, &block2
);
5993 gfc_add_block_to_block (&block
, &arrayse
.post
);
5995 tmp
= gfc_finish_block (&block
);
5998 /* We enclose the above in if (mask) {...}. If the mask is an
5999 optional argument, generate IF (.NOT. PRESENT(MASK)
6002 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6003 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6004 build_empty_stmt (input_location
));
6006 gfc_add_expr_to_block (&body
, tmp
);
6010 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
6012 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
6014 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
6015 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
6017 /* If we have a mask, only add this element if the mask is set. */
6020 gfc_init_se (&maskse
, NULL
);
6021 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
6023 gfc_conv_expr_val (&maskse
, maskexpr
);
6024 gfc_add_block_to_block (&body
, &maskse
.pre
);
6026 gfc_start_block (&block
);
6029 gfc_init_block (&block
);
6031 /* Compare with the current limit. */
6032 gfc_init_se (&arrayse
, NULL
);
6033 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
6034 arrayse
.ss
= arrayss
;
6035 gfc_conv_expr_val (&arrayse
, arrayexpr
);
6036 gfc_add_block_to_block (&block
, &arrayse
.pre
);
6038 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6040 if (HONOR_NANS (DECL_MODE (limit
)))
6042 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
6043 arrayse
.expr
, limit
);
6044 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
6045 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
6046 build_empty_stmt (input_location
));
6047 gfc_add_expr_to_block (&block
, tmp
);
6051 tmp
= fold_build2_loc (input_location
,
6052 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6053 type
, arrayse
.expr
, limit
);
6054 gfc_add_modify (&block
, limit
, tmp
);
6057 gfc_add_block_to_block (&block
, &arrayse
.post
);
6059 tmp
= gfc_finish_block (&block
);
6061 /* We enclose the above in if (mask) {...}. */
6064 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6065 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6066 build_empty_stmt (input_location
));
6069 gfc_add_expr_to_block (&body
, tmp
);
6070 /* Avoid initializing loopvar[0] again, it should be left where
6071 it finished by the first loop. */
6072 loop
.from
[0] = loop
.loopvar
[0];
6074 gfc_trans_scalarizing_loops (&loop
, &body
);
6078 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
6080 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
6081 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
6083 gfc_add_expr_to_block (&loop
.pre
, tmp
);
6085 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
6087 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
6089 gfc_add_modify (&loop
.pre
, limit
, tmp
);
6092 /* For a scalar mask, enclose the loop in an if statement. */
6093 if (maskexpr
&& maskss
== NULL
)
6098 gfc_init_se (&maskse
, NULL
);
6099 gfc_conv_expr_val (&maskse
, maskexpr
);
6100 gfc_init_block (&block
);
6101 gfc_add_block_to_block (&block
, &loop
.pre
);
6102 gfc_add_block_to_block (&block
, &loop
.post
);
6103 tmp
= gfc_finish_block (&block
);
6105 if (HONOR_INFINITIES (DECL_MODE (limit
)))
6106 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
6108 else_stmt
= build_empty_stmt (input_location
);
6110 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6111 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
, else_stmt
);
6112 gfc_add_expr_to_block (&block
, tmp
);
6113 gfc_add_block_to_block (&se
->pre
, &block
);
6117 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6118 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
6121 gfc_cleanup_loop (&loop
);
6126 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6128 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
6134 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6135 type
= TREE_TYPE (args
[0]);
6137 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
6138 build_int_cst (type
, 1), args
[1]);
6139 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
6140 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
6141 build_int_cst (type
, 0));
6142 type
= gfc_typenode_for_spec (&expr
->ts
);
6143 se
->expr
= convert (type
, tmp
);
6147 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6149 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6153 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6155 /* Convert both arguments to the unsigned type of the same size. */
6156 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
6157 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
6159 /* If they have unequal type size, convert to the larger one. */
6160 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
6161 > TYPE_PRECISION (TREE_TYPE (args
[1])))
6162 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
6163 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
6164 > TYPE_PRECISION (TREE_TYPE (args
[0])))
6165 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
6167 /* Now, we compare them. */
6168 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
6173 /* Generate code to perform the specified operation. */
6175 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6179 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6180 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
6186 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
6190 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6191 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6192 TREE_TYPE (arg
), arg
);
6195 /* Set or clear a single bit. */
6197 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
6204 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6205 type
= TREE_TYPE (args
[0]);
6207 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
6208 build_int_cst (type
, 1), args
[1]);
6214 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
6216 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
6219 /* Extract a sequence of bits.
6220 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6222 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
6229 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6230 type
= TREE_TYPE (args
[0]);
6232 mask
= build_int_cst (type
, -1);
6233 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
6234 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
6236 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
6238 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
6242 gfc_conv_intrinsic_shape (gfc_se
*se
, gfc_expr
*expr
)
6244 gfc_actual_arglist
*s
, *k
;
6247 /* Remove the KIND argument, if present. */
6248 s
= expr
->value
.function
.actual
;
6254 gfc_conv_intrinsic_funcall (se
, expr
);
6258 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
6261 tree args
[2], type
, num_bits
, cond
;
6263 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6265 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6266 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6267 type
= TREE_TYPE (args
[0]);
6270 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
6272 gcc_assert (right_shift
);
6274 se
->expr
= fold_build2_loc (input_location
,
6275 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
6276 TREE_TYPE (args
[0]), args
[0], args
[1]);
6279 se
->expr
= fold_convert (type
, se
->expr
);
6281 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6282 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6284 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6285 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6288 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6289 build_int_cst (type
, 0), se
->expr
);
6292 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
6294 : ((shift >= 0) ? i << shift : i >> -shift)
6295 where all shifts are logical shifts. */
6297 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
6309 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6311 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6312 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6314 type
= TREE_TYPE (args
[0]);
6315 utype
= unsigned_type_for (type
);
6317 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
6320 /* Left shift if positive. */
6321 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
6323 /* Right shift if negative.
6324 We convert to an unsigned type because we want a logical shift.
6325 The standard doesn't define the case of shifting negative
6326 numbers, and we try to be compatible with other compilers, most
6327 notably g77, here. */
6328 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
6329 utype
, convert (utype
, args
[0]), width
));
6331 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
6332 build_int_cst (TREE_TYPE (args
[1]), 0));
6333 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
6335 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6336 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6338 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6339 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
6341 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6342 build_int_cst (type
, 0), tmp
);
6346 /* Circular shift. AKA rotate or barrel shift. */
6349 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
6357 unsigned int num_args
;
6359 num_args
= gfc_intrinsic_argument_list_length (expr
);
6360 args
= XALLOCAVEC (tree
, num_args
);
6362 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6366 /* Use a library function for the 3 parameter version. */
6367 tree int4type
= gfc_get_int_type (4);
6369 type
= TREE_TYPE (args
[0]);
6370 /* We convert the first argument to at least 4 bytes, and
6371 convert back afterwards. This removes the need for library
6372 functions for all argument sizes, and function will be
6373 aligned to at least 32 bits, so there's no loss. */
6374 if (expr
->ts
.kind
< 4)
6375 args
[0] = convert (int4type
, args
[0]);
6377 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
6378 need loads of library functions. They cannot have values >
6379 BIT_SIZE (I) so the conversion is safe. */
6380 args
[1] = convert (int4type
, args
[1]);
6381 args
[2] = convert (int4type
, args
[2]);
6383 switch (expr
->ts
.kind
)
6388 tmp
= gfor_fndecl_math_ishftc4
;
6391 tmp
= gfor_fndecl_math_ishftc8
;
6394 tmp
= gfor_fndecl_math_ishftc16
;
6399 se
->expr
= build_call_expr_loc (input_location
,
6400 tmp
, 3, args
[0], args
[1], args
[2]);
6401 /* Convert the result back to the original type, if we extended
6402 the first argument's width above. */
6403 if (expr
->ts
.kind
< 4)
6404 se
->expr
= convert (type
, se
->expr
);
6408 type
= TREE_TYPE (args
[0]);
6410 /* Evaluate arguments only once. */
6411 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6412 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6414 /* Rotate left if positive. */
6415 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
6417 /* Rotate right if negative. */
6418 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
6420 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
6422 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
6423 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
6425 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
6427 /* Do nothing if shift == 0. */
6428 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
6430 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
6435 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
6436 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
6438 The conditional expression is necessary because the result of LEADZ(0)
6439 is defined, but the result of __builtin_clz(0) is undefined for most
6442 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
6443 difference in bit size between the argument of LEADZ and the C int. */
6446 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
6458 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6459 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6461 /* Which variant of __builtin_clz* should we call? */
6462 if (argsize
<= INT_TYPE_SIZE
)
6464 arg_type
= unsigned_type_node
;
6465 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
6467 else if (argsize
<= LONG_TYPE_SIZE
)
6469 arg_type
= long_unsigned_type_node
;
6470 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
6472 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6474 arg_type
= long_long_unsigned_type_node
;
6475 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6479 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6480 arg_type
= gfc_build_uint_type (argsize
);
6484 /* Convert the actual argument twice: first, to the unsigned type of the
6485 same size; then, to the proper argument type for the built-in
6486 function. But the return type is of the default INTEGER kind. */
6487 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6488 arg
= fold_convert (arg_type
, arg
);
6489 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6490 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6492 /* Compute LEADZ for the case i .ne. 0. */
6495 s
= TYPE_PRECISION (arg_type
) - argsize
;
6496 tmp
= fold_convert (result_type
,
6497 build_call_expr_loc (input_location
, func
,
6499 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
6500 tmp
, build_int_cst (result_type
, s
));
6504 /* We end up here if the argument type is larger than 'long long'.
6505 We generate this code:
6507 if (x & (ULL_MAX << ULL_SIZE) != 0)
6508 return clzll ((unsigned long long) (x >> ULLSIZE));
6510 return ULL_SIZE + clzll ((unsigned long long) x);
6511 where ULL_MAX is the largest value that a ULL_MAX can hold
6512 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6513 is the bit-size of the long long type (64 in this example). */
6514 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
6516 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
6517 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6518 long_long_unsigned_type_node
,
6519 build_int_cst (long_long_unsigned_type_node
,
6522 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
6523 fold_convert (arg_type
, ullmax
), ullsize
);
6524 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
6526 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6527 cond
, build_int_cst (arg_type
, 0));
6529 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
6531 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
6532 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6533 tmp1
= fold_convert (result_type
,
6534 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
6536 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
6537 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6538 tmp2
= fold_convert (result_type
,
6539 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
6540 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6543 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
6547 /* Build BIT_SIZE. */
6548 bit_size
= build_int_cst (result_type
, argsize
);
6550 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6551 arg
, build_int_cst (arg_type
, 0));
6552 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
6557 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
6559 The conditional expression is necessary because the result of TRAILZ(0)
6560 is defined, but the result of __builtin_ctz(0) is undefined for most
6564 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
6575 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6576 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6578 /* Which variant of __builtin_ctz* should we call? */
6579 if (argsize
<= INT_TYPE_SIZE
)
6581 arg_type
= unsigned_type_node
;
6582 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
6584 else if (argsize
<= LONG_TYPE_SIZE
)
6586 arg_type
= long_unsigned_type_node
;
6587 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
6589 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6591 arg_type
= long_long_unsigned_type_node
;
6592 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6596 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6597 arg_type
= gfc_build_uint_type (argsize
);
6601 /* Convert the actual argument twice: first, to the unsigned type of the
6602 same size; then, to the proper argument type for the built-in
6603 function. But the return type is of the default INTEGER kind. */
6604 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6605 arg
= fold_convert (arg_type
, arg
);
6606 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6607 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6609 /* Compute TRAILZ for the case i .ne. 0. */
6611 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
6615 /* We end up here if the argument type is larger than 'long long'.
6616 We generate this code:
6618 if ((x & ULL_MAX) == 0)
6619 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
6621 return ctzll ((unsigned long long) x);
6623 where ULL_MAX is the largest value that a ULL_MAX can hold
6624 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6625 is the bit-size of the long long type (64 in this example). */
6626 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
6628 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
6629 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6630 long_long_unsigned_type_node
,
6631 build_int_cst (long_long_unsigned_type_node
, 0));
6633 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
6634 fold_convert (arg_type
, ullmax
));
6635 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
6636 build_int_cst (arg_type
, 0));
6638 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
6640 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
6641 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6642 tmp1
= fold_convert (result_type
,
6643 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
6644 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6647 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
6648 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6649 tmp2
= fold_convert (result_type
,
6650 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
6652 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
6656 /* Build BIT_SIZE. */
6657 bit_size
= build_int_cst (result_type
, argsize
);
6659 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6660 arg
, build_int_cst (arg_type
, 0));
6661 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
6665 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
6666 for types larger than "long long", we call the long long built-in for
6667 the lower and higher bits and combine the result. */
6670 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
6678 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6679 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6680 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6682 /* Which variant of the builtin should we call? */
6683 if (argsize
<= INT_TYPE_SIZE
)
6685 arg_type
= unsigned_type_node
;
6686 func
= builtin_decl_explicit (parity
6688 : BUILT_IN_POPCOUNT
);
6690 else if (argsize
<= LONG_TYPE_SIZE
)
6692 arg_type
= long_unsigned_type_node
;
6693 func
= builtin_decl_explicit (parity
6695 : BUILT_IN_POPCOUNTL
);
6697 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6699 arg_type
= long_long_unsigned_type_node
;
6700 func
= builtin_decl_explicit (parity
6702 : BUILT_IN_POPCOUNTLL
);
6706 /* Our argument type is larger than 'long long', which mean none
6707 of the POPCOUNT builtins covers it. We thus call the 'long long'
6708 variant multiple times, and add the results. */
6709 tree utype
, arg2
, call1
, call2
;
6711 /* For now, we only cover the case where argsize is twice as large
6713 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6715 func
= builtin_decl_explicit (parity
6717 : BUILT_IN_POPCOUNTLL
);
6719 /* Convert it to an integer, and store into a variable. */
6720 utype
= gfc_build_uint_type (argsize
);
6721 arg
= fold_convert (utype
, arg
);
6722 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6724 /* Call the builtin twice. */
6725 call1
= build_call_expr_loc (input_location
, func
, 1,
6726 fold_convert (long_long_unsigned_type_node
,
6729 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
6730 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
6731 call2
= build_call_expr_loc (input_location
, func
, 1,
6732 fold_convert (long_long_unsigned_type_node
,
6735 /* Combine the results. */
6737 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
6740 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6746 /* Convert the actual argument twice: first, to the unsigned type of the
6747 same size; then, to the proper argument type for the built-in
6749 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6750 arg
= fold_convert (arg_type
, arg
);
6752 se
->expr
= fold_convert (result_type
,
6753 build_call_expr_loc (input_location
, func
, 1, arg
));
6757 /* Process an intrinsic with unspecified argument-types that has an optional
6758 argument (which could be of type character), e.g. EOSHIFT. For those, we
6759 need to append the string length of the optional argument if it is not
6760 present and the type is really character.
6761 primary specifies the position (starting at 1) of the non-optional argument
6762 specifying the type and optional gives the position of the optional
6763 argument in the arglist. */
6766 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
6767 unsigned primary
, unsigned optional
)
6769 gfc_actual_arglist
* prim_arg
;
6770 gfc_actual_arglist
* opt_arg
;
6772 gfc_actual_arglist
* arg
;
6774 vec
<tree
, va_gc
> *append_args
;
6776 /* Find the two arguments given as position. */
6780 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
6784 if (cur_pos
== primary
)
6786 if (cur_pos
== optional
)
6789 if (cur_pos
>= primary
&& cur_pos
>= optional
)
6792 gcc_assert (prim_arg
);
6793 gcc_assert (prim_arg
->expr
);
6794 gcc_assert (opt_arg
);
6796 /* If we do have type CHARACTER and the optional argument is really absent,
6797 append a dummy 0 as string length. */
6799 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
6803 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
6804 vec_alloc (append_args
, 1);
6805 append_args
->quick_push (dummy
);
6808 /* Build the call itself. */
6809 gcc_assert (!se
->ignore_optional
);
6810 sym
= gfc_get_symbol_for_expr (expr
, false);
6811 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6813 gfc_free_symbol (sym
);
6816 /* The length of a character string. */
6818 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
6827 gcc_assert (!se
->ss
);
6829 arg
= expr
->value
.function
.actual
->expr
;
6831 type
= gfc_typenode_for_spec (&expr
->ts
);
6832 switch (arg
->expr_type
)
6835 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
6839 /* Obtain the string length from the function used by
6840 trans-array.c(gfc_trans_array_constructor). */
6842 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
6846 if (arg
->ref
== NULL
6847 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6849 /* This doesn't catch all cases.
6850 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6851 and the surrounding thread. */
6852 sym
= arg
->symtree
->n
.sym
;
6853 decl
= gfc_get_symbol_decl (sym
);
6854 if (decl
== current_function_decl
&& sym
->attr
.function
6855 && (sym
->result
== sym
))
6856 decl
= gfc_get_fake_result_decl (sym
, 0);
6858 len
= sym
->ts
.u
.cl
->backend_decl
;
6866 gfc_init_se (&argse
, se
);
6868 gfc_conv_expr (&argse
, arg
);
6870 gfc_conv_expr_descriptor (&argse
, arg
);
6871 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6872 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6873 len
= argse
.string_length
;
6876 se
->expr
= convert (type
, len
);
6879 /* The length of a character string not including trailing blanks. */
6881 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6883 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6884 tree args
[2], type
, fndecl
;
6886 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6887 type
= gfc_typenode_for_spec (&expr
->ts
);
6890 fndecl
= gfor_fndecl_string_len_trim
;
6892 fndecl
= gfor_fndecl_string_len_trim_char4
;
6896 se
->expr
= build_call_expr_loc (input_location
,
6897 fndecl
, 2, args
[0], args
[1]);
6898 se
->expr
= convert (type
, se
->expr
);
6902 /* Returns the starting position of a substring within a string. */
6905 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6908 tree logical4_type_node
= gfc_get_logical_type (4);
6912 unsigned int num_args
;
6914 args
= XALLOCAVEC (tree
, 5);
6916 /* Get number of arguments; characters count double due to the
6917 string length argument. Kind= is not passed to the library
6918 and thus ignored. */
6919 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6924 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6925 type
= gfc_typenode_for_spec (&expr
->ts
);
6928 args
[4] = build_int_cst (logical4_type_node
, 0);
6930 args
[4] = convert (logical4_type_node
, args
[4]);
6932 fndecl
= build_addr (function
);
6933 se
->expr
= build_call_array_loc (input_location
,
6934 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6936 se
->expr
= convert (type
, se
->expr
);
6940 /* The ascii value for a single character. */
6942 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6944 tree args
[3], type
, pchartype
;
6947 nargs
= gfc_intrinsic_argument_list_length (expr
);
6948 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6949 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6950 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6951 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6952 type
= gfc_typenode_for_spec (&expr
->ts
);
6954 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6956 se
->expr
= convert (type
, se
->expr
);
6960 /* Intrinsic ISNAN calls __builtin_isnan. */
6963 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6967 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6968 se
->expr
= build_call_expr_loc (input_location
,
6969 builtin_decl_explicit (BUILT_IN_ISNAN
),
6971 STRIP_TYPE_NOPS (se
->expr
);
6972 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6976 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6977 their argument against a constant integer value. */
6980 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6984 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6985 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6986 gfc_typenode_for_spec (&expr
->ts
),
6987 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6992 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6995 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
7003 unsigned int num_args
;
7005 num_args
= gfc_intrinsic_argument_list_length (expr
);
7006 args
= XALLOCAVEC (tree
, num_args
);
7008 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
7009 if (expr
->ts
.type
!= BT_CHARACTER
)
7017 /* We do the same as in the non-character case, but the argument
7018 list is different because of the string length arguments. We
7019 also have to set the string length for the result. */
7026 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
7028 se
->string_length
= len
;
7030 type
= TREE_TYPE (tsource
);
7031 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
7032 fold_convert (type
, fsource
));
7036 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7039 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
7041 tree args
[3], mask
, type
;
7043 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7044 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
7046 type
= TREE_TYPE (args
[0]);
7047 gcc_assert (TREE_TYPE (args
[1]) == type
);
7048 gcc_assert (TREE_TYPE (mask
) == type
);
7050 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
7051 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
7052 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7054 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
7059 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7060 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7063 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
7065 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
7068 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7069 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7071 type
= gfc_get_int_type (expr
->ts
.kind
);
7072 utype
= unsigned_type_for (type
);
7074 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
7075 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
7077 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
7078 build_int_cst (utype
, 0));
7082 /* Left-justified mask. */
7083 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
7085 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
7086 fold_convert (utype
, res
));
7088 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7089 smaller than type width. */
7090 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
7091 build_int_cst (TREE_TYPE (arg
), 0));
7092 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
7093 build_int_cst (utype
, 0), res
);
7097 /* Right-justified mask. */
7098 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
7099 fold_convert (utype
, arg
));
7100 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
7102 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7103 strictly smaller than type width. */
7104 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7106 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
7107 cond
, allones
, res
);
7110 se
->expr
= fold_convert (type
, res
);
7114 /* FRACTION (s) is translated into:
7115 isfinite (s) ? frexp (s, &dummy_int) : NaN */
7117 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
7119 tree arg
, type
, tmp
, res
, frexp
, cond
;
7121 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7123 type
= gfc_typenode_for_spec (&expr
->ts
);
7124 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7125 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7127 cond
= build_call_expr_loc (input_location
,
7128 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7131 tmp
= gfc_create_var (integer_type_node
, NULL
);
7132 res
= build_call_expr_loc (input_location
, frexp
, 2,
7133 fold_convert (type
, arg
),
7134 gfc_build_addr_expr (NULL_TREE
, tmp
));
7135 res
= fold_convert (type
, res
);
7137 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
7138 cond
, res
, gfc_build_nan (type
, ""));
7142 /* NEAREST (s, dir) is translated into
7143 tmp = copysign (HUGE_VAL, dir);
7144 return nextafter (s, tmp);
7147 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
7149 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
7151 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
7152 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
7154 type
= gfc_typenode_for_spec (&expr
->ts
);
7155 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7157 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
7158 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
7159 fold_convert (type
, args
[1]));
7160 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
7161 fold_convert (type
, args
[0]), tmp
);
7162 se
->expr
= fold_convert (type
, se
->expr
);
7166 /* SPACING (s) is translated into
7176 e = MAX_EXPR (e, emin);
7177 res = scalbn (1., e);
7181 where prec is the precision of s, gfc_real_kinds[k].digits,
7182 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7183 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7186 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
7188 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
7189 tree cond
, nan
, tmp
, frexp
, scalbn
;
7193 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7194 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
7195 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
7196 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
7198 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7199 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7201 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7202 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7204 type
= gfc_typenode_for_spec (&expr
->ts
);
7205 e
= gfc_create_var (integer_type_node
, NULL
);
7206 res
= gfc_create_var (type
, NULL
);
7209 /* Build the block for s /= 0. */
7210 gfc_start_block (&block
);
7211 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7212 gfc_build_addr_expr (NULL_TREE
, e
));
7213 gfc_add_expr_to_block (&block
, tmp
);
7215 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
7217 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
7218 integer_type_node
, tmp
, emin
));
7220 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
7221 build_real_from_int_cst (type
, integer_one_node
), e
);
7222 gfc_add_modify (&block
, res
, tmp
);
7224 /* Finish by building the IF statement for value zero. */
7225 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
7226 build_real_from_int_cst (type
, integer_zero_node
));
7227 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
7228 gfc_finish_block (&block
));
7230 /* And deal with infinities and NaNs. */
7231 cond
= build_call_expr_loc (input_location
,
7232 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7234 nan
= gfc_build_nan (type
, "");
7235 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
7237 gfc_add_expr_to_block (&se
->pre
, tmp
);
7242 /* RRSPACING (s) is translated into
7251 x = scalbn (x, precision - e);
7258 where precision is gfc_real_kinds[k].digits. */
7261 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
7263 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
7267 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7268 prec
= gfc_real_kinds
[k
].digits
;
7270 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7271 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7272 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
7274 type
= gfc_typenode_for_spec (&expr
->ts
);
7275 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7276 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7278 e
= gfc_create_var (integer_type_node
, NULL
);
7279 x
= gfc_create_var (type
, NULL
);
7280 gfc_add_modify (&se
->pre
, x
,
7281 build_call_expr_loc (input_location
, fabs
, 1, arg
));
7284 gfc_start_block (&block
);
7285 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7286 gfc_build_addr_expr (NULL_TREE
, e
));
7287 gfc_add_expr_to_block (&block
, tmp
);
7289 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
7290 build_int_cst (integer_type_node
, prec
), e
);
7291 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
7292 gfc_add_modify (&block
, x
, tmp
);
7293 stmt
= gfc_finish_block (&block
);
7296 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
7297 build_real_from_int_cst (type
, integer_zero_node
));
7298 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
7300 /* And deal with infinities and NaNs. */
7301 cond
= build_call_expr_loc (input_location
,
7302 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7304 nan
= gfc_build_nan (type
, "");
7305 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
7307 gfc_add_expr_to_block (&se
->pre
, tmp
);
7308 se
->expr
= fold_convert (type
, x
);
7312 /* SCALE (s, i) is translated into scalbn (s, i). */
7314 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
7316 tree args
[2], type
, scalbn
;
7318 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7320 type
= gfc_typenode_for_spec (&expr
->ts
);
7321 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7322 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
7323 fold_convert (type
, args
[0]),
7324 fold_convert (integer_type_node
, args
[1]));
7325 se
->expr
= fold_convert (type
, se
->expr
);
7329 /* SET_EXPONENT (s, i) is translated into
7330 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
7332 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
7334 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
7336 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7337 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7339 type
= gfc_typenode_for_spec (&expr
->ts
);
7340 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7341 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
7343 tmp
= gfc_create_var (integer_type_node
, NULL
);
7344 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
7345 fold_convert (type
, args
[0]),
7346 gfc_build_addr_expr (NULL_TREE
, tmp
));
7347 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
7348 fold_convert (integer_type_node
, args
[1]));
7349 res
= fold_convert (type
, res
);
7351 /* Call to isfinite */
7352 cond
= build_call_expr_loc (input_location
,
7353 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7355 nan
= gfc_build_nan (type
, "");
7357 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
7363 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
7365 gfc_actual_arglist
*actual
;
7372 gfc_init_se (&argse
, NULL
);
7373 actual
= expr
->value
.function
.actual
;
7375 if (actual
->expr
->ts
.type
== BT_CLASS
)
7376 gfc_add_class_array_ref (actual
->expr
);
7378 argse
.data_not_needed
= 1;
7379 if (gfc_is_class_array_function (actual
->expr
))
7381 /* For functions that return a class array conv_expr_descriptor is not
7382 able to get the descriptor right. Therefore this special case. */
7383 gfc_conv_expr_reference (&argse
, actual
->expr
);
7384 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
7385 gfc_class_data_get (argse
.expr
));
7389 argse
.want_pointer
= 1;
7390 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
7392 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7393 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7394 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
7396 /* Build the call to size0. */
7397 fncall0
= build_call_expr_loc (input_location
,
7398 gfor_fndecl_size0
, 1, arg1
);
7400 actual
= actual
->next
;
7404 gfc_init_se (&argse
, NULL
);
7405 gfc_conv_expr_type (&argse
, actual
->expr
,
7406 gfc_array_index_type
);
7407 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7409 /* Unusually, for an intrinsic, size does not exclude
7410 an optional arg2, so we must test for it. */
7411 if (actual
->expr
->expr_type
== EXPR_VARIABLE
7412 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
7413 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
7416 /* Build the call to size1. */
7417 fncall1
= build_call_expr_loc (input_location
,
7418 gfor_fndecl_size1
, 2,
7421 gfc_init_se (&argse
, NULL
);
7422 argse
.want_pointer
= 1;
7423 argse
.data_not_needed
= 1;
7424 gfc_conv_expr (&argse
, actual
->expr
);
7425 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7426 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7427 argse
.expr
, null_pointer_node
);
7428 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
7429 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
7430 pvoid_type_node
, tmp
, fncall1
, fncall0
);
7434 se
->expr
= NULL_TREE
;
7435 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
7436 gfc_array_index_type
,
7437 argse
.expr
, gfc_index_one_node
);
7440 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
7442 argse
.expr
= gfc_index_zero_node
;
7443 se
->expr
= NULL_TREE
;
7448 if (se
->expr
== NULL_TREE
)
7450 tree ubound
, lbound
;
7452 arg1
= build_fold_indirect_ref_loc (input_location
,
7454 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
7455 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
7456 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
7457 gfc_array_index_type
, ubound
, lbound
);
7458 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
7459 gfc_array_index_type
,
7460 se
->expr
, gfc_index_one_node
);
7461 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7462 gfc_array_index_type
, se
->expr
,
7463 gfc_index_zero_node
);
7466 type
= gfc_typenode_for_spec (&expr
->ts
);
7467 se
->expr
= convert (type
, se
->expr
);
7471 /* Helper function to compute the size of a character variable,
7472 excluding the terminating null characters. The result has
7473 gfc_array_index_type type. */
7476 size_of_string_in_bytes (int kind
, tree string_length
)
7479 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
7481 bytesize
= build_int_cst (gfc_array_index_type
,
7482 gfc_character_kinds
[i
].bit_size
/ 8);
7484 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7486 fold_convert (gfc_array_index_type
, string_length
));
7491 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
7503 gfc_init_se (&argse
, NULL
);
7504 arg
= expr
->value
.function
.actual
->expr
;
7506 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
7507 gfc_conv_expr_descriptor (&argse
, arg
);
7509 gfc_conv_expr_reference (&argse
, arg
);
7511 if (arg
->ts
.type
== BT_ASSUMED
)
7513 /* This only works if an array descriptor has been passed; thus, extract
7514 the size from the descriptor. */
7515 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
7516 == TYPE_PRECISION (size_type_node
));
7517 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
7518 tmp
= DECL_LANG_SPECIFIC (tmp
)
7519 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
7520 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
7521 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
7522 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7524 tmp
= gfc_conv_descriptor_dtype (tmp
);
7525 field
= gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
7526 GFC_DTYPE_ELEM_LEN
);
7527 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7528 tmp
, field
, NULL_TREE
);
7530 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
7532 else if (arg
->ts
.type
== BT_CLASS
)
7534 /* Conv_expr_descriptor returns a component_ref to _data component of the
7535 class object. The class object may be a non-pointer object, e.g.
7536 located on the stack, or a memory location pointed to, e.g. a
7537 parameter, i.e., an indirect_ref. */
7539 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
7540 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
7541 && GFC_DECL_CLASS (TREE_OPERAND (
7542 TREE_OPERAND (argse
.expr
, 0), 0)))
7543 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
7544 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
7545 else if (arg
->rank
> 0
7547 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
7548 /* The scalarizer added an additional temp. To get the class' vptr
7549 one has to look at the original backend_decl. */
7550 byte_size
= gfc_class_vtab_size_get (
7551 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
7553 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
7557 if (arg
->ts
.type
== BT_CHARACTER
)
7558 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
7562 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7565 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7566 byte_size
= fold_convert (gfc_array_index_type
,
7567 size_in_bytes (byte_size
));
7572 se
->expr
= byte_size
;
7575 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
7576 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
7578 if (arg
->rank
== -1)
7580 tree cond
, loop_var
, exit_label
;
7583 tmp
= fold_convert (gfc_array_index_type
,
7584 gfc_conv_descriptor_rank (argse
.expr
));
7585 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
7586 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
7587 exit_label
= gfc_build_label_decl (NULL_TREE
);
7594 source_bytes = source_bytes * array.dim[i].extent;
7598 gfc_start_block (&body
);
7599 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
7601 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7602 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7603 cond
, tmp
, build_empty_stmt (input_location
));
7604 gfc_add_expr_to_block (&body
, tmp
);
7606 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
7607 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
7608 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
7609 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7610 gfc_array_index_type
, tmp
, source_bytes
);
7611 gfc_add_modify (&body
, source_bytes
, tmp
);
7613 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7614 gfc_array_index_type
, loop_var
,
7615 gfc_index_one_node
);
7616 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
7618 tmp
= gfc_finish_block (&body
);
7620 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
7622 gfc_add_expr_to_block (&argse
.pre
, tmp
);
7624 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7625 gfc_add_expr_to_block (&argse
.pre
, tmp
);
7629 /* Obtain the size of the array in bytes. */
7630 for (n
= 0; n
< arg
->rank
; n
++)
7633 idx
= gfc_rank_cst
[n
];
7634 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7635 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7636 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
7637 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7638 gfc_array_index_type
, tmp
, source_bytes
);
7639 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7642 se
->expr
= source_bytes
;
7645 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7650 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
7654 tree type
, result_type
, tmp
;
7656 arg
= expr
->value
.function
.actual
->expr
;
7658 gfc_init_se (&argse
, NULL
);
7659 result_type
= gfc_get_int_type (expr
->ts
.kind
);
7663 if (arg
->ts
.type
== BT_CLASS
)
7665 gfc_add_vptr_component (arg
);
7666 gfc_add_size_component (arg
);
7667 gfc_conv_expr (&argse
, arg
);
7668 tmp
= fold_convert (result_type
, argse
.expr
);
7672 gfc_conv_expr_reference (&argse
, arg
);
7673 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7678 argse
.want_pointer
= 0;
7679 gfc_conv_expr_descriptor (&argse
, arg
);
7680 if (arg
->ts
.type
== BT_CLASS
)
7683 tmp
= gfc_class_vtab_size_get (
7684 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
7686 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
7687 tmp
= fold_convert (result_type
, tmp
);
7690 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7693 /* Obtain the argument's word length. */
7694 if (arg
->ts
.type
== BT_CHARACTER
)
7695 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
7697 tmp
= size_in_bytes (type
);
7698 tmp
= fold_convert (result_type
, tmp
);
7701 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
7702 build_int_cst (result_type
, BITS_PER_UNIT
));
7703 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7707 /* Intrinsic string comparison functions. */
7710 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
7714 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
7717 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
7718 expr
->value
.function
.actual
->expr
->ts
.kind
,
7720 se
->expr
= fold_build2_loc (input_location
, op
,
7721 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
7722 build_int_cst (TREE_TYPE (se
->expr
), 0));
7725 /* Generate a call to the adjustl/adjustr library function. */
7727 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
7735 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
7738 type
= TREE_TYPE (args
[2]);
7739 var
= gfc_conv_string_tmp (se
, type
, len
);
7742 tmp
= build_call_expr_loc (input_location
,
7743 fndecl
, 3, args
[0], args
[1], args
[2]);
7744 gfc_add_expr_to_block (&se
->pre
, tmp
);
7746 se
->string_length
= len
;
7750 /* Generate code for the TRANSFER intrinsic:
7752 DEST = TRANSFER (SOURCE, MOLD)
7754 typeof<DEST> = typeof<MOLD>
7759 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
7761 typeof<DEST> = typeof<MOLD>
7763 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
7764 sizeof (DEST(0) * SIZE). */
7766 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
7782 tree class_ref
= NULL_TREE
;
7783 gfc_actual_arglist
*arg
;
7785 gfc_array_info
*info
;
7789 gfc_expr
*source_expr
, *mold_expr
, *class_expr
;
7793 info
= &se
->ss
->info
->data
.array
;
7795 /* Convert SOURCE. The output from this stage is:-
7796 source_bytes = length of the source in bytes
7797 source = pointer to the source data. */
7798 arg
= expr
->value
.function
.actual
;
7799 source_expr
= arg
->expr
;
7801 /* Ensure double transfer through LOGICAL preserves all
7803 if (arg
->expr
->expr_type
== EXPR_FUNCTION
7804 && arg
->expr
->value
.function
.esym
== NULL
7805 && arg
->expr
->value
.function
.isym
!= NULL
7806 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
7807 && arg
->expr
->ts
.type
== BT_LOGICAL
7808 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
7809 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
7811 gfc_init_se (&argse
, NULL
);
7813 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7815 /* Obtain the pointer to source and the length of source in bytes. */
7816 if (arg
->expr
->rank
== 0)
7818 gfc_conv_expr_reference (&argse
, arg
->expr
);
7819 if (arg
->expr
->ts
.type
== BT_CLASS
)
7821 tmp
= build_fold_indirect_ref_loc (input_location
, argse
.expr
);
7822 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
7823 source
= gfc_class_data_get (tmp
);
7826 /* Array elements are evaluated as a reference to the data.
7827 To obtain the vptr for the element size, the argument
7828 expression must be stripped to the class reference and
7829 re-evaluated. The pre and post blocks are not needed. */
7830 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
7831 source
= argse
.expr
;
7832 class_expr
= gfc_find_and_cut_at_last_class_ref (arg
->expr
);
7833 gfc_init_se (&argse
, NULL
);
7834 gfc_conv_expr (&argse
, class_expr
);
7835 class_ref
= argse
.expr
;
7839 source
= argse
.expr
;
7841 /* Obtain the source word length. */
7842 switch (arg
->expr
->ts
.type
)
7845 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7846 argse
.string_length
);
7849 if (class_ref
!= NULL_TREE
)
7850 tmp
= gfc_class_vtab_size_get (class_ref
);
7852 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7855 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7857 tmp
= fold_convert (gfc_array_index_type
,
7858 size_in_bytes (source_type
));
7864 argse
.want_pointer
= 0;
7865 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7866 source
= gfc_conv_descriptor_data_get (argse
.expr
);
7867 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7869 /* Repack the source if not simply contiguous. */
7870 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
7872 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
7874 if (warn_array_temporaries
)
7875 gfc_warning (OPT_Warray_temporaries
,
7876 "Creating array temporary at %L", &expr
->where
);
7878 source
= build_call_expr_loc (input_location
,
7879 gfor_fndecl_in_pack
, 1, tmp
);
7880 source
= gfc_evaluate_now (source
, &argse
.pre
);
7882 /* Free the temporary. */
7883 gfc_start_block (&block
);
7884 tmp
= gfc_call_free (source
);
7885 gfc_add_expr_to_block (&block
, tmp
);
7886 stmt
= gfc_finish_block (&block
);
7888 /* Clean up if it was repacked. */
7889 gfc_init_block (&block
);
7890 tmp
= gfc_conv_array_data (argse
.expr
);
7891 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7893 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7894 build_empty_stmt (input_location
));
7895 gfc_add_expr_to_block (&block
, tmp
);
7896 gfc_add_block_to_block (&block
, &se
->post
);
7897 gfc_init_block (&se
->post
);
7898 gfc_add_block_to_block (&se
->post
, &block
);
7901 /* Obtain the source word length. */
7902 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7903 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7904 argse
.string_length
);
7906 tmp
= fold_convert (gfc_array_index_type
,
7907 size_in_bytes (source_type
));
7909 /* Obtain the size of the array in bytes. */
7910 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7911 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7914 idx
= gfc_rank_cst
[n
];
7915 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7916 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7917 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7918 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7919 gfc_array_index_type
, upper
, lower
);
7920 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7921 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7922 gfc_array_index_type
, extent
,
7923 gfc_index_one_node
);
7924 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7925 gfc_array_index_type
, tmp
, source_bytes
);
7929 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7930 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7931 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7933 /* Now convert MOLD. The outputs are:
7934 mold_type = the TREE type of MOLD
7935 dest_word_len = destination word length in bytes. */
7937 mold_expr
= arg
->expr
;
7939 gfc_init_se (&argse
, NULL
);
7941 scalar_mold
= arg
->expr
->rank
== 0;
7943 if (arg
->expr
->rank
== 0)
7945 gfc_conv_expr_reference (&argse
, arg
->expr
);
7946 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7951 gfc_init_se (&argse
, NULL
);
7952 argse
.want_pointer
= 0;
7953 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7954 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7957 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7958 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7960 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7962 /* If this TRANSFER is nested in another TRANSFER, use a type
7963 that preserves all bits. */
7964 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7965 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7968 /* Obtain the destination word length. */
7969 switch (arg
->expr
->ts
.type
)
7972 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7973 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7976 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7979 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7982 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7983 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7985 /* Finally convert SIZE, if it is present. */
7987 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7991 gfc_init_se (&argse
, NULL
);
7992 gfc_conv_expr_reference (&argse
, arg
->expr
);
7993 tmp
= convert (gfc_array_index_type
,
7994 build_fold_indirect_ref_loc (input_location
,
7996 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7997 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8002 /* Separate array and scalar results. */
8003 if (scalar_mold
&& tmp
== NULL_TREE
)
8004 goto scalar_transfer
;
8006 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
8007 if (tmp
!= NULL_TREE
)
8008 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8009 tmp
, dest_word_len
);
8013 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
8014 gfc_add_modify (&se
->pre
, size_words
,
8015 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
8016 gfc_array_index_type
,
8017 size_bytes
, dest_word_len
));
8019 /* Evaluate the bounds of the result. If the loop range exists, we have
8020 to check if it is too large. If so, we modify loop->to be consistent
8021 with min(size, size(source)). Otherwise, size is made consistent with
8022 the loop range, so that the right number of bytes is transferred.*/
8023 n
= se
->loop
->order
[0];
8024 if (se
->loop
->to
[n
] != NULL_TREE
)
8026 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8027 se
->loop
->to
[n
], se
->loop
->from
[n
]);
8028 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8029 tmp
, gfc_index_one_node
);
8030 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
8032 gfc_add_modify (&se
->pre
, size_words
, tmp
);
8033 gfc_add_modify (&se
->pre
, size_bytes
,
8034 fold_build2_loc (input_location
, MULT_EXPR
,
8035 gfc_array_index_type
,
8036 size_words
, dest_word_len
));
8037 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8038 size_words
, se
->loop
->from
[n
]);
8039 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8040 upper
, gfc_index_one_node
);
8044 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8045 size_words
, gfc_index_one_node
);
8046 se
->loop
->from
[n
] = gfc_index_zero_node
;
8049 se
->loop
->to
[n
] = upper
;
8051 /* Build a destination descriptor, using the pointer, source, as the
8053 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
8054 NULL_TREE
, false, true, false, &expr
->where
);
8056 /* Cast the pointer to the result. */
8057 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
8058 tmp
= fold_convert (pvoid_type_node
, tmp
);
8060 /* Use memcpy to do the transfer. */
8062 = build_call_expr_loc (input_location
,
8063 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
8064 fold_convert (pvoid_type_node
, source
),
8065 fold_convert (size_type_node
,
8066 fold_build2_loc (input_location
,
8068 gfc_array_index_type
,
8071 gfc_add_expr_to_block (&se
->pre
, tmp
);
8073 se
->expr
= info
->descriptor
;
8074 if (expr
->ts
.type
== BT_CHARACTER
)
8075 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
8079 /* Deal with scalar results. */
8081 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
8082 dest_word_len
, source_bytes
);
8083 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
8084 extent
, gfc_index_zero_node
);
8086 if (expr
->ts
.type
== BT_CHARACTER
)
8088 tree direct
, indirect
, free
;
8090 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
8091 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
8094 /* If source is longer than the destination, use a pointer to
8095 the source directly. */
8096 gfc_init_block (&block
);
8097 gfc_add_modify (&block
, tmpdecl
, ptr
);
8098 direct
= gfc_finish_block (&block
);
8100 /* Otherwise, allocate a string with the length of the destination
8101 and copy the source into it. */
8102 gfc_init_block (&block
);
8103 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
8104 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
8105 gfc_add_modify (&block
, tmpdecl
,
8106 fold_convert (TREE_TYPE (ptr
), tmp
));
8107 tmp
= build_call_expr_loc (input_location
,
8108 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
8109 fold_convert (pvoid_type_node
, tmpdecl
),
8110 fold_convert (pvoid_type_node
, ptr
),
8111 fold_convert (size_type_node
, extent
));
8112 gfc_add_expr_to_block (&block
, tmp
);
8113 indirect
= gfc_finish_block (&block
);
8115 /* Wrap it up with the condition. */
8116 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
8117 dest_word_len
, source_bytes
);
8118 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
8119 gfc_add_expr_to_block (&se
->pre
, tmp
);
8121 /* Free the temporary string, if necessary. */
8122 free
= gfc_call_free (tmpdecl
);
8123 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8124 dest_word_len
, source_bytes
);
8125 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
8126 gfc_add_expr_to_block (&se
->post
, tmp
);
8129 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
8133 tmpdecl
= gfc_create_var (mold_type
, "transfer");
8135 ptr
= convert (build_pointer_type (mold_type
), source
);
8137 /* For CLASS results, allocate the needed memory first. */
8138 if (mold_expr
->ts
.type
== BT_CLASS
)
8141 cdata
= gfc_class_data_get (tmpdecl
);
8142 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
8143 gfc_add_modify (&se
->pre
, cdata
, tmp
);
8146 /* Use memcpy to do the transfer. */
8147 if (mold_expr
->ts
.type
== BT_CLASS
)
8148 tmp
= gfc_class_data_get (tmpdecl
);
8150 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
8152 tmp
= build_call_expr_loc (input_location
,
8153 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
8154 fold_convert (pvoid_type_node
, tmp
),
8155 fold_convert (pvoid_type_node
, ptr
),
8156 fold_convert (size_type_node
, extent
));
8157 gfc_add_expr_to_block (&se
->pre
, tmp
);
8159 /* For CLASS results, set the _vptr. */
8160 if (mold_expr
->ts
.type
== BT_CLASS
)
8164 vptr
= gfc_class_vptr_get (tmpdecl
);
8165 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
8167 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
8168 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
8176 /* Generate a call to caf_is_present. */
8179 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
8181 tree caf_reference
, caf_decl
, token
, image_index
;
8183 /* Compile the reference chain. */
8184 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
8185 gcc_assert (caf_reference
!= NULL_TREE
);
8187 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
8188 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8189 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8190 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
8191 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
8194 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
8195 3, token
, image_index
, caf_reference
);
8199 /* Test whether this ref-chain refs this image only. */
8202 caf_this_image_ref (gfc_ref
*ref
)
8204 for ( ; ref
; ref
= ref
->next
)
8205 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
8206 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
8212 /* Generate code for the ALLOCATED intrinsic.
8213 Generate inline code that directly check the address of the argument. */
8216 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
8218 gfc_actual_arglist
*arg1
;
8221 symbol_attribute caf_attr
;
8223 gfc_init_se (&arg1se
, NULL
);
8224 arg1
= expr
->value
.function
.actual
;
8226 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8228 /* Make sure that class array expressions have both a _data
8229 component reference and an array reference.... */
8230 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
8231 gfc_add_class_array_ref (arg1
->expr
);
8232 /* .... whilst scalars only need the _data component. */
8234 gfc_add_data_component (arg1
->expr
);
8237 /* When arg1 references an allocatable component in a coarray, then call
8238 the caf-library function caf_is_present (). */
8239 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
8240 && arg1
->expr
->value
.function
.isym
8241 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8242 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
8244 gfc_clear_attr (&caf_attr
);
8245 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
8246 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
8247 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
8250 if (arg1
->expr
->rank
== 0)
8252 /* Allocatable scalar. */
8253 arg1se
.want_pointer
= 1;
8254 gfc_conv_expr (&arg1se
, arg1
->expr
);
8259 /* Allocatable array. */
8260 arg1se
.descriptor_only
= 1;
8261 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8262 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8265 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
8266 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
8269 /* Components of pointer array references sometimes come back with a pre block. */
8270 if (arg1se
.pre
.head
)
8271 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8273 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
8277 /* Generate code for the ASSOCIATED intrinsic.
8278 If both POINTER and TARGET are arrays, generate a call to library function
8279 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
8280 In other cases, generate inline code that directly compare the address of
8281 POINTER with the address of TARGET. */
8284 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
8286 gfc_actual_arglist
*arg1
;
8287 gfc_actual_arglist
*arg2
;
8292 tree nonzero_charlen
;
8293 tree nonzero_arraylen
;
8297 gfc_init_se (&arg1se
, NULL
);
8298 gfc_init_se (&arg2se
, NULL
);
8299 arg1
= expr
->value
.function
.actual
;
8302 /* Check whether the expression is a scalar or not; we cannot use
8303 arg1->expr->rank as it can be nonzero for proc pointers. */
8304 ss
= gfc_walk_expr (arg1
->expr
);
8305 scalar
= ss
== gfc_ss_terminator
;
8307 gfc_free_ss_chain (ss
);
8311 /* No optional target. */
8314 /* A pointer to a scalar. */
8315 arg1se
.want_pointer
= 1;
8316 gfc_conv_expr (&arg1se
, arg1
->expr
);
8317 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8318 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
8319 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
8321 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8323 tmp2
= gfc_class_data_get (arg1se
.expr
);
8324 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
8325 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
8332 /* A pointer to an array. */
8333 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8334 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8336 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8337 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8338 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
8339 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
8344 /* An optional target. */
8345 if (arg2
->expr
->ts
.type
== BT_CLASS
)
8346 gfc_add_data_component (arg2
->expr
);
8348 nonzero_charlen
= NULL_TREE
;
8349 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
8350 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
8352 arg1
->expr
->ts
.u
.cl
->backend_decl
,
8354 (TREE_TYPE (arg1
->expr
->ts
.u
.cl
->backend_decl
)));
8357 /* A pointer to a scalar. */
8358 arg1se
.want_pointer
= 1;
8359 gfc_conv_expr (&arg1se
, arg1
->expr
);
8360 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8361 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
8362 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
8364 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8365 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
8367 arg2se
.want_pointer
= 1;
8368 gfc_conv_expr (&arg2se
, arg2
->expr
);
8369 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8370 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
8371 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
8373 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8374 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8375 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8376 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8377 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8378 arg1se
.expr
, arg2se
.expr
);
8379 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8380 arg1se
.expr
, null_pointer_node
);
8381 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8382 logical_type_node
, tmp
, tmp2
);
8386 /* An array pointer of zero length is not associated if target is
8388 arg1se
.descriptor_only
= 1;
8389 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
8390 if (arg1
->expr
->rank
== -1)
8392 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
8393 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8394 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
8397 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
8398 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
8399 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
8400 logical_type_node
, tmp
,
8401 build_int_cst (TREE_TYPE (tmp
), 0));
8403 /* A pointer to an array, call library function _gfor_associated. */
8404 arg1se
.want_pointer
= 1;
8405 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8406 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8407 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8409 arg2se
.want_pointer
= 1;
8410 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
8411 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8412 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8413 se
->expr
= build_call_expr_loc (input_location
,
8414 gfor_fndecl_associated
, 2,
8415 arg1se
.expr
, arg2se
.expr
);
8416 se
->expr
= convert (logical_type_node
, se
->expr
);
8417 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8418 logical_type_node
, se
->expr
,
8422 /* If target is present zero character length pointers cannot
8424 if (nonzero_charlen
!= NULL_TREE
)
8425 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8427 se
->expr
, nonzero_charlen
);
8430 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8434 /* Generate code for the SAME_TYPE_AS intrinsic.
8435 Generate inline code that directly checks the vindices. */
8438 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
8443 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
8445 gfc_init_se (&se1
, NULL
);
8446 gfc_init_se (&se2
, NULL
);
8448 a
= expr
->value
.function
.actual
->expr
;
8449 b
= expr
->value
.function
.actual
->next
->expr
;
8451 if (UNLIMITED_POLY (a
))
8453 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
8454 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8455 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
8458 if (UNLIMITED_POLY (b
))
8460 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
8461 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8462 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
8465 if (a
->ts
.type
== BT_CLASS
)
8467 gfc_add_vptr_component (a
);
8468 gfc_add_hash_component (a
);
8470 else if (a
->ts
.type
== BT_DERIVED
)
8471 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8472 a
->ts
.u
.derived
->hash_value
);
8474 if (b
->ts
.type
== BT_CLASS
)
8476 gfc_add_vptr_component (b
);
8477 gfc_add_hash_component (b
);
8479 else if (b
->ts
.type
== BT_DERIVED
)
8480 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8481 b
->ts
.u
.derived
->hash_value
);
8483 gfc_conv_expr (&se1
, a
);
8484 gfc_conv_expr (&se2
, b
);
8486 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
8487 logical_type_node
, se1
.expr
,
8488 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
8491 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
8492 logical_type_node
, conda
, tmp
);
8495 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
8496 logical_type_node
, condb
, tmp
);
8498 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
8502 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
8505 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
8509 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
8510 se
->expr
= build_call_expr_loc (input_location
,
8511 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
8512 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8516 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
8519 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
8523 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8525 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
8526 type
= gfc_get_int_type (4);
8527 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
8529 /* Convert it to the required type. */
8530 type
= gfc_typenode_for_spec (&expr
->ts
);
8531 se
->expr
= build_call_expr_loc (input_location
,
8532 gfor_fndecl_si_kind
, 1, arg
);
8533 se
->expr
= fold_convert (type
, se
->expr
);
8537 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
8540 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
8542 gfc_actual_arglist
*actual
;
8545 vec
<tree
, va_gc
> *args
= NULL
;
8547 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
8549 gfc_init_se (&argse
, se
);
8551 /* Pass a NULL pointer for an absent arg. */
8552 if (actual
->expr
== NULL
)
8553 argse
.expr
= null_pointer_node
;
8559 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
8561 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
8562 ts
.type
= BT_INTEGER
;
8563 ts
.kind
= gfc_c_int_kind
;
8564 gfc_convert_type (actual
->expr
, &ts
, 2);
8566 gfc_conv_expr_reference (&argse
, actual
->expr
);
8569 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8570 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8571 vec_safe_push (args
, argse
.expr
);
8574 /* Convert it to the required type. */
8575 type
= gfc_typenode_for_spec (&expr
->ts
);
8576 se
->expr
= build_call_expr_loc_vec (input_location
,
8577 gfor_fndecl_sr_kind
, args
);
8578 se
->expr
= fold_convert (type
, se
->expr
);
8582 /* Generate code for TRIM (A) intrinsic function. */
8585 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
8595 unsigned int num_args
;
8597 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
8598 args
= XALLOCAVEC (tree
, num_args
);
8600 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
8601 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
8602 len
= gfc_create_var (gfc_charlen_type_node
, "len");
8604 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
8605 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
8608 if (expr
->ts
.kind
== 1)
8609 function
= gfor_fndecl_string_trim
;
8610 else if (expr
->ts
.kind
== 4)
8611 function
= gfor_fndecl_string_trim_char4
;
8615 fndecl
= build_addr (function
);
8616 tmp
= build_call_array_loc (input_location
,
8617 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
8619 gfc_add_expr_to_block (&se
->pre
, tmp
);
8621 /* Free the temporary afterwards, if necessary. */
8622 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8623 len
, build_int_cst (TREE_TYPE (len
), 0));
8624 tmp
= gfc_call_free (var
);
8625 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
8626 gfc_add_expr_to_block (&se
->post
, tmp
);
8629 se
->string_length
= len
;
8633 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
8636 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
8638 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
8639 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
8641 stmtblock_t block
, body
;
8644 /* We store in charsize the size of a character. */
8645 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
8646 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
8648 /* Get the arguments. */
8649 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
8650 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
8652 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
8653 ncopies_type
= TREE_TYPE (ncopies
);
8655 /* Check that NCOPIES is not negative. */
8656 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
8657 build_int_cst (ncopies_type
, 0));
8658 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
8659 "Argument NCOPIES of REPEAT intrinsic is negative "
8660 "(its value is %ld)",
8661 fold_convert (long_integer_type_node
, ncopies
));
8663 /* If the source length is zero, any non negative value of NCOPIES
8664 is valid, and nothing happens. */
8665 n
= gfc_create_var (ncopies_type
, "ncopies");
8666 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
8668 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
8669 build_int_cst (ncopies_type
, 0), ncopies
);
8670 gfc_add_modify (&se
->pre
, n
, tmp
);
8673 /* Check that ncopies is not too large: ncopies should be less than
8674 (or equal to) MAX / slen, where MAX is the maximal integer of
8675 the gfc_charlen_type_node type. If slen == 0, we need a special
8676 case to avoid the division by zero. */
8677 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
8678 fold_convert (sizetype
,
8679 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
8681 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
8682 ? sizetype
: ncopies_type
;
8683 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8684 fold_convert (largest
, ncopies
),
8685 fold_convert (largest
, max
));
8686 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
8688 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
8689 logical_false_node
, cond
);
8690 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
8691 "Argument NCOPIES of REPEAT intrinsic is too large");
8693 /* Compute the destination length. */
8694 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
8695 fold_convert (gfc_charlen_type_node
, slen
),
8696 fold_convert (gfc_charlen_type_node
, ncopies
));
8697 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
8698 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
8700 /* Generate the code to do the repeat operation:
8701 for (i = 0; i < ncopies; i++)
8702 memmove (dest + (i * slen * size), src, slen*size); */
8703 gfc_start_block (&block
);
8704 count
= gfc_create_var (sizetype
, "count");
8705 gfc_add_modify (&block
, count
, size_zero_node
);
8706 exit_label
= gfc_build_label_decl (NULL_TREE
);
8708 /* Start the loop body. */
8709 gfc_start_block (&body
);
8711 /* Exit the loop if count >= ncopies. */
8712 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
8713 fold_convert (sizetype
, ncopies
));
8714 tmp
= build1_v (GOTO_EXPR
, exit_label
);
8715 TREE_USED (exit_label
) = 1;
8716 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
8717 build_empty_stmt (input_location
));
8718 gfc_add_expr_to_block (&body
, tmp
);
8720 /* Call memmove (dest + (i*slen*size), src, slen*size). */
8721 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
8723 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
8725 tmp
= fold_build_pointer_plus_loc (input_location
,
8726 fold_convert (pvoid_type_node
, dest
), tmp
);
8727 tmp
= build_call_expr_loc (input_location
,
8728 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
8730 fold_build2_loc (input_location
, MULT_EXPR
,
8731 size_type_node
, slen
, size
));
8732 gfc_add_expr_to_block (&body
, tmp
);
8734 /* Increment count. */
8735 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
8736 count
, size_one_node
);
8737 gfc_add_modify (&body
, count
, tmp
);
8739 /* Build the loop. */
8740 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
8741 gfc_add_expr_to_block (&block
, tmp
);
8743 /* Add the exit label. */
8744 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8745 gfc_add_expr_to_block (&block
, tmp
);
8747 /* Finish the block. */
8748 tmp
= gfc_finish_block (&block
);
8749 gfc_add_expr_to_block (&se
->pre
, tmp
);
8751 /* Set the result value. */
8753 se
->string_length
= dlen
;
8757 /* Generate code for the IARGC intrinsic. */
8760 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
8766 /* Call the library function. This always returns an INTEGER(4). */
8767 fndecl
= gfor_fndecl_iargc
;
8768 tmp
= build_call_expr_loc (input_location
,
8771 /* Convert it to the required type. */
8772 type
= gfc_typenode_for_spec (&expr
->ts
);
8773 tmp
= fold_convert (type
, tmp
);
8779 /* Generate code for the KILL intrinsic. */
8782 conv_intrinsic_kill (gfc_se
*se
, gfc_expr
*expr
)
8785 tree int4_type_node
= gfc_get_int_type (4);
8789 unsigned int num_args
;
8791 num_args
= gfc_intrinsic_argument_list_length (expr
);
8792 args
= XALLOCAVEC (tree
, num_args
);
8793 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
8795 /* Convert PID to a INTEGER(4) entity. */
8796 pid
= convert (int4_type_node
, args
[0]);
8798 /* Convert SIG to a INTEGER(4) entity. */
8799 sig
= convert (int4_type_node
, args
[1]);
8801 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill
, 2, pid
, sig
);
8803 se
->expr
= fold_convert (TREE_TYPE (args
[0]), tmp
);
8808 conv_intrinsic_kill_sub (gfc_code
*code
)
8812 tree int4_type_node
= gfc_get_int_type (4);
8818 /* Make the function call. */
8819 gfc_init_block (&block
);
8820 gfc_init_se (&se
, NULL
);
8822 /* Convert PID to a INTEGER(4) entity. */
8823 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
8824 gfc_add_block_to_block (&block
, &se
.pre
);
8825 pid
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
8826 gfc_add_block_to_block (&block
, &se
.post
);
8828 /* Convert SIG to a INTEGER(4) entity. */
8829 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
8830 gfc_add_block_to_block (&block
, &se
.pre
);
8831 sig
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
8832 gfc_add_block_to_block (&block
, &se
.post
);
8834 /* Deal with an optional STATUS. */
8835 if (code
->ext
.actual
->next
->next
->expr
)
8837 gfc_init_se (&se_stat
, NULL
);
8838 gfc_conv_expr (&se_stat
, code
->ext
.actual
->next
->next
->expr
);
8839 statp
= gfc_create_var (gfc_get_int_type (4), "_statp");
8844 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill_sub
, 3, pid
, sig
,
8845 statp
? gfc_build_addr_expr (NULL_TREE
, statp
) : null_pointer_node
);
8847 gfc_add_expr_to_block (&block
, tmp
);
8849 if (statp
&& statp
!= se_stat
.expr
)
8850 gfc_add_modify (&block
, se_stat
.expr
,
8851 fold_convert (TREE_TYPE (se_stat
.expr
), statp
));
8853 return gfc_finish_block (&block
);
8858 /* The loc intrinsic returns the address of its argument as
8859 gfc_index_integer_kind integer. */
8862 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
8867 gcc_assert (!se
->ss
);
8869 arg_expr
= expr
->value
.function
.actual
->expr
;
8870 if (arg_expr
->rank
== 0)
8872 if (arg_expr
->ts
.type
== BT_CLASS
)
8873 gfc_add_data_component (arg_expr
);
8874 gfc_conv_expr_reference (se
, arg_expr
);
8877 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
8878 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
8880 /* Create a temporary variable for loc return value. Without this,
8881 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
8882 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
8883 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
8884 se
->expr
= temp_var
;
8888 /* The following routine generates code for the intrinsic
8889 functions from the ISO_C_BINDING module:
8895 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
8897 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
8899 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
8901 if (arg
->expr
->rank
== 0)
8902 gfc_conv_expr_reference (se
, arg
->expr
);
8903 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
8904 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
8907 gfc_conv_expr_descriptor (se
, arg
->expr
);
8908 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
8911 /* TODO -- the following two lines shouldn't be necessary, but if
8912 they're removed, a bug is exposed later in the code path.
8913 This workaround was thus introduced, but will have to be
8914 removed; please see PR 35150 for details about the issue. */
8915 se
->expr
= convert (pvoid_type_node
, se
->expr
);
8916 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
8918 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
8919 gfc_conv_expr_reference (se
, arg
->expr
);
8920 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
8925 /* Build the addr_expr for the first argument. The argument is
8926 already an *address* so we don't need to set want_pointer in
8928 gfc_init_se (&arg1se
, NULL
);
8929 gfc_conv_expr (&arg1se
, arg
->expr
);
8930 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8931 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8933 /* See if we were given two arguments. */
8934 if (arg
->next
->expr
== NULL
)
8935 /* Only given one arg so generate a null and do a
8936 not-equal comparison against the first arg. */
8937 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8939 fold_convert (TREE_TYPE (arg1se
.expr
),
8940 null_pointer_node
));
8946 /* Given two arguments so build the arg2se from second arg. */
8947 gfc_init_se (&arg2se
, NULL
);
8948 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
8949 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8950 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8952 /* Generate test to compare that the two args are equal. */
8953 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8954 arg1se
.expr
, arg2se
.expr
);
8955 /* Generate test to ensure that the first arg is not null. */
8956 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
8958 arg1se
.expr
, null_pointer_node
);
8960 /* Finally, the generated test must check that both arg1 is not
8961 NULL and that it is equal to the second arg. */
8962 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8964 not_null_expr
, eq_expr
);
8972 /* The following routine generates code for the intrinsic
8973 subroutines from the ISO_C_BINDING module:
8975 * C_F_PROCPOINTER. */
8978 conv_isocbinding_subroutine (gfc_code
*code
)
8985 tree desc
, dim
, tmp
, stride
, offset
;
8986 stmtblock_t body
, block
;
8988 gfc_actual_arglist
*arg
= code
->ext
.actual
;
8990 gfc_init_se (&se
, NULL
);
8991 gfc_init_se (&cptrse
, NULL
);
8992 gfc_conv_expr (&cptrse
, arg
->expr
);
8993 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
8994 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
8996 gfc_init_se (&fptrse
, NULL
);
8997 if (arg
->next
->expr
->rank
== 0)
8999 fptrse
.want_pointer
= 1;
9000 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
9001 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
9002 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
9003 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
9004 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
9005 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
9007 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9008 TREE_TYPE (fptrse
.expr
),
9010 fold_convert (TREE_TYPE (fptrse
.expr
),
9012 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
9013 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9014 return gfc_finish_block (&se
.pre
);
9017 gfc_start_block (&block
);
9019 /* Get the descriptor of the Fortran pointer. */
9020 fptrse
.descriptor_only
= 1;
9021 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
9022 gfc_add_block_to_block (&block
, &fptrse
.pre
);
9025 /* Set the span field. */
9026 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
9027 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9028 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
9030 /* Set data value, dtype, and offset. */
9031 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
9032 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
9033 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
9034 gfc_get_dtype (TREE_TYPE (desc
)));
9036 /* Start scalarization of the bounds, using the shape argument. */
9038 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
9039 gcc_assert (shape_ss
!= gfc_ss_terminator
);
9040 gfc_init_se (&shapese
, NULL
);
9042 gfc_init_loopinfo (&loop
);
9043 gfc_add_ss_to_loop (&loop
, shape_ss
);
9044 gfc_conv_ss_startstride (&loop
);
9045 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
9046 gfc_mark_ss_chain_used (shape_ss
, 1);
9048 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
9049 shapese
.ss
= shape_ss
;
9051 stride
= gfc_create_var (gfc_array_index_type
, "stride");
9052 offset
= gfc_create_var (gfc_array_index_type
, "offset");
9053 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
9054 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
9057 gfc_start_scalarized_body (&loop
, &body
);
9059 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
9060 loop
.loopvar
[0], loop
.from
[0]);
9062 /* Set bounds and stride. */
9063 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
9064 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
9066 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
9067 gfc_add_block_to_block (&body
, &shapese
.pre
);
9068 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
9069 gfc_add_block_to_block (&body
, &shapese
.post
);
9071 /* Calculate offset. */
9072 gfc_add_modify (&body
, offset
,
9073 fold_build2_loc (input_location
, PLUS_EXPR
,
9074 gfc_array_index_type
, offset
, stride
));
9075 /* Update stride. */
9076 gfc_add_modify (&body
, stride
,
9077 fold_build2_loc (input_location
, MULT_EXPR
,
9078 gfc_array_index_type
, stride
,
9079 fold_convert (gfc_array_index_type
,
9081 /* Finish scalarization loop. */
9082 gfc_trans_scalarizing_loops (&loop
, &body
);
9083 gfc_add_block_to_block (&block
, &loop
.pre
);
9084 gfc_add_block_to_block (&block
, &loop
.post
);
9085 gfc_add_block_to_block (&block
, &fptrse
.post
);
9086 gfc_cleanup_loop (&loop
);
9088 gfc_add_modify (&block
, offset
,
9089 fold_build1_loc (input_location
, NEGATE_EXPR
,
9090 gfc_array_index_type
, offset
));
9091 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
9093 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
9094 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9095 return gfc_finish_block (&se
.pre
);
9099 /* Save and restore floating-point state. */
9102 gfc_save_fp_state (stmtblock_t
*block
)
9104 tree type
, fpstate
, tmp
;
9106 type
= build_array_type (char_type_node
,
9107 build_range_type (size_type_node
, size_zero_node
,
9108 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
9109 fpstate
= gfc_create_var (type
, "fpstate");
9110 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
9112 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
9114 gfc_add_expr_to_block (block
, tmp
);
9121 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
9125 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
9127 gfc_add_expr_to_block (block
, tmp
);
9131 /* Generate code for arguments of IEEE functions. */
9134 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
9137 gfc_actual_arglist
*actual
;
9142 actual
= expr
->value
.function
.actual
;
9143 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
9145 gcc_assert (actual
);
9148 gfc_init_se (&argse
, se
);
9149 gfc_conv_expr_val (&argse
, e
);
9151 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
9152 gfc_add_block_to_block (&se
->post
, &argse
.post
);
9153 argarray
[arg
] = argse
.expr
;
9158 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
9159 and IEEE_UNORDERED, which translate directly to GCC type-generic
9163 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
9164 enum built_in_function code
, int nargs
)
9167 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
9169 conv_ieee_function_args (se
, expr
, args
, nargs
);
9170 se
->expr
= build_call_expr_loc_array (input_location
,
9171 builtin_decl_explicit (code
),
9173 STRIP_TYPE_NOPS (se
->expr
);
9174 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9178 /* Generate code for IEEE_IS_NORMAL intrinsic:
9179 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
9182 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
9184 tree arg
, isnormal
, iszero
;
9186 /* Convert arg, evaluate it only once. */
9187 conv_ieee_function_args (se
, expr
, &arg
, 1);
9188 arg
= gfc_evaluate_now (arg
, &se
->pre
);
9190 isnormal
= build_call_expr_loc (input_location
,
9191 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
9193 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
9194 build_real_from_int_cst (TREE_TYPE (arg
),
9195 integer_zero_node
));
9196 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9197 logical_type_node
, isnormal
, iszero
);
9198 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9202 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
9203 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
9206 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
9208 tree arg
, signbit
, isnan
;
9210 /* Convert arg, evaluate it only once. */
9211 conv_ieee_function_args (se
, expr
, &arg
, 1);
9212 arg
= gfc_evaluate_now (arg
, &se
->pre
);
9214 isnan
= build_call_expr_loc (input_location
,
9215 builtin_decl_explicit (BUILT_IN_ISNAN
),
9217 STRIP_TYPE_NOPS (isnan
);
9219 signbit
= build_call_expr_loc (input_location
,
9220 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
9222 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9223 signbit
, integer_zero_node
);
9225 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9226 logical_type_node
, signbit
,
9227 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
9228 TREE_TYPE(isnan
), isnan
));
9230 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9234 /* Generate code for IEEE_LOGB and IEEE_RINT. */
9237 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
9238 enum built_in_function code
)
9240 tree arg
, decl
, call
, fpstate
;
9243 conv_ieee_function_args (se
, expr
, &arg
, 1);
9244 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
9245 decl
= builtin_decl_for_precision (code
, argprec
);
9247 /* Save floating-point state. */
9248 fpstate
= gfc_save_fp_state (&se
->pre
);
9250 /* Make the function call. */
9251 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
9252 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
9254 /* Restore floating-point state. */
9255 gfc_restore_fp_state (&se
->post
, fpstate
);
9259 /* Generate code for IEEE_REM. */
9262 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
9264 tree args
[2], decl
, call
, fpstate
;
9267 conv_ieee_function_args (se
, expr
, args
, 2);
9269 /* If arguments have unequal size, convert them to the larger. */
9270 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
9271 > TYPE_PRECISION (TREE_TYPE (args
[1])))
9272 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
9273 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
9274 > TYPE_PRECISION (TREE_TYPE (args
[0])))
9275 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
9277 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9278 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
9280 /* Save floating-point state. */
9281 fpstate
= gfc_save_fp_state (&se
->pre
);
9283 /* Make the function call. */
9284 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9285 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9287 /* Restore floating-point state. */
9288 gfc_restore_fp_state (&se
->post
, fpstate
);
9292 /* Generate code for IEEE_NEXT_AFTER. */
9295 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
9297 tree args
[2], decl
, call
, fpstate
;
9300 conv_ieee_function_args (se
, expr
, args
, 2);
9302 /* Result has the characteristics of first argument. */
9303 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
9304 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9305 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
9307 /* Save floating-point state. */
9308 fpstate
= gfc_save_fp_state (&se
->pre
);
9310 /* Make the function call. */
9311 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9312 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9314 /* Restore floating-point state. */
9315 gfc_restore_fp_state (&se
->post
, fpstate
);
9319 /* Generate code for IEEE_SCALB. */
9322 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
9324 tree args
[2], decl
, call
, huge
, type
;
9327 conv_ieee_function_args (se
, expr
, args
, 2);
9329 /* Result has the characteristics of first argument. */
9330 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9331 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
9333 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
9335 /* We need to fold the integer into the range of a C int. */
9336 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
9337 type
= TREE_TYPE (args
[1]);
9339 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
9340 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
9342 huge
= fold_convert (type
, huge
);
9343 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
9345 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
9346 fold_build1_loc (input_location
, NEGATE_EXPR
,
9350 args
[1] = fold_convert (integer_type_node
, args
[1]);
9352 /* Make the function call. */
9353 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9354 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9358 /* Generate code for IEEE_COPY_SIGN. */
9361 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
9363 tree args
[2], decl
, sign
;
9366 conv_ieee_function_args (se
, expr
, args
, 2);
9368 /* Get the sign of the second argument. */
9369 sign
= build_call_expr_loc (input_location
,
9370 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
9372 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9373 sign
, integer_zero_node
);
9375 /* Create a value of one, with the right sign. */
9376 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
9378 fold_build1_loc (input_location
, NEGATE_EXPR
,
9382 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
9384 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9385 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
9387 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9391 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
9395 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
9397 const char *name
= expr
->value
.function
.name
;
9399 if (gfc_str_startswith (name
, "_gfortran_ieee_is_nan"))
9400 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
9401 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_finite"))
9402 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
9403 else if (gfc_str_startswith (name
, "_gfortran_ieee_unordered"))
9404 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
9405 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_normal"))
9406 conv_intrinsic_ieee_is_normal (se
, expr
);
9407 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_negative"))
9408 conv_intrinsic_ieee_is_negative (se
, expr
);
9409 else if (gfc_str_startswith (name
, "_gfortran_ieee_copy_sign"))
9410 conv_intrinsic_ieee_copy_sign (se
, expr
);
9411 else if (gfc_str_startswith (name
, "_gfortran_ieee_scalb"))
9412 conv_intrinsic_ieee_scalb (se
, expr
);
9413 else if (gfc_str_startswith (name
, "_gfortran_ieee_next_after"))
9414 conv_intrinsic_ieee_next_after (se
, expr
);
9415 else if (gfc_str_startswith (name
, "_gfortran_ieee_rem"))
9416 conv_intrinsic_ieee_rem (se
, expr
);
9417 else if (gfc_str_startswith (name
, "_gfortran_ieee_logb"))
9418 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
9419 else if (gfc_str_startswith (name
, "_gfortran_ieee_rint"))
9420 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
9422 /* It is not among the functions we translate directly. We return
9423 false, so a library function call is emitted. */
9430 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
9433 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
9435 tree arg
, res
, restype
;
9437 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
9438 arg
= fold_convert (size_type_node
, arg
);
9439 res
= build_call_expr_loc (input_location
,
9440 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
9441 restype
= gfc_typenode_for_spec (&expr
->ts
);
9442 se
->expr
= fold_convert (restype
, res
);
9446 /* Generate code for an intrinsic function. Some map directly to library
9447 calls, others get special handling. In some cases the name of the function
9448 used depends on the type specifiers. */
9451 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
9457 name
= &expr
->value
.function
.name
[2];
9461 lib
= gfc_is_intrinsic_libcall (expr
);
9465 se
->ignore_optional
= 1;
9467 switch (expr
->value
.function
.isym
->id
)
9469 case GFC_ISYM_EOSHIFT
:
9471 case GFC_ISYM_RESHAPE
:
9472 /* For all of those the first argument specifies the type and the
9473 third is optional. */
9474 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
9477 case GFC_ISYM_FINDLOC
:
9478 gfc_conv_intrinsic_findloc (se
, expr
);
9481 case GFC_ISYM_MINLOC
:
9482 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9485 case GFC_ISYM_MAXLOC
:
9486 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9489 case GFC_ISYM_SHAPE
:
9490 gfc_conv_intrinsic_shape (se
, expr
);
9494 gfc_conv_intrinsic_funcall (se
, expr
);
9502 switch (expr
->value
.function
.isym
->id
)
9507 case GFC_ISYM_REPEAT
:
9508 gfc_conv_intrinsic_repeat (se
, expr
);
9512 gfc_conv_intrinsic_trim (se
, expr
);
9515 case GFC_ISYM_SC_KIND
:
9516 gfc_conv_intrinsic_sc_kind (se
, expr
);
9519 case GFC_ISYM_SI_KIND
:
9520 gfc_conv_intrinsic_si_kind (se
, expr
);
9523 case GFC_ISYM_SR_KIND
:
9524 gfc_conv_intrinsic_sr_kind (se
, expr
);
9527 case GFC_ISYM_EXPONENT
:
9528 gfc_conv_intrinsic_exponent (se
, expr
);
9532 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9534 fndecl
= gfor_fndecl_string_scan
;
9536 fndecl
= gfor_fndecl_string_scan_char4
;
9540 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9543 case GFC_ISYM_VERIFY
:
9544 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9546 fndecl
= gfor_fndecl_string_verify
;
9548 fndecl
= gfor_fndecl_string_verify_char4
;
9552 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9555 case GFC_ISYM_ALLOCATED
:
9556 gfc_conv_allocated (se
, expr
);
9559 case GFC_ISYM_ASSOCIATED
:
9560 gfc_conv_associated(se
, expr
);
9563 case GFC_ISYM_SAME_TYPE_AS
:
9564 gfc_conv_same_type_as (se
, expr
);
9568 gfc_conv_intrinsic_abs (se
, expr
);
9571 case GFC_ISYM_ADJUSTL
:
9572 if (expr
->ts
.kind
== 1)
9573 fndecl
= gfor_fndecl_adjustl
;
9574 else if (expr
->ts
.kind
== 4)
9575 fndecl
= gfor_fndecl_adjustl_char4
;
9579 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
9582 case GFC_ISYM_ADJUSTR
:
9583 if (expr
->ts
.kind
== 1)
9584 fndecl
= gfor_fndecl_adjustr
;
9585 else if (expr
->ts
.kind
== 4)
9586 fndecl
= gfor_fndecl_adjustr_char4
;
9590 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
9593 case GFC_ISYM_AIMAG
:
9594 gfc_conv_intrinsic_imagpart (se
, expr
);
9598 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
9602 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
9605 case GFC_ISYM_ANINT
:
9606 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
9610 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
9614 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
9617 case GFC_ISYM_BTEST
:
9618 gfc_conv_intrinsic_btest (se
, expr
);
9622 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
9626 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
9630 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
9634 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
9637 case GFC_ISYM_C_ASSOCIATED
:
9638 case GFC_ISYM_C_FUNLOC
:
9639 case GFC_ISYM_C_LOC
:
9640 conv_isocbinding_function (se
, expr
);
9643 case GFC_ISYM_ACHAR
:
9645 gfc_conv_intrinsic_char (se
, expr
);
9648 case GFC_ISYM_CONVERSION
:
9650 case GFC_ISYM_LOGICAL
:
9652 gfc_conv_intrinsic_conversion (se
, expr
);
9655 /* Integer conversions are handled separately to make sure we get the
9656 correct rounding mode. */
9661 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
9665 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
9668 case GFC_ISYM_CEILING
:
9669 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
9672 case GFC_ISYM_FLOOR
:
9673 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
9677 gfc_conv_intrinsic_mod (se
, expr
, 0);
9680 case GFC_ISYM_MODULO
:
9681 gfc_conv_intrinsic_mod (se
, expr
, 1);
9684 case GFC_ISYM_CAF_GET
:
9685 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9689 case GFC_ISYM_CMPLX
:
9690 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
9693 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
9694 gfc_conv_intrinsic_iargc (se
, expr
);
9697 case GFC_ISYM_COMPLEX
:
9698 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
9701 case GFC_ISYM_CONJG
:
9702 gfc_conv_intrinsic_conjg (se
, expr
);
9705 case GFC_ISYM_COUNT
:
9706 gfc_conv_intrinsic_count (se
, expr
);
9709 case GFC_ISYM_CTIME
:
9710 gfc_conv_intrinsic_ctime (se
, expr
);
9714 gfc_conv_intrinsic_dim (se
, expr
);
9717 case GFC_ISYM_DOT_PRODUCT
:
9718 gfc_conv_intrinsic_dot_product (se
, expr
);
9721 case GFC_ISYM_DPROD
:
9722 gfc_conv_intrinsic_dprod (se
, expr
);
9725 case GFC_ISYM_DSHIFTL
:
9726 gfc_conv_intrinsic_dshift (se
, expr
, true);
9729 case GFC_ISYM_DSHIFTR
:
9730 gfc_conv_intrinsic_dshift (se
, expr
, false);
9733 case GFC_ISYM_FDATE
:
9734 gfc_conv_intrinsic_fdate (se
, expr
);
9737 case GFC_ISYM_FRACTION
:
9738 gfc_conv_intrinsic_fraction (se
, expr
);
9742 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
9746 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
9750 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
9753 case GFC_ISYM_IBCLR
:
9754 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
9757 case GFC_ISYM_IBITS
:
9758 gfc_conv_intrinsic_ibits (se
, expr
);
9761 case GFC_ISYM_IBSET
:
9762 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
9765 case GFC_ISYM_IACHAR
:
9766 case GFC_ISYM_ICHAR
:
9767 /* We assume ASCII character sequence. */
9768 gfc_conv_intrinsic_ichar (se
, expr
);
9771 case GFC_ISYM_IARGC
:
9772 gfc_conv_intrinsic_iargc (se
, expr
);
9776 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9779 case GFC_ISYM_INDEX
:
9780 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9782 fndecl
= gfor_fndecl_string_index
;
9784 fndecl
= gfor_fndecl_string_index_char4
;
9788 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9792 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9795 case GFC_ISYM_IPARITY
:
9796 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
9799 case GFC_ISYM_IS_IOSTAT_END
:
9800 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
9803 case GFC_ISYM_IS_IOSTAT_EOR
:
9804 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
9807 case GFC_ISYM_IS_CONTIGUOUS
:
9808 gfc_conv_intrinsic_is_contiguous (se
, expr
);
9811 case GFC_ISYM_ISNAN
:
9812 gfc_conv_intrinsic_isnan (se
, expr
);
9816 conv_intrinsic_kill (se
, expr
);
9819 case GFC_ISYM_LSHIFT
:
9820 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9823 case GFC_ISYM_RSHIFT
:
9824 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9827 case GFC_ISYM_SHIFTA
:
9828 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9831 case GFC_ISYM_SHIFTL
:
9832 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9835 case GFC_ISYM_SHIFTR
:
9836 gfc_conv_intrinsic_shift (se
, expr
, true, false);
9839 case GFC_ISYM_ISHFT
:
9840 gfc_conv_intrinsic_ishft (se
, expr
);
9843 case GFC_ISYM_ISHFTC
:
9844 gfc_conv_intrinsic_ishftc (se
, expr
);
9847 case GFC_ISYM_LEADZ
:
9848 gfc_conv_intrinsic_leadz (se
, expr
);
9851 case GFC_ISYM_TRAILZ
:
9852 gfc_conv_intrinsic_trailz (se
, expr
);
9855 case GFC_ISYM_POPCNT
:
9856 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
9859 case GFC_ISYM_POPPAR
:
9860 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
9863 case GFC_ISYM_LBOUND
:
9864 gfc_conv_intrinsic_bound (se
, expr
, 0);
9867 case GFC_ISYM_LCOBOUND
:
9868 conv_intrinsic_cobound (se
, expr
);
9871 case GFC_ISYM_TRANSPOSE
:
9872 /* The scalarizer has already been set up for reversed dimension access
9873 order ; now we just get the argument value normally. */
9874 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
9878 gfc_conv_intrinsic_len (se
, expr
);
9881 case GFC_ISYM_LEN_TRIM
:
9882 gfc_conv_intrinsic_len_trim (se
, expr
);
9886 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
9890 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
9894 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
9898 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
9901 case GFC_ISYM_MALLOC
:
9902 gfc_conv_intrinsic_malloc (se
, expr
);
9905 case GFC_ISYM_MASKL
:
9906 gfc_conv_intrinsic_mask (se
, expr
, 1);
9909 case GFC_ISYM_MASKR
:
9910 gfc_conv_intrinsic_mask (se
, expr
, 0);
9914 if (expr
->ts
.type
== BT_CHARACTER
)
9915 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
9917 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
9920 case GFC_ISYM_MAXLOC
:
9921 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9924 case GFC_ISYM_FINDLOC
:
9925 gfc_conv_intrinsic_findloc (se
, expr
);
9928 case GFC_ISYM_MAXVAL
:
9929 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
9932 case GFC_ISYM_MERGE
:
9933 gfc_conv_intrinsic_merge (se
, expr
);
9936 case GFC_ISYM_MERGE_BITS
:
9937 gfc_conv_intrinsic_merge_bits (se
, expr
);
9941 if (expr
->ts
.type
== BT_CHARACTER
)
9942 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
9944 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
9947 case GFC_ISYM_MINLOC
:
9948 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9951 case GFC_ISYM_MINVAL
:
9952 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
9955 case GFC_ISYM_NEAREST
:
9956 gfc_conv_intrinsic_nearest (se
, expr
);
9959 case GFC_ISYM_NORM2
:
9960 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
9964 gfc_conv_intrinsic_not (se
, expr
);
9968 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9971 case GFC_ISYM_PARITY
:
9972 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
9975 case GFC_ISYM_PRESENT
:
9976 gfc_conv_intrinsic_present (se
, expr
);
9979 case GFC_ISYM_PRODUCT
:
9980 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
9984 gfc_conv_intrinsic_rank (se
, expr
);
9987 case GFC_ISYM_RRSPACING
:
9988 gfc_conv_intrinsic_rrspacing (se
, expr
);
9991 case GFC_ISYM_SET_EXPONENT
:
9992 gfc_conv_intrinsic_set_exponent (se
, expr
);
9995 case GFC_ISYM_SCALE
:
9996 gfc_conv_intrinsic_scale (se
, expr
);
10000 gfc_conv_intrinsic_sign (se
, expr
);
10003 case GFC_ISYM_SIZE
:
10004 gfc_conv_intrinsic_size (se
, expr
);
10007 case GFC_ISYM_SIZEOF
:
10008 case GFC_ISYM_C_SIZEOF
:
10009 gfc_conv_intrinsic_sizeof (se
, expr
);
10012 case GFC_ISYM_STORAGE_SIZE
:
10013 gfc_conv_intrinsic_storage_size (se
, expr
);
10016 case GFC_ISYM_SPACING
:
10017 gfc_conv_intrinsic_spacing (se
, expr
);
10020 case GFC_ISYM_STRIDE
:
10021 conv_intrinsic_stride (se
, expr
);
10025 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
10028 case GFC_ISYM_TEAM_NUMBER
:
10029 conv_intrinsic_team_number (se
, expr
);
10032 case GFC_ISYM_TRANSFER
:
10033 if (se
->ss
&& se
->ss
->info
->useflags
)
10034 /* Access the previously obtained result. */
10035 gfc_conv_tmp_array_ref (se
);
10037 gfc_conv_intrinsic_transfer (se
, expr
);
10040 case GFC_ISYM_TTYNAM
:
10041 gfc_conv_intrinsic_ttynam (se
, expr
);
10044 case GFC_ISYM_UBOUND
:
10045 gfc_conv_intrinsic_bound (se
, expr
, 1);
10048 case GFC_ISYM_UCOBOUND
:
10049 conv_intrinsic_cobound (se
, expr
);
10053 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
10057 gfc_conv_intrinsic_loc (se
, expr
);
10060 case GFC_ISYM_THIS_IMAGE
:
10061 /* For num_images() == 1, handle as LCOBOUND. */
10062 if (expr
->value
.function
.actual
->expr
10063 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
10064 conv_intrinsic_cobound (se
, expr
);
10066 trans_this_image (se
, expr
);
10069 case GFC_ISYM_IMAGE_INDEX
:
10070 trans_image_index (se
, expr
);
10073 case GFC_ISYM_IMAGE_STATUS
:
10074 conv_intrinsic_image_status (se
, expr
);
10077 case GFC_ISYM_NUM_IMAGES
:
10078 trans_num_images (se
, expr
);
10081 case GFC_ISYM_ACCESS
:
10082 case GFC_ISYM_CHDIR
:
10083 case GFC_ISYM_CHMOD
:
10084 case GFC_ISYM_DTIME
:
10085 case GFC_ISYM_ETIME
:
10086 case GFC_ISYM_EXTENDS_TYPE_OF
:
10087 case GFC_ISYM_FGET
:
10088 case GFC_ISYM_FGETC
:
10089 case GFC_ISYM_FNUM
:
10090 case GFC_ISYM_FPUT
:
10091 case GFC_ISYM_FPUTC
:
10092 case GFC_ISYM_FSTAT
:
10093 case GFC_ISYM_FTELL
:
10094 case GFC_ISYM_GETCWD
:
10095 case GFC_ISYM_GETGID
:
10096 case GFC_ISYM_GETPID
:
10097 case GFC_ISYM_GETUID
:
10098 case GFC_ISYM_HOSTNM
:
10099 case GFC_ISYM_IERRNO
:
10100 case GFC_ISYM_IRAND
:
10101 case GFC_ISYM_ISATTY
:
10103 case GFC_ISYM_LINK
:
10104 case GFC_ISYM_LSTAT
:
10105 case GFC_ISYM_MATMUL
:
10106 case GFC_ISYM_MCLOCK
:
10107 case GFC_ISYM_MCLOCK8
:
10108 case GFC_ISYM_RAND
:
10109 case GFC_ISYM_RENAME
:
10110 case GFC_ISYM_SECOND
:
10111 case GFC_ISYM_SECNDS
:
10112 case GFC_ISYM_SIGNAL
:
10113 case GFC_ISYM_STAT
:
10114 case GFC_ISYM_SYMLNK
:
10115 case GFC_ISYM_SYSTEM
:
10116 case GFC_ISYM_TIME
:
10117 case GFC_ISYM_TIME8
:
10118 case GFC_ISYM_UMASK
:
10119 case GFC_ISYM_UNLINK
:
10121 gfc_conv_intrinsic_funcall (se
, expr
);
10124 case GFC_ISYM_EOSHIFT
:
10125 case GFC_ISYM_PACK
:
10126 case GFC_ISYM_RESHAPE
:
10127 /* For those, expr->rank should always be >0 and thus the if above the
10128 switch should have matched. */
10129 gcc_unreachable ();
10133 gfc_conv_intrinsic_lib_function (se
, expr
);
10140 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
10142 gfc_ss
*arg_ss
, *tmp_ss
;
10143 gfc_actual_arglist
*arg
;
10145 arg
= expr
->value
.function
.actual
;
10147 gcc_assert (arg
->expr
);
10149 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
10150 gcc_assert (arg_ss
!= gfc_ss_terminator
);
10152 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
10154 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
10155 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
10157 gcc_assert (tmp_ss
->dimen
== 2);
10159 /* We just invert dimensions. */
10160 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
10163 /* Stop when tmp_ss points to the last valid element of the chain... */
10164 if (tmp_ss
->next
== gfc_ss_terminator
)
10168 /* ... so that we can attach the rest of the chain to it. */
10175 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
10176 This has the side effect of reversing the nested list, so there is no
10177 need to call gfc_reverse_ss on it (the given list is assumed not to be
10181 nest_loop_dimension (gfc_ss
*ss
, int dim
)
10184 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
10185 gfc_loopinfo
*new_loop
;
10187 gcc_assert (ss
!= gfc_ss_terminator
);
10189 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
10191 new_ss
= gfc_get_ss ();
10192 new_ss
->next
= prev_ss
;
10193 new_ss
->parent
= ss
;
10194 new_ss
->info
= ss
->info
;
10195 new_ss
->info
->refcount
++;
10196 if (ss
->dimen
!= 0)
10198 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
10199 && ss
->info
->type
!= GFC_SS_REFERENCE
);
10202 new_ss
->dim
[0] = ss
->dim
[dim
];
10204 gcc_assert (dim
< ss
->dimen
);
10206 ss_dim
= --ss
->dimen
;
10207 for (i
= dim
; i
< ss_dim
; i
++)
10208 ss
->dim
[i
] = ss
->dim
[i
+ 1];
10210 ss
->dim
[ss_dim
] = 0;
10216 ss
->nested_ss
->parent
= new_ss
;
10217 new_ss
->nested_ss
= ss
->nested_ss
;
10219 ss
->nested_ss
= new_ss
;
10222 new_loop
= gfc_get_loopinfo ();
10223 gfc_init_loopinfo (new_loop
);
10225 gcc_assert (prev_ss
!= NULL
);
10226 gcc_assert (prev_ss
!= gfc_ss_terminator
);
10227 gfc_add_ss_to_loop (new_loop
, prev_ss
);
10228 return new_ss
->parent
;
10232 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
10233 is to be inlined. */
10236 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
10238 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
10239 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
10241 bool scalar_mask
= false;
10243 /* The rank of the result will be determined later. */
10244 arg1
= expr
->value
.function
.actual
;
10247 gcc_assert (arg3
!= NULL
);
10249 if (expr
->rank
== 0)
10252 tmp_ss
= gfc_ss_terminator
;
10258 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
10259 if (mask_ss
== tmp_ss
)
10265 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
10266 gcc_assert (array_ss
!= tmp_ss
);
10268 /* Odd thing: If the mask is scalar, it is used by the frontend after
10269 the array (to make an if around the nested loop). Thus it shall
10270 be after array_ss once the gfc_ss list is reversed. */
10272 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
10276 /* "Hide" the dimension on which we will sum in the first arg's scalarization
10278 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
10279 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
10287 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
10290 switch (expr
->value
.function
.isym
->id
)
10292 case GFC_ISYM_PRODUCT
:
10294 return walk_inline_intrinsic_arith (ss
, expr
);
10296 case GFC_ISYM_TRANSPOSE
:
10297 return walk_inline_intrinsic_transpose (ss
, expr
);
10300 gcc_unreachable ();
10302 gcc_unreachable ();
10306 /* This generates code to execute before entering the scalarization loop.
10307 Currently does nothing. */
10310 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
10312 switch (ss
->info
->expr
->value
.function
.isym
->id
)
10314 case GFC_ISYM_UBOUND
:
10315 case GFC_ISYM_LBOUND
:
10316 case GFC_ISYM_UCOBOUND
:
10317 case GFC_ISYM_LCOBOUND
:
10318 case GFC_ISYM_THIS_IMAGE
:
10322 gcc_unreachable ();
10327 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
10328 are expanded into code inside the scalarization loop. */
10331 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
10333 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
10334 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
10336 /* The two argument version returns a scalar. */
10337 if (expr
->value
.function
.actual
->next
->expr
)
10340 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
10344 /* Walk an intrinsic array libcall. */
10347 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
10349 gcc_assert (expr
->rank
> 0);
10350 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10354 /* Return whether the function call expression EXPR will be expanded
10355 inline by gfc_conv_intrinsic_function. */
10358 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
10360 gfc_actual_arglist
*args
, *dim_arg
, *mask_arg
;
10361 gfc_expr
*maskexpr
;
10363 if (!expr
->value
.function
.isym
)
10366 switch (expr
->value
.function
.isym
->id
)
10368 case GFC_ISYM_PRODUCT
:
10370 /* Disable inline expansion if code size matters. */
10374 args
= expr
->value
.function
.actual
;
10375 dim_arg
= args
->next
;
10377 /* We need to be able to subset the SUM argument at compile-time. */
10378 if (dim_arg
->expr
&& dim_arg
->expr
->expr_type
!= EXPR_CONSTANT
)
10381 /* FIXME: If MASK is optional for a more than two-dimensional
10382 argument, the scalarizer gets confused if the mask is
10383 absent. See PR 82995. For now, fall back to the library
10386 mask_arg
= dim_arg
->next
;
10387 maskexpr
= mask_arg
->expr
;
10389 if (expr
->rank
> 0 && maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
10390 && maskexpr
->symtree
->n
.sym
->attr
.dummy
10391 && maskexpr
->symtree
->n
.sym
->attr
.optional
)
10396 case GFC_ISYM_TRANSPOSE
:
10405 /* Returns nonzero if the specified intrinsic function call maps directly to
10406 an external library call. Should only be used for functions that return
10410 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
10412 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
10413 gcc_assert (expr
->rank
> 0);
10415 if (gfc_inline_intrinsic_function_p (expr
))
10418 switch (expr
->value
.function
.isym
->id
)
10422 case GFC_ISYM_COUNT
:
10423 case GFC_ISYM_FINDLOC
:
10425 case GFC_ISYM_IANY
:
10426 case GFC_ISYM_IALL
:
10427 case GFC_ISYM_IPARITY
:
10428 case GFC_ISYM_MATMUL
:
10429 case GFC_ISYM_MAXLOC
:
10430 case GFC_ISYM_MAXVAL
:
10431 case GFC_ISYM_MINLOC
:
10432 case GFC_ISYM_MINVAL
:
10433 case GFC_ISYM_NORM2
:
10434 case GFC_ISYM_PARITY
:
10435 case GFC_ISYM_PRODUCT
:
10437 case GFC_ISYM_SHAPE
:
10438 case GFC_ISYM_SPREAD
:
10440 /* Ignore absent optional parameters. */
10443 case GFC_ISYM_CSHIFT
:
10444 case GFC_ISYM_EOSHIFT
:
10445 case GFC_ISYM_GET_TEAM
:
10446 case GFC_ISYM_FAILED_IMAGES
:
10447 case GFC_ISYM_STOPPED_IMAGES
:
10448 case GFC_ISYM_PACK
:
10449 case GFC_ISYM_RESHAPE
:
10450 case GFC_ISYM_UNPACK
:
10451 /* Pass absent optional parameters. */
10459 /* Walk an intrinsic function. */
10461 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
10462 gfc_intrinsic_sym
* isym
)
10466 if (isym
->elemental
)
10467 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
10468 NULL
, GFC_SS_SCALAR
);
10470 if (expr
->rank
== 0)
10473 if (gfc_inline_intrinsic_function_p (expr
))
10474 return walk_inline_intrinsic_function (ss
, expr
);
10476 if (gfc_is_intrinsic_libcall (expr
))
10477 return gfc_walk_intrinsic_libfunc (ss
, expr
);
10479 /* Special cases. */
10482 case GFC_ISYM_LBOUND
:
10483 case GFC_ISYM_LCOBOUND
:
10484 case GFC_ISYM_UBOUND
:
10485 case GFC_ISYM_UCOBOUND
:
10486 case GFC_ISYM_THIS_IMAGE
:
10487 return gfc_walk_intrinsic_bound (ss
, expr
);
10489 case GFC_ISYM_TRANSFER
:
10490 case GFC_ISYM_CAF_GET
:
10491 return gfc_walk_intrinsic_libfunc (ss
, expr
);
10494 /* This probably meant someone forgot to add an intrinsic to the above
10495 list(s) when they implemented it, or something's gone horribly
10497 gcc_unreachable ();
10503 conv_co_collective (gfc_code
*code
)
10506 stmtblock_t block
, post_block
;
10507 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
10508 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
10510 gfc_start_block (&block
);
10511 gfc_init_block (&post_block
);
10513 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
10515 opr_expr
= code
->ext
.actual
->next
->expr
;
10516 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
10517 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10518 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
10523 image_idx_expr
= code
->ext
.actual
->next
->expr
;
10524 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
10525 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10531 gfc_init_se (&argse
, NULL
);
10532 gfc_conv_expr (&argse
, stat_expr
);
10533 gfc_add_block_to_block (&block
, &argse
.pre
);
10534 gfc_add_block_to_block (&post_block
, &argse
.post
);
10536 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
10537 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
10539 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
10542 stat
= null_pointer_node
;
10544 /* Early exit for GFC_FCOARRAY_SINGLE. */
10545 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
10547 if (stat
!= NULL_TREE
)
10548 gfc_add_modify (&block
, stat
,
10549 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
10550 return gfc_finish_block (&block
);
10553 /* Handle the array. */
10554 gfc_init_se (&argse
, NULL
);
10555 if (code
->ext
.actual
->expr
->rank
== 0)
10557 symbol_attribute attr
;
10558 gfc_clear_attr (&attr
);
10559 gfc_init_se (&argse
, NULL
);
10560 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10561 gfc_add_block_to_block (&block
, &argse
.pre
);
10562 gfc_add_block_to_block (&post_block
, &argse
.post
);
10563 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
10564 array
= gfc_build_addr_expr (NULL_TREE
, array
);
10568 argse
.want_pointer
= 1;
10569 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
10570 array
= argse
.expr
;
10572 gfc_add_block_to_block (&block
, &argse
.pre
);
10573 gfc_add_block_to_block (&post_block
, &argse
.post
);
10575 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
10576 strlen
= argse
.string_length
;
10578 strlen
= integer_zero_node
;
10581 if (image_idx_expr
)
10583 gfc_init_se (&argse
, NULL
);
10584 gfc_conv_expr (&argse
, image_idx_expr
);
10585 gfc_add_block_to_block (&block
, &argse
.pre
);
10586 gfc_add_block_to_block (&post_block
, &argse
.post
);
10587 image_index
= fold_convert (integer_type_node
, argse
.expr
);
10590 image_index
= integer_zero_node
;
10595 gfc_init_se (&argse
, NULL
);
10596 gfc_conv_expr (&argse
, errmsg_expr
);
10597 gfc_add_block_to_block (&block
, &argse
.pre
);
10598 gfc_add_block_to_block (&post_block
, &argse
.post
);
10599 errmsg
= argse
.expr
;
10600 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
10604 errmsg
= null_pointer_node
;
10605 errmsg_len
= build_zero_cst (size_type_node
);
10608 /* Generate the function call. */
10609 switch (code
->resolved_isym
->id
)
10611 case GFC_ISYM_CO_BROADCAST
:
10612 fndecl
= gfor_fndecl_co_broadcast
;
10614 case GFC_ISYM_CO_MAX
:
10615 fndecl
= gfor_fndecl_co_max
;
10617 case GFC_ISYM_CO_MIN
:
10618 fndecl
= gfor_fndecl_co_min
;
10620 case GFC_ISYM_CO_REDUCE
:
10621 fndecl
= gfor_fndecl_co_reduce
;
10623 case GFC_ISYM_CO_SUM
:
10624 fndecl
= gfor_fndecl_co_sum
;
10627 gcc_unreachable ();
10630 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
10631 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
10632 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
10633 image_index
, stat
, errmsg
, errmsg_len
);
10634 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
10635 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
10636 stat
, errmsg
, strlen
, errmsg_len
);
10639 tree opr
, opr_flags
;
10641 // FIXME: Handle TS29113's bind(C) strings with descriptor.
10643 if (gfc_is_proc_ptr_comp (opr_expr
))
10645 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
10646 opr_flag_int
= sym
->attr
.dimension
10647 || (sym
->ts
.type
== BT_CHARACTER
10648 && !sym
->attr
.is_bind_c
)
10649 ? GFC_CAF_BYREF
: 0;
10650 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
10651 && !sym
->attr
.is_bind_c
10652 ? GFC_CAF_HIDDENLEN
: 0;
10653 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
10657 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
10658 ? GFC_CAF_BYREF
: 0;
10659 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
10660 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
10661 ? GFC_CAF_HIDDENLEN
: 0;
10662 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
10663 ? GFC_CAF_ARG_VALUE
: 0;
10665 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
10666 gfc_conv_expr (&argse
, opr_expr
);
10668 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
10669 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
10672 gfc_add_expr_to_block (&block
, fndecl
);
10673 gfc_add_block_to_block (&block
, &post_block
);
10675 return gfc_finish_block (&block
);
10680 conv_intrinsic_atomic_op (gfc_code
*code
)
10683 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
10684 stmtblock_t block
, post_block
;
10685 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10686 gfc_expr
*stat_expr
;
10687 built_in_function fn
;
10689 if (atom_expr
->expr_type
== EXPR_FUNCTION
10690 && atom_expr
->value
.function
.isym
10691 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10692 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10694 gfc_start_block (&block
);
10695 gfc_init_block (&post_block
);
10697 gfc_init_se (&argse
, NULL
);
10698 argse
.want_pointer
= 1;
10699 gfc_conv_expr (&argse
, atom_expr
);
10700 gfc_add_block_to_block (&block
, &argse
.pre
);
10701 gfc_add_block_to_block (&post_block
, &argse
.post
);
10704 gfc_init_se (&argse
, NULL
);
10705 if (flag_coarray
== GFC_FCOARRAY_LIB
10706 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10707 argse
.want_pointer
= 1;
10708 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10709 gfc_add_block_to_block (&block
, &argse
.pre
);
10710 gfc_add_block_to_block (&post_block
, &argse
.post
);
10711 value
= argse
.expr
;
10713 switch (code
->resolved_isym
->id
)
10715 case GFC_ISYM_ATOMIC_ADD
:
10716 case GFC_ISYM_ATOMIC_AND
:
10717 case GFC_ISYM_ATOMIC_DEF
:
10718 case GFC_ISYM_ATOMIC_OR
:
10719 case GFC_ISYM_ATOMIC_XOR
:
10720 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
10721 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10722 old
= null_pointer_node
;
10725 gfc_init_se (&argse
, NULL
);
10726 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10727 argse
.want_pointer
= 1;
10728 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10729 gfc_add_block_to_block (&block
, &argse
.pre
);
10730 gfc_add_block_to_block (&post_block
, &argse
.post
);
10732 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10736 if (stat_expr
!= NULL
)
10738 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
10739 gfc_init_se (&argse
, NULL
);
10740 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10741 argse
.want_pointer
= 1;
10742 gfc_conv_expr_val (&argse
, stat_expr
);
10743 gfc_add_block_to_block (&block
, &argse
.pre
);
10744 gfc_add_block_to_block (&post_block
, &argse
.post
);
10747 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10748 stat
= null_pointer_node
;
10750 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10752 tree image_index
, caf_decl
, offset
, token
;
10755 switch (code
->resolved_isym
->id
)
10757 case GFC_ISYM_ATOMIC_ADD
:
10758 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10759 op
= (int) GFC_CAF_ATOMIC_ADD
;
10761 case GFC_ISYM_ATOMIC_AND
:
10762 case GFC_ISYM_ATOMIC_FETCH_AND
:
10763 op
= (int) GFC_CAF_ATOMIC_AND
;
10765 case GFC_ISYM_ATOMIC_OR
:
10766 case GFC_ISYM_ATOMIC_FETCH_OR
:
10767 op
= (int) GFC_CAF_ATOMIC_OR
;
10769 case GFC_ISYM_ATOMIC_XOR
:
10770 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10771 op
= (int) GFC_CAF_ATOMIC_XOR
;
10773 case GFC_ISYM_ATOMIC_DEF
:
10774 op
= 0; /* Unused. */
10777 gcc_unreachable ();
10780 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10781 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10782 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10784 if (gfc_is_coindexed (atom_expr
))
10785 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10787 image_index
= integer_zero_node
;
10789 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10791 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10792 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
10793 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10796 gfc_init_se (&argse
, NULL
);
10797 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10800 gfc_add_block_to_block (&block
, &argse
.pre
);
10801 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
10802 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
10803 token
, offset
, image_index
, value
, stat
,
10804 build_int_cst (integer_type_node
,
10805 (int) atom_expr
->ts
.type
),
10806 build_int_cst (integer_type_node
,
10807 (int) atom_expr
->ts
.kind
));
10809 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
10810 build_int_cst (integer_type_node
, op
),
10811 token
, offset
, image_index
, value
, old
, stat
,
10812 build_int_cst (integer_type_node
,
10813 (int) atom_expr
->ts
.type
),
10814 build_int_cst (integer_type_node
,
10815 (int) atom_expr
->ts
.kind
));
10817 gfc_add_expr_to_block (&block
, tmp
);
10818 gfc_add_block_to_block (&block
, &argse
.post
);
10819 gfc_add_block_to_block (&block
, &post_block
);
10820 return gfc_finish_block (&block
);
10824 switch (code
->resolved_isym
->id
)
10826 case GFC_ISYM_ATOMIC_ADD
:
10827 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10828 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
10830 case GFC_ISYM_ATOMIC_AND
:
10831 case GFC_ISYM_ATOMIC_FETCH_AND
:
10832 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
10834 case GFC_ISYM_ATOMIC_DEF
:
10835 fn
= BUILT_IN_ATOMIC_STORE_N
;
10837 case GFC_ISYM_ATOMIC_OR
:
10838 case GFC_ISYM_ATOMIC_FETCH_OR
:
10839 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
10841 case GFC_ISYM_ATOMIC_XOR
:
10842 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10843 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
10846 gcc_unreachable ();
10849 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10850 fn
= (built_in_function
) ((int) fn
10851 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10853 tmp
= builtin_decl_explicit (fn
);
10854 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
10855 tmp
= builtin_decl_explicit (fn
);
10857 switch (code
->resolved_isym
->id
)
10859 case GFC_ISYM_ATOMIC_ADD
:
10860 case GFC_ISYM_ATOMIC_AND
:
10861 case GFC_ISYM_ATOMIC_DEF
:
10862 case GFC_ISYM_ATOMIC_OR
:
10863 case GFC_ISYM_ATOMIC_XOR
:
10864 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10865 fold_convert (itype
, value
),
10866 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10867 gfc_add_expr_to_block (&block
, tmp
);
10870 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10871 fold_convert (itype
, value
),
10872 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10873 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
10877 if (stat
!= NULL_TREE
)
10878 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10879 gfc_add_block_to_block (&block
, &post_block
);
10880 return gfc_finish_block (&block
);
10885 conv_intrinsic_atomic_ref (gfc_code
*code
)
10888 tree tmp
, atom
, value
, stat
= NULL_TREE
;
10889 stmtblock_t block
, post_block
;
10890 built_in_function fn
;
10891 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
10893 if (atom_expr
->expr_type
== EXPR_FUNCTION
10894 && atom_expr
->value
.function
.isym
10895 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10896 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10898 gfc_start_block (&block
);
10899 gfc_init_block (&post_block
);
10900 gfc_init_se (&argse
, NULL
);
10901 argse
.want_pointer
= 1;
10902 gfc_conv_expr (&argse
, atom_expr
);
10903 gfc_add_block_to_block (&block
, &argse
.pre
);
10904 gfc_add_block_to_block (&post_block
, &argse
.post
);
10907 gfc_init_se (&argse
, NULL
);
10908 if (flag_coarray
== GFC_FCOARRAY_LIB
10909 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10910 argse
.want_pointer
= 1;
10911 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10912 gfc_add_block_to_block (&block
, &argse
.pre
);
10913 gfc_add_block_to_block (&post_block
, &argse
.post
);
10914 value
= argse
.expr
;
10917 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
10919 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10921 gfc_init_se (&argse
, NULL
);
10922 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10923 argse
.want_pointer
= 1;
10924 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10925 gfc_add_block_to_block (&block
, &argse
.pre
);
10926 gfc_add_block_to_block (&post_block
, &argse
.post
);
10929 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10930 stat
= null_pointer_node
;
10932 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10934 tree image_index
, caf_decl
, offset
, token
;
10935 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
10937 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10938 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10939 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10941 if (gfc_is_coindexed (atom_expr
))
10942 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10944 image_index
= integer_zero_node
;
10946 gfc_init_se (&argse
, NULL
);
10947 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10949 gfc_add_block_to_block (&block
, &argse
.pre
);
10951 /* Different type, need type conversion. */
10952 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10954 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10955 orig_value
= value
;
10956 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
10959 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
10960 token
, offset
, image_index
, value
, stat
,
10961 build_int_cst (integer_type_node
,
10962 (int) atom_expr
->ts
.type
),
10963 build_int_cst (integer_type_node
,
10964 (int) atom_expr
->ts
.kind
));
10965 gfc_add_expr_to_block (&block
, tmp
);
10966 if (vardecl
!= NULL_TREE
)
10967 gfc_add_modify (&block
, orig_value
,
10968 fold_convert (TREE_TYPE (orig_value
), vardecl
));
10969 gfc_add_block_to_block (&block
, &argse
.post
);
10970 gfc_add_block_to_block (&block
, &post_block
);
10971 return gfc_finish_block (&block
);
10974 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10975 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
10976 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10978 tmp
= builtin_decl_explicit (fn
);
10979 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
10980 build_int_cst (integer_type_node
,
10981 MEMMODEL_RELAXED
));
10982 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
10984 if (stat
!= NULL_TREE
)
10985 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10986 gfc_add_block_to_block (&block
, &post_block
);
10987 return gfc_finish_block (&block
);
10992 conv_intrinsic_atomic_cas (gfc_code
*code
)
10995 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
10996 stmtblock_t block
, post_block
;
10997 built_in_function fn
;
10998 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
11000 if (atom_expr
->expr_type
== EXPR_FUNCTION
11001 && atom_expr
->value
.function
.isym
11002 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11003 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11005 gfc_init_block (&block
);
11006 gfc_init_block (&post_block
);
11007 gfc_init_se (&argse
, NULL
);
11008 argse
.want_pointer
= 1;
11009 gfc_conv_expr (&argse
, atom_expr
);
11012 gfc_init_se (&argse
, NULL
);
11013 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11014 argse
.want_pointer
= 1;
11015 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
11016 gfc_add_block_to_block (&block
, &argse
.pre
);
11017 gfc_add_block_to_block (&post_block
, &argse
.post
);
11020 gfc_init_se (&argse
, NULL
);
11021 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11022 argse
.want_pointer
= 1;
11023 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
11024 gfc_add_block_to_block (&block
, &argse
.pre
);
11025 gfc_add_block_to_block (&post_block
, &argse
.post
);
11028 gfc_init_se (&argse
, NULL
);
11029 if (flag_coarray
== GFC_FCOARRAY_LIB
11030 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
11031 == atom_expr
->ts
.kind
)
11032 argse
.want_pointer
= 1;
11033 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
11034 gfc_add_block_to_block (&block
, &argse
.pre
);
11035 gfc_add_block_to_block (&post_block
, &argse
.post
);
11036 new_val
= argse
.expr
;
11039 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
11041 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
11043 gfc_init_se (&argse
, NULL
);
11044 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11045 argse
.want_pointer
= 1;
11046 gfc_conv_expr_val (&argse
,
11047 code
->ext
.actual
->next
->next
->next
->next
->expr
);
11048 gfc_add_block_to_block (&block
, &argse
.pre
);
11049 gfc_add_block_to_block (&post_block
, &argse
.post
);
11052 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11053 stat
= null_pointer_node
;
11055 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11057 tree image_index
, caf_decl
, offset
, token
;
11059 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
11060 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
11061 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
11063 if (gfc_is_coindexed (atom_expr
))
11064 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
11066 image_index
= integer_zero_node
;
11068 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
11070 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
11071 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
11072 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11075 /* Convert a constant to a pointer. */
11076 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
11078 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
11079 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
11080 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11083 gfc_init_se (&argse
, NULL
);
11084 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
11086 gfc_add_block_to_block (&block
, &argse
.pre
);
11088 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
11089 token
, offset
, image_index
, old
, comp
, new_val
,
11090 stat
, build_int_cst (integer_type_node
,
11091 (int) atom_expr
->ts
.type
),
11092 build_int_cst (integer_type_node
,
11093 (int) atom_expr
->ts
.kind
));
11094 gfc_add_expr_to_block (&block
, tmp
);
11095 gfc_add_block_to_block (&block
, &argse
.post
);
11096 gfc_add_block_to_block (&block
, &post_block
);
11097 return gfc_finish_block (&block
);
11100 tmp
= TREE_TYPE (TREE_TYPE (atom
));
11101 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
11102 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
11104 tmp
= builtin_decl_explicit (fn
);
11106 gfc_add_modify (&block
, old
, comp
);
11107 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
11108 gfc_build_addr_expr (NULL
, old
),
11109 fold_convert (TREE_TYPE (old
), new_val
),
11110 boolean_false_node
,
11111 build_int_cst (NULL
, MEMMODEL_RELAXED
),
11112 build_int_cst (NULL
, MEMMODEL_RELAXED
));
11113 gfc_add_expr_to_block (&block
, tmp
);
11115 if (stat
!= NULL_TREE
)
11116 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11117 gfc_add_block_to_block (&block
, &post_block
);
11118 return gfc_finish_block (&block
);
11122 conv_intrinsic_event_query (gfc_code
*code
)
11125 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
11126 tree count
= NULL_TREE
, count2
= NULL_TREE
;
11128 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
11130 if (code
->ext
.actual
->next
->next
->expr
)
11132 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
11134 gfc_init_se (&argse
, NULL
);
11135 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
11138 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11139 stat
= null_pointer_node
;
11141 if (code
->ext
.actual
->next
->expr
)
11143 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
11144 gfc_init_se (&argse
, NULL
);
11145 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
11146 count
= argse
.expr
;
11149 gfc_start_block (&se
.pre
);
11150 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11152 tree tmp
, token
, image_index
;
11153 tree index
= build_zero_cst (gfc_array_index_type
);
11155 if (event_expr
->expr_type
== EXPR_FUNCTION
11156 && event_expr
->value
.function
.isym
11157 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11158 event_expr
= event_expr
->value
.function
.actual
->expr
;
11160 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
11162 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
11163 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
11164 != INTMOD_ISO_FORTRAN_ENV
11165 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
11166 != ISOFORTRAN_EVENT_TYPE
)
11168 gfc_error ("Sorry, the event component of derived type at %L is not "
11169 "yet supported", &event_expr
->where
);
11173 if (gfc_is_coindexed (event_expr
))
11175 gfc_error ("The event variable at %L shall not be coindexed",
11176 &event_expr
->where
);
11180 image_index
= integer_zero_node
;
11182 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
11185 /* For arrays, obtain the array index. */
11186 if (gfc_expr_attr (event_expr
).dimension
)
11188 tree desc
, tmp
, extent
, lbound
, ubound
;
11189 gfc_array_ref
*ar
, ar2
;
11192 /* TODO: Extend this, once DT components are supported. */
11193 ar
= &event_expr
->ref
->u
.ar
;
11195 memset (ar
, '\0', sizeof (*ar
));
11197 ar
->type
= AR_FULL
;
11199 gfc_init_se (&argse
, NULL
);
11200 argse
.descriptor_only
= 1;
11201 gfc_conv_expr_descriptor (&argse
, event_expr
);
11202 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
11206 extent
= build_one_cst (gfc_array_index_type
);
11207 for (i
= 0; i
< ar
->dimen
; i
++)
11209 gfc_init_se (&argse
, NULL
);
11210 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
11211 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
11212 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
11213 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
11214 TREE_TYPE (lbound
), argse
.expr
, lbound
);
11215 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
11216 TREE_TYPE (tmp
), extent
, tmp
);
11217 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
11218 TREE_TYPE (tmp
), index
, tmp
);
11219 if (i
< ar
->dimen
- 1)
11221 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
11222 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
11223 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
11224 TREE_TYPE (tmp
), extent
, tmp
);
11229 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
11232 count
= gfc_create_var (integer_type_node
, "count");
11235 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
11238 stat
= gfc_create_var (integer_type_node
, "stat");
11241 index
= fold_convert (size_type_node
, index
);
11242 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
11243 token
, index
, image_index
, count
11244 ? gfc_build_addr_expr (NULL
, count
) : count
,
11245 stat
!= null_pointer_node
11246 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
11247 gfc_add_expr_to_block (&se
.pre
, tmp
);
11249 if (count2
!= NULL_TREE
)
11250 gfc_add_modify (&se
.pre
, count2
,
11251 fold_convert (TREE_TYPE (count2
), count
));
11253 if (stat2
!= NULL_TREE
)
11254 gfc_add_modify (&se
.pre
, stat2
,
11255 fold_convert (TREE_TYPE (stat2
), stat
));
11257 return gfc_finish_block (&se
.pre
);
11260 gfc_init_se (&argse
, NULL
);
11261 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
11262 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
11264 if (stat
!= NULL_TREE
)
11265 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11267 return gfc_finish_block (&se
.pre
);
11271 conv_intrinsic_move_alloc (gfc_code
*code
)
11274 gfc_expr
*from_expr
, *to_expr
;
11275 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
11276 gfc_se from_se
, to_se
;
11280 gfc_start_block (&block
);
11282 from_expr
= code
->ext
.actual
->expr
;
11283 to_expr
= code
->ext
.actual
->next
->expr
;
11285 gfc_init_se (&from_se
, NULL
);
11286 gfc_init_se (&to_se
, NULL
);
11288 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
11289 || to_expr
->ts
.type
== BT_CLASS
);
11290 coarray
= gfc_get_corank (from_expr
) != 0;
11292 if (from_expr
->rank
== 0 && !coarray
)
11294 if (from_expr
->ts
.type
!= BT_CLASS
)
11295 from_expr2
= from_expr
;
11298 from_expr2
= gfc_copy_expr (from_expr
);
11299 gfc_add_data_component (from_expr2
);
11302 if (to_expr
->ts
.type
!= BT_CLASS
)
11303 to_expr2
= to_expr
;
11306 to_expr2
= gfc_copy_expr (to_expr
);
11307 gfc_add_data_component (to_expr2
);
11310 from_se
.want_pointer
= 1;
11311 to_se
.want_pointer
= 1;
11312 gfc_conv_expr (&from_se
, from_expr2
);
11313 gfc_conv_expr (&to_se
, to_expr2
);
11314 gfc_add_block_to_block (&block
, &from_se
.pre
);
11315 gfc_add_block_to_block (&block
, &to_se
.pre
);
11317 /* Deallocate "to". */
11318 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
11319 true, to_expr
, to_expr
->ts
);
11320 gfc_add_expr_to_block (&block
, tmp
);
11322 /* Assign (_data) pointers. */
11323 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11324 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
11326 /* Set "from" to NULL. */
11327 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11328 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
11330 gfc_add_block_to_block (&block
, &from_se
.post
);
11331 gfc_add_block_to_block (&block
, &to_se
.post
);
11334 if (to_expr
->ts
.type
== BT_CLASS
)
11338 gfc_free_expr (to_expr2
);
11339 gfc_init_se (&to_se
, NULL
);
11340 to_se
.want_pointer
= 1;
11341 gfc_add_vptr_component (to_expr
);
11342 gfc_conv_expr (&to_se
, to_expr
);
11344 if (from_expr
->ts
.type
== BT_CLASS
)
11346 if (UNLIMITED_POLY (from_expr
))
11350 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
11354 gfc_free_expr (from_expr2
);
11355 gfc_init_se (&from_se
, NULL
);
11356 from_se
.want_pointer
= 1;
11357 gfc_add_vptr_component (from_expr
);
11358 gfc_conv_expr (&from_se
, from_expr
);
11359 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11360 fold_convert (TREE_TYPE (to_se
.expr
),
11363 /* Reset _vptr component to declared type. */
11365 /* Unlimited polymorphic. */
11366 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11367 fold_convert (TREE_TYPE (from_se
.expr
),
11368 null_pointer_node
));
11371 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11372 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11373 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
11378 vtab
= gfc_find_vtab (&from_expr
->ts
);
11380 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11381 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11382 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
11386 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
11388 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
11389 fold_convert (TREE_TYPE (to_se
.string_length
),
11390 from_se
.string_length
));
11391 if (from_expr
->ts
.deferred
)
11392 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
11393 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
11396 return gfc_finish_block (&block
);
11399 /* Update _vptr component. */
11400 if (to_expr
->ts
.type
== BT_CLASS
)
11404 to_se
.want_pointer
= 1;
11405 to_expr2
= gfc_copy_expr (to_expr
);
11406 gfc_add_vptr_component (to_expr2
);
11407 gfc_conv_expr (&to_se
, to_expr2
);
11409 if (from_expr
->ts
.type
== BT_CLASS
)
11411 if (UNLIMITED_POLY (from_expr
))
11415 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
11419 from_se
.want_pointer
= 1;
11420 from_expr2
= gfc_copy_expr (from_expr
);
11421 gfc_add_vptr_component (from_expr2
);
11422 gfc_conv_expr (&from_se
, from_expr2
);
11423 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11424 fold_convert (TREE_TYPE (to_se
.expr
),
11427 /* Reset _vptr component to declared type. */
11429 /* Unlimited polymorphic. */
11430 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11431 fold_convert (TREE_TYPE (from_se
.expr
),
11432 null_pointer_node
));
11435 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11436 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11437 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
11442 vtab
= gfc_find_vtab (&from_expr
->ts
);
11444 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11445 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11446 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
11449 gfc_free_expr (to_expr2
);
11450 gfc_init_se (&to_se
, NULL
);
11452 if (from_expr
->ts
.type
== BT_CLASS
)
11454 gfc_free_expr (from_expr2
);
11455 gfc_init_se (&from_se
, NULL
);
11460 /* Deallocate "to". */
11461 if (from_expr
->rank
== 0)
11463 to_se
.want_coarray
= 1;
11464 from_se
.want_coarray
= 1;
11466 gfc_conv_expr_descriptor (&to_se
, to_expr
);
11467 gfc_conv_expr_descriptor (&from_se
, from_expr
);
11469 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
11470 is an image control "statement", cf. IR F08/0040 in 12-006A. */
11471 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
11475 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
11476 NULL_TREE
, NULL_TREE
, true, to_expr
,
11477 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
11478 gfc_add_expr_to_block (&block
, tmp
);
11480 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
11481 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
11482 logical_type_node
, tmp
,
11483 fold_convert (TREE_TYPE (tmp
),
11484 null_pointer_node
));
11485 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
11486 3, null_pointer_node
, null_pointer_node
,
11487 build_int_cst (integer_type_node
, 0));
11489 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
11490 tmp
, build_empty_stmt (input_location
));
11491 gfc_add_expr_to_block (&block
, tmp
);
11495 if (to_expr
->ts
.type
== BT_DERIVED
11496 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
11498 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
11499 to_se
.expr
, to_expr
->rank
);
11500 gfc_add_expr_to_block (&block
, tmp
);
11503 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
11504 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
11505 NULL_TREE
, true, to_expr
,
11506 GFC_CAF_COARRAY_NOCOARRAY
);
11507 gfc_add_expr_to_block (&block
, tmp
);
11510 /* Move the pointer and update the array descriptor data. */
11511 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
11513 /* Set "from" to NULL. */
11514 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
11515 gfc_add_modify_loc (input_location
, &block
, tmp
,
11516 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
11519 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
11521 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
11522 fold_convert (TREE_TYPE (to_se
.string_length
),
11523 from_se
.string_length
));
11524 if (from_expr
->ts
.deferred
)
11525 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
11526 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
11529 return gfc_finish_block (&block
);
11534 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
11538 gcc_assert (code
->resolved_isym
);
11540 switch (code
->resolved_isym
->id
)
11542 case GFC_ISYM_MOVE_ALLOC
:
11543 res
= conv_intrinsic_move_alloc (code
);
11546 case GFC_ISYM_ATOMIC_CAS
:
11547 res
= conv_intrinsic_atomic_cas (code
);
11550 case GFC_ISYM_ATOMIC_ADD
:
11551 case GFC_ISYM_ATOMIC_AND
:
11552 case GFC_ISYM_ATOMIC_DEF
:
11553 case GFC_ISYM_ATOMIC_OR
:
11554 case GFC_ISYM_ATOMIC_XOR
:
11555 case GFC_ISYM_ATOMIC_FETCH_ADD
:
11556 case GFC_ISYM_ATOMIC_FETCH_AND
:
11557 case GFC_ISYM_ATOMIC_FETCH_OR
:
11558 case GFC_ISYM_ATOMIC_FETCH_XOR
:
11559 res
= conv_intrinsic_atomic_op (code
);
11562 case GFC_ISYM_ATOMIC_REF
:
11563 res
= conv_intrinsic_atomic_ref (code
);
11566 case GFC_ISYM_EVENT_QUERY
:
11567 res
= conv_intrinsic_event_query (code
);
11570 case GFC_ISYM_C_F_POINTER
:
11571 case GFC_ISYM_C_F_PROCPOINTER
:
11572 res
= conv_isocbinding_subroutine (code
);
11575 case GFC_ISYM_CAF_SEND
:
11576 res
= conv_caf_send (code
);
11579 case GFC_ISYM_CO_BROADCAST
:
11580 case GFC_ISYM_CO_MIN
:
11581 case GFC_ISYM_CO_MAX
:
11582 case GFC_ISYM_CO_REDUCE
:
11583 case GFC_ISYM_CO_SUM
:
11584 res
= conv_co_collective (code
);
11587 case GFC_ISYM_FREE
:
11588 res
= conv_intrinsic_free (code
);
11591 case GFC_ISYM_RANDOM_INIT
:
11592 res
= conv_intrinsic_random_init (code
);
11595 case GFC_ISYM_KILL
:
11596 res
= conv_intrinsic_kill_sub (code
);
11599 case GFC_ISYM_SYSTEM_CLOCK
:
11600 res
= conv_intrinsic_system_clock (code
);
11611 #include "gt-fortran-trans-intrinsic.h"