1 /* Intrinsic translation
2 Copyright (C) 2002-2022 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. */
45 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
47 /* This maps Fortran intrinsic math functions to external library or GCC
49 typedef struct GTY(()) gfc_intrinsic_map_t
{
50 /* The explicit enum is required to work around inadequacies in the
51 garbage collection/gengtype parsing mechanism. */
54 /* Enum value from the "language-independent", aka C-centric, part
55 of gcc, or END_BUILTINS of no such value set. */
56 enum built_in_function float_built_in
;
57 enum built_in_function double_built_in
;
58 enum built_in_function long_double_built_in
;
59 enum built_in_function complex_float_built_in
;
60 enum built_in_function complex_double_built_in
;
61 enum built_in_function complex_long_double_built_in
;
63 /* True if the naming pattern is to prepend "c" for complex and
64 append "f" for kind=4. False if the naming pattern is to
65 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
68 /* True if a complex version of the function exists. */
69 bool complex_available
;
71 /* True if the function should be marked const. */
74 /* The base library name of this function. */
77 /* Cache decls created for the various operand types. */
89 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
90 defines complex variants of all of the entries in mathbuiltins.def
92 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
93 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
94 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
95 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
96 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
98 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
99 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
100 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
101 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
102 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
104 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
105 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
106 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
108 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
110 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
111 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
112 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
113 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
114 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
116 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
118 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
119 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
120 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
121 #include "mathbuiltins.def"
123 /* Functions in libgfortran. */
124 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
125 LIB_FUNCTION (SIND
, "sind", false),
126 LIB_FUNCTION (COSD
, "cosd", false),
127 LIB_FUNCTION (TAND
, "tand", false),
130 LIB_FUNCTION (NONE
, NULL
, false)
135 #undef DEFINE_MATH_BUILTIN
136 #undef DEFINE_MATH_BUILTIN_C
139 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
142 /* Find the correct variant of a given builtin from its argument. */
144 builtin_decl_for_precision (enum built_in_function base_built_in
,
147 enum built_in_function i
= END_BUILTINS
;
149 gfc_intrinsic_map_t
*m
;
150 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
153 if (precision
== TYPE_PRECISION (float_type_node
))
154 i
= m
->float_built_in
;
155 else if (precision
== TYPE_PRECISION (double_type_node
))
156 i
= m
->double_built_in
;
157 else if (precision
== TYPE_PRECISION (long_double_type_node
))
158 i
= m
->long_double_built_in
;
159 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
161 /* Special treatment, because it is not exactly a built-in, but
162 a library function. */
163 return m
->real16_decl
;
166 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
171 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
174 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
176 if (gfc_real_kinds
[i
].c_float128
)
178 /* For _Float128, the story is a bit different, because we return
179 a decl to a library function rather than a built-in. */
180 gfc_intrinsic_map_t
*m
;
181 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
184 return m
->real16_decl
;
187 return builtin_decl_for_precision (double_built_in
,
188 gfc_real_kinds
[i
].mode_precision
);
192 /* Evaluate the arguments to an intrinsic function. The value
193 of NARGS may be less than the actual number of arguments in EXPR
194 to allow optional "KIND" arguments that are not included in the
195 generated code to be ignored. */
198 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
199 tree
*argarray
, int nargs
)
201 gfc_actual_arglist
*actual
;
203 gfc_intrinsic_arg
*formal
;
207 formal
= expr
->value
.function
.isym
->formal
;
208 actual
= expr
->value
.function
.actual
;
210 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
211 actual
= actual
->next
,
212 formal
= formal
? formal
->next
: NULL
)
216 /* Skip omitted optional arguments. */
223 /* Evaluate the parameter. This will substitute scalarized
224 references automatically. */
225 gfc_init_se (&argse
, se
);
227 if (e
->ts
.type
== BT_CHARACTER
)
229 gfc_conv_expr (&argse
, e
);
230 gfc_conv_string_parameter (&argse
);
231 argarray
[curr_arg
++] = argse
.string_length
;
232 gcc_assert (curr_arg
< nargs
);
235 gfc_conv_expr_val (&argse
, e
);
237 /* If an optional argument is itself an optional dummy argument,
238 check its presence and substitute a null if absent. */
239 if (e
->expr_type
== EXPR_VARIABLE
240 && e
->symtree
->n
.sym
->attr
.optional
243 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
245 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
246 gfc_add_block_to_block (&se
->post
, &argse
.post
);
247 argarray
[curr_arg
] = argse
.expr
;
251 /* Count the number of actual arguments to the intrinsic function EXPR
252 including any "hidden" string length arguments. */
255 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
258 gfc_actual_arglist
*actual
;
260 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
265 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
275 /* Conversions between different types are output by the frontend as
276 intrinsic functions. We implement these directly with inline code. */
279 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
285 nargs
= gfc_intrinsic_argument_list_length (expr
);
286 args
= XALLOCAVEC (tree
, nargs
);
288 /* Evaluate all the arguments passed. Whilst we're only interested in the
289 first one here, there are other parts of the front-end that assume this
290 and will trigger an ICE if it's not the case. */
291 type
= gfc_typenode_for_spec (&expr
->ts
);
292 gcc_assert (expr
->value
.function
.actual
->expr
);
293 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
295 /* Conversion between character kinds involves a call to a library
297 if (expr
->ts
.type
== BT_CHARACTER
)
299 tree fndecl
, var
, addr
, tmp
;
301 if (expr
->ts
.kind
== 1
302 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
303 fndecl
= gfor_fndecl_convert_char4_to_char1
;
304 else if (expr
->ts
.kind
== 4
305 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
306 fndecl
= gfor_fndecl_convert_char1_to_char4
;
310 /* Create the variable storing the converted value. */
311 type
= gfc_get_pchar_type (expr
->ts
.kind
);
312 var
= gfc_create_var (type
, "str");
313 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
315 /* Call the library function that will perform the conversion. */
316 gcc_assert (nargs
>= 2);
317 tmp
= build_call_expr_loc (input_location
,
318 fndecl
, 3, addr
, args
[0], args
[1]);
319 gfc_add_expr_to_block (&se
->pre
, tmp
);
321 /* Free the temporary afterwards. */
322 tmp
= gfc_call_free (var
);
323 gfc_add_expr_to_block (&se
->post
, tmp
);
326 se
->string_length
= args
[0];
331 /* Conversion from complex to non-complex involves taking the real
332 component of the value. */
333 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
334 && expr
->ts
.type
!= BT_COMPLEX
)
338 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
339 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
343 se
->expr
= convert (type
, args
[0]);
346 /* This is needed because the gcc backend only implements
347 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
348 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
349 Similarly for CEILING. */
352 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
359 argtype
= TREE_TYPE (arg
);
360 arg
= gfc_evaluate_now (arg
, pblock
);
362 intval
= convert (type
, arg
);
363 intval
= gfc_evaluate_now (intval
, pblock
);
365 tmp
= convert (argtype
, intval
);
366 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
367 logical_type_node
, tmp
, arg
);
369 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
370 intval
, build_int_cst (type
, 1));
371 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
376 /* Round to nearest integer, away from zero. */
379 build_round_expr (tree arg
, tree restype
)
383 int argprec
, resprec
;
385 argtype
= TREE_TYPE (arg
);
386 argprec
= TYPE_PRECISION (argtype
);
387 resprec
= TYPE_PRECISION (restype
);
389 /* Depending on the type of the result, choose the int intrinsic (iround,
390 available only as a builtin, therefore cannot use it for _Float128), long
391 int intrinsic (lround family) or long long intrinsic (llround). If we
392 don't have an appropriate function that converts directly to the integer
393 type (such as kind == 16), just use ROUND, and then convert the result to
394 an integer. We might also need to convert the result afterwards. */
395 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
396 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
397 else if (resprec
<= LONG_TYPE_SIZE
)
398 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
399 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
400 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
401 else if (resprec
>= argprec
)
402 fn
= builtin_decl_for_precision (BUILT_IN_ROUND
, argprec
);
406 return convert (restype
, build_call_expr_loc (input_location
,
411 /* Convert a real to an integer using a specific rounding mode.
412 Ideally we would just build the corresponding GENERIC node,
413 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
416 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
417 enum rounding_mode op
)
422 return build_fixbound_expr (pblock
, arg
, type
, 0);
425 return build_fixbound_expr (pblock
, arg
, type
, 1);
428 return build_round_expr (arg
, type
);
431 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
439 /* Round a real value using the specified rounding mode.
440 We use a temporary integer of that same kind size as the result.
441 Values larger than those that can be represented by this kind are
442 unchanged, as they will not be accurate enough to represent the
444 huge = HUGE (KIND (a))
445 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
449 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
461 kind
= expr
->ts
.kind
;
462 nargs
= gfc_intrinsic_argument_list_length (expr
);
465 /* We have builtin functions for some cases. */
469 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
473 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
480 /* Evaluate the argument. */
481 gcc_assert (expr
->value
.function
.actual
->expr
);
482 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
484 /* Use a builtin function if one exists. */
485 if (decl
!= NULL_TREE
)
487 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
491 /* This code is probably redundant, but we'll keep it lying around just
493 type
= gfc_typenode_for_spec (&expr
->ts
);
494 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
496 /* Test if the value is too large to handle sensibly. */
497 gfc_set_model_kind (kind
);
499 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
500 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
501 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
502 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, arg
[0],
505 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
506 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
507 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, arg
[0],
509 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, logical_type_node
,
511 itype
= gfc_get_int_type (kind
);
513 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
514 tmp
= convert (type
, tmp
);
515 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
521 /* Convert to an integer using the specified rounding mode. */
524 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
530 nargs
= gfc_intrinsic_argument_list_length (expr
);
531 args
= XALLOCAVEC (tree
, nargs
);
533 /* Evaluate the argument, we process all arguments even though we only
534 use the first one for code generation purposes. */
535 type
= gfc_typenode_for_spec (&expr
->ts
);
536 gcc_assert (expr
->value
.function
.actual
->expr
);
537 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
539 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
541 /* Conversion to a different integer kind. */
542 se
->expr
= convert (type
, args
[0]);
546 /* Conversion from complex to non-complex involves taking the real
547 component of the value. */
548 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
549 && expr
->ts
.type
!= BT_COMPLEX
)
553 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
554 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
558 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
563 /* Get the imaginary component of a value. */
566 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
570 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
571 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
572 TREE_TYPE (TREE_TYPE (arg
)), arg
);
576 /* Get the complex conjugate of a value. */
579 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
583 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
584 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
590 define_quad_builtin (const char *name
, tree type
, bool is_const
)
593 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
596 /* Mark the decl as external. */
597 DECL_EXTERNAL (fndecl
) = 1;
598 TREE_PUBLIC (fndecl
) = 1;
600 /* Mark it __attribute__((const)). */
601 TREE_READONLY (fndecl
) = is_const
;
603 rest_of_decl_compilation (fndecl
, 1, 0);
608 /* Add SIMD attribute for FNDECL built-in if the built-in
609 name is in VECTORIZED_BUILTINS. */
612 add_simd_flag_for_built_in (tree fndecl
)
614 if (gfc_vectorized_builtins
== NULL
615 || fndecl
== NULL_TREE
)
618 const char *name
= IDENTIFIER_POINTER (DECL_NAME (fndecl
));
619 int *clauses
= gfc_vectorized_builtins
->get (name
);
622 for (unsigned i
= 0; i
< 3; i
++)
623 if (*clauses
& (1 << i
))
625 gfc_simd_clause simd_type
= (gfc_simd_clause
)*clauses
;
626 tree omp_clause
= NULL_TREE
;
627 if (simd_type
== SIMD_NONE
)
628 ; /* No SIMD clause. */
632 = (simd_type
== SIMD_INBRANCH
633 ? OMP_CLAUSE_INBRANCH
: OMP_CLAUSE_NOTINBRANCH
);
634 omp_clause
= build_omp_clause (UNKNOWN_LOCATION
, code
);
635 omp_clause
= build_tree_list (NULL_TREE
, omp_clause
);
638 DECL_ATTRIBUTES (fndecl
)
639 = tree_cons (get_identifier ("omp declare simd"), omp_clause
,
640 DECL_ATTRIBUTES (fndecl
));
645 /* Set SIMD attribute to all built-in functions that are mentioned
646 in gfc_vectorized_builtins vector. */
649 gfc_adjust_builtins (void)
651 gfc_intrinsic_map_t
*m
;
652 for (m
= gfc_intrinsic_map
;
653 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
655 add_simd_flag_for_built_in (m
->real4_decl
);
656 add_simd_flag_for_built_in (m
->complex4_decl
);
657 add_simd_flag_for_built_in (m
->real8_decl
);
658 add_simd_flag_for_built_in (m
->complex8_decl
);
659 add_simd_flag_for_built_in (m
->real10_decl
);
660 add_simd_flag_for_built_in (m
->complex10_decl
);
661 add_simd_flag_for_built_in (m
->real16_decl
);
662 add_simd_flag_for_built_in (m
->complex16_decl
);
663 add_simd_flag_for_built_in (m
->real16_decl
);
664 add_simd_flag_for_built_in (m
->complex16_decl
);
667 /* Release all strings. */
668 if (gfc_vectorized_builtins
!= NULL
)
670 for (hash_map
<nofree_string_hash
, int>::iterator it
671 = gfc_vectorized_builtins
->begin ();
672 it
!= gfc_vectorized_builtins
->end (); ++it
)
673 free (CONST_CAST (char *, (*it
).first
));
675 delete gfc_vectorized_builtins
;
676 gfc_vectorized_builtins
= NULL
;
680 /* Initialize function decls for library functions. The external functions
681 are created as required. Builtin functions are added here. */
684 gfc_build_intrinsic_lib_fndecls (void)
686 gfc_intrinsic_map_t
*m
;
687 tree quad_decls
[END_BUILTINS
+ 1];
689 if (gfc_real16_is_float128
)
691 /* If we have soft-float types, we create the decls for their
692 C99-like library functions. For now, we only handle _Float128
693 q-suffixed functions. */
695 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
696 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
698 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
700 type
= gfc_float128_type_node
;
701 complex_type
= gfc_complex_float128_type_node
;
702 /* type (*) (type) */
703 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
705 func_iround
= build_function_type_list (integer_type_node
,
707 /* long (*) (type) */
708 func_lround
= build_function_type_list (long_integer_type_node
,
710 /* long long (*) (type) */
711 func_llround
= build_function_type_list (long_long_integer_type_node
,
713 /* type (*) (type, type) */
714 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
715 /* type (*) (type, &int) */
717 = build_function_type_list (type
,
719 build_pointer_type (integer_type_node
),
721 /* type (*) (type, int) */
722 func_scalbn
= build_function_type_list (type
,
723 type
, integer_type_node
, NULL_TREE
);
724 /* type (*) (complex type) */
725 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
726 /* complex type (*) (complex type, complex type) */
728 = build_function_type_list (complex_type
,
729 complex_type
, complex_type
, NULL_TREE
);
731 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
732 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
733 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
735 /* Only these built-ins are actually needed here. These are used directly
736 from the code, when calling builtin_decl_for_precision() or
737 builtin_decl_for_float_type(). The others are all constructed by
738 gfc_get_intrinsic_lib_fndecl(). */
739 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
740 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
742 #include "mathbuiltins.def"
746 #undef DEFINE_MATH_BUILTIN
747 #undef DEFINE_MATH_BUILTIN_C
749 /* There is one built-in we defined manually, because it gets called
750 with builtin_decl_for_precision() or builtin_decl_for_float_type()
751 even though it is not an OTHER_BUILTIN: it is SQRT. */
752 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
756 /* Add GCC builtin functions. */
757 for (m
= gfc_intrinsic_map
;
758 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
760 if (m
->float_built_in
!= END_BUILTINS
)
761 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
762 if (m
->complex_float_built_in
!= END_BUILTINS
)
763 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
764 if (m
->double_built_in
!= END_BUILTINS
)
765 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
766 if (m
->complex_double_built_in
!= END_BUILTINS
)
767 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
769 /* If real(kind=10) exists, it is always long double. */
770 if (m
->long_double_built_in
!= END_BUILTINS
)
771 m
->real10_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 if (!gfc_real16_is_float128
)
778 if (m
->long_double_built_in
!= END_BUILTINS
)
779 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
780 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
782 = builtin_decl_explicit (m
->complex_long_double_built_in
);
784 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
786 /* Quad-precision function calls are constructed when first
787 needed by builtin_decl_for_precision(), except for those
788 that will be used directly (define by OTHER_BUILTIN). */
789 m
->real16_decl
= quad_decls
[m
->double_built_in
];
791 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
793 /* Same thing for the complex ones. */
794 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
800 /* Create a fndecl for a simple intrinsic library function. */
803 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
806 vec
<tree
, va_gc
> *argtypes
;
808 gfc_actual_arglist
*actual
;
811 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
814 if (ts
->type
== BT_REAL
)
819 pdecl
= &m
->real4_decl
;
822 pdecl
= &m
->real8_decl
;
825 pdecl
= &m
->real10_decl
;
828 pdecl
= &m
->real16_decl
;
834 else if (ts
->type
== BT_COMPLEX
)
836 gcc_assert (m
->complex_available
);
841 pdecl
= &m
->complex4_decl
;
844 pdecl
= &m
->complex8_decl
;
847 pdecl
= &m
->complex10_decl
;
850 pdecl
= &m
->complex16_decl
;
864 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
865 if (gfc_real_kinds
[n
].c_float
)
866 snprintf (name
, sizeof (name
), "%s%s%s",
867 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
868 else if (gfc_real_kinds
[n
].c_double
)
869 snprintf (name
, sizeof (name
), "%s%s",
870 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
871 else if (gfc_real_kinds
[n
].c_long_double
)
872 snprintf (name
, sizeof (name
), "%s%s%s",
873 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
874 else if (gfc_real_kinds
[n
].c_float128
)
875 snprintf (name
, sizeof (name
), "%s%s%s",
876 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
882 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
883 ts
->type
== BT_COMPLEX
? 'c' : 'r',
888 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
890 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
891 vec_safe_push (argtypes
, type
);
893 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
894 fndecl
= build_decl (input_location
,
895 FUNCTION_DECL
, get_identifier (name
), type
);
897 /* Mark the decl as external. */
898 DECL_EXTERNAL (fndecl
) = 1;
899 TREE_PUBLIC (fndecl
) = 1;
901 /* Mark it __attribute__((const)), if possible. */
902 TREE_READONLY (fndecl
) = m
->is_constant
;
904 rest_of_decl_compilation (fndecl
, 1, 0);
911 /* Convert an intrinsic function into an external or builtin call. */
914 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
916 gfc_intrinsic_map_t
*m
;
920 unsigned int num_args
;
923 id
= expr
->value
.function
.isym
->id
;
924 /* Find the entry for this function. */
925 for (m
= gfc_intrinsic_map
;
926 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
932 if (m
->id
== GFC_ISYM_NONE
)
934 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
935 expr
->value
.function
.name
, id
);
938 /* Get the decl and generate the call. */
939 num_args
= gfc_intrinsic_argument_list_length (expr
);
940 args
= XALLOCAVEC (tree
, num_args
);
942 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
943 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
944 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
946 fndecl
= build_addr (fndecl
);
947 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
951 /* If bounds-checking is enabled, create code to verify at runtime that the
952 string lengths for both expressions are the same (needed for e.g. MERGE).
953 If bounds-checking is not enabled, does nothing. */
956 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
957 tree a
, tree b
, stmtblock_t
* target
)
962 /* If bounds-checking is disabled, do nothing. */
963 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
966 /* Compare the two string lengths. */
967 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, a
, b
);
969 /* Output the runtime-check. */
970 name
= gfc_build_cstring_const (intr_name
);
971 name
= gfc_build_addr_expr (pchar_type_node
, name
);
972 gfc_trans_runtime_check (true, false, cond
, target
, where
,
973 "Unequal character lengths (%ld/%ld) in %s",
974 fold_convert (long_integer_type_node
, a
),
975 fold_convert (long_integer_type_node
, b
), name
);
979 /* The EXPONENT(X) intrinsic function is translated into
981 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
982 so that if X is a NaN or infinity, the result is HUGE(0).
986 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
988 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
991 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
992 expr
->value
.function
.actual
->expr
->ts
.kind
);
994 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
995 arg
= gfc_evaluate_now (arg
, &se
->pre
);
997 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
998 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
999 cond
= build_call_expr_loc (input_location
,
1000 builtin_decl_explicit (BUILT_IN_ISFINITE
),
1003 res
= gfc_create_var (integer_type_node
, NULL
);
1004 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
1005 gfc_build_addr_expr (NULL_TREE
, res
));
1006 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
1008 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
1011 type
= gfc_typenode_for_spec (&expr
->ts
);
1012 se
->expr
= fold_convert (type
, se
->expr
);
1016 /* Fill in the following structure
1017 struct caf_vector_t {
1018 size_t nvec; // size of the vector
1025 ptrdiff_t lower_bound;
1026 ptrdiff_t upper_bound;
1033 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
1034 tree lower
, tree upper
, tree stride
,
1035 tree vector
, int kind
, tree nvec
)
1037 tree field
, type
, tmp
;
1039 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
1040 type
= TREE_TYPE (desc
);
1042 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1043 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1044 desc
, field
, NULL_TREE
);
1045 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
1048 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1049 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1050 desc
, field
, NULL_TREE
);
1051 type
= TREE_TYPE (desc
);
1053 /* Access the inner struct. */
1054 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
1055 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1056 desc
, field
, NULL_TREE
);
1057 type
= TREE_TYPE (desc
);
1059 if (vector
!= NULL_TREE
)
1061 /* Set vector and kind. */
1062 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1063 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1064 desc
, field
, NULL_TREE
);
1065 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
1066 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1067 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1068 desc
, field
, NULL_TREE
);
1069 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
1073 /* Set dim.lower/upper/stride. */
1074 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1075 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1076 desc
, field
, NULL_TREE
);
1077 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1079 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1080 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1081 desc
, field
, NULL_TREE
);
1082 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1084 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1085 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1086 desc
, field
, NULL_TREE
);
1087 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1093 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1096 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1097 tree lbound
, ubound
, tmp
;
1100 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1102 for (i
= 0; i
< ar
->dimen
; i
++)
1103 switch (ar
->dimen_type
[i
])
1108 gfc_init_se (&argse
, NULL
);
1109 gfc_conv_expr (&argse
, ar
->end
[i
]);
1110 gfc_add_block_to_block (block
, &argse
.pre
);
1111 upper
= gfc_evaluate_now (argse
.expr
, block
);
1114 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1117 gfc_init_se (&argse
, NULL
);
1118 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1119 gfc_add_block_to_block (block
, &argse
.pre
);
1120 stride
= gfc_evaluate_now (argse
.expr
, block
);
1123 stride
= gfc_index_one_node
;
1129 gfc_init_se (&argse
, NULL
);
1130 gfc_conv_expr (&argse
, ar
->start
[i
]);
1131 gfc_add_block_to_block (block
, &argse
.pre
);
1132 lower
= gfc_evaluate_now (argse
.expr
, block
);
1135 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1136 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1139 stride
= gfc_index_one_node
;
1142 nvec
= size_zero_node
;
1143 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1148 gfc_init_se (&argse
, NULL
);
1149 argse
.descriptor_only
= 1;
1150 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1151 gfc_add_block_to_block (block
, &argse
.pre
);
1152 vector
= argse
.expr
;
1153 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1154 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1155 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1156 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1157 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1158 TREE_TYPE (nvec
), nvec
, tmp
);
1159 lower
= gfc_index_zero_node
;
1160 upper
= gfc_index_zero_node
;
1161 stride
= gfc_index_zero_node
;
1162 vector
= gfc_conv_descriptor_data_get (vector
);
1163 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1164 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1169 return gfc_build_addr_expr (NULL_TREE
, var
);
1174 compute_component_offset (tree field
, tree type
)
1177 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1178 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1180 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1181 DECL_FIELD_BIT_OFFSET (field
),
1183 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1186 return DECL_FIELD_OFFSET (field
);
1191 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1193 gfc_ref
*ref
= expr
->ref
, *last_comp_ref
;
1194 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1195 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1196 start
, end
, stride
, vector
, nvec
;
1198 bool ref_static_array
= false;
1199 tree last_component_ref_tree
= NULL_TREE
;
1204 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1205 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
1206 && !expr
->symtree
->n
.sym
->attr
.pointer
;
1209 /* Prevent uninit-warning. */
1210 reference_type
= NULL_TREE
;
1212 /* Skip refs upto the first coarray-ref. */
1213 last_comp_ref
= NULL
;
1214 while (ref
&& (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
== 0))
1216 /* Remember the type of components skipped. */
1217 if (ref
->type
== REF_COMPONENT
)
1218 last_comp_ref
= ref
;
1221 /* When a component was skipped, get the type information of the last
1222 component ref, else get the type from the symbol. */
1225 last_type
= gfc_typenode_for_spec (&last_comp_ref
->u
.c
.component
->ts
);
1226 last_type_n
= last_comp_ref
->u
.c
.component
->ts
.type
;
1230 last_type
= gfc_typenode_for_spec (&expr
->symtree
->n
.sym
->ts
);
1231 last_type_n
= expr
->symtree
->n
.sym
->ts
.type
;
1236 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0
1237 && ref
->u
.ar
.dimen
== 0)
1239 /* Skip pure coindexes. */
1243 tmp
= gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1244 reference_type
= TREE_TYPE (tmp
);
1246 if (caf_ref
== NULL_TREE
)
1249 /* Construct the chain of refs. */
1250 if (prev_caf_ref
!= NULL_TREE
)
1252 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1253 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1254 TREE_TYPE (field
), prev_caf_ref
, field
,
1256 gfc_add_modify (block
, tmp2
, gfc_build_addr_expr (TREE_TYPE (field
),
1264 last_type
= gfc_typenode_for_spec (&ref
->u
.c
.component
->ts
);
1265 last_type_n
= ref
->u
.c
.component
->ts
.type
;
1266 /* Set the type of the ref. */
1267 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1268 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1269 TREE_TYPE (field
), prev_caf_ref
, field
,
1271 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1272 GFC_CAF_REF_COMPONENT
));
1274 /* Ref the c in union u. */
1275 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1276 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1277 TREE_TYPE (field
), prev_caf_ref
, field
,
1279 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 0);
1280 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1281 TREE_TYPE (field
), tmp
, field
,
1284 /* Set the offset. */
1285 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1286 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1287 TREE_TYPE (field
), inner_struct
, field
,
1289 /* Computing the offset is somewhat harder. The bit_offset has to be
1290 taken into account. When the bit_offset in the field_decl is non-
1291 null, divide it by the bitsize_unit and add it to the regular
1293 tmp2
= compute_component_offset (ref
->u
.c
.component
->backend_decl
,
1295 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1297 /* Set caf_token_offset. */
1298 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 1);
1299 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1300 TREE_TYPE (field
), inner_struct
, field
,
1302 if ((ref
->u
.c
.component
->attr
.allocatable
1303 || ref
->u
.c
.component
->attr
.pointer
)
1304 && ref
->u
.c
.component
->attr
.dimension
)
1306 tree arr_desc_token_offset
;
1307 /* Get the token field from the descriptor. */
1308 arr_desc_token_offset
= TREE_OPERAND (
1309 gfc_conv_descriptor_token (ref
->u
.c
.component
->backend_decl
), 1);
1310 arr_desc_token_offset
1311 = compute_component_offset (arr_desc_token_offset
,
1313 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
,
1314 TREE_TYPE (tmp2
), tmp2
,
1315 arr_desc_token_offset
);
1317 else if (ref
->u
.c
.component
->caf_token
)
1318 tmp2
= compute_component_offset (ref
->u
.c
.component
->caf_token
,
1321 tmp2
= integer_zero_node
;
1322 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1324 /* Remember whether this ref was to a non-allocatable/non-pointer
1325 component so the next array ref can be tailored correctly. */
1326 ref_static_array
= !ref
->u
.c
.component
->attr
.allocatable
1327 && !ref
->u
.c
.component
->attr
.pointer
;
1328 last_component_ref_tree
= ref_static_array
1329 ? ref
->u
.c
.component
->backend_decl
: NULL_TREE
;
1332 if (ref_static_array
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
)
1333 ref_static_array
= false;
1334 /* Set the type of the ref. */
1335 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1336 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1337 TREE_TYPE (field
), prev_caf_ref
, field
,
1339 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1341 ? GFC_CAF_REF_STATIC_ARRAY
1342 : GFC_CAF_REF_ARRAY
));
1344 /* Ref the a in union u. */
1345 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1346 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1347 TREE_TYPE (field
), prev_caf_ref
, field
,
1349 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 1);
1350 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1351 TREE_TYPE (field
), tmp
, field
,
1354 /* Set the static_array_type in a for static arrays. */
1355 if (ref_static_array
)
1357 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)),
1359 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1360 TREE_TYPE (field
), inner_struct
, field
,
1362 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (tmp
),
1365 /* Ref the mode in the inner_struct. */
1366 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1367 mode
= fold_build3_loc (input_location
, COMPONENT_REF
,
1368 TREE_TYPE (field
), inner_struct
, field
,
1370 /* Ref the dim in the inner_struct. */
1371 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 2);
1372 dim_array
= fold_build3_loc (input_location
, COMPONENT_REF
,
1373 TREE_TYPE (field
), inner_struct
, field
,
1375 for (i
= 0; i
< ref
->u
.ar
.dimen
; ++i
)
1378 dim
= gfc_build_array_ref (dim_array
, gfc_rank_cst
[i
], NULL_TREE
);
1379 dim_type
= TREE_TYPE (dim
);
1380 mode_rhs
= start
= end
= stride
= NULL_TREE
;
1381 switch (ref
->u
.ar
.dimen_type
[i
])
1384 if (ref
->u
.ar
.end
[i
])
1386 gfc_init_se (&se
, NULL
);
1387 gfc_conv_expr (&se
, ref
->u
.ar
.end
[i
]);
1388 gfc_add_block_to_block (block
, &se
.pre
);
1389 if (ref_static_array
)
1391 /* Make the index zero-based, when reffing a static
1394 gfc_init_se (&se
, NULL
);
1395 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1396 gfc_add_block_to_block (block
, &se
.pre
);
1397 se
.expr
= fold_build2 (MINUS_EXPR
,
1398 gfc_array_index_type
,
1400 gfc_array_index_type
,
1403 end
= gfc_evaluate_now (fold_convert (
1404 gfc_array_index_type
,
1408 else if (ref_static_array
)
1409 end
= fold_build2 (MINUS_EXPR
,
1410 gfc_array_index_type
,
1411 gfc_conv_array_ubound (
1412 last_component_ref_tree
, i
),
1413 gfc_conv_array_lbound (
1414 last_component_ref_tree
, i
));
1418 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1419 GFC_CAF_ARR_REF_OPEN_END
);
1421 if (ref
->u
.ar
.stride
[i
])
1423 gfc_init_se (&se
, NULL
);
1424 gfc_conv_expr (&se
, ref
->u
.ar
.stride
[i
]);
1425 gfc_add_block_to_block (block
, &se
.pre
);
1426 stride
= gfc_evaluate_now (fold_convert (
1427 gfc_array_index_type
,
1430 if (ref_static_array
)
1432 /* Make the index zero-based, when reffing a static
1434 stride
= fold_build2 (MULT_EXPR
,
1435 gfc_array_index_type
,
1436 gfc_conv_array_stride (
1437 last_component_ref_tree
,
1440 gcc_assert (end
!= NULL_TREE
);
1441 /* Multiply with the product of array's stride and
1442 the step of the ref to a virtual upper bound.
1443 We cannot compute the actual upper bound here or
1444 the caflib would compute the extend
1446 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1447 end
, gfc_conv_array_stride (
1448 last_component_ref_tree
,
1450 end
= gfc_evaluate_now (end
, block
);
1451 stride
= gfc_evaluate_now (stride
, block
);
1454 else if (ref_static_array
)
1456 stride
= gfc_conv_array_stride (last_component_ref_tree
,
1458 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1460 end
= gfc_evaluate_now (end
, block
);
1463 /* Always set a ref stride of one to make caflib's
1465 stride
= gfc_index_one_node
;
1469 if (ref
->u
.ar
.start
[i
])
1471 gfc_init_se (&se
, NULL
);
1472 gfc_conv_expr (&se
, ref
->u
.ar
.start
[i
]);
1473 gfc_add_block_to_block (block
, &se
.pre
);
1474 if (ref_static_array
)
1476 /* Make the index zero-based, when reffing a static
1478 start
= fold_convert (gfc_array_index_type
, se
.expr
);
1479 gfc_init_se (&se
, NULL
);
1480 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1481 gfc_add_block_to_block (block
, &se
.pre
);
1482 se
.expr
= fold_build2 (MINUS_EXPR
,
1483 gfc_array_index_type
,
1484 start
, fold_convert (
1485 gfc_array_index_type
,
1487 /* Multiply with the stride. */
1488 se
.expr
= fold_build2 (MULT_EXPR
,
1489 gfc_array_index_type
,
1491 gfc_conv_array_stride (
1492 last_component_ref_tree
,
1495 start
= gfc_evaluate_now (fold_convert (
1496 gfc_array_index_type
,
1499 if (mode_rhs
== NULL_TREE
)
1500 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1501 ref
->u
.ar
.dimen_type
[i
]
1503 ? GFC_CAF_ARR_REF_SINGLE
1504 : GFC_CAF_ARR_REF_RANGE
);
1506 else if (ref_static_array
)
1508 start
= integer_zero_node
;
1509 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1510 ref
->u
.ar
.start
[i
] == NULL
1511 ? GFC_CAF_ARR_REF_FULL
1512 : GFC_CAF_ARR_REF_RANGE
);
1514 else if (end
== NULL_TREE
)
1515 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1516 GFC_CAF_ARR_REF_FULL
);
1518 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1519 GFC_CAF_ARR_REF_OPEN_START
);
1521 /* Ref the s in dim. */
1522 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 0);
1523 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1524 TREE_TYPE (field
), dim
, field
,
1527 /* Set start in s. */
1528 if (start
!= NULL_TREE
)
1530 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1532 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1533 TREE_TYPE (field
), tmp
, field
,
1535 gfc_add_modify (block
, tmp2
,
1536 fold_convert (TREE_TYPE (tmp2
), start
));
1540 if (end
!= NULL_TREE
)
1542 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1544 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1545 TREE_TYPE (field
), tmp
, field
,
1547 gfc_add_modify (block
, tmp2
,
1548 fold_convert (TREE_TYPE (tmp2
), end
));
1552 if (stride
!= NULL_TREE
)
1554 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1556 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1557 TREE_TYPE (field
), tmp
, field
,
1559 gfc_add_modify (block
, tmp2
,
1560 fold_convert (TREE_TYPE (tmp2
), stride
));
1564 /* TODO: In case of static array. */
1565 gcc_assert (!ref_static_array
);
1566 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1567 GFC_CAF_ARR_REF_VECTOR
);
1568 gfc_init_se (&se
, NULL
);
1569 se
.descriptor_only
= 1;
1570 gfc_conv_expr_descriptor (&se
, ref
->u
.ar
.start
[i
]);
1571 gfc_add_block_to_block (block
, &se
.pre
);
1573 tmp
= gfc_conv_descriptor_lbound_get (vector
,
1575 tmp2
= gfc_conv_descriptor_ubound_get (vector
,
1577 nvec
= gfc_conv_array_extent_dim (tmp
, tmp2
, NULL
);
1578 tmp
= gfc_conv_descriptor_stride_get (vector
,
1580 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1581 TREE_TYPE (nvec
), nvec
, tmp
);
1582 vector
= gfc_conv_descriptor_data_get (vector
);
1584 /* Ref the v in dim. */
1585 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 1);
1586 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1587 TREE_TYPE (field
), dim
, field
,
1590 /* Set vector in v. */
1591 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 0);
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 nvec in v. */
1599 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 1);
1600 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1601 TREE_TYPE (field
), tmp
, field
,
1603 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1606 /* Set kind in v. */
1607 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 2);
1608 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1609 TREE_TYPE (field
), tmp
, field
,
1611 gfc_add_modify (block
, tmp2
, build_int_cst (integer_type_node
,
1612 ref
->u
.ar
.start
[i
]->ts
.kind
));
1617 /* Set the mode for dim i. */
1618 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1619 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
),
1623 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1624 if (i
< GFC_MAX_DIMENSIONS
)
1626 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1627 gfc_add_modify (block
, tmp
,
1628 build_int_cst (unsigned_char_type_node
,
1629 GFC_CAF_ARR_REF_NONE
));
1636 /* Set the size of the current type. */
1637 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 2);
1638 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1639 prev_caf_ref
, field
, NULL_TREE
);
1640 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1641 TYPE_SIZE_UNIT (last_type
)));
1646 if (prev_caf_ref
!= NULL_TREE
)
1648 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1649 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1650 prev_caf_ref
, field
, NULL_TREE
);
1651 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1652 null_pointer_node
));
1654 return caf_ref
!= NULL_TREE
? gfc_build_addr_expr (NULL_TREE
, caf_ref
)
1658 /* Get data from a remote coarray. */
1661 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1662 tree may_require_tmp
, bool may_realloc
,
1663 symbol_attribute
*caf_attr
)
1665 gfc_expr
*array_expr
, *tmp_stat
;
1667 tree caf_decl
, token
, offset
, image_index
, tmp
;
1668 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
1670 symbol_attribute caf_attr_store
;
1672 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1674 if (se
->ss
&& se
->ss
->info
->useflags
)
1676 /* Access the previously obtained result. */
1677 gfc_conv_tmp_array_ref (se
);
1681 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1682 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1683 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1685 if (caf_attr
== NULL
)
1687 caf_attr_store
= gfc_caf_attr (array_expr
);
1688 caf_attr
= &caf_attr_store
;
1694 vec
= null_pointer_node
;
1695 tmp_stat
= gfc_find_stat_co (expr
);
1700 gfc_init_se (&stat_se
, NULL
);
1701 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1702 stat
= stat_se
.expr
;
1703 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1704 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1707 stat
= null_pointer_node
;
1709 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1710 is reallocatable or the right-hand side has allocatable components. */
1711 if (caf_attr
->alloc_comp
|| caf_attr
->pointer_comp
|| may_realloc
)
1713 /* Get using caf_get_by_ref. */
1714 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, array_expr
);
1716 if (caf_reference
!= NULL_TREE
)
1718 if (lhs
== NULL_TREE
)
1720 if (array_expr
->ts
.type
== BT_CHARACTER
)
1721 gfc_init_se (&argse
, NULL
);
1722 if (array_expr
->rank
== 0)
1724 symbol_attribute attr
;
1725 gfc_clear_attr (&attr
);
1726 if (array_expr
->ts
.type
== BT_CHARACTER
)
1728 res_var
= gfc_conv_string_tmp (se
,
1729 build_pointer_type (type
),
1730 array_expr
->ts
.u
.cl
->backend_decl
);
1731 argse
.string_length
= array_expr
->ts
.u
.cl
->backend_decl
;
1734 res_var
= gfc_create_var (type
, "caf_res");
1735 dst_var
= gfc_conv_scalar_to_descriptor (se
, res_var
, attr
);
1736 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1740 /* Create temporary. */
1741 if (array_expr
->ts
.type
== BT_CHARACTER
)
1742 gfc_conv_expr_descriptor (&argse
, array_expr
);
1743 may_realloc
= gfc_trans_create_temp_array (&se
->pre
,
1750 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1751 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1754 tmp
= gfc_conv_descriptor_data_get (res_var
);
1755 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
,
1756 NULL_TREE
, NULL_TREE
,
1759 GFC_CAF_COARRAY_NOCOARRAY
);
1760 gfc_add_expr_to_block (&se
->post
, tmp
);
1765 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1766 if (lhs_kind
== NULL_TREE
)
1769 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1770 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1771 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1772 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1774 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1777 /* No overlap possible as we have generated a temporary. */
1778 if (lhs
== NULL_TREE
)
1779 may_require_tmp
= boolean_false_node
;
1781 /* It guarantees memory consistency within the same segment. */
1782 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1783 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1784 gfc_build_string_const (1, ""), NULL_TREE
,
1785 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1787 ASM_VOLATILE_P (tmp
) = 1;
1788 gfc_add_expr_to_block (&se
->pre
, tmp
);
1790 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1791 10, token
, image_index
, dst_var
,
1792 caf_reference
, lhs_kind
, kind
,
1794 may_realloc
? boolean_true_node
:
1796 stat
, build_int_cst (integer_type_node
,
1797 array_expr
->ts
.type
));
1799 gfc_add_expr_to_block (&se
->pre
, tmp
);
1802 gfc_advance_se_ss_chain (se
);
1805 if (array_expr
->ts
.type
== BT_CHARACTER
)
1806 se
->string_length
= argse
.string_length
;
1812 gfc_init_se (&argse
, NULL
);
1813 if (array_expr
->rank
== 0)
1815 symbol_attribute attr
;
1817 gfc_clear_attr (&attr
);
1818 gfc_conv_expr (&argse
, array_expr
);
1820 if (lhs
== NULL_TREE
)
1822 gfc_clear_attr (&attr
);
1823 if (array_expr
->ts
.type
== BT_CHARACTER
)
1824 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1825 argse
.string_length
);
1827 res_var
= gfc_create_var (type
, "caf_res");
1828 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1829 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1831 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1832 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1836 /* If has_vector, pass descriptor for whole array and the
1837 vector bounds separately. */
1838 gfc_array_ref
*ar
, ar2
;
1839 bool has_vector
= false;
1841 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1844 ar
= gfc_find_array_ref (expr
);
1846 memset (ar
, '\0', sizeof (*ar
));
1850 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1851 gfc_conv_expr_descriptor (&argse
, array_expr
);
1852 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1853 has the wrong type if component references are done. */
1854 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1855 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1860 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1864 if (lhs
== NULL_TREE
)
1866 /* Create temporary. */
1867 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1868 if (se
->loop
->to
[n
] == NULL_TREE
)
1870 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1872 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1875 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1876 NULL_TREE
, false, true, false,
1877 &array_expr
->where
);
1878 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1879 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1881 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1884 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1885 if (lhs_kind
== NULL_TREE
)
1888 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1889 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1891 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1892 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1893 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1894 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1895 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1898 /* No overlap possible as we have generated a temporary. */
1899 if (lhs
== NULL_TREE
)
1900 may_require_tmp
= boolean_false_node
;
1902 /* It guarantees memory consistency within the same segment. */
1903 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1904 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1905 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1906 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1907 ASM_VOLATILE_P (tmp
) = 1;
1908 gfc_add_expr_to_block (&se
->pre
, tmp
);
1910 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1911 token
, offset
, image_index
, argse
.expr
, vec
,
1912 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1914 gfc_add_expr_to_block (&se
->pre
, tmp
);
1917 gfc_advance_se_ss_chain (se
);
1920 if (array_expr
->ts
.type
== BT_CHARACTER
)
1921 se
->string_length
= argse
.string_length
;
1925 /* Send data to a remote coarray. */
1928 conv_caf_send (gfc_code
*code
) {
1929 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
, *tmp_team
;
1930 gfc_se lhs_se
, rhs_se
;
1932 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1933 tree may_require_tmp
, src_stat
, dst_stat
, dst_team
;
1934 tree lhs_type
= NULL_TREE
;
1935 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1936 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1938 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1940 lhs_expr
= code
->ext
.actual
->expr
;
1941 rhs_expr
= code
->ext
.actual
->next
->expr
;
1942 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, true) == 0
1943 ? boolean_false_node
: boolean_true_node
;
1944 gfc_init_block (&block
);
1946 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1947 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1948 src_stat
= dst_stat
= null_pointer_node
;
1949 dst_team
= null_pointer_node
;
1952 gfc_init_se (&lhs_se
, NULL
);
1953 if (lhs_expr
->rank
== 0)
1955 if (lhs_expr
->ts
.type
== BT_CHARACTER
&& lhs_expr
->ts
.deferred
)
1957 lhs_se
.expr
= gfc_get_tree_for_caf_expr (lhs_expr
);
1958 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1962 symbol_attribute attr
;
1963 gfc_clear_attr (&attr
);
1964 gfc_conv_expr (&lhs_se
, lhs_expr
);
1965 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1966 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
,
1968 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1971 else if ((lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
1972 && lhs_caf_attr
.codimension
)
1974 lhs_se
.want_pointer
= 1;
1975 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1976 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1977 has the wrong type if component references are done. */
1978 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1979 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1980 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1981 gfc_get_dtype_rank_type (
1982 gfc_has_vector_subscript (lhs_expr
)
1983 ? gfc_find_array_ref (lhs_expr
)->dimen
1989 bool has_vector
= gfc_has_vector_subscript (lhs_expr
);
1991 if (gfc_is_coindexed (lhs_expr
) || !has_vector
)
1993 /* If has_vector, pass descriptor for whole array and the
1994 vector bounds separately. */
1995 gfc_array_ref
*ar
, ar2
;
1996 bool has_tmp_lhs_array
= false;
1999 has_tmp_lhs_array
= true;
2000 ar
= gfc_find_array_ref (lhs_expr
);
2002 memset (ar
, '\0', sizeof (*ar
));
2006 lhs_se
.want_pointer
= 1;
2007 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
2008 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
2009 that has the wrong type if component references are done. */
2010 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
2011 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
2012 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2013 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2016 if (has_tmp_lhs_array
)
2018 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
2024 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
2025 indexed array expression. This is rewritten to:
2027 tmp_array = arr2[...]
2028 arr1 ([...]) = tmp_array
2030 because using the standard gfc_conv_expr (lhs_expr) did the
2031 assignment with lhs and rhs exchanged. */
2033 gfc_ss
*lss_for_tmparray
, *lss_real
;
2037 tree tmparr_desc
, src
;
2038 tree index
= gfc_index_zero_node
;
2039 tree stride
= gfc_index_zero_node
;
2042 /* Walk both sides of the assignment, once to get the shape of the
2043 temporary array to create right. */
2044 lss_for_tmparray
= gfc_walk_expr (lhs_expr
);
2045 /* And a second time to be able to create an assignment of the
2046 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
2047 the tree in the descriptor with the one for the temporary
2049 lss_real
= gfc_walk_expr (lhs_expr
);
2050 gfc_init_loopinfo (&loop
);
2051 gfc_add_ss_to_loop (&loop
, lss_for_tmparray
);
2052 gfc_add_ss_to_loop (&loop
, lss_real
);
2053 gfc_conv_ss_startstride (&loop
);
2054 gfc_conv_loop_setup (&loop
, &lhs_expr
->where
);
2055 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
2056 gfc_trans_create_temp_array (&lhs_se
.pre
, &lhs_se
.post
,
2057 lss_for_tmparray
, lhs_type
, NULL_TREE
,
2060 tmparr_desc
= lss_for_tmparray
->info
->data
.array
.descriptor
;
2061 gfc_start_scalarized_body (&loop
, &body
);
2062 gfc_init_se (&se
, NULL
);
2063 gfc_copy_loopinfo_to_se (&se
, &loop
);
2065 gfc_conv_expr (&se
, lhs_expr
);
2066 gfc_add_block_to_block (&body
, &se
.pre
);
2068 /* Walk over all indexes of the loop. */
2069 for (n
= loop
.dimen
- 1; n
> 0; --n
)
2071 tmp
= loop
.loopvar
[n
];
2072 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2073 gfc_array_index_type
, tmp
, loop
.from
[n
]);
2074 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2075 gfc_array_index_type
, tmp
, index
);
2077 stride
= fold_build2_loc (input_location
, MINUS_EXPR
,
2078 gfc_array_index_type
,
2079 loop
.to
[n
- 1], loop
.from
[n
- 1]);
2080 stride
= fold_build2_loc (input_location
, PLUS_EXPR
,
2081 gfc_array_index_type
,
2082 stride
, gfc_index_one_node
);
2084 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2085 gfc_array_index_type
, tmp
, stride
);
2088 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2089 gfc_array_index_type
,
2090 index
, loop
.from
[0]);
2092 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2093 gfc_array_index_type
,
2094 loop
.loopvar
[0], index
);
2096 src
= build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc
));
2097 src
= gfc_build_array_ref (src
, index
, NULL
);
2098 /* Now create the assignment of lhs_expr = tmp_array. */
2099 gfc_add_modify (&body
, se
.expr
, src
);
2100 gfc_add_block_to_block (&body
, &se
.post
);
2101 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, tmparr_desc
);
2102 gfc_trans_scalarizing_loops (&loop
, &body
);
2103 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2104 gfc_add_expr_to_block (&lhs_se
.post
, gfc_finish_block (&loop
.pre
));
2105 gfc_free_ss (lss_for_tmparray
);
2106 gfc_free_ss (lss_real
);
2110 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
2112 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2113 temporary and a loop. */
2114 if (!gfc_is_coindexed (lhs_expr
)
2115 && (!lhs_caf_attr
.codimension
2116 || !(lhs_expr
->rank
> 0
2117 && (lhs_caf_attr
.allocatable
|| lhs_caf_attr
.pointer
))))
2119 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
2120 gcc_assert (gfc_is_coindexed (rhs_expr
));
2121 gfc_init_se (&rhs_se
, NULL
);
2122 if (lhs_expr
->rank
== 0 && lhs_caf_attr
.allocatable
)
2125 gfc_init_se (&scal_se
, NULL
);
2126 scal_se
.want_pointer
= 1;
2127 gfc_conv_expr (&scal_se
, lhs_expr
);
2128 /* Ensure scalar on lhs is allocated. */
2129 gfc_add_block_to_block (&block
, &scal_se
.pre
);
2131 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
2133 gfc_typenode_for_spec (&lhs_expr
->ts
)),
2135 tmp
= fold_build2 (EQ_EXPR
, logical_type_node
, scal_se
.expr
,
2137 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2138 tmp
, gfc_finish_block (&scal_se
.pre
),
2139 build_empty_stmt (input_location
));
2140 gfc_add_expr_to_block (&block
, tmp
);
2143 lhs_may_realloc
= lhs_may_realloc
2144 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
2145 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2146 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
2147 may_require_tmp
, lhs_may_realloc
,
2149 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2150 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2151 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2152 return gfc_finish_block (&block
);
2155 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2157 /* Obtain token, offset and image index for the LHS. */
2158 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
2159 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2160 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2161 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
2163 if (lhs_caf_attr
.alloc_comp
)
2164 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
2167 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
2172 gfc_init_se (&rhs_se
, NULL
);
2173 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
2174 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2175 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
2176 if (rhs_expr
->rank
== 0)
2178 symbol_attribute attr
;
2179 gfc_clear_attr (&attr
);
2180 gfc_conv_expr (&rhs_se
, rhs_expr
);
2181 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
2182 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2184 else if ((rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2185 && rhs_caf_attr
.codimension
)
2188 rhs_se
.want_pointer
= 1;
2189 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2190 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2191 has the wrong type if component references are done. */
2192 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2193 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2194 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2195 gfc_get_dtype_rank_type (
2196 gfc_has_vector_subscript (rhs_expr
)
2197 ? gfc_find_array_ref (rhs_expr
)->dimen
2203 /* If has_vector, pass descriptor for whole array and the
2204 vector bounds separately. */
2205 gfc_array_ref
*ar
, ar2
;
2206 bool has_vector
= false;
2209 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2212 ar
= gfc_find_array_ref (rhs_expr
);
2214 memset (ar
, '\0', sizeof (*ar
));
2218 rhs_se
.want_pointer
= 1;
2219 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2220 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2221 has the wrong type if component references are done. */
2222 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2223 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2224 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2225 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2230 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2235 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2237 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2239 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2244 gfc_init_se (&stat_se
, NULL
);
2245 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2246 dst_stat
= stat_se
.expr
;
2247 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2248 gfc_add_block_to_block (&block
, &stat_se
.post
);
2251 tmp_team
= gfc_find_team_co (lhs_expr
);
2256 gfc_init_se (&team_se
, NULL
);
2257 gfc_conv_expr_reference (&team_se
, tmp_team
);
2258 dst_team
= team_se
.expr
;
2259 gfc_add_block_to_block (&block
, &team_se
.pre
);
2260 gfc_add_block_to_block (&block
, &team_se
.post
);
2263 if (!gfc_is_coindexed (rhs_expr
))
2265 if (lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
2267 tree reference
, dst_realloc
;
2268 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2269 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2270 : boolean_false_node
;
2271 tmp
= build_call_expr_loc (input_location
,
2272 gfor_fndecl_caf_send_by_ref
,
2273 10, token
, image_index
, rhs_se
.expr
,
2274 reference
, lhs_kind
, rhs_kind
,
2275 may_require_tmp
, dst_realloc
, src_stat
,
2276 build_int_cst (integer_type_node
,
2277 lhs_expr
->ts
.type
));
2280 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 11,
2281 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2282 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2283 may_require_tmp
, src_stat
, dst_team
);
2287 tree rhs_token
, rhs_offset
, rhs_image_index
;
2289 /* It guarantees memory consistency within the same segment. */
2290 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2291 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2292 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2293 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2294 ASM_VOLATILE_P (tmp
) = 1;
2295 gfc_add_expr_to_block (&block
, tmp
);
2297 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2298 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2299 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2300 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2302 if (rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2304 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2309 gfc_init_se (&stat_se
, NULL
);
2310 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2311 src_stat
= stat_se
.expr
;
2312 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2313 gfc_add_block_to_block (&block
, &stat_se
.post
);
2316 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2318 tree lhs_reference
, rhs_reference
;
2319 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2320 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2321 tmp
= build_call_expr_loc (input_location
,
2322 gfor_fndecl_caf_sendget_by_ref
, 13,
2323 token
, image_index
, lhs_reference
,
2324 rhs_token
, rhs_image_index
, rhs_reference
,
2325 lhs_kind
, rhs_kind
, may_require_tmp
,
2327 build_int_cst (integer_type_node
,
2329 build_int_cst (integer_type_node
,
2330 rhs_expr
->ts
.type
));
2334 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2336 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2337 14, token
, offset
, image_index
,
2338 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2339 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2340 rhs_kind
, may_require_tmp
, src_stat
);
2343 gfc_add_expr_to_block (&block
, tmp
);
2344 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2345 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2347 /* It guarantees memory consistency within the same segment. */
2348 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2349 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2350 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2351 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2352 ASM_VOLATILE_P (tmp
) = 1;
2353 gfc_add_expr_to_block (&block
, tmp
);
2355 return gfc_finish_block (&block
);
2360 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2363 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2364 lbound
, ubound
, extent
, ml
;
2367 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2369 if (expr
->value
.function
.actual
->expr
2370 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2371 distance
= expr
->value
.function
.actual
->expr
;
2373 /* The case -fcoarray=single is handled elsewhere. */
2374 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2376 /* Argument-free version: THIS_IMAGE(). */
2377 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2381 gfc_init_se (&argse
, NULL
);
2382 gfc_conv_expr_val (&argse
, distance
);
2383 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2384 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2385 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2388 tmp
= integer_zero_node
;
2389 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2391 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2396 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2398 type
= gfc_get_int_type (gfc_default_integer_kind
);
2399 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2400 rank
= expr
->value
.function
.actual
->expr
->rank
;
2402 /* Obtain the descriptor of the COARRAY. */
2403 gfc_init_se (&argse
, NULL
);
2404 argse
.want_coarray
= 1;
2405 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2406 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2407 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2412 /* Create an implicit second parameter from the loop variable. */
2413 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2414 gcc_assert (corank
> 0);
2415 gcc_assert (se
->loop
->dimen
== 1);
2416 gcc_assert (se
->ss
->info
->expr
== expr
);
2418 dim_arg
= se
->loop
->loopvar
[0];
2419 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2420 gfc_array_index_type
, dim_arg
,
2421 build_int_cst (TREE_TYPE (dim_arg
), 1));
2422 gfc_advance_se_ss_chain (se
);
2426 /* Use the passed DIM= argument. */
2427 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2428 gfc_init_se (&argse
, NULL
);
2429 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2430 gfc_array_index_type
);
2431 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2432 dim_arg
= argse
.expr
;
2434 if (INTEGER_CST_P (dim_arg
))
2436 if (wi::ltu_p (wi::to_wide (dim_arg
), 1)
2437 || wi::gtu_p (wi::to_wide (dim_arg
),
2438 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2439 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2440 "dimension index", expr
->value
.function
.isym
->name
,
2443 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2445 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2446 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2448 build_int_cst (TREE_TYPE (dim_arg
), 1));
2449 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2450 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2452 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2453 logical_type_node
, cond
, tmp
);
2454 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2459 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2460 one always has a dim_arg argument.
2462 m = this_image() - 1
2465 sub(1) = m + lcobound(corank)
2469 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2472 extent = gfc_extent(i)
2480 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2481 : m + lcobound(corank)
2484 /* this_image () - 1. */
2485 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2487 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2488 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2491 /* sub(1) = m + lcobound(corank). */
2492 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2493 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2495 lbound
= fold_convert (type
, lbound
);
2496 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2502 m
= gfc_create_var (type
, NULL
);
2503 ml
= gfc_create_var (type
, NULL
);
2504 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2505 min_var
= gfc_create_var (integer_type_node
, NULL
);
2507 /* m = this_image () - 1. */
2508 gfc_add_modify (&se
->pre
, m
, tmp
);
2510 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2511 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2512 fold_convert (integer_type_node
, dim_arg
),
2513 build_int_cst (integer_type_node
, rank
- 1));
2514 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2515 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2517 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2520 tmp
= build_int_cst (integer_type_node
, rank
);
2521 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2523 exit_label
= gfc_build_label_decl (NULL_TREE
);
2524 TREE_USED (exit_label
) = 1;
2527 gfc_init_block (&loop
);
2530 gfc_add_modify (&loop
, ml
, m
);
2533 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2534 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2535 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2536 extent
= fold_convert (type
, extent
);
2539 gfc_add_modify (&loop
, m
,
2540 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2543 /* Exit condition: if (i >= min_var) goto exit_label. */
2544 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, loop_var
,
2546 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2547 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2548 build_empty_stmt (input_location
));
2549 gfc_add_expr_to_block (&loop
, tmp
);
2551 /* Increment loop variable: i++. */
2552 gfc_add_modify (&loop
, loop_var
,
2553 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2555 build_int_cst (integer_type_node
, 1)));
2557 /* Making the loop... actually loop! */
2558 tmp
= gfc_finish_block (&loop
);
2559 tmp
= build1_v (LOOP_EXPR
, tmp
);
2560 gfc_add_expr_to_block (&se
->pre
, tmp
);
2562 /* The exit label. */
2563 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2564 gfc_add_expr_to_block (&se
->pre
, tmp
);
2566 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2567 : m + lcobound(corank) */
2569 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, dim_arg
,
2570 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2572 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2573 fold_build2_loc (input_location
, PLUS_EXPR
,
2574 gfc_array_index_type
, dim_arg
,
2575 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2576 lbound
= fold_convert (type
, lbound
);
2578 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2579 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2581 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2583 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2584 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2589 /* Convert a call to image_status. */
2592 conv_intrinsic_image_status (gfc_se
*se
, gfc_expr
*expr
)
2594 unsigned int num_args
;
2597 num_args
= gfc_intrinsic_argument_list_length (expr
);
2598 args
= XALLOCAVEC (tree
, num_args
);
2599 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2600 /* In args[0] the number of the image the status is desired for has to be
2603 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2606 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2607 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2608 fold_convert (integer_type_node
, arg
),
2610 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2611 tmp
, integer_zero_node
,
2612 build_int_cst (integer_type_node
,
2613 GFC_STAT_STOPPED_IMAGE
));
2615 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2616 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_image_status
, 2,
2617 args
[0], build_int_cst (integer_type_node
, -1));
2625 conv_intrinsic_team_number (gfc_se
*se
, gfc_expr
*expr
)
2627 unsigned int num_args
;
2631 num_args
= gfc_intrinsic_argument_list_length (expr
);
2632 args
= XALLOCAVEC (tree
, num_args
);
2633 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2636 GFC_FCOARRAY_SINGLE
&& expr
->value
.function
.actual
->expr
)
2640 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2641 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2642 fold_convert (integer_type_node
, arg
),
2644 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2645 tmp
, integer_zero_node
,
2646 build_int_cst (integer_type_node
,
2647 GFC_STAT_STOPPED_IMAGE
));
2649 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2651 // the value -1 represents that no team has been created yet
2652 tmp
= build_int_cst (integer_type_node
, -1);
2654 else if (flag_coarray
== GFC_FCOARRAY_LIB
&& expr
->value
.function
.actual
->expr
)
2655 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2656 args
[0], build_int_cst (integer_type_node
, -1));
2657 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2658 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2659 integer_zero_node
, build_int_cst (integer_type_node
, -1));
2668 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2670 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2672 gfc_se argse
, subse
;
2673 int rank
, corank
, codim
;
2675 type
= gfc_get_int_type (gfc_default_integer_kind
);
2676 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2677 rank
= expr
->value
.function
.actual
->expr
->rank
;
2679 /* Obtain the descriptor of the COARRAY. */
2680 gfc_init_se (&argse
, NULL
);
2681 argse
.want_coarray
= 1;
2682 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2683 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2684 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2687 /* Obtain a handle to the SUB argument. */
2688 gfc_init_se (&subse
, NULL
);
2689 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2690 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2691 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2692 subdesc
= build_fold_indirect_ref_loc (input_location
,
2693 gfc_conv_descriptor_data_get (subse
.expr
));
2695 /* Fortran 2008 does not require that the values remain in the cobounds,
2696 thus we need explicitly check this - and return 0 if they are exceeded. */
2698 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2699 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2700 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2701 fold_convert (gfc_array_index_type
, tmp
),
2704 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2706 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2707 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2708 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2709 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2710 fold_convert (gfc_array_index_type
, tmp
),
2712 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2713 logical_type_node
, invalid_bound
, cond
);
2714 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2715 fold_convert (gfc_array_index_type
, tmp
),
2717 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2718 logical_type_node
, invalid_bound
, cond
);
2721 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2723 /* See Fortran 2008, C.10 for the following algorithm. */
2725 /* coindex = sub(corank) - lcobound(n). */
2726 coindex
= fold_convert (gfc_array_index_type
,
2727 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2729 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2730 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2731 fold_convert (gfc_array_index_type
, coindex
),
2734 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2736 tree extent
, ubound
;
2738 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2739 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2740 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2741 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2743 /* coindex *= extent. */
2744 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2745 gfc_array_index_type
, coindex
, extent
);
2747 /* coindex += sub(codim). */
2748 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2749 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2750 gfc_array_index_type
, coindex
,
2751 fold_convert (gfc_array_index_type
, tmp
));
2753 /* coindex -= lbound(codim). */
2754 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2755 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2756 gfc_array_index_type
, coindex
, lbound
);
2759 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2760 fold_convert(type
, coindex
),
2761 build_int_cst (type
, 1));
2763 /* Return 0 if "coindex" exceeds num_images(). */
2765 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2766 num_images
= build_int_cst (type
, 1);
2769 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2771 build_int_cst (integer_type_node
, -1));
2772 num_images
= fold_convert (type
, tmp
);
2775 tmp
= gfc_create_var (type
, NULL
);
2776 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2778 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, tmp
,
2780 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
2782 fold_convert (logical_type_node
, invalid_bound
));
2783 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2784 build_int_cst (type
, 0), tmp
);
2788 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2790 tree tmp
, distance
, failed
;
2793 if (expr
->value
.function
.actual
->expr
)
2795 gfc_init_se (&argse
, NULL
);
2796 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2797 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2798 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2799 distance
= fold_convert (integer_type_node
, argse
.expr
);
2802 distance
= integer_zero_node
;
2804 if (expr
->value
.function
.actual
->next
->expr
)
2806 gfc_init_se (&argse
, NULL
);
2807 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2808 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2809 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2810 failed
= fold_convert (integer_type_node
, argse
.expr
);
2813 failed
= build_int_cst (integer_type_node
, -1);
2814 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2816 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2821 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2825 gfc_init_se (&argse
, NULL
);
2826 argse
.data_not_needed
= 1;
2827 argse
.descriptor_only
= 1;
2829 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2830 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2831 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2833 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2834 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2840 gfc_conv_intrinsic_is_contiguous (gfc_se
* se
, gfc_expr
* expr
)
2843 arg
= expr
->value
.function
.actual
->expr
;
2844 gfc_conv_is_contiguous_expr (se
, arg
);
2845 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2848 /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2849 plus it can be called directly. */
2852 gfc_conv_is_contiguous_expr (gfc_se
*se
, gfc_expr
*arg
)
2856 tree desc
, tmp
, stride
, extent
, cond
;
2861 if (arg
->ts
.type
== BT_CLASS
)
2862 gfc_add_class_array_ref (arg
);
2864 ss
= gfc_walk_expr (arg
);
2865 gcc_assert (ss
!= gfc_ss_terminator
);
2866 gfc_init_se (&argse
, NULL
);
2867 argse
.data_not_needed
= 1;
2868 gfc_conv_expr_descriptor (&argse
, arg
);
2870 as
= gfc_get_full_arrayspec_from_expr (arg
);
2872 /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2873 Note in addition that zero-sized arrays don't count as contiguous. */
2875 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2877 /* Build the call to is_contiguous0. */
2878 argse
.want_pointer
= 1;
2879 gfc_conv_expr_descriptor (&argse
, arg
);
2880 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2881 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2882 desc
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2883 fncall0
= build_call_expr_loc (input_location
,
2884 gfor_fndecl_is_contiguous0
, 1, desc
);
2886 se
->expr
= convert (logical_type_node
, se
->expr
);
2890 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2891 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2892 desc
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2894 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[0]);
2895 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2896 stride
, build_int_cst (TREE_TYPE (stride
), 1));
2898 for (i
= 0; i
< arg
->rank
- 1; i
++)
2900 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2901 extent
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2902 extent
= fold_build2_loc (input_location
, MINUS_EXPR
,
2903 gfc_array_index_type
, extent
, tmp
);
2904 extent
= fold_build2_loc (input_location
, PLUS_EXPR
,
2905 gfc_array_index_type
, extent
,
2906 gfc_index_one_node
);
2907 tmp
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[i
]);
2908 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2910 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[i
+1]);
2911 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2913 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2914 boolean_type_node
, cond
, tmp
);
2921 /* Evaluate a single upper or lower bound. */
2922 /* TODO: bound intrinsic generates way too much unnecessary code. */
2925 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, enum gfc_isym_id op
)
2927 gfc_actual_arglist
*arg
;
2928 gfc_actual_arglist
*arg2
;
2938 gfc_array_spec
* as
;
2939 bool assumed_rank_lb_one
;
2941 arg
= expr
->value
.function
.actual
;
2946 /* Create an implicit second parameter from the loop variable. */
2947 gcc_assert (!arg2
->expr
|| op
== GFC_ISYM_SHAPE
);
2948 gcc_assert (se
->loop
->dimen
== 1);
2949 gcc_assert (se
->ss
->info
->expr
== expr
);
2950 gfc_advance_se_ss_chain (se
);
2951 bound
= se
->loop
->loopvar
[0];
2952 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2953 gfc_array_index_type
, bound
,
2958 /* use the passed argument. */
2959 gcc_assert (arg2
->expr
);
2960 gfc_init_se (&argse
, NULL
);
2961 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2962 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2964 /* Convert from one based to zero based. */
2965 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2966 gfc_array_index_type
, bound
,
2967 gfc_index_one_node
);
2970 /* TODO: don't re-evaluate the descriptor on each iteration. */
2971 /* Get a descriptor for the first parameter. */
2972 gfc_init_se (&argse
, NULL
);
2973 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2974 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2975 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2979 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2981 if (INTEGER_CST_P (bound
))
2983 gcc_assert (op
!= GFC_ISYM_SHAPE
);
2984 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2985 && wi::geu_p (wi::to_wide (bound
),
2986 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2987 || wi::gtu_p (wi::to_wide (bound
), GFC_MAX_DIMENSIONS
))
2988 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2990 (op
== GFC_ISYM_UBOUND
) ? "UBOUND" : "LBOUND",
2994 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
2996 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2998 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2999 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3000 bound
, build_int_cst (TREE_TYPE (bound
), 0));
3001 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3002 tmp
= gfc_conv_descriptor_rank (desc
);
3004 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
3005 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3006 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
3007 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3008 logical_type_node
, cond
, tmp
);
3009 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
3014 /* Take care of the lbound shift for assumed-rank arrays that are
3015 nonallocatable and nonpointers. Those have a lbound of 1. */
3016 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
3017 && ((arg
->expr
->ts
.type
!= BT_CLASS
3018 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
3019 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
3020 || (arg
->expr
->ts
.type
== BT_CLASS
3021 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
3022 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
3024 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3025 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3026 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
3027 gfc_array_index_type
, ubound
, lbound
);
3028 size
= fold_build2_loc (input_location
, PLUS_EXPR
,
3029 gfc_array_index_type
, size
, gfc_index_one_node
);
3031 /* 13.14.53: Result value for LBOUND
3033 Case (i): For an array section or for an array expression other than a
3034 whole array or array structure component, LBOUND(ARRAY, DIM)
3035 has the value 1. For a whole array or array structure
3036 component, LBOUND(ARRAY, DIM) has the value:
3037 (a) equal to the lower bound for subscript DIM of ARRAY if
3038 dimension DIM of ARRAY does not have extent zero
3039 or if ARRAY is an assumed-size array of rank DIM,
3042 13.14.113: Result value for UBOUND
3044 Case (i): For an array section or for an array expression other than a
3045 whole array or array structure component, UBOUND(ARRAY, DIM)
3046 has the value equal to the number of elements in the given
3047 dimension; otherwise, it has a value equal to the upper bound
3048 for subscript DIM of ARRAY if dimension DIM of ARRAY does
3049 not have size zero and has value zero if dimension DIM has
3052 if (op
== GFC_ISYM_LBOUND
&& assumed_rank_lb_one
)
3053 se
->expr
= gfc_index_one_node
;
3056 if (op
== GFC_ISYM_UBOUND
)
3058 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3059 size
, gfc_index_zero_node
);
3060 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3061 gfc_array_index_type
, cond
,
3062 (assumed_rank_lb_one
? size
: ubound
),
3063 gfc_index_zero_node
);
3065 else if (op
== GFC_ISYM_LBOUND
)
3067 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3068 size
, gfc_index_zero_node
);
3069 if (as
->type
== AS_ASSUMED_SIZE
)
3071 cond1
= fold_build2_loc (input_location
, EQ_EXPR
,
3072 logical_type_node
, bound
,
3073 build_int_cst (TREE_TYPE (bound
),
3074 arg
->expr
->rank
- 1));
3075 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3076 logical_type_node
, cond
, cond1
);
3078 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3079 gfc_array_index_type
, cond
,
3080 lbound
, gfc_index_one_node
);
3082 else if (op
== GFC_ISYM_SHAPE
)
3087 /* According to F2018 16.9.172, para 5, an assumed rank object,
3088 argument associated with and assumed size array, has the ubound
3089 of the final dimension set to -1 and UBOUND must return this.
3090 Similarly for the SHAPE intrinsic. */
3091 if (op
!= GFC_ISYM_LBOUND
&& assumed_rank_lb_one
)
3093 tree minus_one
= build_int_cst (gfc_array_index_type
, -1);
3094 tree rank
= fold_convert (gfc_array_index_type
,
3095 gfc_conv_descriptor_rank (desc
));
3096 rank
= fold_build2_loc (input_location
, PLUS_EXPR
,
3097 gfc_array_index_type
, rank
, minus_one
);
3099 /* Fix the expression to stop it from becoming even more
3101 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3103 /* Descriptors for assumed-size arrays have ubound = -1
3104 in the last dimension. */
3105 cond1
= fold_build2_loc (input_location
, EQ_EXPR
,
3106 logical_type_node
, ubound
, minus_one
);
3107 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
3108 logical_type_node
, bound
, rank
);
3109 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3110 logical_type_node
, cond
, cond1
);
3111 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3112 gfc_array_index_type
, cond
,
3113 minus_one
, se
->expr
);
3116 else /* as is null; this is an old-fashioned 1-based array. */
3118 if (op
!= GFC_ISYM_LBOUND
)
3120 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
3121 gfc_array_index_type
, size
,
3122 gfc_index_zero_node
);
3125 se
->expr
= gfc_index_one_node
;
3129 type
= gfc_typenode_for_spec (&expr
->ts
);
3130 se
->expr
= convert (type
, se
->expr
);
3135 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
3137 gfc_actual_arglist
*arg
;
3138 gfc_actual_arglist
*arg2
;
3140 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
3144 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
3145 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
3146 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
3148 arg
= expr
->value
.function
.actual
;
3151 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
3152 corank
= gfc_get_corank (arg
->expr
);
3154 gfc_init_se (&argse
, NULL
);
3155 argse
.want_coarray
= 1;
3157 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
3158 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3159 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3164 /* Create an implicit second parameter from the loop variable. */
3165 gcc_assert (!arg2
->expr
);
3166 gcc_assert (corank
> 0);
3167 gcc_assert (se
->loop
->dimen
== 1);
3168 gcc_assert (se
->ss
->info
->expr
== expr
);
3170 bound
= se
->loop
->loopvar
[0];
3171 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3172 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
3173 gfc_advance_se_ss_chain (se
);
3177 /* use the passed argument. */
3178 gcc_assert (arg2
->expr
);
3179 gfc_init_se (&argse
, NULL
);
3180 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
3181 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3184 if (INTEGER_CST_P (bound
))
3186 if (wi::ltu_p (wi::to_wide (bound
), 1)
3187 || wi::gtu_p (wi::to_wide (bound
),
3188 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
3189 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3190 "dimension index", expr
->value
.function
.isym
->name
,
3193 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3195 bound
= gfc_evaluate_now (bound
, &se
->pre
);
3196 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3197 bound
, build_int_cst (TREE_TYPE (bound
), 1));
3198 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
3199 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3201 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3202 logical_type_node
, cond
, tmp
);
3203 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
3208 /* Subtract 1 to get to zero based and add dimensions. */
3209 switch (arg
->expr
->rank
)
3212 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
3213 gfc_array_index_type
, bound
,
3214 gfc_index_one_node
);
3218 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3219 gfc_array_index_type
, bound
,
3220 gfc_rank_cst
[arg
->expr
->rank
- 1]);
3224 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3226 /* Handle UCOBOUND with special handling of the last codimension. */
3227 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
3229 /* Last codimension: For -fcoarray=single just return
3230 the lcobound - otherwise add
3231 ceiling (real (num_images ()) / real (size)) - 1
3232 = (num_images () + size - 1) / size - 1
3233 = (num_images - 1) / size(),
3234 where size is the product of the extent of all but the last
3237 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
3241 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
3242 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3243 2, integer_zero_node
,
3244 build_int_cst (integer_type_node
, -1));
3245 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3246 gfc_array_index_type
,
3247 fold_convert (gfc_array_index_type
, tmp
),
3248 build_int_cst (gfc_array_index_type
, 1));
3249 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
3250 gfc_array_index_type
, tmp
,
3251 fold_convert (gfc_array_index_type
, cosize
));
3252 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3253 gfc_array_index_type
, resbound
, tmp
);
3255 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
3257 /* ubound = lbound + num_images() - 1. */
3258 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3259 2, integer_zero_node
,
3260 build_int_cst (integer_type_node
, -1));
3261 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3262 gfc_array_index_type
,
3263 fold_convert (gfc_array_index_type
, tmp
),
3264 build_int_cst (gfc_array_index_type
, 1));
3265 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3266 gfc_array_index_type
, resbound
, tmp
);
3271 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3273 build_int_cst (TREE_TYPE (bound
),
3274 arg
->expr
->rank
+ corank
- 1));
3276 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3277 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3278 gfc_array_index_type
, cond
,
3279 resbound
, resbound2
);
3282 se
->expr
= resbound
;
3285 se
->expr
= resbound
;
3287 type
= gfc_typenode_for_spec (&expr
->ts
);
3288 se
->expr
= convert (type
, se
->expr
);
3293 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
3295 gfc_actual_arglist
*array_arg
;
3296 gfc_actual_arglist
*dim_arg
;
3300 array_arg
= expr
->value
.function
.actual
;
3301 dim_arg
= array_arg
->next
;
3303 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
3305 gfc_init_se (&argse
, NULL
);
3306 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
3307 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3308 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3311 gcc_assert (dim_arg
->expr
);
3312 gfc_init_se (&argse
, NULL
);
3313 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
3314 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3315 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3316 argse
.expr
, gfc_index_one_node
);
3317 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
3321 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
3325 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3327 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
3331 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
3336 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
3337 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
3346 /* Create a complex value from one or two real components. */
3349 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
3355 unsigned int num_args
;
3357 num_args
= gfc_intrinsic_argument_list_length (expr
);
3358 args
= XALLOCAVEC (tree
, num_args
);
3360 type
= gfc_typenode_for_spec (&expr
->ts
);
3361 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3362 real
= convert (TREE_TYPE (type
), args
[0]);
3364 imag
= convert (TREE_TYPE (type
), args
[1]);
3365 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
3367 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
3368 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
3369 imag
= convert (TREE_TYPE (type
), imag
);
3372 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3374 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3378 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3379 MODULO(A, P) = A - FLOOR (A / P) * P
3381 The obvious algorithms above are numerically instable for large
3382 arguments, hence these intrinsics are instead implemented via calls
3383 to the fmod family of functions. It is the responsibility of the
3384 user to ensure that the second argument is non-zero. */
3387 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3397 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3399 switch (expr
->ts
.type
)
3402 /* Integer case is easy, we've got a builtin op. */
3403 type
= TREE_TYPE (args
[0]);
3406 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3409 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3415 /* Check if we have a builtin fmod. */
3416 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3418 /* The builtin should always be available. */
3419 gcc_assert (fmod
!= NULL_TREE
);
3421 tmp
= build_addr (fmod
);
3422 se
->expr
= build_call_array_loc (input_location
,
3423 TREE_TYPE (TREE_TYPE (fmod
)),
3428 type
= TREE_TYPE (args
[0]);
3430 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3431 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3434 modulo = arg - floor (arg/arg2) * arg2
3436 In order to calculate the result accurately, we use the fmod
3437 function as follows.
3439 res = fmod (arg, arg2);
3442 if ((arg < 0) xor (arg2 < 0))
3446 res = copysign (0., arg2);
3448 => As two nested ternary exprs:
3450 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3451 : copysign (0., arg2);
3455 zero
= gfc_build_const (type
, integer_zero_node
);
3456 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3457 if (!flag_signed_zeros
)
3459 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3461 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3463 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3464 logical_type_node
, test
, test2
);
3465 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3467 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3468 logical_type_node
, test
, test2
);
3469 test
= gfc_evaluate_now (test
, &se
->pre
);
3470 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3471 fold_build2_loc (input_location
,
3473 type
, tmp
, args
[1]),
3478 tree expr1
, copysign
, cscall
;
3479 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3481 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3483 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3485 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3486 logical_type_node
, test
, test2
);
3487 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3488 fold_build2_loc (input_location
,
3490 type
, tmp
, args
[1]),
3492 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3494 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3496 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3506 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3507 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3508 where the right shifts are logical (i.e. 0's are shifted in).
3509 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3510 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3512 DSHIFTL(I,J,BITSIZE) = J
3514 DSHIFTR(I,J,BITSIZE) = I. */
3517 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3519 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3520 tree args
[3], cond
, tmp
;
3523 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3525 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3526 type
= TREE_TYPE (args
[0]);
3527 bitsize
= TYPE_PRECISION (type
);
3528 utype
= unsigned_type_for (type
);
3529 stype
= TREE_TYPE (args
[2]);
3531 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3532 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3533 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3535 /* The generic case. */
3536 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3537 build_int_cst (stype
, bitsize
), shift
);
3538 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3539 arg1
, dshiftl
? shift
: tmp
);
3541 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3542 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3543 right
= fold_convert (type
, right
);
3545 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3547 /* Special cases. */
3548 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3549 build_int_cst (stype
, 0));
3550 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3551 dshiftl
? arg1
: arg2
, res
);
3553 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3554 build_int_cst (stype
, bitsize
));
3555 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3556 dshiftl
? arg2
: arg1
, res
);
3562 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3565 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3573 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3574 type
= TREE_TYPE (args
[0]);
3576 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3577 val
= gfc_evaluate_now (val
, &se
->pre
);
3579 zero
= gfc_build_const (type
, integer_zero_node
);
3580 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, val
, zero
);
3581 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3585 /* SIGN(A, B) is absolute value of A times sign of B.
3586 The real value versions use library functions to ensure the correct
3587 handling of negative zero. Integer case implemented as:
3588 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3592 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3598 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3599 if (expr
->ts
.type
== BT_REAL
)
3603 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3604 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3606 /* We explicitly have to ignore the minus sign. We do so by using
3607 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3609 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3612 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3613 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3615 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3616 TREE_TYPE (args
[0]), cond
,
3617 build_call_expr_loc (input_location
, abs
, 1,
3619 build_call_expr_loc (input_location
, tmp
, 2,
3623 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3628 /* Having excluded floating point types, we know we are now dealing
3629 with signed integer types. */
3630 type
= TREE_TYPE (args
[0]);
3632 /* Args[0] is used multiple times below. */
3633 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3635 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3636 the signs of A and B are the same, and of all ones if they differ. */
3637 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3638 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3639 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3640 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3642 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3643 is all ones (i.e. -1). */
3644 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3645 fold_build2_loc (input_location
, PLUS_EXPR
,
3646 type
, args
[0], tmp
), tmp
);
3650 /* Test for the presence of an optional argument. */
3653 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3657 arg
= expr
->value
.function
.actual
->expr
;
3658 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3659 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3660 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3664 /* Calculate the double precision product of two single precision values. */
3667 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3672 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3674 /* Convert the args to double precision before multiplying. */
3675 type
= gfc_typenode_for_spec (&expr
->ts
);
3676 args
[0] = convert (type
, args
[0]);
3677 args
[1] = convert (type
, args
[1]);
3678 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3683 /* Return a length one character string containing an ascii character. */
3686 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3691 unsigned int num_args
;
3693 num_args
= gfc_intrinsic_argument_list_length (expr
);
3694 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3696 type
= gfc_get_char_type (expr
->ts
.kind
);
3697 var
= gfc_create_var (type
, "char");
3699 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3700 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3701 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3702 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3707 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3715 unsigned int num_args
;
3717 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3718 args
= XALLOCAVEC (tree
, num_args
);
3720 var
= gfc_create_var (pchar_type_node
, "pstr");
3721 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3723 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3724 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3725 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3727 fndecl
= build_addr (gfor_fndecl_ctime
);
3728 tmp
= build_call_array_loc (input_location
,
3729 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3730 fndecl
, num_args
, args
);
3731 gfc_add_expr_to_block (&se
->pre
, tmp
);
3733 /* Free the temporary afterwards, if necessary. */
3734 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3735 len
, build_int_cst (TREE_TYPE (len
), 0));
3736 tmp
= gfc_call_free (var
);
3737 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3738 gfc_add_expr_to_block (&se
->post
, tmp
);
3741 se
->string_length
= len
;
3746 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3754 unsigned int num_args
;
3756 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3757 args
= XALLOCAVEC (tree
, num_args
);
3759 var
= gfc_create_var (pchar_type_node
, "pstr");
3760 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3762 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3763 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3764 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3766 fndecl
= build_addr (gfor_fndecl_fdate
);
3767 tmp
= build_call_array_loc (input_location
,
3768 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3769 fndecl
, num_args
, args
);
3770 gfc_add_expr_to_block (&se
->pre
, tmp
);
3772 /* Free the temporary afterwards, if necessary. */
3773 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3774 len
, build_int_cst (TREE_TYPE (len
), 0));
3775 tmp
= gfc_call_free (var
);
3776 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3777 gfc_add_expr_to_block (&se
->post
, tmp
);
3780 se
->string_length
= len
;
3784 /* Generate a direct call to free() for the FREE subroutine. */
3787 conv_intrinsic_free (gfc_code
*code
)
3793 gfc_init_se (&argse
, NULL
);
3794 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3795 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3797 gfc_init_block (&block
);
3798 call
= build_call_expr_loc (input_location
,
3799 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3800 gfc_add_expr_to_block (&block
, call
);
3801 return gfc_finish_block (&block
);
3805 /* Call the RANDOM_INIT library subroutine with a hidden argument for
3806 handling seeding on coarray images. */
3809 conv_intrinsic_random_init (gfc_code
*code
)
3813 tree arg1
, arg2
, tmp
;
3814 /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3815 tree used_bool_type_node
= flag_coarray
== GFC_FCOARRAY_LIB
3817 : gfc_get_logical_type (4);
3819 /* Make the function call. */
3820 gfc_init_block (&block
);
3821 gfc_init_se (&se
, NULL
);
3823 /* Convert REPEATABLE to the desired LOGICAL entity. */
3824 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
3825 gfc_add_block_to_block (&block
, &se
.pre
);
3826 arg1
= fold_convert (used_bool_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3827 gfc_add_block_to_block (&block
, &se
.post
);
3829 /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3830 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
3831 gfc_add_block_to_block (&block
, &se
.pre
);
3832 arg2
= fold_convert (used_bool_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3833 gfc_add_block_to_block (&block
, &se
.post
);
3835 if (flag_coarray
== GFC_FCOARRAY_LIB
)
3837 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_random_init
,
3842 /* The ABI for libgfortran needs to be maintained, so a hidden
3843 argument must be include if code is compiled with -fcoarray=single
3844 or without the option. Set to 0. */
3845 tree arg3
= build_int_cst (gfc_get_int_type (4), 0);
3846 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_random_init
,
3847 3, arg1
, arg2
, arg3
);
3850 gfc_add_expr_to_block (&block
, tmp
);
3852 return gfc_finish_block (&block
);
3856 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3860 conv_intrinsic_system_clock (gfc_code
*code
)
3863 gfc_se count_se
, count_rate_se
, count_max_se
;
3864 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3868 gfc_expr
*count
= code
->ext
.actual
->expr
;
3869 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3870 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3872 /* Evaluate our arguments. */
3875 gfc_init_se (&count_se
, NULL
);
3876 gfc_conv_expr (&count_se
, count
);
3881 gfc_init_se (&count_rate_se
, NULL
);
3882 gfc_conv_expr (&count_rate_se
, count_rate
);
3887 gfc_init_se (&count_max_se
, NULL
);
3888 gfc_conv_expr (&count_max_se
, count_max
);
3891 /* Find the smallest kind found of the arguments. */
3893 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3894 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3896 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3899 /* Prepare temporary variables. */
3904 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3905 else if (least
== 4)
3906 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3907 else if (count
->ts
.kind
== 1)
3908 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3911 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3918 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3919 else if (least
== 4)
3920 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3922 arg2
= integer_zero_node
;
3928 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3929 else if (least
== 4)
3930 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3932 arg3
= integer_zero_node
;
3935 /* Make the function call. */
3936 gfc_init_block (&block
);
3942 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3943 : null_pointer_node
;
3944 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3945 : null_pointer_node
;
3946 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3947 : null_pointer_node
;
3952 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3953 : null_pointer_node
;
3954 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3955 : null_pointer_node
;
3956 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3957 : null_pointer_node
;
3964 tmp
= build_call_expr_loc (input_location
,
3965 gfor_fndecl_system_clock4
, 3,
3966 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3967 : null_pointer_node
,
3968 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3969 : null_pointer_node
,
3970 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3971 : null_pointer_node
);
3972 gfc_add_expr_to_block (&block
, tmp
);
3974 /* Handle kind>=8, 10, or 16 arguments */
3977 tmp
= build_call_expr_loc (input_location
,
3978 gfor_fndecl_system_clock8
, 3,
3979 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3980 : null_pointer_node
,
3981 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3982 : null_pointer_node
,
3983 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3984 : null_pointer_node
);
3985 gfc_add_expr_to_block (&block
, tmp
);
3989 /* And store values back if needed. */
3990 if (arg1
&& arg1
!= count_se
.expr
)
3991 gfc_add_modify (&block
, count_se
.expr
,
3992 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
3993 if (arg2
&& arg2
!= count_rate_se
.expr
)
3994 gfc_add_modify (&block
, count_rate_se
.expr
,
3995 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
3996 if (arg3
&& arg3
!= count_max_se
.expr
)
3997 gfc_add_modify (&block
, count_max_se
.expr
,
3998 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
4000 return gfc_finish_block (&block
);
4004 /* Return a character string containing the tty name. */
4007 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
4015 unsigned int num_args
;
4017 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
4018 args
= XALLOCAVEC (tree
, num_args
);
4020 var
= gfc_create_var (pchar_type_node
, "pstr");
4021 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4023 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
4024 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
4025 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
4027 fndecl
= build_addr (gfor_fndecl_ttynam
);
4028 tmp
= build_call_array_loc (input_location
,
4029 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
4030 fndecl
, num_args
, args
);
4031 gfc_add_expr_to_block (&se
->pre
, tmp
);
4033 /* Free the temporary afterwards, if necessary. */
4034 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4035 len
, build_int_cst (TREE_TYPE (len
), 0));
4036 tmp
= gfc_call_free (var
);
4037 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4038 gfc_add_expr_to_block (&se
->post
, tmp
);
4041 se
->string_length
= len
;
4045 /* Get the minimum/maximum value of all the parameters.
4046 minmax (a1, a2, a3, ...)
4049 mvar = COMP (mvar, a2)
4050 mvar = COMP (mvar, a3)
4054 Where COMP is MIN/MAX_EXPR for integral types or when we don't
4055 care about NaNs, or IFN_FMIN/MAX when the target has support for
4056 fast NaN-honouring min/max. When neither holds expand a sequence
4057 of explicit comparisons. */
4059 /* TODO: Mismatching types can occur when specific names are used.
4060 These should be handled during resolution. */
4062 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4070 gfc_actual_arglist
*argexpr
;
4071 unsigned int i
, nargs
;
4073 nargs
= gfc_intrinsic_argument_list_length (expr
);
4074 args
= XALLOCAVEC (tree
, nargs
);
4076 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
4077 type
= gfc_typenode_for_spec (&expr
->ts
);
4079 /* Only evaluate the argument once. */
4080 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
4081 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4083 /* Determine suitable type of temporary, as a GNU extension allows
4084 different argument kinds. */
4085 argtype
= TREE_TYPE (args
[0]);
4086 argexpr
= expr
->value
.function
.actual
;
4087 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++, argexpr
= argexpr
->next
)
4089 tree tmptype
= TREE_TYPE (args
[i
]);
4090 if (TYPE_PRECISION (tmptype
) > TYPE_PRECISION (argtype
))
4093 mvar
= gfc_create_var (argtype
, "M");
4094 gfc_add_modify (&se
->pre
, mvar
, convert (argtype
, args
[0]));
4096 argexpr
= expr
->value
.function
.actual
;
4097 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++, argexpr
= argexpr
->next
)
4099 tree cond
= NULL_TREE
;
4102 /* Handle absent optional arguments by ignoring the comparison. */
4103 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
4104 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
4105 && TREE_CODE (val
) == INDIRECT_REF
)
4107 cond
= fold_build2_loc (input_location
,
4108 NE_EXPR
, logical_type_node
,
4109 TREE_OPERAND (val
, 0),
4110 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
4112 else if (!VAR_P (val
) && !TREE_CONSTANT (val
))
4113 /* Only evaluate the argument once. */
4114 val
= gfc_evaluate_now (val
, &se
->pre
);
4117 /* For floating point types, the question is what MAX(a, NaN) or
4118 MIN(a, NaN) should return (where "a" is a normal number).
4119 There are valid usecase for returning either one, but the
4120 Fortran standard doesn't specify which one should be chosen.
4121 Also, there is no consensus among other tested compilers. In
4122 short, it's a mess. So lets just do whatever is fastest. */
4123 tree_code code
= op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
;
4124 calc
= fold_build2_loc (input_location
, code
, argtype
,
4125 convert (argtype
, val
), mvar
);
4126 tmp
= build2_v (MODIFY_EXPR
, mvar
, calc
);
4128 if (cond
!= NULL_TREE
)
4129 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
4130 build_empty_stmt (input_location
));
4131 gfc_add_expr_to_block (&se
->pre
, tmp
);
4133 se
->expr
= convert (type
, mvar
);
4137 /* Generate library calls for MIN and MAX intrinsics for character
4140 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
4143 tree var
, len
, fndecl
, tmp
, cond
, function
;
4146 nargs
= gfc_intrinsic_argument_list_length (expr
);
4147 args
= XALLOCAVEC (tree
, nargs
+ 4);
4148 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
4150 /* Create the result variables. */
4151 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4152 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
4153 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
4154 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
4155 args
[2] = build_int_cst (integer_type_node
, op
);
4156 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
4158 if (expr
->ts
.kind
== 1)
4159 function
= gfor_fndecl_string_minmax
;
4160 else if (expr
->ts
.kind
== 4)
4161 function
= gfor_fndecl_string_minmax_char4
;
4165 /* Make the function call. */
4166 fndecl
= build_addr (function
);
4167 tmp
= build_call_array_loc (input_location
,
4168 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4170 gfc_add_expr_to_block (&se
->pre
, tmp
);
4172 /* Free the temporary afterwards, if necessary. */
4173 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4174 len
, build_int_cst (TREE_TYPE (len
), 0));
4175 tmp
= gfc_call_free (var
);
4176 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4177 gfc_add_expr_to_block (&se
->post
, tmp
);
4180 se
->string_length
= len
;
4184 /* Create a symbol node for this intrinsic. The symbol from the frontend
4185 has the generic name. */
4188 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
4192 /* TODO: Add symbols for intrinsic function to the global namespace. */
4193 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
4194 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
4197 sym
->attr
.external
= 1;
4198 sym
->attr
.function
= 1;
4199 sym
->attr
.always_explicit
= 1;
4200 sym
->attr
.proc
= PROC_INTRINSIC
;
4201 sym
->attr
.flavor
= FL_PROCEDURE
;
4205 sym
->attr
.dimension
= 1;
4206 sym
->as
= gfc_get_array_spec ();
4207 sym
->as
->type
= AS_ASSUMED_SHAPE
;
4208 sym
->as
->rank
= expr
->rank
;
4211 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
4212 ignore_optional
? expr
->value
.function
.actual
4218 /* Remove empty actual arguments. */
4221 remove_empty_actual_arguments (gfc_actual_arglist
**ap
)
4225 if ((*ap
)->expr
== NULL
)
4227 gfc_actual_arglist
*r
= *ap
;
4230 gfc_free_actual_arglist (r
);
4233 ap
= &((*ap
)->next
);
4237 #define MAX_SPEC_ARG 12
4239 /* Make up an fn spec that's right for intrinsic functions that we
4243 intrinsic_fnspec (gfc_expr
*expr
)
4245 static char fnspec_buf
[MAX_SPEC_ARG
*2+1];
4250 #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
4252 /* Set the fndecl. */
4254 /* Function return value. FIXME: Check if the second letter could
4255 be something other than a space, for further optimization. */
4257 if (expr
->rank
== 0)
4259 if (expr
->ts
.type
== BT_CHARACTER
)
4261 ADD_CHAR ('w'); /* Address of character. */
4262 ADD_CHAR ('.'); /* Length of character. */
4266 ADD_CHAR ('w'); /* Return value is a descriptor. */
4269 for (gfc_actual_arglist
*a
= expr
->value
.function
.actual
; a
; a
= a
->next
)
4271 if (a
->expr
== NULL
)
4274 if (a
->name
&& strcmp (a
->name
,"%VAL") == 0)
4278 if (a
->expr
->rank
> 0)
4283 num_char_args
+= a
->expr
->ts
.type
== BT_CHARACTER
;
4284 gcc_assert (fp
- fnspec_buf
+ num_char_args
<= MAX_SPEC_ARG
*2);
4287 for (i
= 0; i
< num_char_args
; i
++)
4297 /* Generate the right symbol for the specific intrinsic function and
4298 modify the expr accordingly. This assumes that absent optional
4299 arguments should be removed. */
4302 specific_intrinsic_symbol (gfc_expr
*expr
)
4306 sym
= gfc_find_intrinsic_symbol (expr
);
4309 sym
= gfc_get_intrinsic_function_symbol (expr
);
4311 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
)
4312 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
4314 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
4315 expr
->value
.function
.actual
, true);
4317 = gfc_get_extern_function_decl (sym
, expr
->value
.function
.actual
,
4318 intrinsic_fnspec (expr
));
4321 remove_empty_actual_arguments (&(expr
->value
.function
.actual
));
4326 /* Generate a call to an external intrinsic function. FIXME: So far,
4327 this only works for functions which are called with well-defined
4328 types; CSHIFT and friends will come later. */
4331 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
4334 vec
<tree
, va_gc
> *append_args
;
4335 bool specific_symbol
;
4337 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
4340 gcc_assert (expr
->rank
> 0);
4342 gcc_assert (expr
->rank
== 0);
4344 switch (expr
->value
.function
.isym
->id
)
4348 case GFC_ISYM_FINDLOC
:
4349 case GFC_ISYM_MAXLOC
:
4350 case GFC_ISYM_MINLOC
:
4351 case GFC_ISYM_MAXVAL
:
4352 case GFC_ISYM_MINVAL
:
4353 case GFC_ISYM_NORM2
:
4354 case GFC_ISYM_PRODUCT
:
4356 specific_symbol
= true;
4359 specific_symbol
= false;
4362 if (specific_symbol
)
4364 /* Need to copy here because specific_intrinsic_symbol modifies
4365 expr to omit the absent optional arguments. */
4366 expr
= gfc_copy_expr (expr
);
4367 sym
= specific_intrinsic_symbol (expr
);
4370 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
4372 /* Calls to libgfortran_matmul need to be appended special arguments,
4373 to be able to call the BLAS ?gemm functions if required and possible. */
4375 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
4376 && !expr
->external_blas
4377 && sym
->ts
.type
!= BT_LOGICAL
)
4379 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
4381 if (flag_external_blas
4382 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
4383 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
4387 if (sym
->ts
.type
== BT_REAL
)
4389 if (sym
->ts
.kind
== 4)
4390 gemm_fndecl
= gfor_fndecl_sgemm
;
4392 gemm_fndecl
= gfor_fndecl_dgemm
;
4396 if (sym
->ts
.kind
== 4)
4397 gemm_fndecl
= gfor_fndecl_cgemm
;
4399 gemm_fndecl
= gfor_fndecl_zgemm
;
4402 vec_alloc (append_args
, 3);
4403 append_args
->quick_push (build_int_cst (cint
, 1));
4404 append_args
->quick_push (build_int_cst (cint
,
4405 flag_blas_matmul_limit
));
4406 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
4411 vec_alloc (append_args
, 3);
4412 append_args
->quick_push (build_int_cst (cint
, 0));
4413 append_args
->quick_push (build_int_cst (cint
, 0));
4414 append_args
->quick_push (null_pointer_node
);
4418 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4421 if (specific_symbol
)
4422 gfc_free_expr (expr
);
4424 gfc_free_symbol (sym
);
4427 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4447 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4456 gfc_actual_arglist
*actual
;
4463 gfc_conv_intrinsic_funcall (se
, expr
);
4467 actual
= expr
->value
.function
.actual
;
4468 type
= gfc_typenode_for_spec (&expr
->ts
);
4469 /* Initialize the result. */
4470 resvar
= gfc_create_var (type
, "test");
4472 tmp
= convert (type
, boolean_true_node
);
4474 tmp
= convert (type
, boolean_false_node
);
4475 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4477 /* Walk the arguments. */
4478 arrayss
= gfc_walk_expr (actual
->expr
);
4479 gcc_assert (arrayss
!= gfc_ss_terminator
);
4481 /* Initialize the scalarizer. */
4482 gfc_init_loopinfo (&loop
);
4483 exit_label
= gfc_build_label_decl (NULL_TREE
);
4484 TREE_USED (exit_label
) = 1;
4485 gfc_add_ss_to_loop (&loop
, arrayss
);
4487 /* Initialize the loop. */
4488 gfc_conv_ss_startstride (&loop
);
4489 gfc_conv_loop_setup (&loop
, &expr
->where
);
4491 gfc_mark_ss_chain_used (arrayss
, 1);
4492 /* Generate the loop body. */
4493 gfc_start_scalarized_body (&loop
, &body
);
4495 /* If the condition matches then set the return value. */
4496 gfc_start_block (&block
);
4498 tmp
= convert (type
, boolean_false_node
);
4500 tmp
= convert (type
, boolean_true_node
);
4501 gfc_add_modify (&block
, resvar
, tmp
);
4503 /* And break out of the loop. */
4504 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4505 gfc_add_expr_to_block (&block
, tmp
);
4507 found
= gfc_finish_block (&block
);
4509 /* Check this element. */
4510 gfc_init_se (&arrayse
, NULL
);
4511 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4512 arrayse
.ss
= arrayss
;
4513 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4515 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4516 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
, arrayse
.expr
,
4517 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
4518 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
4519 gfc_add_expr_to_block (&body
, tmp
);
4520 gfc_add_block_to_block (&body
, &arrayse
.post
);
4522 gfc_trans_scalarizing_loops (&loop
, &body
);
4524 /* Add the exit label. */
4525 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4526 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4528 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4529 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4530 gfc_cleanup_loop (&loop
);
4536 /* Generate the constant 180 / pi, which is used in the conversion
4537 of acosd(), asind(), atand(), atan2d(). */
4545 gfc_set_model_kind (kind
);
4548 mpfr_set_si (t0
, 180, GFC_RND_MODE
);
4549 mpfr_const_pi (pi
, GFC_RND_MODE
);
4550 mpfr_div (t0
, t0
, pi
, GFC_RND_MODE
);
4551 retval
= gfc_conv_mpfr_to_tree (t0
, kind
, 0);
4558 static gfc_intrinsic_map_t
*
4559 gfc_lookup_intrinsic (gfc_isym_id id
)
4561 gfc_intrinsic_map_t
*m
= gfc_intrinsic_map
;
4562 for (; m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
4565 gcc_assert (id
== m
->id
);
4570 /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4571 ASIND(x) is translated into ASIN(x) * 180 / pi.
4572 ATAND(x) is translated into ATAN(x) * 180 / pi. */
4575 gfc_conv_intrinsic_atrigd (gfc_se
* se
, gfc_expr
* expr
, gfc_isym_id id
)
4580 gfc_intrinsic_map_t
*m
;
4582 type
= gfc_typenode_for_spec (&expr
->ts
);
4584 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4588 case GFC_ISYM_ACOSD
:
4589 m
= gfc_lookup_intrinsic (GFC_ISYM_ACOS
);
4591 case GFC_ISYM_ASIND
:
4592 m
= gfc_lookup_intrinsic (GFC_ISYM_ASIN
);
4594 case GFC_ISYM_ATAND
:
4595 m
= gfc_lookup_intrinsic (GFC_ISYM_ATAN
);
4600 atrigd
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4601 atrigd
= build_call_expr_loc (input_location
, atrigd
, 1, arg
);
4603 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, atrigd
,
4604 fold_convert (type
, rad2deg (expr
->ts
.kind
)));
4608 /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4609 COS(X) / SIN(X) for COMPLEX argument. */
4612 gfc_conv_intrinsic_cotan (gfc_se
*se
, gfc_expr
*expr
)
4614 gfc_intrinsic_map_t
*m
;
4618 type
= gfc_typenode_for_spec (&expr
->ts
);
4619 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4621 if (expr
->ts
.type
== BT_REAL
)
4628 gfc_set_model_kind (expr
->ts
.kind
);
4630 mpfr_const_pi (pio2
, GFC_RND_MODE
);
4631 mpfr_div_ui (pio2
, pio2
, 2, GFC_RND_MODE
);
4632 tmp
= gfc_conv_mpfr_to_tree (pio2
, expr
->ts
.kind
, 0);
4635 /* Find tan builtin function. */
4636 m
= gfc_lookup_intrinsic (GFC_ISYM_TAN
);
4637 tan
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4638 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, arg
, tmp
);
4639 tan
= build_call_expr_loc (input_location
, tan
, 1, tmp
);
4640 se
->expr
= fold_build1_loc (input_location
, NEGATE_EXPR
, type
, tan
);
4647 /* Find cos builtin function. */
4648 m
= gfc_lookup_intrinsic (GFC_ISYM_COS
);
4649 cos
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4650 cos
= build_call_expr_loc (input_location
, cos
, 1, arg
);
4652 /* Find sin builtin function. */
4653 m
= gfc_lookup_intrinsic (GFC_ISYM_SIN
);
4654 sin
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4655 sin
= build_call_expr_loc (input_location
, sin
, 1, arg
);
4657 /* Divide cos by sin. */
4658 se
->expr
= fold_build2_loc (input_location
, RDIV_EXPR
, type
, cos
, sin
);
4663 /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4666 gfc_conv_intrinsic_cotand (gfc_se
*se
, gfc_expr
*expr
)
4673 type
= gfc_typenode_for_spec (&expr
->ts
);
4674 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4676 gfc_set_model_kind (expr
->ts
.kind
);
4678 /* Build the tree for x + 90. */
4679 mpfr_init_set_ui (ninety
, 90, GFC_RND_MODE
);
4680 ninety_tree
= gfc_conv_mpfr_to_tree (ninety
, expr
->ts
.kind
, 0);
4681 arg
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, arg
, ninety_tree
);
4682 mpfr_clear (ninety
);
4685 gfc_intrinsic_map_t
*m
= gfc_lookup_intrinsic (GFC_ISYM_TAND
);
4686 tree tand
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4687 tand
= build_call_expr_loc (input_location
, tand
, 1, arg
);
4689 se
->expr
= fold_build1_loc (input_location
, NEGATE_EXPR
, type
, tand
);
4693 /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4696 gfc_conv_intrinsic_atan2d (gfc_se
*se
, gfc_expr
*expr
)
4702 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4703 type
= TREE_TYPE (args
[0]);
4705 gfc_intrinsic_map_t
*m
= gfc_lookup_intrinsic (GFC_ISYM_ATAN2
);
4706 atan2d
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4707 atan2d
= build_call_expr_loc (input_location
, atan2d
, 2, args
[0], args
[1]);
4709 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, atan2d
,
4710 rad2deg (expr
->ts
.kind
));
4714 /* COUNT(A) = Number of true elements in A. */
4716 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4723 gfc_actual_arglist
*actual
;
4729 gfc_conv_intrinsic_funcall (se
, expr
);
4733 actual
= expr
->value
.function
.actual
;
4735 type
= gfc_typenode_for_spec (&expr
->ts
);
4736 /* Initialize the result. */
4737 resvar
= gfc_create_var (type
, "count");
4738 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4740 /* Walk the arguments. */
4741 arrayss
= gfc_walk_expr (actual
->expr
);
4742 gcc_assert (arrayss
!= gfc_ss_terminator
);
4744 /* Initialize the scalarizer. */
4745 gfc_init_loopinfo (&loop
);
4746 gfc_add_ss_to_loop (&loop
, arrayss
);
4748 /* Initialize the loop. */
4749 gfc_conv_ss_startstride (&loop
);
4750 gfc_conv_loop_setup (&loop
, &expr
->where
);
4752 gfc_mark_ss_chain_used (arrayss
, 1);
4753 /* Generate the loop body. */
4754 gfc_start_scalarized_body (&loop
, &body
);
4756 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4757 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4758 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4760 gfc_init_se (&arrayse
, NULL
);
4761 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4762 arrayse
.ss
= arrayss
;
4763 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4764 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4765 build_empty_stmt (input_location
));
4767 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4768 gfc_add_expr_to_block (&body
, tmp
);
4769 gfc_add_block_to_block (&body
, &arrayse
.post
);
4771 gfc_trans_scalarizing_loops (&loop
, &body
);
4773 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4774 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4775 gfc_cleanup_loop (&loop
);
4781 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4782 struct and return the corresponding loopinfo. */
4784 static gfc_loopinfo
*
4785 enter_nested_loop (gfc_se
*se
)
4787 se
->ss
= se
->ss
->nested_ss
;
4788 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4790 return se
->ss
->loop
;
4793 /* Build the condition for a mask, which may be optional. */
4796 conv_mask_condition (gfc_se
*maskse
, gfc_expr
*maskexpr
,
4804 type
= TREE_TYPE (maskse
->expr
);
4805 present
= gfc_conv_expr_present (maskexpr
->symtree
->n
.sym
);
4806 present
= convert (type
, present
);
4807 present
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, type
,
4809 return fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4810 type
, present
, maskse
->expr
);
4813 return maskse
->expr
;
4816 /* Inline implementation of the sum and product intrinsics. */
4818 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4822 tree scale
= NULL_TREE
;
4827 gfc_loopinfo loop
, *ploop
;
4828 gfc_actual_arglist
*arg_array
, *arg_mask
;
4829 gfc_ss
*arrayss
= NULL
;
4830 gfc_ss
*maskss
= NULL
;
4834 gfc_expr
*arrayexpr
;
4840 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4846 type
= gfc_typenode_for_spec (&expr
->ts
);
4847 /* Initialize the result. */
4848 resvar
= gfc_create_var (type
, "val");
4853 scale
= gfc_create_var (type
, "scale");
4854 gfc_add_modify (&se
->pre
, scale
,
4855 gfc_build_const (type
, integer_one_node
));
4856 tmp
= gfc_build_const (type
, integer_zero_node
);
4858 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4859 tmp
= gfc_build_const (type
, integer_zero_node
);
4860 else if (op
== NE_EXPR
)
4862 tmp
= convert (type
, boolean_false_node
);
4863 else if (op
== BIT_AND_EXPR
)
4864 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4865 type
, integer_one_node
));
4867 tmp
= gfc_build_const (type
, integer_one_node
);
4869 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4871 arg_array
= expr
->value
.function
.actual
;
4873 arrayexpr
= arg_array
->expr
;
4875 if (op
== NE_EXPR
|| norm2
)
4877 /* PARITY and NORM2. */
4879 optional_mask
= false;
4883 arg_mask
= arg_array
->next
->next
;
4884 gcc_assert (arg_mask
!= NULL
);
4885 maskexpr
= arg_mask
->expr
;
4886 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
4887 && maskexpr
->symtree
->n
.sym
->attr
.dummy
4888 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
4891 if (expr
->rank
== 0)
4893 /* Walk the arguments. */
4894 arrayss
= gfc_walk_expr (arrayexpr
);
4895 gcc_assert (arrayss
!= gfc_ss_terminator
);
4897 if (maskexpr
&& maskexpr
->rank
> 0)
4899 maskss
= gfc_walk_expr (maskexpr
);
4900 gcc_assert (maskss
!= gfc_ss_terminator
);
4905 /* Initialize the scalarizer. */
4906 gfc_init_loopinfo (&loop
);
4908 /* We add the mask first because the number of iterations is
4909 taken from the last ss, and this breaks if an absent
4910 optional argument is used for mask. */
4912 if (maskexpr
&& maskexpr
->rank
> 0)
4913 gfc_add_ss_to_loop (&loop
, maskss
);
4914 gfc_add_ss_to_loop (&loop
, arrayss
);
4916 /* Initialize the loop. */
4917 gfc_conv_ss_startstride (&loop
);
4918 gfc_conv_loop_setup (&loop
, &expr
->where
);
4920 if (maskexpr
&& maskexpr
->rank
> 0)
4921 gfc_mark_ss_chain_used (maskss
, 1);
4922 gfc_mark_ss_chain_used (arrayss
, 1);
4927 /* All the work has been done in the parent loops. */
4928 ploop
= enter_nested_loop (se
);
4932 /* Generate the loop body. */
4933 gfc_start_scalarized_body (ploop
, &body
);
4935 /* If we have a mask, only add this element if the mask is set. */
4936 if (maskexpr
&& maskexpr
->rank
> 0)
4938 gfc_init_se (&maskse
, parent_se
);
4939 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4940 if (expr
->rank
== 0)
4942 gfc_conv_expr_val (&maskse
, maskexpr
);
4943 gfc_add_block_to_block (&body
, &maskse
.pre
);
4945 gfc_start_block (&block
);
4948 gfc_init_block (&block
);
4950 /* Do the actual summation/product. */
4951 gfc_init_se (&arrayse
, parent_se
);
4952 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4953 if (expr
->rank
== 0)
4954 arrayse
.ss
= arrayss
;
4955 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4956 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4960 /* if (x (i) != 0.0)
4966 result = 1.0 + result * val * val;
4972 result += val * val;
4975 tree res1
, res2
, cond
, absX
, val
;
4976 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4978 gfc_init_block (&ifblock1
);
4980 absX
= gfc_create_var (type
, "absX");
4981 gfc_add_modify (&ifblock1
, absX
,
4982 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4984 val
= gfc_create_var (type
, "val");
4985 gfc_add_expr_to_block (&ifblock1
, val
);
4987 gfc_init_block (&ifblock2
);
4988 gfc_add_modify (&ifblock2
, val
,
4989 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4991 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4992 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4993 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4994 gfc_build_const (type
, integer_one_node
));
4995 gfc_add_modify (&ifblock2
, resvar
, res1
);
4996 gfc_add_modify (&ifblock2
, scale
, absX
);
4997 res1
= gfc_finish_block (&ifblock2
);
4999 gfc_init_block (&ifblock3
);
5000 gfc_add_modify (&ifblock3
, val
,
5001 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
5003 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
5004 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
5005 gfc_add_modify (&ifblock3
, resvar
, res2
);
5006 res2
= gfc_finish_block (&ifblock3
);
5008 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
5010 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
5011 gfc_add_expr_to_block (&ifblock1
, tmp
);
5012 tmp
= gfc_finish_block (&ifblock1
);
5014 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
5016 gfc_build_const (type
, integer_zero_node
));
5018 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
5019 gfc_add_expr_to_block (&block
, tmp
);
5023 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
5024 gfc_add_modify (&block
, resvar
, tmp
);
5027 gfc_add_block_to_block (&block
, &arrayse
.post
);
5029 if (maskexpr
&& maskexpr
->rank
> 0)
5031 /* We enclose the above in if (mask) {...} . If the mask is an
5032 optional argument, generate
5033 IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
5035 tmp
= gfc_finish_block (&block
);
5036 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5037 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5038 build_empty_stmt (input_location
));
5041 tmp
= gfc_finish_block (&block
);
5042 gfc_add_expr_to_block (&body
, tmp
);
5044 gfc_trans_scalarizing_loops (ploop
, &body
);
5046 /* For a scalar mask, enclose the loop in an if statement. */
5047 if (maskexpr
&& maskexpr
->rank
== 0)
5049 gfc_init_block (&block
);
5050 gfc_add_block_to_block (&block
, &ploop
->pre
);
5051 gfc_add_block_to_block (&block
, &ploop
->post
);
5052 tmp
= gfc_finish_block (&block
);
5056 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
5057 build_empty_stmt (input_location
));
5058 gfc_advance_se_ss_chain (se
);
5064 gcc_assert (expr
->rank
== 0);
5065 gfc_init_se (&maskse
, NULL
);
5066 gfc_conv_expr_val (&maskse
, maskexpr
);
5067 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5068 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5069 build_empty_stmt (input_location
));
5072 gfc_add_expr_to_block (&block
, tmp
);
5073 gfc_add_block_to_block (&se
->pre
, &block
);
5074 gcc_assert (se
->post
.head
== NULL
);
5078 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
5079 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
5082 if (expr
->rank
== 0)
5083 gfc_cleanup_loop (ploop
);
5087 /* result = scale * sqrt(result). */
5089 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
5090 resvar
= build_call_expr_loc (input_location
,
5092 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
5099 /* Inline implementation of the dot_product intrinsic. This function
5100 is based on gfc_conv_intrinsic_arith (the previous function). */
5102 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
5110 gfc_actual_arglist
*actual
;
5111 gfc_ss
*arrayss1
, *arrayss2
;
5112 gfc_se arrayse1
, arrayse2
;
5113 gfc_expr
*arrayexpr1
, *arrayexpr2
;
5115 type
= gfc_typenode_for_spec (&expr
->ts
);
5117 /* Initialize the result. */
5118 resvar
= gfc_create_var (type
, "val");
5119 if (expr
->ts
.type
== BT_LOGICAL
)
5120 tmp
= build_int_cst (type
, 0);
5122 tmp
= gfc_build_const (type
, integer_zero_node
);
5124 gfc_add_modify (&se
->pre
, resvar
, tmp
);
5126 /* Walk argument #1. */
5127 actual
= expr
->value
.function
.actual
;
5128 arrayexpr1
= actual
->expr
;
5129 arrayss1
= gfc_walk_expr (arrayexpr1
);
5130 gcc_assert (arrayss1
!= gfc_ss_terminator
);
5132 /* Walk argument #2. */
5133 actual
= actual
->next
;
5134 arrayexpr2
= actual
->expr
;
5135 arrayss2
= gfc_walk_expr (arrayexpr2
);
5136 gcc_assert (arrayss2
!= gfc_ss_terminator
);
5138 /* Initialize the scalarizer. */
5139 gfc_init_loopinfo (&loop
);
5140 gfc_add_ss_to_loop (&loop
, arrayss1
);
5141 gfc_add_ss_to_loop (&loop
, arrayss2
);
5143 /* Initialize the loop. */
5144 gfc_conv_ss_startstride (&loop
);
5145 gfc_conv_loop_setup (&loop
, &expr
->where
);
5147 gfc_mark_ss_chain_used (arrayss1
, 1);
5148 gfc_mark_ss_chain_used (arrayss2
, 1);
5150 /* Generate the loop body. */
5151 gfc_start_scalarized_body (&loop
, &body
);
5152 gfc_init_block (&block
);
5154 /* Make the tree expression for [conjg(]array1[)]. */
5155 gfc_init_se (&arrayse1
, NULL
);
5156 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
5157 arrayse1
.ss
= arrayss1
;
5158 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
5159 if (expr
->ts
.type
== BT_COMPLEX
)
5160 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
5162 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
5164 /* Make the tree expression for array2. */
5165 gfc_init_se (&arrayse2
, NULL
);
5166 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
5167 arrayse2
.ss
= arrayss2
;
5168 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
5169 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
5171 /* Do the actual product and sum. */
5172 if (expr
->ts
.type
== BT_LOGICAL
)
5174 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
5175 arrayse1
.expr
, arrayse2
.expr
);
5176 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
5180 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
5182 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
5184 gfc_add_modify (&block
, resvar
, tmp
);
5186 /* Finish up the loop block and the loop. */
5187 tmp
= gfc_finish_block (&block
);
5188 gfc_add_expr_to_block (&body
, tmp
);
5190 gfc_trans_scalarizing_loops (&loop
, &body
);
5191 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5192 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5193 gfc_cleanup_loop (&loop
);
5199 /* Remove unneeded kind= argument from actual argument list when the
5200 result conversion is dealt with in a different place. */
5203 strip_kind_from_actual (gfc_actual_arglist
* actual
)
5205 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
5207 if (a
&& a
->name
&& strcmp (a
->name
, "kind") == 0)
5209 gfc_free_expr (a
->expr
);
5215 /* Emit code for minloc or maxloc intrinsic. There are many different cases
5216 we need to handle. For performance reasons we sometimes create two
5217 loops instead of one, where the second one is much simpler.
5218 Examples for minloc intrinsic:
5219 1) Result is an array, a call is generated
5220 2) Array mask is used and NaNs need to be supported:
5226 if (pos == 0) pos = S + (1 - from);
5227 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5234 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5238 3) NaNs need to be supported, but it is known at compile time or cheaply
5239 at runtime whether array is nonempty or not:
5244 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5247 if (from <= to) pos = 1;
5251 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5255 4) NaNs aren't supported, array mask is used:
5256 limit = infinities_supported ? Infinity : huge (limit);
5260 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5266 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5270 5) Same without array mask:
5271 limit = infinities_supported ? Infinity : huge (limit);
5272 pos = (from <= to) ? 1 : 0;
5275 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5278 For 3) and 5), if mask is scalar, this all goes into a conditional,
5279 setting pos = 0; in the else branch.
5281 Since we now also support the BACK argument, instead of using
5282 if (a[S] < limit), we now use
5285 cond = a[S] <= limit;
5287 cond = a[S] < limit;
5291 The optimizer is smart enough to move the condition out of the loop.
5292 The are now marked as unlikely to for further speedup. */
5295 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5299 stmtblock_t ifblock
;
5300 stmtblock_t elseblock
;
5312 gfc_actual_arglist
*actual
;
5317 gfc_expr
*arrayexpr
;
5325 actual
= expr
->value
.function
.actual
;
5327 /* The last argument, BACK, is passed by value. Ensure that
5328 by setting its name to %VAL. */
5329 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
5331 if (a
->next
== NULL
)
5337 gfc_conv_intrinsic_funcall (se
, expr
);
5341 arrayexpr
= actual
->expr
;
5343 /* Special case for character maxloc. Remove unneeded actual
5344 arguments, then call a library function. */
5346 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5348 gfc_actual_arglist
*a
;
5350 strip_kind_from_actual (a
);
5353 if (a
->name
&& strcmp (a
->name
, "dim") == 0)
5355 gfc_free_expr (a
->expr
);
5360 gfc_conv_intrinsic_funcall (se
, expr
);
5364 /* Initialize the result. */
5365 pos
= gfc_create_var (gfc_array_index_type
, "pos");
5366 offset
= gfc_create_var (gfc_array_index_type
, "offset");
5367 type
= gfc_typenode_for_spec (&expr
->ts
);
5369 /* Walk the arguments. */
5370 arrayss
= gfc_walk_expr (arrayexpr
);
5371 gcc_assert (arrayss
!= gfc_ss_terminator
);
5373 actual
= actual
->next
->next
;
5374 gcc_assert (actual
);
5375 maskexpr
= actual
->expr
;
5376 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5377 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5378 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5379 backexpr
= actual
->next
->next
->expr
;
5381 if (maskexpr
&& maskexpr
->rank
!= 0)
5383 maskss
= gfc_walk_expr (maskexpr
);
5384 gcc_assert (maskss
!= gfc_ss_terminator
);
5389 if (gfc_array_size (arrayexpr
, &asize
))
5391 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5393 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5394 logical_type_node
, nonempty
,
5395 gfc_index_zero_node
);
5400 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
5401 switch (arrayexpr
->ts
.type
)
5404 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
5408 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
5409 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
5410 arrayexpr
->ts
.kind
);
5417 /* We start with the most negative possible value for MAXLOC, and the most
5418 positive possible value for MINLOC. The most negative possible value is
5419 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5420 possible value is HUGE in both cases. */
5422 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5423 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
5424 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
5425 build_int_cst (TREE_TYPE (tmp
), 1));
5427 gfc_add_modify (&se
->pre
, limit
, tmp
);
5429 /* Initialize the scalarizer. */
5430 gfc_init_loopinfo (&loop
);
5432 /* We add the mask first because the number of iterations is taken
5433 from the last ss, and this breaks if an absent optional argument
5434 is used for mask. */
5437 gfc_add_ss_to_loop (&loop
, maskss
);
5439 gfc_add_ss_to_loop (&loop
, arrayss
);
5441 /* Initialize the loop. */
5442 gfc_conv_ss_startstride (&loop
);
5444 /* The code generated can have more than one loop in sequence (see the
5445 comment at the function header). This doesn't work well with the
5446 scalarizer, which changes arrays' offset when the scalarization loops
5447 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
5448 are currently inlined in the scalar case only (for which loop is of rank
5449 one). As there is no dependency to care about in that case, there is no
5450 temporary, so that we can use the scalarizer temporary code to handle
5451 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
5452 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
5454 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
5455 should eventually go away. We could either create two loops properly,
5456 or find another way to save/restore the array offsets between the two
5457 loops (without conflicting with temporary management), or use a single
5458 loop minmaxloc implementation. See PR 31067. */
5459 loop
.temp_dim
= loop
.dimen
;
5460 gfc_conv_loop_setup (&loop
, &expr
->where
);
5462 gcc_assert (loop
.dimen
== 1);
5463 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
5464 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5465 loop
.from
[0], loop
.to
[0]);
5469 /* Initialize the position to zero, following Fortran 2003. We are free
5470 to do this because Fortran 95 allows the result of an entirely false
5471 mask to be processor dependent. If we know at compile time the array
5472 is non-empty and no MASK is used, we can initialize to 1 to simplify
5474 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
5475 gfc_add_modify (&loop
.pre
, pos
,
5476 fold_build3_loc (input_location
, COND_EXPR
,
5477 gfc_array_index_type
,
5478 nonempty
, gfc_index_one_node
,
5479 gfc_index_zero_node
));
5482 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
5483 lab1
= gfc_build_label_decl (NULL_TREE
);
5484 TREE_USED (lab1
) = 1;
5485 lab2
= gfc_build_label_decl (NULL_TREE
);
5486 TREE_USED (lab2
) = 1;
5489 /* An offset must be added to the loop
5490 counter to obtain the required position. */
5491 gcc_assert (loop
.from
[0]);
5493 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5494 gfc_index_one_node
, loop
.from
[0]);
5495 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5497 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
5499 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
5500 /* Generate the loop body. */
5501 gfc_start_scalarized_body (&loop
, &body
);
5503 /* If we have a mask, only check this element if the mask is set. */
5506 gfc_init_se (&maskse
, NULL
);
5507 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5509 gfc_conv_expr_val (&maskse
, maskexpr
);
5510 gfc_add_block_to_block (&body
, &maskse
.pre
);
5512 gfc_start_block (&block
);
5515 gfc_init_block (&block
);
5517 /* Compare with the current limit. */
5518 gfc_init_se (&arrayse
, NULL
);
5519 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5520 arrayse
.ss
= arrayss
;
5521 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5522 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5524 gfc_init_se (&backse
, NULL
);
5525 gfc_conv_expr_val (&backse
, backexpr
);
5526 gfc_add_block_to_block (&block
, &backse
.pre
);
5528 /* We do the following if this is a more extreme value. */
5529 gfc_start_block (&ifblock
);
5531 /* Assign the value to the limit... */
5532 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5534 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
5536 stmtblock_t ifblock2
;
5539 gfc_start_block (&ifblock2
);
5540 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5541 loop
.loopvar
[0], offset
);
5542 gfc_add_modify (&ifblock2
, pos
, tmp
);
5543 ifbody2
= gfc_finish_block (&ifblock2
);
5544 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pos
,
5545 gfc_index_zero_node
);
5546 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
5547 build_empty_stmt (input_location
));
5548 gfc_add_expr_to_block (&block
, tmp
);
5551 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5552 loop
.loopvar
[0], offset
);
5553 gfc_add_modify (&ifblock
, pos
, tmp
);
5556 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
5558 ifbody
= gfc_finish_block (&ifblock
);
5560 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
5563 cond
= fold_build2_loc (input_location
,
5564 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5565 logical_type_node
, arrayse
.expr
, limit
);
5568 tree ifbody2
, elsebody2
;
5570 /* We switch to > or >= depending on the value of the BACK argument. */
5571 cond
= gfc_create_var (logical_type_node
, "cond");
5573 gfc_start_block (&ifblock
);
5574 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5575 logical_type_node
, arrayse
.expr
, limit
);
5577 gfc_add_modify (&ifblock
, cond
, b_if
);
5578 ifbody2
= gfc_finish_block (&ifblock
);
5580 gfc_start_block (&elseblock
);
5581 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5582 arrayse
.expr
, limit
);
5584 gfc_add_modify (&elseblock
, cond
, b_else
);
5585 elsebody2
= gfc_finish_block (&elseblock
);
5587 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5588 backse
.expr
, ifbody2
, elsebody2
);
5590 gfc_add_expr_to_block (&block
, tmp
);
5593 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5594 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
5595 build_empty_stmt (input_location
));
5597 gfc_add_expr_to_block (&block
, ifbody
);
5601 /* We enclose the above in if (mask) {...}. If the mask is an
5602 optional argument, generate IF (.NOT. PRESENT(MASK)
5606 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5607 tmp
= gfc_finish_block (&block
);
5608 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5609 build_empty_stmt (input_location
));
5612 tmp
= gfc_finish_block (&block
);
5613 gfc_add_expr_to_block (&body
, tmp
);
5617 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5619 if (HONOR_NANS (DECL_MODE (limit
)))
5621 if (nonempty
!= NULL
)
5623 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
5624 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
5625 build_empty_stmt (input_location
));
5626 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
5630 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
5631 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
5633 /* If we have a mask, only check this element if the mask is set. */
5636 gfc_init_se (&maskse
, NULL
);
5637 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5639 gfc_conv_expr_val (&maskse
, maskexpr
);
5640 gfc_add_block_to_block (&body
, &maskse
.pre
);
5642 gfc_start_block (&block
);
5645 gfc_init_block (&block
);
5647 /* Compare with the current limit. */
5648 gfc_init_se (&arrayse
, NULL
);
5649 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5650 arrayse
.ss
= arrayss
;
5651 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5652 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5654 /* We do the following if this is a more extreme value. */
5655 gfc_start_block (&ifblock
);
5657 /* Assign the value to the limit... */
5658 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5660 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5661 loop
.loopvar
[0], offset
);
5662 gfc_add_modify (&ifblock
, pos
, tmp
);
5664 ifbody
= gfc_finish_block (&ifblock
);
5666 /* We switch to > or >= depending on the value of the BACK argument. */
5668 tree ifbody2
, elsebody2
;
5670 cond
= gfc_create_var (logical_type_node
, "cond");
5672 gfc_start_block (&ifblock
);
5673 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5674 logical_type_node
, arrayse
.expr
, limit
);
5676 gfc_add_modify (&ifblock
, cond
, b_if
);
5677 ifbody2
= gfc_finish_block (&ifblock
);
5679 gfc_start_block (&elseblock
);
5680 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5681 arrayse
.expr
, limit
);
5683 gfc_add_modify (&elseblock
, cond
, b_else
);
5684 elsebody2
= gfc_finish_block (&elseblock
);
5686 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5687 backse
.expr
, ifbody2
, elsebody2
);
5690 gfc_add_expr_to_block (&block
, tmp
);
5691 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5692 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
5693 build_empty_stmt (input_location
));
5695 gfc_add_expr_to_block (&block
, tmp
);
5699 /* We enclose the above in if (mask) {...}. If the mask is
5700 an optional argument, generate IF (.NOT. PRESENT(MASK)
5704 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5705 tmp
= gfc_finish_block (&block
);
5706 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5707 build_empty_stmt (input_location
));
5710 tmp
= gfc_finish_block (&block
);
5711 gfc_add_expr_to_block (&body
, tmp
);
5712 /* Avoid initializing loopvar[0] again, it should be left where
5713 it finished by the first loop. */
5714 loop
.from
[0] = loop
.loopvar
[0];
5717 gfc_trans_scalarizing_loops (&loop
, &body
);
5720 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
5722 /* For a scalar mask, enclose the loop in an if statement. */
5723 if (maskexpr
&& maskss
== NULL
)
5727 gfc_init_se (&maskse
, NULL
);
5728 gfc_conv_expr_val (&maskse
, maskexpr
);
5729 gfc_init_block (&block
);
5730 gfc_add_block_to_block (&block
, &loop
.pre
);
5731 gfc_add_block_to_block (&block
, &loop
.post
);
5732 tmp
= gfc_finish_block (&block
);
5734 /* For the else part of the scalar mask, just initialize
5735 the pos variable the same way as above. */
5737 gfc_init_block (&elseblock
);
5738 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
5739 elsetmp
= gfc_finish_block (&elseblock
);
5740 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5741 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
, elsetmp
);
5742 gfc_add_expr_to_block (&block
, tmp
);
5743 gfc_add_block_to_block (&se
->pre
, &block
);
5747 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5748 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5750 gfc_cleanup_loop (&loop
);
5752 se
->expr
= convert (type
, pos
);
5755 /* Emit code for findloc. */
5758 gfc_conv_intrinsic_findloc (gfc_se
*se
, gfc_expr
*expr
)
5760 gfc_actual_arglist
*array_arg
, *value_arg
, *dim_arg
, *mask_arg
,
5761 *kind_arg
, *back_arg
;
5762 gfc_expr
*value_expr
;
5767 stmtblock_t loopblock
;
5771 tree forward_branch
= NULL_TREE
;
5786 array_arg
= expr
->value
.function
.actual
;
5787 value_arg
= array_arg
->next
;
5788 dim_arg
= value_arg
->next
;
5789 mask_arg
= dim_arg
->next
;
5790 kind_arg
= mask_arg
->next
;
5791 back_arg
= kind_arg
->next
;
5793 /* Remove kind and set ikind. */
5796 ikind
= mpz_get_si (kind_arg
->expr
->value
.integer
);
5797 gfc_free_expr (kind_arg
->expr
);
5798 kind_arg
->expr
= NULL
;
5801 ikind
= gfc_default_integer_kind
;
5803 value_expr
= value_arg
->expr
;
5805 /* Unless it's a string, pass VALUE by value. */
5806 if (value_expr
->ts
.type
!= BT_CHARACTER
)
5807 value_arg
->name
= "%VAL";
5809 /* Pass BACK argument by value. */
5810 back_arg
->name
= "%VAL";
5812 /* Call the library if we have a character function or if
5814 if (se
->ss
|| array_arg
->expr
->ts
.type
== BT_CHARACTER
)
5816 se
->ignore_optional
= 1;
5817 if (expr
->rank
== 0)
5819 /* Remove dim argument. */
5820 gfc_free_expr (dim_arg
->expr
);
5821 dim_arg
->expr
= NULL
;
5823 gfc_conv_intrinsic_funcall (se
, expr
);
5827 type
= gfc_get_int_type (ikind
);
5829 /* Initialize the result. */
5830 resvar
= gfc_create_var (gfc_array_index_type
, "pos");
5831 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (gfc_array_index_type
, 0));
5832 offset
= gfc_create_var (gfc_array_index_type
, "offset");
5834 maskexpr
= mask_arg
->expr
;
5835 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5836 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5837 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5839 /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5841 for (i
= 0 ; i
< 2; i
++)
5843 /* Walk the arguments. */
5844 arrayss
= gfc_walk_expr (array_arg
->expr
);
5845 gcc_assert (arrayss
!= gfc_ss_terminator
);
5847 if (maskexpr
&& maskexpr
->rank
!= 0)
5849 maskss
= gfc_walk_expr (maskexpr
);
5850 gcc_assert (maskss
!= gfc_ss_terminator
);
5855 /* Initialize the scalarizer. */
5856 gfc_init_loopinfo (&loop
);
5857 exit_label
= gfc_build_label_decl (NULL_TREE
);
5858 TREE_USED (exit_label
) = 1;
5860 /* We add the mask first because the number of iterations is
5861 taken from the last ss, and this breaks if an absent
5862 optional argument is used for mask. */
5865 gfc_add_ss_to_loop (&loop
, maskss
);
5866 gfc_add_ss_to_loop (&loop
, arrayss
);
5868 /* Initialize the loop. */
5869 gfc_conv_ss_startstride (&loop
);
5870 gfc_conv_loop_setup (&loop
, &expr
->where
);
5872 /* Calculate the offset. */
5873 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5874 gfc_index_one_node
, loop
.from
[0]);
5875 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5877 gfc_mark_ss_chain_used (arrayss
, 1);
5879 gfc_mark_ss_chain_used (maskss
, 1);
5881 /* The first loop is for BACK=.true. */
5883 loop
.reverse
[0] = GFC_REVERSE_SET
;
5885 /* Generate the loop body. */
5886 gfc_start_scalarized_body (&loop
, &body
);
5888 /* If we have an array mask, only add the element if it is
5892 gfc_init_se (&maskse
, NULL
);
5893 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5895 gfc_conv_expr_val (&maskse
, maskexpr
);
5896 gfc_add_block_to_block (&body
, &maskse
.pre
);
5899 /* If the condition matches then set the return value. */
5900 gfc_start_block (&block
);
5902 /* Add the offset. */
5903 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5905 loop
.loopvar
[0], offset
);
5906 gfc_add_modify (&block
, resvar
, tmp
);
5907 /* And break out of the loop. */
5908 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5909 gfc_add_expr_to_block (&block
, tmp
);
5911 found
= gfc_finish_block (&block
);
5913 /* Check this element. */
5914 gfc_init_se (&arrayse
, NULL
);
5915 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5916 arrayse
.ss
= arrayss
;
5917 gfc_conv_expr_val (&arrayse
, array_arg
->expr
);
5918 gfc_add_block_to_block (&body
, &arrayse
.pre
);
5920 gfc_init_se (&valuese
, NULL
);
5921 gfc_conv_expr_val (&valuese
, value_arg
->expr
);
5922 gfc_add_block_to_block (&body
, &valuese
.pre
);
5924 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5925 arrayse
.expr
, valuese
.expr
);
5927 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
5930 /* We enclose the above in if (mask) {...}. If the mask is
5931 an optional argument, generate IF (.NOT. PRESENT(MASK)
5935 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5936 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5937 build_empty_stmt (input_location
));
5940 gfc_add_expr_to_block (&body
, tmp
);
5941 gfc_add_block_to_block (&body
, &arrayse
.post
);
5943 gfc_trans_scalarizing_loops (&loop
, &body
);
5945 /* Add the exit label. */
5946 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5947 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5948 gfc_start_block (&loopblock
);
5949 gfc_add_block_to_block (&loopblock
, &loop
.pre
);
5950 gfc_add_block_to_block (&loopblock
, &loop
.post
);
5952 forward_branch
= gfc_finish_block (&loopblock
);
5954 back_branch
= gfc_finish_block (&loopblock
);
5956 gfc_cleanup_loop (&loop
);
5959 /* Enclose the two loops in an IF statement. */
5961 gfc_init_se (&backse
, NULL
);
5962 gfc_conv_expr_val (&backse
, back_arg
->expr
);
5963 gfc_add_block_to_block (&se
->pre
, &backse
.pre
);
5964 tmp
= build3_v (COND_EXPR
, backse
.expr
, forward_branch
, back_branch
);
5966 /* For a scalar mask, enclose the loop in an if statement. */
5967 if (maskexpr
&& maskss
== NULL
)
5972 gfc_init_se (&maskse
, NULL
);
5973 gfc_conv_expr_val (&maskse
, maskexpr
);
5974 gfc_init_block (&block
);
5975 gfc_add_expr_to_block (&block
, maskse
.expr
);
5976 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5977 if_stmt
= build3_v (COND_EXPR
, ifmask
, tmp
,
5978 build_empty_stmt (input_location
));
5979 gfc_add_expr_to_block (&block
, if_stmt
);
5980 tmp
= gfc_finish_block (&block
);
5983 gfc_add_expr_to_block (&se
->pre
, tmp
);
5984 se
->expr
= convert (type
, resvar
);
5988 /* Emit code for minval or maxval intrinsic. There are many different cases
5989 we need to handle. For performance reasons we sometimes create two
5990 loops instead of one, where the second one is much simpler.
5991 Examples for minval intrinsic:
5992 1) Result is an array, a call is generated
5993 2) Array mask is used and NaNs need to be supported, rank 1:
5998 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
6001 limit = nonempty ? NaN : huge (limit);
6003 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6004 3) NaNs need to be supported, but it is known at compile time or cheaply
6005 at runtime whether array is nonempty or not, rank 1:
6008 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
6009 limit = (from <= to) ? NaN : huge (limit);
6011 while (S <= to) { limit = min (a[S], limit); S++; }
6012 4) Array mask is used and NaNs need to be supported, rank > 1:
6021 if (fast) limit = min (a[S1][S2], limit);
6024 if (a[S1][S2] <= limit) {
6035 limit = nonempty ? NaN : huge (limit);
6036 5) NaNs need to be supported, but it is known at compile time or cheaply
6037 at runtime whether array is nonempty or not, rank > 1:
6044 if (fast) limit = min (a[S1][S2], limit);
6046 if (a[S1][S2] <= limit) {
6056 limit = (nonempty_array) ? NaN : huge (limit);
6057 6) NaNs aren't supported, but infinities are. Array mask is used:
6062 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6065 limit = nonempty ? limit : huge (limit);
6066 7) Same without array mask:
6069 while (S <= to) { limit = min (a[S], limit); S++; }
6070 limit = (from <= to) ? limit : huge (limit);
6071 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6072 limit = huge (limit);
6074 while (S <= to) { limit = min (a[S], limit); S++); }
6076 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6077 with array mask instead).
6078 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6079 setting limit = huge (limit); in the else branch. */
6082 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6092 tree huge_cst
= NULL
, nan_cst
= NULL
;
6094 stmtblock_t block
, block2
;
6096 gfc_actual_arglist
*actual
;
6101 gfc_expr
*arrayexpr
;
6108 gfc_conv_intrinsic_funcall (se
, expr
);
6112 actual
= expr
->value
.function
.actual
;
6113 arrayexpr
= actual
->expr
;
6115 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
6117 gfc_actual_arglist
*dim
= actual
->next
;
6118 if (expr
->rank
== 0 && dim
->expr
!= 0)
6120 gfc_free_expr (dim
->expr
);
6123 gfc_conv_intrinsic_funcall (se
, expr
);
6127 type
= gfc_typenode_for_spec (&expr
->ts
);
6128 /* Initialize the result. */
6129 limit
= gfc_create_var (type
, "limit");
6130 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
6131 switch (expr
->ts
.type
)
6134 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
6136 if (HONOR_INFINITIES (DECL_MODE (limit
)))
6138 REAL_VALUE_TYPE real
;
6140 tmp
= build_real (type
, real
);
6144 if (HONOR_NANS (DECL_MODE (limit
)))
6145 nan_cst
= gfc_build_nan (type
, "");
6149 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
6156 /* We start with the most negative possible value for MAXVAL, and the most
6157 positive possible value for MINVAL. The most negative possible value is
6158 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6159 possible value is HUGE in both cases. */
6162 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
6164 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
6165 TREE_TYPE (huge_cst
), huge_cst
);
6168 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
6169 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6170 tmp
, build_int_cst (type
, 1));
6172 gfc_add_modify (&se
->pre
, limit
, tmp
);
6174 /* Walk the arguments. */
6175 arrayss
= gfc_walk_expr (arrayexpr
);
6176 gcc_assert (arrayss
!= gfc_ss_terminator
);
6178 actual
= actual
->next
->next
;
6179 gcc_assert (actual
);
6180 maskexpr
= actual
->expr
;
6181 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
6182 && maskexpr
->symtree
->n
.sym
->attr
.dummy
6183 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
6185 if (maskexpr
&& maskexpr
->rank
!= 0)
6187 maskss
= gfc_walk_expr (maskexpr
);
6188 gcc_assert (maskss
!= gfc_ss_terminator
);
6193 if (gfc_array_size (arrayexpr
, &asize
))
6195 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
6197 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
6198 logical_type_node
, nonempty
,
6199 gfc_index_zero_node
);
6204 /* Initialize the scalarizer. */
6205 gfc_init_loopinfo (&loop
);
6207 /* We add the mask first because the number of iterations is taken
6208 from the last ss, and this breaks if an absent optional argument
6209 is used for mask. */
6212 gfc_add_ss_to_loop (&loop
, maskss
);
6213 gfc_add_ss_to_loop (&loop
, arrayss
);
6215 /* Initialize the loop. */
6216 gfc_conv_ss_startstride (&loop
);
6218 /* The code generated can have more than one loop in sequence (see the
6219 comment at the function header). This doesn't work well with the
6220 scalarizer, which changes arrays' offset when the scalarization loops
6221 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6222 are currently inlined in the scalar case only. As there is no dependency
6223 to care about in that case, there is no temporary, so that we can use the
6224 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6225 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6226 gfc_trans_scalarized_loop_boundary even later to restore offset.
6227 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6228 should eventually go away. We could either create two loops properly,
6229 or find another way to save/restore the array offsets between the two
6230 loops (without conflicting with temporary management), or use a single
6231 loop minmaxval implementation. See PR 31067. */
6232 loop
.temp_dim
= loop
.dimen
;
6233 gfc_conv_loop_setup (&loop
, &expr
->where
);
6235 if (nonempty
== NULL
&& maskss
== NULL
6236 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
6237 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
6238 loop
.from
[0], loop
.to
[0]);
6239 nonempty_var
= NULL
;
6240 if (nonempty
== NULL
6241 && (HONOR_INFINITIES (DECL_MODE (limit
))
6242 || HONOR_NANS (DECL_MODE (limit
))))
6244 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
6245 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
6246 nonempty
= nonempty_var
;
6250 if (HONOR_NANS (DECL_MODE (limit
)))
6252 if (loop
.dimen
== 1)
6254 lab
= gfc_build_label_decl (NULL_TREE
);
6255 TREE_USED (lab
) = 1;
6259 fast
= gfc_create_var (logical_type_node
, "fast");
6260 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
6264 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
6266 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
6267 /* Generate the loop body. */
6268 gfc_start_scalarized_body (&loop
, &body
);
6270 /* If we have a mask, only add this element if the mask is set. */
6273 gfc_init_se (&maskse
, NULL
);
6274 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
6276 gfc_conv_expr_val (&maskse
, maskexpr
);
6277 gfc_add_block_to_block (&body
, &maskse
.pre
);
6279 gfc_start_block (&block
);
6282 gfc_init_block (&block
);
6284 /* Compare with the current limit. */
6285 gfc_init_se (&arrayse
, NULL
);
6286 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
6287 arrayse
.ss
= arrayss
;
6288 gfc_conv_expr_val (&arrayse
, arrayexpr
);
6289 gfc_add_block_to_block (&block
, &arrayse
.pre
);
6291 gfc_init_block (&block2
);
6294 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
6296 if (HONOR_NANS (DECL_MODE (limit
)))
6298 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
6299 logical_type_node
, arrayse
.expr
, limit
);
6301 ifbody
= build1_v (GOTO_EXPR
, lab
);
6304 stmtblock_t ifblock
;
6306 gfc_init_block (&ifblock
);
6307 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
6308 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
6309 ifbody
= gfc_finish_block (&ifblock
);
6311 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
6312 build_empty_stmt (input_location
));
6313 gfc_add_expr_to_block (&block2
, tmp
);
6317 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6319 tmp
= fold_build2_loc (input_location
,
6320 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6321 type
, arrayse
.expr
, limit
);
6322 gfc_add_modify (&block2
, limit
, tmp
);
6327 tree elsebody
= gfc_finish_block (&block2
);
6329 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6331 if (HONOR_NANS (DECL_MODE (limit
)))
6333 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
6334 arrayse
.expr
, limit
);
6335 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
6336 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
6337 build_empty_stmt (input_location
));
6341 tmp
= fold_build2_loc (input_location
,
6342 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6343 type
, arrayse
.expr
, limit
);
6344 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
6346 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
6347 gfc_add_expr_to_block (&block
, tmp
);
6350 gfc_add_block_to_block (&block
, &block2
);
6352 gfc_add_block_to_block (&block
, &arrayse
.post
);
6354 tmp
= gfc_finish_block (&block
);
6357 /* We enclose the above in if (mask) {...}. If the mask is an
6358 optional argument, generate IF (.NOT. PRESENT(MASK)
6361 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6362 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6363 build_empty_stmt (input_location
));
6365 gfc_add_expr_to_block (&body
, tmp
);
6369 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
6371 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
6373 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
6374 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
6376 /* If we have a mask, only add this element if the mask is set. */
6379 gfc_init_se (&maskse
, NULL
);
6380 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
6382 gfc_conv_expr_val (&maskse
, maskexpr
);
6383 gfc_add_block_to_block (&body
, &maskse
.pre
);
6385 gfc_start_block (&block
);
6388 gfc_init_block (&block
);
6390 /* Compare with the current limit. */
6391 gfc_init_se (&arrayse
, NULL
);
6392 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
6393 arrayse
.ss
= arrayss
;
6394 gfc_conv_expr_val (&arrayse
, arrayexpr
);
6395 gfc_add_block_to_block (&block
, &arrayse
.pre
);
6397 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6399 if (HONOR_NANS (DECL_MODE (limit
)))
6401 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
6402 arrayse
.expr
, limit
);
6403 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
6404 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
6405 build_empty_stmt (input_location
));
6406 gfc_add_expr_to_block (&block
, tmp
);
6410 tmp
= fold_build2_loc (input_location
,
6411 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6412 type
, arrayse
.expr
, limit
);
6413 gfc_add_modify (&block
, limit
, tmp
);
6416 gfc_add_block_to_block (&block
, &arrayse
.post
);
6418 tmp
= gfc_finish_block (&block
);
6420 /* We enclose the above in if (mask) {...}. */
6423 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6424 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6425 build_empty_stmt (input_location
));
6428 gfc_add_expr_to_block (&body
, tmp
);
6429 /* Avoid initializing loopvar[0] again, it should be left where
6430 it finished by the first loop. */
6431 loop
.from
[0] = loop
.loopvar
[0];
6433 gfc_trans_scalarizing_loops (&loop
, &body
);
6437 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
6439 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
6440 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
6442 gfc_add_expr_to_block (&loop
.pre
, tmp
);
6444 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
6446 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
6448 gfc_add_modify (&loop
.pre
, limit
, tmp
);
6451 /* For a scalar mask, enclose the loop in an if statement. */
6452 if (maskexpr
&& maskss
== NULL
)
6457 gfc_init_se (&maskse
, NULL
);
6458 gfc_conv_expr_val (&maskse
, maskexpr
);
6459 gfc_init_block (&block
);
6460 gfc_add_block_to_block (&block
, &loop
.pre
);
6461 gfc_add_block_to_block (&block
, &loop
.post
);
6462 tmp
= gfc_finish_block (&block
);
6464 if (HONOR_INFINITIES (DECL_MODE (limit
)))
6465 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
6467 else_stmt
= build_empty_stmt (input_location
);
6469 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6470 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
, else_stmt
);
6471 gfc_add_expr_to_block (&block
, tmp
);
6472 gfc_add_block_to_block (&se
->pre
, &block
);
6476 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6477 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
6480 gfc_cleanup_loop (&loop
);
6485 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6487 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
6493 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6494 type
= TREE_TYPE (args
[0]);
6496 /* Optionally generate code for runtime argument check. */
6497 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6499 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6500 logical_type_node
, args
[1],
6501 build_int_cst (TREE_TYPE (args
[1]), 0));
6502 tree nbits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6503 tree above
= fold_build2_loc (input_location
, GE_EXPR
,
6504 logical_type_node
, args
[1], nbits
);
6505 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6506 logical_type_node
, below
, above
);
6507 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6508 "POS argument (%ld) out of range 0:%ld "
6509 "in intrinsic BTEST",
6510 fold_convert (long_integer_type_node
, args
[1]),
6511 fold_convert (long_integer_type_node
, nbits
));
6514 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
6515 build_int_cst (type
, 1), args
[1]);
6516 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
6517 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
6518 build_int_cst (type
, 0));
6519 type
= gfc_typenode_for_spec (&expr
->ts
);
6520 se
->expr
= convert (type
, tmp
);
6524 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6526 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6530 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6532 /* Convert both arguments to the unsigned type of the same size. */
6533 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
6534 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
6536 /* If they have unequal type size, convert to the larger one. */
6537 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
6538 > TYPE_PRECISION (TREE_TYPE (args
[1])))
6539 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
6540 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
6541 > TYPE_PRECISION (TREE_TYPE (args
[0])))
6542 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
6544 /* Now, we compare them. */
6545 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
6550 /* Generate code to perform the specified operation. */
6552 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6556 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6557 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
6563 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
6567 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6568 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6569 TREE_TYPE (arg
), arg
);
6572 /* Set or clear a single bit. */
6574 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
6581 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6582 type
= TREE_TYPE (args
[0]);
6584 /* Optionally generate code for runtime argument check. */
6585 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6587 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6588 logical_type_node
, args
[1],
6589 build_int_cst (TREE_TYPE (args
[1]), 0));
6590 tree nbits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6591 tree above
= fold_build2_loc (input_location
, GE_EXPR
,
6592 logical_type_node
, args
[1], nbits
);
6593 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6594 logical_type_node
, below
, above
);
6595 size_t len_name
= strlen (expr
->value
.function
.isym
->name
);
6596 char *name
= XALLOCAVEC (char, len_name
+ 1);
6597 for (size_t i
= 0; i
< len_name
; i
++)
6598 name
[i
] = TOUPPER (expr
->value
.function
.isym
->name
[i
]);
6599 name
[len_name
] = '\0';
6600 tree iname
= gfc_build_addr_expr (pchar_type_node
,
6601 gfc_build_cstring_const (name
));
6602 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6603 "POS argument (%ld) out of range 0:%ld "
6605 fold_convert (long_integer_type_node
, args
[1]),
6606 fold_convert (long_integer_type_node
, nbits
),
6610 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
6611 build_int_cst (type
, 1), args
[1]);
6617 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
6619 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
6622 /* Extract a sequence of bits.
6623 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6625 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
6632 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6633 type
= TREE_TYPE (args
[0]);
6635 /* Optionally generate code for runtime argument check. */
6636 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6638 tree tmp1
= fold_convert (long_integer_type_node
, args
[1]);
6639 tree tmp2
= fold_convert (long_integer_type_node
, args
[2]);
6640 tree nbits
= build_int_cst (long_integer_type_node
,
6641 TYPE_PRECISION (type
));
6642 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6643 logical_type_node
, args
[1],
6644 build_int_cst (TREE_TYPE (args
[1]), 0));
6645 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6646 logical_type_node
, tmp1
, nbits
);
6647 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6648 logical_type_node
, below
, above
);
6649 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6650 "POS argument (%ld) out of range 0:%ld "
6651 "in intrinsic IBITS", tmp1
, nbits
);
6652 below
= fold_build2_loc (input_location
, LT_EXPR
,
6653 logical_type_node
, args
[2],
6654 build_int_cst (TREE_TYPE (args
[2]), 0));
6655 above
= fold_build2_loc (input_location
, GT_EXPR
,
6656 logical_type_node
, tmp2
, nbits
);
6657 scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6658 logical_type_node
, below
, above
);
6659 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6660 "LEN argument (%ld) out of range 0:%ld "
6661 "in intrinsic IBITS", tmp2
, nbits
);
6662 above
= fold_build2_loc (input_location
, PLUS_EXPR
,
6663 long_integer_type_node
, tmp1
, tmp2
);
6664 scond
= fold_build2_loc (input_location
, GT_EXPR
,
6665 logical_type_node
, above
, nbits
);
6666 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6667 "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6668 "in intrinsic IBITS", tmp1
, tmp2
, nbits
);
6671 mask
= build_int_cst (type
, -1);
6672 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
6673 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
6675 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
6677 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
6681 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
6684 tree args
[2], type
, num_bits
, cond
;
6687 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6689 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6690 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6691 type
= TREE_TYPE (args
[0]);
6694 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
6696 gcc_assert (right_shift
);
6698 se
->expr
= fold_build2_loc (input_location
,
6699 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
6700 TREE_TYPE (args
[0]), args
[0], args
[1]);
6703 se
->expr
= fold_convert (type
, se
->expr
);
6706 bigshift
= build_int_cst (type
, 0);
6709 tree nonneg
= fold_build2_loc (input_location
, GE_EXPR
,
6710 logical_type_node
, args
[0],
6711 build_int_cst (TREE_TYPE (args
[0]), 0));
6712 bigshift
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonneg
,
6713 build_int_cst (type
, 0),
6714 build_int_cst (type
, -1));
6717 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6718 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6720 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6722 /* Optionally generate code for runtime argument check. */
6723 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6725 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6726 logical_type_node
, args
[1],
6727 build_int_cst (TREE_TYPE (args
[1]), 0));
6728 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6729 logical_type_node
, args
[1], num_bits
);
6730 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6731 logical_type_node
, below
, above
);
6732 size_t len_name
= strlen (expr
->value
.function
.isym
->name
);
6733 char *name
= XALLOCAVEC (char, len_name
+ 1);
6734 for (size_t i
= 0; i
< len_name
; i
++)
6735 name
[i
] = TOUPPER (expr
->value
.function
.isym
->name
[i
]);
6736 name
[len_name
] = '\0';
6737 tree iname
= gfc_build_addr_expr (pchar_type_node
,
6738 gfc_build_cstring_const (name
));
6739 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6740 "SHIFT argument (%ld) out of range 0:%ld "
6742 fold_convert (long_integer_type_node
, args
[1]),
6743 fold_convert (long_integer_type_node
, num_bits
),
6747 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6750 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6751 bigshift
, se
->expr
);
6754 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
6756 : ((shift >= 0) ? i << shift : i >> -shift)
6757 where all shifts are logical shifts. */
6759 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
6771 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6773 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6774 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6776 type
= TREE_TYPE (args
[0]);
6777 utype
= unsigned_type_for (type
);
6779 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
6782 /* Left shift if positive. */
6783 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
6785 /* Right shift if negative.
6786 We convert to an unsigned type because we want a logical shift.
6787 The standard doesn't define the case of shifting negative
6788 numbers, and we try to be compatible with other compilers, most
6789 notably g77, here. */
6790 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
6791 utype
, convert (utype
, args
[0]), width
));
6793 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
6794 build_int_cst (TREE_TYPE (args
[1]), 0));
6795 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
6797 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6798 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6800 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6802 /* Optionally generate code for runtime argument check. */
6803 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6805 tree outside
= fold_build2_loc (input_location
, GT_EXPR
,
6806 logical_type_node
, width
, num_bits
);
6807 gfc_trans_runtime_check (true, false, outside
, &se
->pre
, &expr
->where
,
6808 "SHIFT argument (%ld) out of range -%ld:%ld "
6809 "in intrinsic ISHFT",
6810 fold_convert (long_integer_type_node
, args
[1]),
6811 fold_convert (long_integer_type_node
, num_bits
),
6812 fold_convert (long_integer_type_node
, num_bits
));
6815 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
6817 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6818 build_int_cst (type
, 0), tmp
);
6822 /* Circular shift. AKA rotate or barrel shift. */
6825 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
6834 unsigned int num_args
;
6836 num_args
= gfc_intrinsic_argument_list_length (expr
);
6837 args
= XALLOCAVEC (tree
, num_args
);
6839 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6841 type
= TREE_TYPE (args
[0]);
6842 nbits
= build_int_cst (long_integer_type_node
, TYPE_PRECISION (type
));
6846 /* Use a library function for the 3 parameter version. */
6847 tree int4type
= gfc_get_int_type (4);
6849 /* We convert the first argument to at least 4 bytes, and
6850 convert back afterwards. This removes the need for library
6851 functions for all argument sizes, and function will be
6852 aligned to at least 32 bits, so there's no loss. */
6853 if (expr
->ts
.kind
< 4)
6854 args
[0] = convert (int4type
, args
[0]);
6856 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
6857 need loads of library functions. They cannot have values >
6858 BIT_SIZE (I) so the conversion is safe. */
6859 args
[1] = convert (int4type
, args
[1]);
6860 args
[2] = convert (int4type
, args
[2]);
6862 /* Optionally generate code for runtime argument check. */
6863 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6865 tree size
= fold_convert (long_integer_type_node
, args
[2]);
6866 tree below
= fold_build2_loc (input_location
, LE_EXPR
,
6867 logical_type_node
, size
,
6868 build_int_cst (TREE_TYPE (args
[1]), 0));
6869 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6870 logical_type_node
, size
, nbits
);
6871 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6872 logical_type_node
, below
, above
);
6873 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6874 "SIZE argument (%ld) out of range 1:%ld "
6875 "in intrinsic ISHFTC", size
, nbits
);
6876 tree width
= fold_convert (long_integer_type_node
, args
[1]);
6877 width
= fold_build1_loc (input_location
, ABS_EXPR
,
6878 long_integer_type_node
, width
);
6879 scond
= fold_build2_loc (input_location
, GT_EXPR
,
6880 logical_type_node
, width
, size
);
6881 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6882 "SHIFT argument (%ld) out of range -%ld:%ld "
6883 "in intrinsic ISHFTC",
6884 fold_convert (long_integer_type_node
, args
[1]),
6888 switch (expr
->ts
.kind
)
6893 tmp
= gfor_fndecl_math_ishftc4
;
6896 tmp
= gfor_fndecl_math_ishftc8
;
6899 tmp
= gfor_fndecl_math_ishftc16
;
6904 se
->expr
= build_call_expr_loc (input_location
,
6905 tmp
, 3, args
[0], args
[1], args
[2]);
6906 /* Convert the result back to the original type, if we extended
6907 the first argument's width above. */
6908 if (expr
->ts
.kind
< 4)
6909 se
->expr
= convert (type
, se
->expr
);
6914 /* Evaluate arguments only once. */
6915 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6916 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6918 /* Optionally generate code for runtime argument check. */
6919 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6921 tree width
= fold_convert (long_integer_type_node
, args
[1]);
6922 width
= fold_build1_loc (input_location
, ABS_EXPR
,
6923 long_integer_type_node
, width
);
6924 tree outside
= fold_build2_loc (input_location
, GT_EXPR
,
6925 logical_type_node
, width
, nbits
);
6926 gfc_trans_runtime_check (true, false, outside
, &se
->pre
, &expr
->where
,
6927 "SHIFT argument (%ld) out of range -%ld:%ld "
6928 "in intrinsic ISHFTC",
6929 fold_convert (long_integer_type_node
, args
[1]),
6933 /* Rotate left if positive. */
6934 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
6936 /* Rotate right if negative. */
6937 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
6939 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
6941 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
6942 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
6944 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
6946 /* Do nothing if shift == 0. */
6947 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
6949 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
6954 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
6955 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
6957 The conditional expression is necessary because the result of LEADZ(0)
6958 is defined, but the result of __builtin_clz(0) is undefined for most
6961 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
6962 difference in bit size between the argument of LEADZ and the C int. */
6965 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
6977 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6978 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6980 /* Which variant of __builtin_clz* should we call? */
6981 if (argsize
<= INT_TYPE_SIZE
)
6983 arg_type
= unsigned_type_node
;
6984 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
6986 else if (argsize
<= LONG_TYPE_SIZE
)
6988 arg_type
= long_unsigned_type_node
;
6989 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
6991 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6993 arg_type
= long_long_unsigned_type_node
;
6994 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6998 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6999 arg_type
= gfc_build_uint_type (argsize
);
7003 /* Convert the actual argument twice: first, to the unsigned type of the
7004 same size; then, to the proper argument type for the built-in
7005 function. But the return type is of the default INTEGER kind. */
7006 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7007 arg
= fold_convert (arg_type
, arg
);
7008 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7009 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7011 /* Compute LEADZ for the case i .ne. 0. */
7014 s
= TYPE_PRECISION (arg_type
) - argsize
;
7015 tmp
= fold_convert (result_type
,
7016 build_call_expr_loc (input_location
, func
,
7018 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
7019 tmp
, build_int_cst (result_type
, s
));
7023 /* We end up here if the argument type is larger than 'long long'.
7024 We generate this code:
7026 if (x & (ULL_MAX << ULL_SIZE) != 0)
7027 return clzll ((unsigned long long) (x >> ULLSIZE));
7029 return ULL_SIZE + clzll ((unsigned long long) x);
7030 where ULL_MAX is the largest value that a ULL_MAX can hold
7031 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7032 is the bit-size of the long long type (64 in this example). */
7033 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
7035 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
7036 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7037 long_long_unsigned_type_node
,
7038 build_int_cst (long_long_unsigned_type_node
,
7041 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
7042 fold_convert (arg_type
, ullmax
), ullsize
);
7043 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
7045 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7046 cond
, build_int_cst (arg_type
, 0));
7048 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
7050 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
7051 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
7052 tmp1
= fold_convert (result_type
,
7053 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
7055 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
7056 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
7057 tmp2
= fold_convert (result_type
,
7058 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
7059 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7062 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
7066 /* Build BIT_SIZE. */
7067 bit_size
= build_int_cst (result_type
, argsize
);
7069 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7070 arg
, build_int_cst (arg_type
, 0));
7071 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
7076 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7078 The conditional expression is necessary because the result of TRAILZ(0)
7079 is defined, but the result of __builtin_ctz(0) is undefined for most
7083 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
7094 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7095 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
7097 /* Which variant of __builtin_ctz* should we call? */
7098 if (argsize
<= INT_TYPE_SIZE
)
7100 arg_type
= unsigned_type_node
;
7101 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
7103 else if (argsize
<= LONG_TYPE_SIZE
)
7105 arg_type
= long_unsigned_type_node
;
7106 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
7108 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
7110 arg_type
= long_long_unsigned_type_node
;
7111 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7115 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
7116 arg_type
= gfc_build_uint_type (argsize
);
7120 /* Convert the actual argument twice: first, to the unsigned type of the
7121 same size; then, to the proper argument type for the built-in
7122 function. But the return type is of the default INTEGER kind. */
7123 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7124 arg
= fold_convert (arg_type
, arg
);
7125 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7126 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7128 /* Compute TRAILZ for the case i .ne. 0. */
7130 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
7134 /* We end up here if the argument type is larger than 'long long'.
7135 We generate this code:
7137 if ((x & ULL_MAX) == 0)
7138 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7140 return ctzll ((unsigned long long) x);
7142 where ULL_MAX is the largest value that a ULL_MAX can hold
7143 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7144 is the bit-size of the long long type (64 in this example). */
7145 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
7147 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
7148 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7149 long_long_unsigned_type_node
,
7150 build_int_cst (long_long_unsigned_type_node
, 0));
7152 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
7153 fold_convert (arg_type
, ullmax
));
7154 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
7155 build_int_cst (arg_type
, 0));
7157 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
7159 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
7160 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7161 tmp1
= fold_convert (result_type
,
7162 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
7163 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7166 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
7167 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7168 tmp2
= fold_convert (result_type
,
7169 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
7171 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
7175 /* Build BIT_SIZE. */
7176 bit_size
= build_int_cst (result_type
, argsize
);
7178 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7179 arg
, build_int_cst (arg_type
, 0));
7180 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
7184 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7185 for types larger than "long long", we call the long long built-in for
7186 the lower and higher bits and combine the result. */
7189 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
7197 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7198 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
7199 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7201 /* Which variant of the builtin should we call? */
7202 if (argsize
<= INT_TYPE_SIZE
)
7204 arg_type
= unsigned_type_node
;
7205 func
= builtin_decl_explicit (parity
7207 : BUILT_IN_POPCOUNT
);
7209 else if (argsize
<= LONG_TYPE_SIZE
)
7211 arg_type
= long_unsigned_type_node
;
7212 func
= builtin_decl_explicit (parity
7214 : BUILT_IN_POPCOUNTL
);
7216 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
7218 arg_type
= long_long_unsigned_type_node
;
7219 func
= builtin_decl_explicit (parity
7221 : BUILT_IN_POPCOUNTLL
);
7225 /* Our argument type is larger than 'long long', which mean none
7226 of the POPCOUNT builtins covers it. We thus call the 'long long'
7227 variant multiple times, and add the results. */
7228 tree utype
, arg2
, call1
, call2
;
7230 /* For now, we only cover the case where argsize is twice as large
7232 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
7234 func
= builtin_decl_explicit (parity
7236 : BUILT_IN_POPCOUNTLL
);
7238 /* Convert it to an integer, and store into a variable. */
7239 utype
= gfc_build_uint_type (argsize
);
7240 arg
= fold_convert (utype
, arg
);
7241 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7243 /* Call the builtin twice. */
7244 call1
= build_call_expr_loc (input_location
, func
, 1,
7245 fold_convert (long_long_unsigned_type_node
,
7248 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
7249 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
7250 call2
= build_call_expr_loc (input_location
, func
, 1,
7251 fold_convert (long_long_unsigned_type_node
,
7254 /* Combine the results. */
7256 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
7259 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7265 /* Convert the actual argument twice: first, to the unsigned type of the
7266 same size; then, to the proper argument type for the built-in
7268 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7269 arg
= fold_convert (arg_type
, arg
);
7271 se
->expr
= fold_convert (result_type
,
7272 build_call_expr_loc (input_location
, func
, 1, arg
));
7276 /* Process an intrinsic with unspecified argument-types that has an optional
7277 argument (which could be of type character), e.g. EOSHIFT. For those, we
7278 need to append the string length of the optional argument if it is not
7279 present and the type is really character.
7280 primary specifies the position (starting at 1) of the non-optional argument
7281 specifying the type and optional gives the position of the optional
7282 argument in the arglist. */
7285 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
7286 unsigned primary
, unsigned optional
)
7288 gfc_actual_arglist
* prim_arg
;
7289 gfc_actual_arglist
* opt_arg
;
7291 gfc_actual_arglist
* arg
;
7293 vec
<tree
, va_gc
> *append_args
;
7295 /* Find the two arguments given as position. */
7299 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
7303 if (cur_pos
== primary
)
7305 if (cur_pos
== optional
)
7308 if (cur_pos
>= primary
&& cur_pos
>= optional
)
7311 gcc_assert (prim_arg
);
7312 gcc_assert (prim_arg
->expr
);
7313 gcc_assert (opt_arg
);
7315 /* If we do have type CHARACTER and the optional argument is really absent,
7316 append a dummy 0 as string length. */
7318 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
7322 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
7323 vec_alloc (append_args
, 1);
7324 append_args
->quick_push (dummy
);
7327 /* Build the call itself. */
7328 gcc_assert (!se
->ignore_optional
);
7329 sym
= gfc_get_symbol_for_expr (expr
, false);
7330 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
7332 gfc_free_symbol (sym
);
7335 /* The length of a character string. */
7337 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
7346 gcc_assert (!se
->ss
);
7348 arg
= expr
->value
.function
.actual
->expr
;
7350 type
= gfc_typenode_for_spec (&expr
->ts
);
7351 switch (arg
->expr_type
)
7354 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
7358 /* Obtain the string length from the function used by
7359 trans-array.c(gfc_trans_array_constructor). */
7361 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
7365 if (arg
->ref
== NULL
7366 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
7368 /* This doesn't catch all cases.
7369 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7370 and the surrounding thread. */
7371 sym
= arg
->symtree
->n
.sym
;
7372 decl
= gfc_get_symbol_decl (sym
);
7373 if (decl
== current_function_decl
&& sym
->attr
.function
7374 && (sym
->result
== sym
))
7375 decl
= gfc_get_fake_result_decl (sym
, 0);
7377 len
= sym
->ts
.u
.cl
->backend_decl
;
7385 gfc_init_se (&argse
, se
);
7387 gfc_conv_expr (&argse
, arg
);
7389 gfc_conv_expr_descriptor (&argse
, arg
);
7390 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7391 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7392 len
= argse
.string_length
;
7395 se
->expr
= convert (type
, len
);
7398 /* The length of a character string not including trailing blanks. */
7400 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
7402 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7403 tree args
[2], type
, fndecl
;
7405 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7406 type
= gfc_typenode_for_spec (&expr
->ts
);
7409 fndecl
= gfor_fndecl_string_len_trim
;
7411 fndecl
= gfor_fndecl_string_len_trim_char4
;
7415 se
->expr
= build_call_expr_loc (input_location
,
7416 fndecl
, 2, args
[0], args
[1]);
7417 se
->expr
= convert (type
, se
->expr
);
7421 /* Returns the starting position of a substring within a string. */
7424 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
7427 tree logical4_type_node
= gfc_get_logical_type (4);
7431 unsigned int num_args
;
7433 args
= XALLOCAVEC (tree
, 5);
7435 /* Get number of arguments; characters count double due to the
7436 string length argument. Kind= is not passed to the library
7437 and thus ignored. */
7438 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
7443 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
7444 type
= gfc_typenode_for_spec (&expr
->ts
);
7447 args
[4] = build_int_cst (logical4_type_node
, 0);
7449 args
[4] = convert (logical4_type_node
, args
[4]);
7451 fndecl
= build_addr (function
);
7452 se
->expr
= build_call_array_loc (input_location
,
7453 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7455 se
->expr
= convert (type
, se
->expr
);
7459 /* The ascii value for a single character. */
7461 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
7463 tree args
[3], type
, pchartype
;
7466 nargs
= gfc_intrinsic_argument_list_length (expr
);
7467 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
7468 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
7469 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
7470 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
7471 type
= gfc_typenode_for_spec (&expr
->ts
);
7473 se
->expr
= build_fold_indirect_ref_loc (input_location
,
7475 se
->expr
= convert (type
, se
->expr
);
7479 /* Intrinsic ISNAN calls __builtin_isnan. */
7482 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
7486 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7487 se
->expr
= build_call_expr_loc (input_location
,
7488 builtin_decl_explicit (BUILT_IN_ISNAN
),
7490 STRIP_TYPE_NOPS (se
->expr
);
7491 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7495 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7496 their argument against a constant integer value. */
7499 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
7503 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7504 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
7505 gfc_typenode_for_spec (&expr
->ts
),
7506 arg
, build_int_cst (TREE_TYPE (arg
), value
));
7511 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7514 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
7522 unsigned int num_args
;
7524 num_args
= gfc_intrinsic_argument_list_length (expr
);
7525 args
= XALLOCAVEC (tree
, num_args
);
7527 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
7528 if (expr
->ts
.type
!= BT_CHARACTER
)
7536 /* We do the same as in the non-character case, but the argument
7537 list is different because of the string length arguments. We
7538 also have to set the string length for the result. */
7545 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
7547 se
->string_length
= len
;
7549 type
= TREE_TYPE (tsource
);
7550 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
7551 fold_convert (type
, fsource
));
7555 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7558 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
7560 tree args
[3], mask
, type
;
7562 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7563 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
7565 type
= TREE_TYPE (args
[0]);
7566 gcc_assert (TREE_TYPE (args
[1]) == type
);
7567 gcc_assert (TREE_TYPE (mask
) == type
);
7569 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
7570 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
7571 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7573 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
7578 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7579 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7582 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
7584 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
7587 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7588 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7590 type
= gfc_get_int_type (expr
->ts
.kind
);
7591 utype
= unsigned_type_for (type
);
7593 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
7594 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
7596 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
7597 build_int_cst (utype
, 0));
7601 /* Left-justified mask. */
7602 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
7604 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
7605 fold_convert (utype
, res
));
7607 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7608 smaller than type width. */
7609 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
7610 build_int_cst (TREE_TYPE (arg
), 0));
7611 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
7612 build_int_cst (utype
, 0), res
);
7616 /* Right-justified mask. */
7617 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
7618 fold_convert (utype
, arg
));
7619 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
7621 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7622 strictly smaller than type width. */
7623 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7625 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
7626 cond
, allones
, res
);
7629 se
->expr
= fold_convert (type
, res
);
7633 /* FRACTION (s) is translated into:
7634 isfinite (s) ? frexp (s, &dummy_int) : NaN */
7636 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
7638 tree arg
, type
, tmp
, res
, frexp
, cond
;
7640 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7642 type
= gfc_typenode_for_spec (&expr
->ts
);
7643 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7644 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7646 cond
= build_call_expr_loc (input_location
,
7647 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7650 tmp
= gfc_create_var (integer_type_node
, NULL
);
7651 res
= build_call_expr_loc (input_location
, frexp
, 2,
7652 fold_convert (type
, arg
),
7653 gfc_build_addr_expr (NULL_TREE
, tmp
));
7654 res
= fold_convert (type
, res
);
7656 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
7657 cond
, res
, gfc_build_nan (type
, ""));
7661 /* NEAREST (s, dir) is translated into
7662 tmp = copysign (HUGE_VAL, dir);
7663 return nextafter (s, tmp);
7666 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
7668 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
7670 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
7671 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
7673 type
= gfc_typenode_for_spec (&expr
->ts
);
7674 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7676 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
7677 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
7678 fold_convert (type
, args
[1]));
7679 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
7680 fold_convert (type
, args
[0]), tmp
);
7681 se
->expr
= fold_convert (type
, se
->expr
);
7685 /* SPACING (s) is translated into
7695 e = MAX_EXPR (e, emin);
7696 res = scalbn (1., e);
7700 where prec is the precision of s, gfc_real_kinds[k].digits,
7701 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7702 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7705 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
7707 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
7708 tree cond
, nan
, tmp
, frexp
, scalbn
;
7712 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7713 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
7714 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
7715 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
7717 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7718 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7720 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7721 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7723 type
= gfc_typenode_for_spec (&expr
->ts
);
7724 e
= gfc_create_var (integer_type_node
, NULL
);
7725 res
= gfc_create_var (type
, NULL
);
7728 /* Build the block for s /= 0. */
7729 gfc_start_block (&block
);
7730 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7731 gfc_build_addr_expr (NULL_TREE
, e
));
7732 gfc_add_expr_to_block (&block
, tmp
);
7734 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
7736 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
7737 integer_type_node
, tmp
, emin
));
7739 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
7740 build_real_from_int_cst (type
, integer_one_node
), e
);
7741 gfc_add_modify (&block
, res
, tmp
);
7743 /* Finish by building the IF statement for value zero. */
7744 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
7745 build_real_from_int_cst (type
, integer_zero_node
));
7746 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
7747 gfc_finish_block (&block
));
7749 /* And deal with infinities and NaNs. */
7750 cond
= build_call_expr_loc (input_location
,
7751 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7753 nan
= gfc_build_nan (type
, "");
7754 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
7756 gfc_add_expr_to_block (&se
->pre
, tmp
);
7761 /* RRSPACING (s) is translated into
7770 x = scalbn (x, precision - e);
7777 where precision is gfc_real_kinds[k].digits. */
7780 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
7782 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
7786 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7787 prec
= gfc_real_kinds
[k
].digits
;
7789 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7790 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7791 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
7793 type
= gfc_typenode_for_spec (&expr
->ts
);
7794 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7795 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7797 e
= gfc_create_var (integer_type_node
, NULL
);
7798 x
= gfc_create_var (type
, NULL
);
7799 gfc_add_modify (&se
->pre
, x
,
7800 build_call_expr_loc (input_location
, fabs
, 1, arg
));
7803 gfc_start_block (&block
);
7804 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7805 gfc_build_addr_expr (NULL_TREE
, e
));
7806 gfc_add_expr_to_block (&block
, tmp
);
7808 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
7809 build_int_cst (integer_type_node
, prec
), e
);
7810 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
7811 gfc_add_modify (&block
, x
, tmp
);
7812 stmt
= gfc_finish_block (&block
);
7815 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
7816 build_real_from_int_cst (type
, integer_zero_node
));
7817 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
7819 /* And deal with infinities and NaNs. */
7820 cond
= build_call_expr_loc (input_location
,
7821 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7823 nan
= gfc_build_nan (type
, "");
7824 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
7826 gfc_add_expr_to_block (&se
->pre
, tmp
);
7827 se
->expr
= fold_convert (type
, x
);
7831 /* SCALE (s, i) is translated into scalbn (s, i). */
7833 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
7835 tree args
[2], type
, scalbn
;
7837 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7839 type
= gfc_typenode_for_spec (&expr
->ts
);
7840 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7841 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
7842 fold_convert (type
, args
[0]),
7843 fold_convert (integer_type_node
, args
[1]));
7844 se
->expr
= fold_convert (type
, se
->expr
);
7848 /* SET_EXPONENT (s, i) is translated into
7849 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
7851 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
7853 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
7855 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7856 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7858 type
= gfc_typenode_for_spec (&expr
->ts
);
7859 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7860 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
7862 tmp
= gfc_create_var (integer_type_node
, NULL
);
7863 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
7864 fold_convert (type
, args
[0]),
7865 gfc_build_addr_expr (NULL_TREE
, tmp
));
7866 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
7867 fold_convert (integer_type_node
, args
[1]));
7868 res
= fold_convert (type
, res
);
7870 /* Call to isfinite */
7871 cond
= build_call_expr_loc (input_location
,
7872 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7874 nan
= gfc_build_nan (type
, "");
7876 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
7882 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
7884 gfc_actual_arglist
*actual
;
7890 gfc_symbol
*sym
= NULL
;
7892 gfc_init_se (&argse
, NULL
);
7893 actual
= expr
->value
.function
.actual
;
7895 if (actual
->expr
->ts
.type
== BT_CLASS
)
7896 gfc_add_class_array_ref (actual
->expr
);
7900 /* These are emerging from the interface mapping, when a class valued
7901 function appears as the rhs in a realloc on assign statement, where
7902 the size of the result is that of one of the actual arguments. */
7903 if (e
->expr_type
== EXPR_VARIABLE
7904 && e
->symtree
->n
.sym
->ns
== NULL
/* This is distinctive! */
7905 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7906 && e
->ref
&& e
->ref
->type
== REF_COMPONENT
7907 && strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0)
7908 sym
= e
->symtree
->n
.sym
;
7910 if ((gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
)
7912 && (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
))
7914 symbol_attribute attr
;
7919 if (e
->symtree
->n
.sym
&& IS_CLASS_ARRAY (e
->symtree
->n
.sym
))
7921 attr
= CLASS_DATA (e
->symtree
->n
.sym
)->attr
;
7922 attr
.pointer
= attr
.class_pointer
;
7925 attr
= gfc_expr_attr (e
);
7927 if (attr
.allocatable
)
7928 msg
= xasprintf ("Allocatable argument '%s' is not allocated",
7929 e
->symtree
->n
.sym
->name
);
7930 else if (attr
.pointer
)
7931 msg
= xasprintf ("Pointer argument '%s' is not associated",
7932 e
->symtree
->n
.sym
->name
);
7938 temp
= gfc_class_data_get (sym
->backend_decl
);
7939 temp
= gfc_conv_descriptor_data_get (temp
);
7943 argse
.descriptor_only
= 1;
7944 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
7945 temp
= gfc_conv_descriptor_data_get (argse
.expr
);
7948 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7949 logical_type_node
, temp
,
7950 fold_convert (TREE_TYPE (temp
),
7951 null_pointer_node
));
7952 gfc_trans_runtime_check (true, false, cond
, &argse
.pre
, &e
->where
, msg
);
7958 argse
.data_not_needed
= 1;
7959 if (gfc_is_class_array_function (e
))
7961 /* For functions that return a class array conv_expr_descriptor is not
7962 able to get the descriptor right. Therefore this special case. */
7963 gfc_conv_expr_reference (&argse
, e
);
7964 argse
.expr
= gfc_class_data_get (argse
.expr
);
7966 else if (sym
&& sym
->backend_decl
)
7968 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
7969 argse
.expr
= gfc_class_data_get (sym
->backend_decl
);
7972 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
7973 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7974 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7977 actual
= actual
->next
;
7981 gfc_init_block (&block
);
7982 gfc_init_se (&argse
, NULL
);
7983 gfc_conv_expr_type (&argse
, actual
->expr
,
7984 gfc_array_index_type
);
7985 gfc_add_block_to_block (&block
, &argse
.pre
);
7986 tree tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7987 argse
.expr
, gfc_index_one_node
);
7988 size
= gfc_tree_array_size (&block
, arg1
, e
, tmp
);
7990 /* Unusually, for an intrinsic, size does not exclude
7991 an optional arg2, so we must test for it. */
7992 if (actual
->expr
->expr_type
== EXPR_VARIABLE
7993 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
7994 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
7998 gfc_init_block (&block2
);
7999 gfc_init_se (&argse
, NULL
);
8000 argse
.want_pointer
= 1;
8001 argse
.data_not_needed
= 1;
8002 gfc_conv_expr (&argse
, actual
->expr
);
8003 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8004 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8005 argse
.expr
, null_pointer_node
);
8006 cond
= gfc_evaluate_now (cond
, &se
->pre
);
8007 /* 'block2' contains the arg2 absent case, 'block' the arg2 present
8008 case; size_var can be used in both blocks. */
8009 tree size_var
= gfc_tree_array_size (&block2
, arg1
, e
, NULL_TREE
);
8010 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8011 TREE_TYPE (size_var
), size_var
, size
);
8012 gfc_add_expr_to_block (&block
, tmp
);
8013 tmp
= build3_v (COND_EXPR
, cond
, gfc_finish_block (&block
),
8014 gfc_finish_block (&block2
));
8015 gfc_add_expr_to_block (&se
->pre
, tmp
);
8019 gfc_add_block_to_block (&se
->pre
, &block
);
8022 size
= gfc_tree_array_size (&se
->pre
, arg1
, e
, NULL_TREE
);
8023 type
= gfc_typenode_for_spec (&expr
->ts
);
8024 se
->expr
= convert (type
, size
);
8028 /* Helper function to compute the size of a character variable,
8029 excluding the terminating null characters. The result has
8030 gfc_array_index_type type. */
8033 size_of_string_in_bytes (int kind
, tree string_length
)
8036 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
8038 bytesize
= build_int_cst (gfc_array_index_type
,
8039 gfc_character_kinds
[i
].bit_size
/ 8);
8041 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8043 fold_convert (gfc_array_index_type
, string_length
));
8048 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
8060 gfc_init_se (&argse
, NULL
);
8061 arg
= expr
->value
.function
.actual
->expr
;
8063 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
8064 gfc_conv_expr_descriptor (&argse
, arg
);
8066 gfc_conv_expr_reference (&argse
, arg
);
8068 if (arg
->ts
.type
== BT_ASSUMED
)
8070 /* This only works if an array descriptor has been passed; thus, extract
8071 the size from the descriptor. */
8072 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
8073 == TYPE_PRECISION (size_type_node
));
8074 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
8075 tmp
= DECL_LANG_SPECIFIC (tmp
)
8076 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
8077 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
8078 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
8079 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8081 tmp
= gfc_conv_descriptor_dtype (tmp
);
8082 field
= gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8083 GFC_DTYPE_ELEM_LEN
);
8084 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
8085 tmp
, field
, NULL_TREE
);
8087 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
8089 else if (arg
->ts
.type
== BT_CLASS
)
8091 /* Conv_expr_descriptor returns a component_ref to _data component of the
8092 class object. The class object may be a non-pointer object, e.g.
8093 located on the stack, or a memory location pointed to, e.g. a
8094 parameter, i.e., an indirect_ref. */
8096 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
8097 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
8098 && GFC_DECL_CLASS (TREE_OPERAND (
8099 TREE_OPERAND (argse
.expr
, 0), 0)))
8100 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
8101 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
8102 else if (arg
->rank
> 0
8104 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
8105 /* The scalarizer added an additional temp. To get the class' vptr
8106 one has to look at the original backend_decl. */
8107 byte_size
= gfc_class_vtab_size_get (
8108 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
8110 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
8114 if (arg
->ts
.type
== BT_CHARACTER
)
8115 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
8119 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8122 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8123 byte_size
= fold_convert (gfc_array_index_type
,
8124 size_in_bytes (byte_size
));
8129 se
->expr
= byte_size
;
8132 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
8133 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
8135 if (arg
->rank
== -1)
8137 tree cond
, loop_var
, exit_label
;
8140 tmp
= fold_convert (gfc_array_index_type
,
8141 gfc_conv_descriptor_rank (argse
.expr
));
8142 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
8143 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
8144 exit_label
= gfc_build_label_decl (NULL_TREE
);
8151 source_bytes = source_bytes * array.dim[i].extent;
8155 gfc_start_block (&body
);
8156 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
8158 tmp
= build1_v (GOTO_EXPR
, exit_label
);
8159 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
8160 cond
, tmp
, build_empty_stmt (input_location
));
8161 gfc_add_expr_to_block (&body
, tmp
);
8163 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
8164 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
8165 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
8166 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8167 gfc_array_index_type
, tmp
, source_bytes
);
8168 gfc_add_modify (&body
, source_bytes
, tmp
);
8170 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8171 gfc_array_index_type
, loop_var
,
8172 gfc_index_one_node
);
8173 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
8175 tmp
= gfc_finish_block (&body
);
8177 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
8179 gfc_add_expr_to_block (&argse
.pre
, tmp
);
8181 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8182 gfc_add_expr_to_block (&argse
.pre
, tmp
);
8186 /* Obtain the size of the array in bytes. */
8187 for (n
= 0; n
< arg
->rank
; n
++)
8190 idx
= gfc_rank_cst
[n
];
8191 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
8192 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
8193 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
8194 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8195 gfc_array_index_type
, tmp
, source_bytes
);
8196 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8199 se
->expr
= source_bytes
;
8202 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8207 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
8211 tree type
, result_type
, tmp
;
8213 arg
= expr
->value
.function
.actual
->expr
;
8215 gfc_init_se (&argse
, NULL
);
8216 result_type
= gfc_get_int_type (expr
->ts
.kind
);
8220 if (arg
->ts
.type
== BT_CLASS
)
8222 gfc_add_vptr_component (arg
);
8223 gfc_add_size_component (arg
);
8224 gfc_conv_expr (&argse
, arg
);
8225 tmp
= fold_convert (result_type
, argse
.expr
);
8229 gfc_conv_expr_reference (&argse
, arg
);
8230 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8235 argse
.want_pointer
= 0;
8236 gfc_conv_expr_descriptor (&argse
, arg
);
8237 if (arg
->ts
.type
== BT_CLASS
)
8240 tmp
= gfc_class_vtab_size_get (
8241 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
8243 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
8244 tmp
= fold_convert (result_type
, tmp
);
8247 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8250 /* Obtain the argument's word length. */
8251 if (arg
->ts
.type
== BT_CHARACTER
)
8252 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
8254 tmp
= size_in_bytes (type
);
8255 tmp
= fold_convert (result_type
, tmp
);
8258 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
8259 build_int_cst (result_type
, BITS_PER_UNIT
));
8260 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8264 /* Intrinsic string comparison functions. */
8267 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
8271 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
8274 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
8275 expr
->value
.function
.actual
->expr
->ts
.kind
,
8277 se
->expr
= fold_build2_loc (input_location
, op
,
8278 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
8279 build_int_cst (TREE_TYPE (se
->expr
), 0));
8282 /* Generate a call to the adjustl/adjustr library function. */
8284 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
8292 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
8295 type
= TREE_TYPE (args
[2]);
8296 var
= gfc_conv_string_tmp (se
, type
, len
);
8299 tmp
= build_call_expr_loc (input_location
,
8300 fndecl
, 3, args
[0], args
[1], args
[2]);
8301 gfc_add_expr_to_block (&se
->pre
, tmp
);
8303 se
->string_length
= len
;
8307 /* Generate code for the TRANSFER intrinsic:
8309 DEST = TRANSFER (SOURCE, MOLD)
8311 typeof<DEST> = typeof<MOLD>
8316 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8318 typeof<DEST> = typeof<MOLD>
8320 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8321 sizeof (DEST(0) * SIZE). */
8323 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
8339 tree class_ref
= NULL_TREE
;
8340 gfc_actual_arglist
*arg
;
8342 gfc_array_info
*info
;
8346 gfc_expr
*source_expr
, *mold_expr
, *class_expr
;
8350 info
= &se
->ss
->info
->data
.array
;
8352 /* Convert SOURCE. The output from this stage is:-
8353 source_bytes = length of the source in bytes
8354 source = pointer to the source data. */
8355 arg
= expr
->value
.function
.actual
;
8356 source_expr
= arg
->expr
;
8358 /* Ensure double transfer through LOGICAL preserves all
8360 if (arg
->expr
->expr_type
== EXPR_FUNCTION
8361 && arg
->expr
->value
.function
.esym
== NULL
8362 && arg
->expr
->value
.function
.isym
!= NULL
8363 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
8364 && arg
->expr
->ts
.type
== BT_LOGICAL
8365 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
8366 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
8368 gfc_init_se (&argse
, NULL
);
8370 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
8372 /* Obtain the pointer to source and the length of source in bytes. */
8373 if (arg
->expr
->rank
== 0)
8375 gfc_conv_expr_reference (&argse
, arg
->expr
);
8376 if (arg
->expr
->ts
.type
== BT_CLASS
)
8378 tmp
= build_fold_indirect_ref_loc (input_location
, argse
.expr
);
8379 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
8380 source
= gfc_class_data_get (tmp
);
8383 /* Array elements are evaluated as a reference to the data.
8384 To obtain the vptr for the element size, the argument
8385 expression must be stripped to the class reference and
8386 re-evaluated. The pre and post blocks are not needed. */
8387 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
8388 source
= argse
.expr
;
8389 class_expr
= gfc_find_and_cut_at_last_class_ref (arg
->expr
);
8390 gfc_init_se (&argse
, NULL
);
8391 gfc_conv_expr (&argse
, class_expr
);
8392 class_ref
= argse
.expr
;
8396 source
= argse
.expr
;
8398 /* Obtain the source word length. */
8399 switch (arg
->expr
->ts
.type
)
8402 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
8403 argse
.string_length
);
8406 if (class_ref
!= NULL_TREE
)
8407 tmp
= gfc_class_vtab_size_get (class_ref
);
8409 tmp
= gfc_class_vtab_size_get (argse
.expr
);
8412 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8414 tmp
= fold_convert (gfc_array_index_type
,
8415 size_in_bytes (source_type
));
8421 argse
.want_pointer
= 0;
8422 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
8423 source
= gfc_conv_descriptor_data_get (argse
.expr
);
8424 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8426 /* Repack the source if not simply contiguous. */
8427 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
8429 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
8431 if (warn_array_temporaries
)
8432 gfc_warning (OPT_Warray_temporaries
,
8433 "Creating array temporary at %L", &expr
->where
);
8435 source
= build_call_expr_loc (input_location
,
8436 gfor_fndecl_in_pack
, 1, tmp
);
8437 source
= gfc_evaluate_now (source
, &argse
.pre
);
8439 /* Free the temporary. */
8440 gfc_start_block (&block
);
8441 tmp
= gfc_call_free (source
);
8442 gfc_add_expr_to_block (&block
, tmp
);
8443 stmt
= gfc_finish_block (&block
);
8445 /* Clean up if it was repacked. */
8446 gfc_init_block (&block
);
8447 tmp
= gfc_conv_array_data (argse
.expr
);
8448 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8450 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
8451 build_empty_stmt (input_location
));
8452 gfc_add_expr_to_block (&block
, tmp
);
8453 gfc_add_block_to_block (&block
, &se
->post
);
8454 gfc_init_block (&se
->post
);
8455 gfc_add_block_to_block (&se
->post
, &block
);
8458 /* Obtain the source word length. */
8459 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
8460 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
8461 argse
.string_length
);
8463 tmp
= fold_convert (gfc_array_index_type
,
8464 size_in_bytes (source_type
));
8466 /* Obtain the size of the array in bytes. */
8467 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
8468 for (n
= 0; n
< arg
->expr
->rank
; n
++)
8471 idx
= gfc_rank_cst
[n
];
8472 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8473 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
8474 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
8475 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8476 gfc_array_index_type
, upper
, lower
);
8477 gfc_add_modify (&argse
.pre
, extent
, tmp
);
8478 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8479 gfc_array_index_type
, extent
,
8480 gfc_index_one_node
);
8481 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8482 gfc_array_index_type
, tmp
, source_bytes
);
8486 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8487 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8488 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8490 /* Now convert MOLD. The outputs are:
8491 mold_type = the TREE type of MOLD
8492 dest_word_len = destination word length in bytes. */
8494 mold_expr
= arg
->expr
;
8496 gfc_init_se (&argse
, NULL
);
8498 scalar_mold
= arg
->expr
->rank
== 0;
8500 if (arg
->expr
->rank
== 0)
8502 gfc_conv_expr_reference (&argse
, arg
->expr
);
8503 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8508 gfc_init_se (&argse
, NULL
);
8509 argse
.want_pointer
= 0;
8510 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
8511 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8514 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8515 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8517 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
8519 /* If this TRANSFER is nested in another TRANSFER, use a type
8520 that preserves all bits. */
8521 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
8522 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
8525 /* Obtain the destination word length. */
8526 switch (arg
->expr
->ts
.type
)
8529 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
8530 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
8533 tmp
= gfc_class_vtab_size_get (argse
.expr
);
8536 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
8539 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
8540 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
8542 /* Finally convert SIZE, if it is present. */
8544 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
8548 gfc_init_se (&argse
, NULL
);
8549 gfc_conv_expr_reference (&argse
, arg
->expr
);
8550 tmp
= convert (gfc_array_index_type
,
8551 build_fold_indirect_ref_loc (input_location
,
8553 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8554 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8559 /* Separate array and scalar results. */
8560 if (scalar_mold
&& tmp
== NULL_TREE
)
8561 goto scalar_transfer
;
8563 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
8564 if (tmp
!= NULL_TREE
)
8565 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8566 tmp
, dest_word_len
);
8570 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
8571 gfc_add_modify (&se
->pre
, size_words
,
8572 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
8573 gfc_array_index_type
,
8574 size_bytes
, dest_word_len
));
8576 /* Evaluate the bounds of the result. If the loop range exists, we have
8577 to check if it is too large. If so, we modify loop->to be consistent
8578 with min(size, size(source)). Otherwise, size is made consistent with
8579 the loop range, so that the right number of bytes is transferred.*/
8580 n
= se
->loop
->order
[0];
8581 if (se
->loop
->to
[n
] != NULL_TREE
)
8583 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8584 se
->loop
->to
[n
], se
->loop
->from
[n
]);
8585 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8586 tmp
, gfc_index_one_node
);
8587 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
8589 gfc_add_modify (&se
->pre
, size_words
, tmp
);
8590 gfc_add_modify (&se
->pre
, size_bytes
,
8591 fold_build2_loc (input_location
, MULT_EXPR
,
8592 gfc_array_index_type
,
8593 size_words
, dest_word_len
));
8594 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8595 size_words
, se
->loop
->from
[n
]);
8596 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8597 upper
, gfc_index_one_node
);
8601 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8602 size_words
, gfc_index_one_node
);
8603 se
->loop
->from
[n
] = gfc_index_zero_node
;
8606 se
->loop
->to
[n
] = upper
;
8608 /* Build a destination descriptor, using the pointer, source, as the
8610 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
8611 NULL_TREE
, false, true, false, &expr
->where
);
8613 /* Cast the pointer to the result. */
8614 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
8615 tmp
= fold_convert (pvoid_type_node
, tmp
);
8617 /* Use memcpy to do the transfer. */
8619 = build_call_expr_loc (input_location
,
8620 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
8621 fold_convert (pvoid_type_node
, source
),
8622 fold_convert (size_type_node
,
8623 fold_build2_loc (input_location
,
8625 gfc_array_index_type
,
8628 gfc_add_expr_to_block (&se
->pre
, tmp
);
8630 se
->expr
= info
->descriptor
;
8631 if (expr
->ts
.type
== BT_CHARACTER
)
8632 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
8636 /* Deal with scalar results. */
8638 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
8639 dest_word_len
, source_bytes
);
8640 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
8641 extent
, gfc_index_zero_node
);
8643 if (expr
->ts
.type
== BT_CHARACTER
)
8645 tree direct
, indirect
, free
;
8647 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
8648 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
8651 /* If source is longer than the destination, use a pointer to
8652 the source directly. */
8653 gfc_init_block (&block
);
8654 gfc_add_modify (&block
, tmpdecl
, ptr
);
8655 direct
= gfc_finish_block (&block
);
8657 /* Otherwise, allocate a string with the length of the destination
8658 and copy the source into it. */
8659 gfc_init_block (&block
);
8660 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
8661 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
8662 gfc_add_modify (&block
, tmpdecl
,
8663 fold_convert (TREE_TYPE (ptr
), tmp
));
8664 tmp
= build_call_expr_loc (input_location
,
8665 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
8666 fold_convert (pvoid_type_node
, tmpdecl
),
8667 fold_convert (pvoid_type_node
, ptr
),
8668 fold_convert (size_type_node
, extent
));
8669 gfc_add_expr_to_block (&block
, tmp
);
8670 indirect
= gfc_finish_block (&block
);
8672 /* Wrap it up with the condition. */
8673 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
8674 dest_word_len
, source_bytes
);
8675 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
8676 gfc_add_expr_to_block (&se
->pre
, tmp
);
8678 /* Free the temporary string, if necessary. */
8679 free
= gfc_call_free (tmpdecl
);
8680 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8681 dest_word_len
, source_bytes
);
8682 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
8683 gfc_add_expr_to_block (&se
->post
, tmp
);
8686 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
8690 tmpdecl
= gfc_create_var (mold_type
, "transfer");
8692 ptr
= convert (build_pointer_type (mold_type
), source
);
8694 /* For CLASS results, allocate the needed memory first. */
8695 if (mold_expr
->ts
.type
== BT_CLASS
)
8698 cdata
= gfc_class_data_get (tmpdecl
);
8699 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
8700 gfc_add_modify (&se
->pre
, cdata
, tmp
);
8703 /* Use memcpy to do the transfer. */
8704 if (mold_expr
->ts
.type
== BT_CLASS
)
8705 tmp
= gfc_class_data_get (tmpdecl
);
8707 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
8709 tmp
= build_call_expr_loc (input_location
,
8710 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
8711 fold_convert (pvoid_type_node
, tmp
),
8712 fold_convert (pvoid_type_node
, ptr
),
8713 fold_convert (size_type_node
, extent
));
8714 gfc_add_expr_to_block (&se
->pre
, tmp
);
8716 /* For CLASS results, set the _vptr. */
8717 if (mold_expr
->ts
.type
== BT_CLASS
)
8721 vptr
= gfc_class_vptr_get (tmpdecl
);
8722 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
8724 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
8725 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
8733 /* Generate a call to caf_is_present. */
8736 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
8738 tree caf_reference
, caf_decl
, token
, image_index
;
8740 /* Compile the reference chain. */
8741 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
8742 gcc_assert (caf_reference
!= NULL_TREE
);
8744 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
8745 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8746 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8747 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
8748 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
8751 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
8752 3, token
, image_index
, caf_reference
);
8756 /* Test whether this ref-chain refs this image only. */
8759 caf_this_image_ref (gfc_ref
*ref
)
8761 for ( ; ref
; ref
= ref
->next
)
8762 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
8763 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
8769 /* Generate code for the ALLOCATED intrinsic.
8770 Generate inline code that directly check the address of the argument. */
8773 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
8777 bool coindexed_caf_comp
= false;
8778 gfc_expr
*e
= expr
->value
.function
.actual
->expr
;
8780 gfc_init_se (&arg1se
, NULL
);
8781 if (e
->ts
.type
== BT_CLASS
)
8783 /* Make sure that class array expressions have both a _data
8784 component reference and an array reference.... */
8785 if (CLASS_DATA (e
)->attr
.dimension
)
8786 gfc_add_class_array_ref (e
);
8787 /* .... whilst scalars only need the _data component. */
8789 gfc_add_data_component (e
);
8792 /* When 'e' references an allocatable component in a coarray, then call
8793 the caf-library function caf_is_present (). */
8794 if (flag_coarray
== GFC_FCOARRAY_LIB
&& e
->expr_type
== EXPR_FUNCTION
8795 && e
->value
.function
.isym
8796 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8798 e
= e
->value
.function
.actual
->expr
;
8799 if (gfc_expr_attr (e
).codimension
)
8801 /* Last partref is the coindexed coarray. As coarrays are collectively
8802 (de)allocated, the allocation status must be the same as the one of
8803 the local allocation. Convert to local access. */
8804 for (gfc_ref
*ref
= e
->ref
; ref
; ref
= ref
->next
)
8805 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
8807 for (int i
= ref
->u
.ar
.dimen
;
8808 i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; ++i
)
8809 ref
->u
.ar
.dimen_type
[i
] = DIMEN_THIS_IMAGE
;
8813 else if (!caf_this_image_ref (e
->ref
))
8814 coindexed_caf_comp
= true;
8816 if (coindexed_caf_comp
)
8817 tmp
= trans_caf_is_present (se
, e
);
8822 /* Allocatable scalar. */
8823 arg1se
.want_pointer
= 1;
8824 gfc_conv_expr (&arg1se
, e
);
8829 /* Allocatable array. */
8830 arg1se
.descriptor_only
= 1;
8831 gfc_conv_expr_descriptor (&arg1se
, e
);
8832 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8835 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
8836 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
8839 /* Components of pointer array references sometimes come back with a pre block. */
8840 if (arg1se
.pre
.head
)
8841 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8843 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
8847 /* Generate code for the ASSOCIATED intrinsic.
8848 If both POINTER and TARGET are arrays, generate a call to library function
8849 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
8850 In other cases, generate inline code that directly compare the address of
8851 POINTER with the address of TARGET. */
8854 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
8856 gfc_actual_arglist
*arg1
;
8857 gfc_actual_arglist
*arg2
;
8862 tree nonzero_arraylen
= NULL_TREE
;
8866 gfc_init_se (&arg1se
, NULL
);
8867 gfc_init_se (&arg2se
, NULL
);
8868 arg1
= expr
->value
.function
.actual
;
8871 /* Check whether the expression is a scalar or not; we cannot use
8872 arg1->expr->rank as it can be nonzero for proc pointers. */
8873 ss
= gfc_walk_expr (arg1
->expr
);
8874 scalar
= ss
== gfc_ss_terminator
;
8876 gfc_free_ss_chain (ss
);
8880 /* No optional target. */
8883 /* A pointer to a scalar. */
8884 arg1se
.want_pointer
= 1;
8885 gfc_conv_expr (&arg1se
, arg1
->expr
);
8886 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8887 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
8888 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
8890 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8892 tmp2
= gfc_class_data_get (arg1se
.expr
);
8893 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
8894 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
8901 /* A pointer to an array. */
8902 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8903 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8905 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8906 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8907 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
8908 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
8913 /* An optional target. */
8914 if (arg2
->expr
->ts
.type
== BT_CLASS
8915 && arg2
->expr
->expr_type
!= EXPR_FUNCTION
)
8916 gfc_add_data_component (arg2
->expr
);
8920 /* A pointer to a scalar. */
8921 arg1se
.want_pointer
= 1;
8922 gfc_conv_expr (&arg1se
, arg1
->expr
);
8923 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8924 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
8925 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
8927 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8928 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
8930 arg2se
.want_pointer
= 1;
8931 gfc_conv_expr (&arg2se
, arg2
->expr
);
8932 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8933 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
8934 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
8936 if (arg2
->expr
->ts
.type
== BT_CLASS
)
8938 arg2se
.expr
= gfc_evaluate_now (arg2se
.expr
, &arg2se
.pre
);
8939 arg2se
.expr
= gfc_class_data_get (arg2se
.expr
);
8941 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8942 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8943 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8944 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8945 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8946 arg1se
.expr
, arg2se
.expr
);
8947 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8948 arg1se
.expr
, null_pointer_node
);
8949 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8950 logical_type_node
, tmp
, tmp2
);
8954 /* An array pointer of zero length is not associated if target is
8956 arg1se
.descriptor_only
= 1;
8957 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
8958 if (arg1
->expr
->rank
== -1)
8960 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
8961 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8962 TREE_TYPE (tmp
), tmp
,
8963 build_int_cst (TREE_TYPE (tmp
), 1));
8966 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
8967 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
8968 if (arg2
->expr
->rank
!= 0)
8969 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
8970 logical_type_node
, tmp
,
8971 build_int_cst (TREE_TYPE (tmp
), 0));
8973 /* A pointer to an array, call library function _gfor_associated. */
8974 arg1se
.want_pointer
= 1;
8975 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8976 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8977 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8979 arg2se
.want_pointer
= 1;
8980 arg2se
.force_no_tmp
= 1;
8981 if (arg2
->expr
->rank
!= 0)
8982 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
8985 gfc_conv_expr (&arg2se
, arg2
->expr
);
8987 = gfc_conv_scalar_to_descriptor (&arg2se
, arg2se
.expr
,
8988 gfc_expr_attr (arg2
->expr
));
8989 arg2se
.expr
= gfc_build_addr_expr (NULL_TREE
, arg2se
.expr
);
8991 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8992 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8993 se
->expr
= build_call_expr_loc (input_location
,
8994 gfor_fndecl_associated
, 2,
8995 arg1se
.expr
, arg2se
.expr
);
8996 se
->expr
= convert (logical_type_node
, se
->expr
);
8997 if (arg2
->expr
->rank
!= 0)
8998 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8999 logical_type_node
, se
->expr
,
9003 /* If target is present zero character length pointers cannot
9005 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
9007 tmp
= arg1se
.string_length
;
9008 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9009 logical_type_node
, tmp
,
9010 build_zero_cst (TREE_TYPE (tmp
)));
9011 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9012 logical_type_node
, se
->expr
, tmp
);
9016 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9020 /* Generate code for the SAME_TYPE_AS intrinsic.
9021 Generate inline code that directly checks the vindices. */
9024 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
9029 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
9031 gfc_init_se (&se1
, NULL
);
9032 gfc_init_se (&se2
, NULL
);
9034 a
= expr
->value
.function
.actual
->expr
;
9035 b
= expr
->value
.function
.actual
->next
->expr
;
9037 bool unlimited_poly_a
= UNLIMITED_POLY (a
);
9038 bool unlimited_poly_b
= UNLIMITED_POLY (b
);
9039 if (unlimited_poly_a
)
9041 se1
.want_pointer
= 1;
9042 gfc_add_vptr_component (a
);
9044 else if (a
->ts
.type
== BT_CLASS
)
9046 gfc_add_vptr_component (a
);
9047 gfc_add_hash_component (a
);
9049 else if (a
->ts
.type
== BT_DERIVED
)
9050 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
9051 a
->ts
.u
.derived
->hash_value
);
9053 if (unlimited_poly_b
)
9055 se2
.want_pointer
= 1;
9056 gfc_add_vptr_component (b
);
9058 else if (b
->ts
.type
== BT_CLASS
)
9060 gfc_add_vptr_component (b
);
9061 gfc_add_hash_component (b
);
9063 else if (b
->ts
.type
== BT_DERIVED
)
9064 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
9065 b
->ts
.u
.derived
->hash_value
);
9067 gfc_conv_expr (&se1
, a
);
9068 gfc_conv_expr (&se2
, b
);
9070 if (unlimited_poly_a
)
9072 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9074 build_int_cst (TREE_TYPE (se1
.expr
), 0));
9075 se1
.expr
= gfc_vptr_hash_get (se1
.expr
);
9078 if (unlimited_poly_b
)
9080 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9082 build_int_cst (TREE_TYPE (se2
.expr
), 0));
9083 se2
.expr
= gfc_vptr_hash_get (se2
.expr
);
9086 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
9087 logical_type_node
, se1
.expr
,
9088 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
9091 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
9092 logical_type_node
, conda
, tmp
);
9095 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
9096 logical_type_node
, condb
, tmp
);
9098 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
9102 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9105 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
9109 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
9110 se
->expr
= build_call_expr_loc (input_location
,
9111 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
9112 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9116 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9119 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
9123 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
9125 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9126 type
= gfc_get_int_type (4);
9127 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
9129 /* Convert it to the required type. */
9130 type
= gfc_typenode_for_spec (&expr
->ts
);
9131 se
->expr
= build_call_expr_loc (input_location
,
9132 gfor_fndecl_si_kind
, 1, arg
);
9133 se
->expr
= fold_convert (type
, se
->expr
);
9137 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9140 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
9142 gfc_actual_arglist
*actual
;
9145 vec
<tree
, va_gc
> *args
= NULL
;
9147 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
9149 gfc_init_se (&argse
, se
);
9151 /* Pass a NULL pointer for an absent arg. */
9152 if (actual
->expr
== NULL
)
9153 argse
.expr
= null_pointer_node
;
9159 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
9161 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9162 ts
.type
= BT_INTEGER
;
9163 ts
.kind
= gfc_c_int_kind
;
9164 gfc_convert_type (actual
->expr
, &ts
, 2);
9166 gfc_conv_expr_reference (&argse
, actual
->expr
);
9169 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
9170 gfc_add_block_to_block (&se
->post
, &argse
.post
);
9171 vec_safe_push (args
, argse
.expr
);
9174 /* Convert it to the required type. */
9175 type
= gfc_typenode_for_spec (&expr
->ts
);
9176 se
->expr
= build_call_expr_loc_vec (input_location
,
9177 gfor_fndecl_sr_kind
, args
);
9178 se
->expr
= fold_convert (type
, se
->expr
);
9182 /* Generate code for TRIM (A) intrinsic function. */
9185 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
9195 unsigned int num_args
;
9197 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
9198 args
= XALLOCAVEC (tree
, num_args
);
9200 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
9201 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
9202 len
= gfc_create_var (gfc_charlen_type_node
, "len");
9204 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
9205 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
9208 if (expr
->ts
.kind
== 1)
9209 function
= gfor_fndecl_string_trim
;
9210 else if (expr
->ts
.kind
== 4)
9211 function
= gfor_fndecl_string_trim_char4
;
9215 fndecl
= build_addr (function
);
9216 tmp
= build_call_array_loc (input_location
,
9217 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
9219 gfc_add_expr_to_block (&se
->pre
, tmp
);
9221 /* Free the temporary afterwards, if necessary. */
9222 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
9223 len
, build_int_cst (TREE_TYPE (len
), 0));
9224 tmp
= gfc_call_free (var
);
9225 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
9226 gfc_add_expr_to_block (&se
->post
, tmp
);
9229 se
->string_length
= len
;
9233 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9236 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
9238 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
9239 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
9241 stmtblock_t block
, body
;
9244 /* We store in charsize the size of a character. */
9245 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
9246 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
9248 /* Get the arguments. */
9249 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
9250 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
9252 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
9253 ncopies_type
= TREE_TYPE (ncopies
);
9255 /* Check that NCOPIES is not negative. */
9256 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
9257 build_int_cst (ncopies_type
, 0));
9258 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
9259 "Argument NCOPIES of REPEAT intrinsic is negative "
9260 "(its value is %ld)",
9261 fold_convert (long_integer_type_node
, ncopies
));
9263 /* If the source length is zero, any non negative value of NCOPIES
9264 is valid, and nothing happens. */
9265 n
= gfc_create_var (ncopies_type
, "ncopies");
9266 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
9268 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
9269 build_int_cst (ncopies_type
, 0), ncopies
);
9270 gfc_add_modify (&se
->pre
, n
, tmp
);
9273 /* Check that ncopies is not too large: ncopies should be less than
9274 (or equal to) MAX / slen, where MAX is the maximal integer of
9275 the gfc_charlen_type_node type. If slen == 0, we need a special
9276 case to avoid the division by zero. */
9277 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
9278 fold_convert (sizetype
,
9279 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
9281 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
9282 ? sizetype
: ncopies_type
;
9283 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
9284 fold_convert (largest
, ncopies
),
9285 fold_convert (largest
, max
));
9286 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
9288 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
9289 logical_false_node
, cond
);
9290 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
9291 "Argument NCOPIES of REPEAT intrinsic is too large");
9293 /* Compute the destination length. */
9294 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
9295 fold_convert (gfc_charlen_type_node
, slen
),
9296 fold_convert (gfc_charlen_type_node
, ncopies
));
9297 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
9298 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
9300 /* Generate the code to do the repeat operation:
9301 for (i = 0; i < ncopies; i++)
9302 memmove (dest + (i * slen * size), src, slen*size); */
9303 gfc_start_block (&block
);
9304 count
= gfc_create_var (sizetype
, "count");
9305 gfc_add_modify (&block
, count
, size_zero_node
);
9306 exit_label
= gfc_build_label_decl (NULL_TREE
);
9308 /* Start the loop body. */
9309 gfc_start_block (&body
);
9311 /* Exit the loop if count >= ncopies. */
9312 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
9313 fold_convert (sizetype
, ncopies
));
9314 tmp
= build1_v (GOTO_EXPR
, exit_label
);
9315 TREE_USED (exit_label
) = 1;
9316 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
9317 build_empty_stmt (input_location
));
9318 gfc_add_expr_to_block (&body
, tmp
);
9320 /* Call memmove (dest + (i*slen*size), src, slen*size). */
9321 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
9323 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
9325 tmp
= fold_build_pointer_plus_loc (input_location
,
9326 fold_convert (pvoid_type_node
, dest
), tmp
);
9327 tmp
= build_call_expr_loc (input_location
,
9328 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
9330 fold_build2_loc (input_location
, MULT_EXPR
,
9331 size_type_node
, slen
, size
));
9332 gfc_add_expr_to_block (&body
, tmp
);
9334 /* Increment count. */
9335 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
9336 count
, size_one_node
);
9337 gfc_add_modify (&body
, count
, tmp
);
9339 /* Build the loop. */
9340 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
9341 gfc_add_expr_to_block (&block
, tmp
);
9343 /* Add the exit label. */
9344 tmp
= build1_v (LABEL_EXPR
, exit_label
);
9345 gfc_add_expr_to_block (&block
, tmp
);
9347 /* Finish the block. */
9348 tmp
= gfc_finish_block (&block
);
9349 gfc_add_expr_to_block (&se
->pre
, tmp
);
9351 /* Set the result value. */
9353 se
->string_length
= dlen
;
9357 /* Generate code for the IARGC intrinsic. */
9360 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
9366 /* Call the library function. This always returns an INTEGER(4). */
9367 fndecl
= gfor_fndecl_iargc
;
9368 tmp
= build_call_expr_loc (input_location
,
9371 /* Convert it to the required type. */
9372 type
= gfc_typenode_for_spec (&expr
->ts
);
9373 tmp
= fold_convert (type
, tmp
);
9379 /* Generate code for the KILL intrinsic. */
9382 conv_intrinsic_kill (gfc_se
*se
, gfc_expr
*expr
)
9385 tree int4_type_node
= gfc_get_int_type (4);
9389 unsigned int num_args
;
9391 num_args
= gfc_intrinsic_argument_list_length (expr
);
9392 args
= XALLOCAVEC (tree
, num_args
);
9393 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
9395 /* Convert PID to a INTEGER(4) entity. */
9396 pid
= convert (int4_type_node
, args
[0]);
9398 /* Convert SIG to a INTEGER(4) entity. */
9399 sig
= convert (int4_type_node
, args
[1]);
9401 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill
, 2, pid
, sig
);
9403 se
->expr
= fold_convert (TREE_TYPE (args
[0]), tmp
);
9408 conv_intrinsic_kill_sub (gfc_code
*code
)
9412 tree int4_type_node
= gfc_get_int_type (4);
9418 /* Make the function call. */
9419 gfc_init_block (&block
);
9420 gfc_init_se (&se
, NULL
);
9422 /* Convert PID to a INTEGER(4) entity. */
9423 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
9424 gfc_add_block_to_block (&block
, &se
.pre
);
9425 pid
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
9426 gfc_add_block_to_block (&block
, &se
.post
);
9428 /* Convert SIG to a INTEGER(4) entity. */
9429 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
9430 gfc_add_block_to_block (&block
, &se
.pre
);
9431 sig
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
9432 gfc_add_block_to_block (&block
, &se
.post
);
9434 /* Deal with an optional STATUS. */
9435 if (code
->ext
.actual
->next
->next
->expr
)
9437 gfc_init_se (&se_stat
, NULL
);
9438 gfc_conv_expr (&se_stat
, code
->ext
.actual
->next
->next
->expr
);
9439 statp
= gfc_create_var (gfc_get_int_type (4), "_statp");
9444 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill_sub
, 3, pid
, sig
,
9445 statp
? gfc_build_addr_expr (NULL_TREE
, statp
) : null_pointer_node
);
9447 gfc_add_expr_to_block (&block
, tmp
);
9449 if (statp
&& statp
!= se_stat
.expr
)
9450 gfc_add_modify (&block
, se_stat
.expr
,
9451 fold_convert (TREE_TYPE (se_stat
.expr
), statp
));
9453 return gfc_finish_block (&block
);
9458 /* The loc intrinsic returns the address of its argument as
9459 gfc_index_integer_kind integer. */
9462 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
9467 gcc_assert (!se
->ss
);
9469 arg_expr
= expr
->value
.function
.actual
->expr
;
9470 if (arg_expr
->rank
== 0)
9472 if (arg_expr
->ts
.type
== BT_CLASS
)
9473 gfc_add_data_component (arg_expr
);
9474 gfc_conv_expr_reference (se
, arg_expr
);
9477 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
9478 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
9480 /* Create a temporary variable for loc return value. Without this,
9481 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
9482 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
9483 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
9484 se
->expr
= temp_var
;
9488 /* The following routine generates code for the intrinsic
9489 functions from the ISO_C_BINDING module:
9495 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
9497 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
9499 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
9501 if (arg
->expr
->rank
== 0)
9502 gfc_conv_expr_reference (se
, arg
->expr
);
9503 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
9504 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
9507 gfc_conv_expr_descriptor (se
, arg
->expr
);
9508 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
9511 /* TODO -- the following two lines shouldn't be necessary, but if
9512 they're removed, a bug is exposed later in the code path.
9513 This workaround was thus introduced, but will have to be
9514 removed; please see PR 35150 for details about the issue. */
9515 se
->expr
= convert (pvoid_type_node
, se
->expr
);
9516 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
9518 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
9519 gfc_conv_expr_reference (se
, arg
->expr
);
9520 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
9525 /* Build the addr_expr for the first argument. The argument is
9526 already an *address* so we don't need to set want_pointer in
9528 gfc_init_se (&arg1se
, NULL
);
9529 gfc_conv_expr (&arg1se
, arg
->expr
);
9530 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
9531 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
9533 /* See if we were given two arguments. */
9534 if (arg
->next
->expr
== NULL
)
9535 /* Only given one arg so generate a null and do a
9536 not-equal comparison against the first arg. */
9537 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9539 fold_convert (TREE_TYPE (arg1se
.expr
),
9540 null_pointer_node
));
9546 /* Given two arguments so build the arg2se from second arg. */
9547 gfc_init_se (&arg2se
, NULL
);
9548 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
9549 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
9550 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
9552 /* Generate test to compare that the two args are equal. */
9553 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9554 arg1se
.expr
, arg2se
.expr
);
9555 /* Generate test to ensure that the first arg is not null. */
9556 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
9558 arg1se
.expr
, null_pointer_node
);
9560 /* Finally, the generated test must check that both arg1 is not
9561 NULL and that it is equal to the second arg. */
9562 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9564 not_null_expr
, eq_expr
);
9572 /* The following routine generates code for the intrinsic
9573 subroutines from the ISO_C_BINDING module:
9575 * C_F_PROCPOINTER. */
9578 conv_isocbinding_subroutine (gfc_code
*code
)
9585 tree desc
, dim
, tmp
, stride
, offset
;
9586 stmtblock_t body
, block
;
9588 gfc_actual_arglist
*arg
= code
->ext
.actual
;
9590 gfc_init_se (&se
, NULL
);
9591 gfc_init_se (&cptrse
, NULL
);
9592 gfc_conv_expr (&cptrse
, arg
->expr
);
9593 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
9594 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
9596 gfc_init_se (&fptrse
, NULL
);
9597 if (arg
->next
->expr
->rank
== 0)
9599 fptrse
.want_pointer
= 1;
9600 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
9601 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
9602 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
9603 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
9604 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
9605 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
9607 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9608 TREE_TYPE (fptrse
.expr
),
9610 fold_convert (TREE_TYPE (fptrse
.expr
),
9612 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
9613 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9614 return gfc_finish_block (&se
.pre
);
9617 gfc_start_block (&block
);
9619 /* Get the descriptor of the Fortran pointer. */
9620 fptrse
.descriptor_only
= 1;
9621 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
9622 gfc_add_block_to_block (&block
, &fptrse
.pre
);
9625 /* Set the span field. */
9626 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
9627 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9628 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
9630 /* Set data value, dtype, and offset. */
9631 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
9632 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
9633 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
9634 gfc_get_dtype (TREE_TYPE (desc
)));
9636 /* Start scalarization of the bounds, using the shape argument. */
9638 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
9639 gcc_assert (shape_ss
!= gfc_ss_terminator
);
9640 gfc_init_se (&shapese
, NULL
);
9642 gfc_init_loopinfo (&loop
);
9643 gfc_add_ss_to_loop (&loop
, shape_ss
);
9644 gfc_conv_ss_startstride (&loop
);
9645 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
9646 gfc_mark_ss_chain_used (shape_ss
, 1);
9648 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
9649 shapese
.ss
= shape_ss
;
9651 stride
= gfc_create_var (gfc_array_index_type
, "stride");
9652 offset
= gfc_create_var (gfc_array_index_type
, "offset");
9653 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
9654 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
9657 gfc_start_scalarized_body (&loop
, &body
);
9659 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
9660 loop
.loopvar
[0], loop
.from
[0]);
9662 /* Set bounds and stride. */
9663 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
9664 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
9666 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
9667 gfc_add_block_to_block (&body
, &shapese
.pre
);
9668 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
9669 gfc_add_block_to_block (&body
, &shapese
.post
);
9671 /* Calculate offset. */
9672 gfc_add_modify (&body
, offset
,
9673 fold_build2_loc (input_location
, PLUS_EXPR
,
9674 gfc_array_index_type
, offset
, stride
));
9675 /* Update stride. */
9676 gfc_add_modify (&body
, stride
,
9677 fold_build2_loc (input_location
, MULT_EXPR
,
9678 gfc_array_index_type
, stride
,
9679 fold_convert (gfc_array_index_type
,
9681 /* Finish scalarization loop. */
9682 gfc_trans_scalarizing_loops (&loop
, &body
);
9683 gfc_add_block_to_block (&block
, &loop
.pre
);
9684 gfc_add_block_to_block (&block
, &loop
.post
);
9685 gfc_add_block_to_block (&block
, &fptrse
.post
);
9686 gfc_cleanup_loop (&loop
);
9688 gfc_add_modify (&block
, offset
,
9689 fold_build1_loc (input_location
, NEGATE_EXPR
,
9690 gfc_array_index_type
, offset
));
9691 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
9693 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
9694 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9695 return gfc_finish_block (&se
.pre
);
9699 /* Save and restore floating-point state. */
9702 gfc_save_fp_state (stmtblock_t
*block
)
9704 tree type
, fpstate
, tmp
;
9706 type
= build_array_type (char_type_node
,
9707 build_range_type (size_type_node
, size_zero_node
,
9708 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
9709 fpstate
= gfc_create_var (type
, "fpstate");
9710 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
9712 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
9714 gfc_add_expr_to_block (block
, tmp
);
9721 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
9725 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
9727 gfc_add_expr_to_block (block
, tmp
);
9731 /* Generate code for arguments of IEEE functions. */
9734 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
9737 gfc_actual_arglist
*actual
;
9742 actual
= expr
->value
.function
.actual
;
9743 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
9745 gcc_assert (actual
);
9748 gfc_init_se (&argse
, se
);
9749 gfc_conv_expr_val (&argse
, e
);
9751 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
9752 gfc_add_block_to_block (&se
->post
, &argse
.post
);
9753 argarray
[arg
] = argse
.expr
;
9758 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
9759 and IEEE_UNORDERED, which translate directly to GCC type-generic
9763 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
9764 enum built_in_function code
, int nargs
)
9767 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
9769 conv_ieee_function_args (se
, expr
, args
, nargs
);
9770 se
->expr
= build_call_expr_loc_array (input_location
,
9771 builtin_decl_explicit (code
),
9773 STRIP_TYPE_NOPS (se
->expr
);
9774 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9778 /* Generate code for IEEE_IS_NORMAL intrinsic:
9779 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
9782 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
9784 tree arg
, isnormal
, iszero
;
9786 /* Convert arg, evaluate it only once. */
9787 conv_ieee_function_args (se
, expr
, &arg
, 1);
9788 arg
= gfc_evaluate_now (arg
, &se
->pre
);
9790 isnormal
= build_call_expr_loc (input_location
,
9791 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
9793 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
9794 build_real_from_int_cst (TREE_TYPE (arg
),
9795 integer_zero_node
));
9796 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9797 logical_type_node
, isnormal
, iszero
);
9798 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9802 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
9803 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
9806 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
9808 tree arg
, signbit
, isnan
;
9810 /* Convert arg, evaluate it only once. */
9811 conv_ieee_function_args (se
, expr
, &arg
, 1);
9812 arg
= gfc_evaluate_now (arg
, &se
->pre
);
9814 isnan
= build_call_expr_loc (input_location
,
9815 builtin_decl_explicit (BUILT_IN_ISNAN
),
9817 STRIP_TYPE_NOPS (isnan
);
9819 signbit
= build_call_expr_loc (input_location
,
9820 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
9822 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9823 signbit
, integer_zero_node
);
9825 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9826 logical_type_node
, signbit
,
9827 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
9828 TREE_TYPE(isnan
), isnan
));
9830 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9834 /* Generate code for IEEE_LOGB and IEEE_RINT. */
9837 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
9838 enum built_in_function code
)
9840 tree arg
, decl
, call
, fpstate
;
9843 conv_ieee_function_args (se
, expr
, &arg
, 1);
9844 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
9845 decl
= builtin_decl_for_precision (code
, argprec
);
9847 /* Save floating-point state. */
9848 fpstate
= gfc_save_fp_state (&se
->pre
);
9850 /* Make the function call. */
9851 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
9852 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
9854 /* Restore floating-point state. */
9855 gfc_restore_fp_state (&se
->post
, fpstate
);
9859 /* Generate code for IEEE_REM. */
9862 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
9864 tree args
[2], decl
, call
, fpstate
;
9867 conv_ieee_function_args (se
, expr
, args
, 2);
9869 /* If arguments have unequal size, convert them to the larger. */
9870 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
9871 > TYPE_PRECISION (TREE_TYPE (args
[1])))
9872 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
9873 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
9874 > TYPE_PRECISION (TREE_TYPE (args
[0])))
9875 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
9877 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9878 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
9880 /* Save floating-point state. */
9881 fpstate
= gfc_save_fp_state (&se
->pre
);
9883 /* Make the function call. */
9884 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9885 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9887 /* Restore floating-point state. */
9888 gfc_restore_fp_state (&se
->post
, fpstate
);
9892 /* Generate code for IEEE_NEXT_AFTER. */
9895 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
9897 tree args
[2], decl
, call
, fpstate
;
9900 conv_ieee_function_args (se
, expr
, args
, 2);
9902 /* Result has the characteristics of first argument. */
9903 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
9904 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9905 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
9907 /* Save floating-point state. */
9908 fpstate
= gfc_save_fp_state (&se
->pre
);
9910 /* Make the function call. */
9911 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9912 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9914 /* Restore floating-point state. */
9915 gfc_restore_fp_state (&se
->post
, fpstate
);
9919 /* Generate code for IEEE_SCALB. */
9922 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
9924 tree args
[2], decl
, call
, huge
, type
;
9927 conv_ieee_function_args (se
, expr
, args
, 2);
9929 /* Result has the characteristics of first argument. */
9930 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9931 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
9933 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
9935 /* We need to fold the integer into the range of a C int. */
9936 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
9937 type
= TREE_TYPE (args
[1]);
9939 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
9940 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
9942 huge
= fold_convert (type
, huge
);
9943 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
9945 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
9946 fold_build1_loc (input_location
, NEGATE_EXPR
,
9950 args
[1] = fold_convert (integer_type_node
, args
[1]);
9952 /* Make the function call. */
9953 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9954 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9958 /* Generate code for IEEE_COPY_SIGN. */
9961 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
9963 tree args
[2], decl
, sign
;
9966 conv_ieee_function_args (se
, expr
, args
, 2);
9968 /* Get the sign of the second argument. */
9969 sign
= build_call_expr_loc (input_location
,
9970 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
9972 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9973 sign
, integer_zero_node
);
9975 /* Create a value of one, with the right sign. */
9976 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
9978 fold_build1_loc (input_location
, NEGATE_EXPR
,
9982 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
9984 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9985 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
9987 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9991 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
9995 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
9997 const char *name
= expr
->value
.function
.name
;
9999 if (startswith (name
, "_gfortran_ieee_is_nan"))
10000 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
10001 else if (startswith (name
, "_gfortran_ieee_is_finite"))
10002 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
10003 else if (startswith (name
, "_gfortran_ieee_unordered"))
10004 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
10005 else if (startswith (name
, "_gfortran_ieee_is_normal"))
10006 conv_intrinsic_ieee_is_normal (se
, expr
);
10007 else if (startswith (name
, "_gfortran_ieee_is_negative"))
10008 conv_intrinsic_ieee_is_negative (se
, expr
);
10009 else if (startswith (name
, "_gfortran_ieee_copy_sign"))
10010 conv_intrinsic_ieee_copy_sign (se
, expr
);
10011 else if (startswith (name
, "_gfortran_ieee_scalb"))
10012 conv_intrinsic_ieee_scalb (se
, expr
);
10013 else if (startswith (name
, "_gfortran_ieee_next_after"))
10014 conv_intrinsic_ieee_next_after (se
, expr
);
10015 else if (startswith (name
, "_gfortran_ieee_rem"))
10016 conv_intrinsic_ieee_rem (se
, expr
);
10017 else if (startswith (name
, "_gfortran_ieee_logb"))
10018 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
10019 else if (startswith (name
, "_gfortran_ieee_rint"))
10020 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
10022 /* It is not among the functions we translate directly. We return
10023 false, so a library function call is emitted. */
10030 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
10033 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
10035 tree arg
, res
, restype
;
10037 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
10038 arg
= fold_convert (size_type_node
, arg
);
10039 res
= build_call_expr_loc (input_location
,
10040 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
10041 restype
= gfc_typenode_for_spec (&expr
->ts
);
10042 se
->expr
= fold_convert (restype
, res
);
10046 /* Generate code for an intrinsic function. Some map directly to library
10047 calls, others get special handling. In some cases the name of the function
10048 used depends on the type specifiers. */
10051 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
10057 name
= &expr
->value
.function
.name
[2];
10059 if (expr
->rank
> 0)
10061 lib
= gfc_is_intrinsic_libcall (expr
);
10065 se
->ignore_optional
= 1;
10067 switch (expr
->value
.function
.isym
->id
)
10069 case GFC_ISYM_EOSHIFT
:
10070 case GFC_ISYM_PACK
:
10071 case GFC_ISYM_RESHAPE
:
10072 /* For all of those the first argument specifies the type and the
10073 third is optional. */
10074 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
10077 case GFC_ISYM_FINDLOC
:
10078 gfc_conv_intrinsic_findloc (se
, expr
);
10081 case GFC_ISYM_MINLOC
:
10082 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
10085 case GFC_ISYM_MAXLOC
:
10086 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
10090 gfc_conv_intrinsic_funcall (se
, expr
);
10098 switch (expr
->value
.function
.isym
->id
)
10100 case GFC_ISYM_NONE
:
10101 gcc_unreachable ();
10103 case GFC_ISYM_REPEAT
:
10104 gfc_conv_intrinsic_repeat (se
, expr
);
10107 case GFC_ISYM_TRIM
:
10108 gfc_conv_intrinsic_trim (se
, expr
);
10111 case GFC_ISYM_SC_KIND
:
10112 gfc_conv_intrinsic_sc_kind (se
, expr
);
10115 case GFC_ISYM_SI_KIND
:
10116 gfc_conv_intrinsic_si_kind (se
, expr
);
10119 case GFC_ISYM_SR_KIND
:
10120 gfc_conv_intrinsic_sr_kind (se
, expr
);
10123 case GFC_ISYM_EXPONENT
:
10124 gfc_conv_intrinsic_exponent (se
, expr
);
10127 case GFC_ISYM_SCAN
:
10128 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10130 fndecl
= gfor_fndecl_string_scan
;
10131 else if (kind
== 4)
10132 fndecl
= gfor_fndecl_string_scan_char4
;
10134 gcc_unreachable ();
10136 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10139 case GFC_ISYM_VERIFY
:
10140 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10142 fndecl
= gfor_fndecl_string_verify
;
10143 else if (kind
== 4)
10144 fndecl
= gfor_fndecl_string_verify_char4
;
10146 gcc_unreachable ();
10148 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10151 case GFC_ISYM_ALLOCATED
:
10152 gfc_conv_allocated (se
, expr
);
10155 case GFC_ISYM_ASSOCIATED
:
10156 gfc_conv_associated(se
, expr
);
10159 case GFC_ISYM_SAME_TYPE_AS
:
10160 gfc_conv_same_type_as (se
, expr
);
10164 gfc_conv_intrinsic_abs (se
, expr
);
10167 case GFC_ISYM_ADJUSTL
:
10168 if (expr
->ts
.kind
== 1)
10169 fndecl
= gfor_fndecl_adjustl
;
10170 else if (expr
->ts
.kind
== 4)
10171 fndecl
= gfor_fndecl_adjustl_char4
;
10173 gcc_unreachable ();
10175 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
10178 case GFC_ISYM_ADJUSTR
:
10179 if (expr
->ts
.kind
== 1)
10180 fndecl
= gfor_fndecl_adjustr
;
10181 else if (expr
->ts
.kind
== 4)
10182 fndecl
= gfor_fndecl_adjustr_char4
;
10184 gcc_unreachable ();
10186 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
10189 case GFC_ISYM_AIMAG
:
10190 gfc_conv_intrinsic_imagpart (se
, expr
);
10193 case GFC_ISYM_AINT
:
10194 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
10198 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
10201 case GFC_ISYM_ANINT
:
10202 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
10206 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
10210 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
10213 case GFC_ISYM_ACOSD
:
10214 case GFC_ISYM_ASIND
:
10215 case GFC_ISYM_ATAND
:
10216 gfc_conv_intrinsic_atrigd (se
, expr
, expr
->value
.function
.isym
->id
);
10219 case GFC_ISYM_COTAN
:
10220 gfc_conv_intrinsic_cotan (se
, expr
);
10223 case GFC_ISYM_COTAND
:
10224 gfc_conv_intrinsic_cotand (se
, expr
);
10227 case GFC_ISYM_ATAN2D
:
10228 gfc_conv_intrinsic_atan2d (se
, expr
);
10231 case GFC_ISYM_BTEST
:
10232 gfc_conv_intrinsic_btest (se
, expr
);
10236 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
10240 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
10244 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
10248 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
10251 case GFC_ISYM_C_ASSOCIATED
:
10252 case GFC_ISYM_C_FUNLOC
:
10253 case GFC_ISYM_C_LOC
:
10254 conv_isocbinding_function (se
, expr
);
10257 case GFC_ISYM_ACHAR
:
10258 case GFC_ISYM_CHAR
:
10259 gfc_conv_intrinsic_char (se
, expr
);
10262 case GFC_ISYM_CONVERSION
:
10263 case GFC_ISYM_DBLE
:
10264 case GFC_ISYM_DFLOAT
:
10265 case GFC_ISYM_FLOAT
:
10266 case GFC_ISYM_LOGICAL
:
10267 case GFC_ISYM_REAL
:
10268 case GFC_ISYM_REALPART
:
10269 case GFC_ISYM_SNGL
:
10270 gfc_conv_intrinsic_conversion (se
, expr
);
10273 /* Integer conversions are handled separately to make sure we get the
10274 correct rounding mode. */
10276 case GFC_ISYM_INT2
:
10277 case GFC_ISYM_INT8
:
10278 case GFC_ISYM_LONG
:
10279 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
10282 case GFC_ISYM_NINT
:
10283 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
10286 case GFC_ISYM_CEILING
:
10287 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
10290 case GFC_ISYM_FLOOR
:
10291 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
10295 gfc_conv_intrinsic_mod (se
, expr
, 0);
10298 case GFC_ISYM_MODULO
:
10299 gfc_conv_intrinsic_mod (se
, expr
, 1);
10302 case GFC_ISYM_CAF_GET
:
10303 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10307 case GFC_ISYM_CMPLX
:
10308 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
10311 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
10312 gfc_conv_intrinsic_iargc (se
, expr
);
10315 case GFC_ISYM_COMPLEX
:
10316 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
10319 case GFC_ISYM_CONJG
:
10320 gfc_conv_intrinsic_conjg (se
, expr
);
10323 case GFC_ISYM_COUNT
:
10324 gfc_conv_intrinsic_count (se
, expr
);
10327 case GFC_ISYM_CTIME
:
10328 gfc_conv_intrinsic_ctime (se
, expr
);
10332 gfc_conv_intrinsic_dim (se
, expr
);
10335 case GFC_ISYM_DOT_PRODUCT
:
10336 gfc_conv_intrinsic_dot_product (se
, expr
);
10339 case GFC_ISYM_DPROD
:
10340 gfc_conv_intrinsic_dprod (se
, expr
);
10343 case GFC_ISYM_DSHIFTL
:
10344 gfc_conv_intrinsic_dshift (se
, expr
, true);
10347 case GFC_ISYM_DSHIFTR
:
10348 gfc_conv_intrinsic_dshift (se
, expr
, false);
10351 case GFC_ISYM_FDATE
:
10352 gfc_conv_intrinsic_fdate (se
, expr
);
10355 case GFC_ISYM_FRACTION
:
10356 gfc_conv_intrinsic_fraction (se
, expr
);
10359 case GFC_ISYM_IALL
:
10360 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
10363 case GFC_ISYM_IAND
:
10364 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
10367 case GFC_ISYM_IANY
:
10368 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
10371 case GFC_ISYM_IBCLR
:
10372 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
10375 case GFC_ISYM_IBITS
:
10376 gfc_conv_intrinsic_ibits (se
, expr
);
10379 case GFC_ISYM_IBSET
:
10380 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
10383 case GFC_ISYM_IACHAR
:
10384 case GFC_ISYM_ICHAR
:
10385 /* We assume ASCII character sequence. */
10386 gfc_conv_intrinsic_ichar (se
, expr
);
10389 case GFC_ISYM_IARGC
:
10390 gfc_conv_intrinsic_iargc (se
, expr
);
10393 case GFC_ISYM_IEOR
:
10394 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
10397 case GFC_ISYM_INDEX
:
10398 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10400 fndecl
= gfor_fndecl_string_index
;
10401 else if (kind
== 4)
10402 fndecl
= gfor_fndecl_string_index_char4
;
10404 gcc_unreachable ();
10406 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10410 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
10413 case GFC_ISYM_IPARITY
:
10414 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
10417 case GFC_ISYM_IS_IOSTAT_END
:
10418 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
10421 case GFC_ISYM_IS_IOSTAT_EOR
:
10422 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
10425 case GFC_ISYM_IS_CONTIGUOUS
:
10426 gfc_conv_intrinsic_is_contiguous (se
, expr
);
10429 case GFC_ISYM_ISNAN
:
10430 gfc_conv_intrinsic_isnan (se
, expr
);
10433 case GFC_ISYM_KILL
:
10434 conv_intrinsic_kill (se
, expr
);
10437 case GFC_ISYM_LSHIFT
:
10438 gfc_conv_intrinsic_shift (se
, expr
, false, false);
10441 case GFC_ISYM_RSHIFT
:
10442 gfc_conv_intrinsic_shift (se
, expr
, true, true);
10445 case GFC_ISYM_SHIFTA
:
10446 gfc_conv_intrinsic_shift (se
, expr
, true, true);
10449 case GFC_ISYM_SHIFTL
:
10450 gfc_conv_intrinsic_shift (se
, expr
, false, false);
10453 case GFC_ISYM_SHIFTR
:
10454 gfc_conv_intrinsic_shift (se
, expr
, true, false);
10457 case GFC_ISYM_ISHFT
:
10458 gfc_conv_intrinsic_ishft (se
, expr
);
10461 case GFC_ISYM_ISHFTC
:
10462 gfc_conv_intrinsic_ishftc (se
, expr
);
10465 case GFC_ISYM_LEADZ
:
10466 gfc_conv_intrinsic_leadz (se
, expr
);
10469 case GFC_ISYM_TRAILZ
:
10470 gfc_conv_intrinsic_trailz (se
, expr
);
10473 case GFC_ISYM_POPCNT
:
10474 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
10477 case GFC_ISYM_POPPAR
:
10478 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
10481 case GFC_ISYM_LBOUND
:
10482 gfc_conv_intrinsic_bound (se
, expr
, GFC_ISYM_LBOUND
);
10485 case GFC_ISYM_LCOBOUND
:
10486 conv_intrinsic_cobound (se
, expr
);
10489 case GFC_ISYM_TRANSPOSE
:
10490 /* The scalarizer has already been set up for reversed dimension access
10491 order ; now we just get the argument value normally. */
10492 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
10496 gfc_conv_intrinsic_len (se
, expr
);
10499 case GFC_ISYM_LEN_TRIM
:
10500 gfc_conv_intrinsic_len_trim (se
, expr
);
10504 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
10508 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
10512 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
10516 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
10519 case GFC_ISYM_MALLOC
:
10520 gfc_conv_intrinsic_malloc (se
, expr
);
10523 case GFC_ISYM_MASKL
:
10524 gfc_conv_intrinsic_mask (se
, expr
, 1);
10527 case GFC_ISYM_MASKR
:
10528 gfc_conv_intrinsic_mask (se
, expr
, 0);
10532 if (expr
->ts
.type
== BT_CHARACTER
)
10533 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
10535 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
10538 case GFC_ISYM_MAXLOC
:
10539 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
10542 case GFC_ISYM_FINDLOC
:
10543 gfc_conv_intrinsic_findloc (se
, expr
);
10546 case GFC_ISYM_MAXVAL
:
10547 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
10550 case GFC_ISYM_MERGE
:
10551 gfc_conv_intrinsic_merge (se
, expr
);
10554 case GFC_ISYM_MERGE_BITS
:
10555 gfc_conv_intrinsic_merge_bits (se
, expr
);
10559 if (expr
->ts
.type
== BT_CHARACTER
)
10560 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
10562 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
10565 case GFC_ISYM_MINLOC
:
10566 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
10569 case GFC_ISYM_MINVAL
:
10570 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
10573 case GFC_ISYM_NEAREST
:
10574 gfc_conv_intrinsic_nearest (se
, expr
);
10577 case GFC_ISYM_NORM2
:
10578 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
10582 gfc_conv_intrinsic_not (se
, expr
);
10586 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
10589 case GFC_ISYM_PARITY
:
10590 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
10593 case GFC_ISYM_PRESENT
:
10594 gfc_conv_intrinsic_present (se
, expr
);
10597 case GFC_ISYM_PRODUCT
:
10598 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
10601 case GFC_ISYM_RANK
:
10602 gfc_conv_intrinsic_rank (se
, expr
);
10605 case GFC_ISYM_RRSPACING
:
10606 gfc_conv_intrinsic_rrspacing (se
, expr
);
10609 case GFC_ISYM_SET_EXPONENT
:
10610 gfc_conv_intrinsic_set_exponent (se
, expr
);
10613 case GFC_ISYM_SCALE
:
10614 gfc_conv_intrinsic_scale (se
, expr
);
10617 case GFC_ISYM_SHAPE
:
10618 gfc_conv_intrinsic_bound (se
, expr
, GFC_ISYM_SHAPE
);
10621 case GFC_ISYM_SIGN
:
10622 gfc_conv_intrinsic_sign (se
, expr
);
10625 case GFC_ISYM_SIZE
:
10626 gfc_conv_intrinsic_size (se
, expr
);
10629 case GFC_ISYM_SIZEOF
:
10630 case GFC_ISYM_C_SIZEOF
:
10631 gfc_conv_intrinsic_sizeof (se
, expr
);
10634 case GFC_ISYM_STORAGE_SIZE
:
10635 gfc_conv_intrinsic_storage_size (se
, expr
);
10638 case GFC_ISYM_SPACING
:
10639 gfc_conv_intrinsic_spacing (se
, expr
);
10642 case GFC_ISYM_STRIDE
:
10643 conv_intrinsic_stride (se
, expr
);
10647 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
10650 case GFC_ISYM_TEAM_NUMBER
:
10651 conv_intrinsic_team_number (se
, expr
);
10654 case GFC_ISYM_TRANSFER
:
10655 if (se
->ss
&& se
->ss
->info
->useflags
)
10656 /* Access the previously obtained result. */
10657 gfc_conv_tmp_array_ref (se
);
10659 gfc_conv_intrinsic_transfer (se
, expr
);
10662 case GFC_ISYM_TTYNAM
:
10663 gfc_conv_intrinsic_ttynam (se
, expr
);
10666 case GFC_ISYM_UBOUND
:
10667 gfc_conv_intrinsic_bound (se
, expr
, GFC_ISYM_UBOUND
);
10670 case GFC_ISYM_UCOBOUND
:
10671 conv_intrinsic_cobound (se
, expr
);
10675 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
10679 gfc_conv_intrinsic_loc (se
, expr
);
10682 case GFC_ISYM_THIS_IMAGE
:
10683 /* For num_images() == 1, handle as LCOBOUND. */
10684 if (expr
->value
.function
.actual
->expr
10685 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
10686 conv_intrinsic_cobound (se
, expr
);
10688 trans_this_image (se
, expr
);
10691 case GFC_ISYM_IMAGE_INDEX
:
10692 trans_image_index (se
, expr
);
10695 case GFC_ISYM_IMAGE_STATUS
:
10696 conv_intrinsic_image_status (se
, expr
);
10699 case GFC_ISYM_NUM_IMAGES
:
10700 trans_num_images (se
, expr
);
10703 case GFC_ISYM_ACCESS
:
10704 case GFC_ISYM_CHDIR
:
10705 case GFC_ISYM_CHMOD
:
10706 case GFC_ISYM_DTIME
:
10707 case GFC_ISYM_ETIME
:
10708 case GFC_ISYM_EXTENDS_TYPE_OF
:
10709 case GFC_ISYM_FGET
:
10710 case GFC_ISYM_FGETC
:
10711 case GFC_ISYM_FNUM
:
10712 case GFC_ISYM_FPUT
:
10713 case GFC_ISYM_FPUTC
:
10714 case GFC_ISYM_FSTAT
:
10715 case GFC_ISYM_FTELL
:
10716 case GFC_ISYM_GETCWD
:
10717 case GFC_ISYM_GETGID
:
10718 case GFC_ISYM_GETPID
:
10719 case GFC_ISYM_GETUID
:
10720 case GFC_ISYM_HOSTNM
:
10721 case GFC_ISYM_IERRNO
:
10722 case GFC_ISYM_IRAND
:
10723 case GFC_ISYM_ISATTY
:
10725 case GFC_ISYM_LINK
:
10726 case GFC_ISYM_LSTAT
:
10727 case GFC_ISYM_MATMUL
:
10728 case GFC_ISYM_MCLOCK
:
10729 case GFC_ISYM_MCLOCK8
:
10730 case GFC_ISYM_RAND
:
10731 case GFC_ISYM_RENAME
:
10732 case GFC_ISYM_SECOND
:
10733 case GFC_ISYM_SECNDS
:
10734 case GFC_ISYM_SIGNAL
:
10735 case GFC_ISYM_STAT
:
10736 case GFC_ISYM_SYMLNK
:
10737 case GFC_ISYM_SYSTEM
:
10738 case GFC_ISYM_TIME
:
10739 case GFC_ISYM_TIME8
:
10740 case GFC_ISYM_UMASK
:
10741 case GFC_ISYM_UNLINK
:
10743 gfc_conv_intrinsic_funcall (se
, expr
);
10746 case GFC_ISYM_EOSHIFT
:
10747 case GFC_ISYM_PACK
:
10748 case GFC_ISYM_RESHAPE
:
10749 /* For those, expr->rank should always be >0 and thus the if above the
10750 switch should have matched. */
10751 gcc_unreachable ();
10755 gfc_conv_intrinsic_lib_function (se
, expr
);
10762 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
10764 gfc_ss
*arg_ss
, *tmp_ss
;
10765 gfc_actual_arglist
*arg
;
10767 arg
= expr
->value
.function
.actual
;
10769 gcc_assert (arg
->expr
);
10771 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
10772 gcc_assert (arg_ss
!= gfc_ss_terminator
);
10774 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
10776 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
10777 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
10779 gcc_assert (tmp_ss
->dimen
== 2);
10781 /* We just invert dimensions. */
10782 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
10785 /* Stop when tmp_ss points to the last valid element of the chain... */
10786 if (tmp_ss
->next
== gfc_ss_terminator
)
10790 /* ... so that we can attach the rest of the chain to it. */
10797 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
10798 This has the side effect of reversing the nested list, so there is no
10799 need to call gfc_reverse_ss on it (the given list is assumed not to be
10803 nest_loop_dimension (gfc_ss
*ss
, int dim
)
10806 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
10807 gfc_loopinfo
*new_loop
;
10809 gcc_assert (ss
!= gfc_ss_terminator
);
10811 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
10813 new_ss
= gfc_get_ss ();
10814 new_ss
->next
= prev_ss
;
10815 new_ss
->parent
= ss
;
10816 new_ss
->info
= ss
->info
;
10817 new_ss
->info
->refcount
++;
10818 if (ss
->dimen
!= 0)
10820 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
10821 && ss
->info
->type
!= GFC_SS_REFERENCE
);
10824 new_ss
->dim
[0] = ss
->dim
[dim
];
10826 gcc_assert (dim
< ss
->dimen
);
10828 ss_dim
= --ss
->dimen
;
10829 for (i
= dim
; i
< ss_dim
; i
++)
10830 ss
->dim
[i
] = ss
->dim
[i
+ 1];
10832 ss
->dim
[ss_dim
] = 0;
10838 ss
->nested_ss
->parent
= new_ss
;
10839 new_ss
->nested_ss
= ss
->nested_ss
;
10841 ss
->nested_ss
= new_ss
;
10844 new_loop
= gfc_get_loopinfo ();
10845 gfc_init_loopinfo (new_loop
);
10847 gcc_assert (prev_ss
!= NULL
);
10848 gcc_assert (prev_ss
!= gfc_ss_terminator
);
10849 gfc_add_ss_to_loop (new_loop
, prev_ss
);
10850 return new_ss
->parent
;
10854 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
10855 is to be inlined. */
10858 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
10860 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
10861 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
10863 bool scalar_mask
= false;
10865 /* The rank of the result will be determined later. */
10866 arg1
= expr
->value
.function
.actual
;
10869 gcc_assert (arg3
!= NULL
);
10871 if (expr
->rank
== 0)
10874 tmp_ss
= gfc_ss_terminator
;
10880 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
10881 if (mask_ss
== tmp_ss
)
10887 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
10888 gcc_assert (array_ss
!= tmp_ss
);
10890 /* Odd thing: If the mask is scalar, it is used by the frontend after
10891 the array (to make an if around the nested loop). Thus it shall
10892 be after array_ss once the gfc_ss list is reversed. */
10894 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
10898 /* "Hide" the dimension on which we will sum in the first arg's scalarization
10900 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
10901 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
10909 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
10912 switch (expr
->value
.function
.isym
->id
)
10914 case GFC_ISYM_PRODUCT
:
10916 return walk_inline_intrinsic_arith (ss
, expr
);
10918 case GFC_ISYM_TRANSPOSE
:
10919 return walk_inline_intrinsic_transpose (ss
, expr
);
10922 gcc_unreachable ();
10924 gcc_unreachable ();
10928 /* This generates code to execute before entering the scalarization loop.
10929 Currently does nothing. */
10932 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
10934 switch (ss
->info
->expr
->value
.function
.isym
->id
)
10936 case GFC_ISYM_UBOUND
:
10937 case GFC_ISYM_LBOUND
:
10938 case GFC_ISYM_UCOBOUND
:
10939 case GFC_ISYM_LCOBOUND
:
10940 case GFC_ISYM_THIS_IMAGE
:
10941 case GFC_ISYM_SHAPE
:
10945 gcc_unreachable ();
10950 /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
10951 one parameter are expanded into code inside the scalarization loop. */
10954 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
10956 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
10957 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
10959 /* The two argument version returns a scalar. */
10960 if (expr
->value
.function
.isym
->id
!= GFC_ISYM_SHAPE
10961 && expr
->value
.function
.actual
->next
->expr
)
10964 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
10968 /* Walk an intrinsic array libcall. */
10971 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
10973 gcc_assert (expr
->rank
> 0);
10974 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10978 /* Return whether the function call expression EXPR will be expanded
10979 inline by gfc_conv_intrinsic_function. */
10982 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
10984 gfc_actual_arglist
*args
, *dim_arg
, *mask_arg
;
10985 gfc_expr
*maskexpr
;
10987 if (!expr
->value
.function
.isym
)
10990 switch (expr
->value
.function
.isym
->id
)
10992 case GFC_ISYM_PRODUCT
:
10994 /* Disable inline expansion if code size matters. */
10998 args
= expr
->value
.function
.actual
;
10999 dim_arg
= args
->next
;
11001 /* We need to be able to subset the SUM argument at compile-time. */
11002 if (dim_arg
->expr
&& dim_arg
->expr
->expr_type
!= EXPR_CONSTANT
)
11005 /* FIXME: If MASK is optional for a more than two-dimensional
11006 argument, the scalarizer gets confused if the mask is
11007 absent. See PR 82995. For now, fall back to the library
11010 mask_arg
= dim_arg
->next
;
11011 maskexpr
= mask_arg
->expr
;
11013 if (expr
->rank
> 0 && maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
11014 && maskexpr
->symtree
->n
.sym
->attr
.dummy
11015 && maskexpr
->symtree
->n
.sym
->attr
.optional
)
11020 case GFC_ISYM_TRANSPOSE
:
11029 /* Returns nonzero if the specified intrinsic function call maps directly to
11030 an external library call. Should only be used for functions that return
11034 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
11036 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
11037 gcc_assert (expr
->rank
> 0);
11039 if (gfc_inline_intrinsic_function_p (expr
))
11042 switch (expr
->value
.function
.isym
->id
)
11046 case GFC_ISYM_COUNT
:
11047 case GFC_ISYM_FINDLOC
:
11049 case GFC_ISYM_IANY
:
11050 case GFC_ISYM_IALL
:
11051 case GFC_ISYM_IPARITY
:
11052 case GFC_ISYM_MATMUL
:
11053 case GFC_ISYM_MAXLOC
:
11054 case GFC_ISYM_MAXVAL
:
11055 case GFC_ISYM_MINLOC
:
11056 case GFC_ISYM_MINVAL
:
11057 case GFC_ISYM_NORM2
:
11058 case GFC_ISYM_PARITY
:
11059 case GFC_ISYM_PRODUCT
:
11061 case GFC_ISYM_SPREAD
:
11063 /* Ignore absent optional parameters. */
11066 case GFC_ISYM_CSHIFT
:
11067 case GFC_ISYM_EOSHIFT
:
11068 case GFC_ISYM_GET_TEAM
:
11069 case GFC_ISYM_FAILED_IMAGES
:
11070 case GFC_ISYM_STOPPED_IMAGES
:
11071 case GFC_ISYM_PACK
:
11072 case GFC_ISYM_RESHAPE
:
11073 case GFC_ISYM_UNPACK
:
11074 /* Pass absent optional parameters. */
11082 /* Walk an intrinsic function. */
11084 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
11085 gfc_intrinsic_sym
* isym
)
11089 if (isym
->elemental
)
11090 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
11091 expr
->value
.function
.isym
,
11094 if (expr
->rank
== 0)
11097 if (gfc_inline_intrinsic_function_p (expr
))
11098 return walk_inline_intrinsic_function (ss
, expr
);
11100 if (gfc_is_intrinsic_libcall (expr
))
11101 return gfc_walk_intrinsic_libfunc (ss
, expr
);
11103 /* Special cases. */
11106 case GFC_ISYM_LBOUND
:
11107 case GFC_ISYM_LCOBOUND
:
11108 case GFC_ISYM_UBOUND
:
11109 case GFC_ISYM_UCOBOUND
:
11110 case GFC_ISYM_THIS_IMAGE
:
11111 case GFC_ISYM_SHAPE
:
11112 return gfc_walk_intrinsic_bound (ss
, expr
);
11114 case GFC_ISYM_TRANSFER
:
11115 case GFC_ISYM_CAF_GET
:
11116 return gfc_walk_intrinsic_libfunc (ss
, expr
);
11119 /* This probably meant someone forgot to add an intrinsic to the above
11120 list(s) when they implemented it, or something's gone horribly
11122 gcc_unreachable ();
11127 conv_co_collective (gfc_code
*code
)
11130 stmtblock_t block
, post_block
;
11131 tree fndecl
, array
= NULL_TREE
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
11132 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
11134 gfc_start_block (&block
);
11135 gfc_init_block (&post_block
);
11137 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
11139 opr_expr
= code
->ext
.actual
->next
->expr
;
11140 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
11141 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11142 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
11147 image_idx_expr
= code
->ext
.actual
->next
->expr
;
11148 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
11149 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11155 gfc_init_se (&argse
, NULL
);
11156 gfc_conv_expr (&argse
, stat_expr
);
11157 gfc_add_block_to_block (&block
, &argse
.pre
);
11158 gfc_add_block_to_block (&post_block
, &argse
.post
);
11160 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
11161 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
11163 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
11166 stat
= null_pointer_node
;
11168 /* Early exit for GFC_FCOARRAY_SINGLE. */
11169 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
11171 if (stat
!= NULL_TREE
)
11173 /* For optional stats, check the pointer is valid before zero'ing. */
11174 if (gfc_expr_attr (stat_expr
).optional
)
11177 stmtblock_t ass_block
;
11178 gfc_start_block (&ass_block
);
11179 gfc_add_modify (&ass_block
, stat
,
11180 fold_convert (TREE_TYPE (stat
),
11181 integer_zero_node
));
11182 tmp
= fold_build2 (NE_EXPR
, logical_type_node
,
11183 gfc_build_addr_expr (NULL_TREE
, stat
),
11184 null_pointer_node
);
11185 tmp
= fold_build3 (COND_EXPR
, void_type_node
, tmp
,
11186 gfc_finish_block (&ass_block
),
11187 build_empty_stmt (input_location
));
11188 gfc_add_expr_to_block (&block
, tmp
);
11191 gfc_add_modify (&block
, stat
,
11192 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
11194 return gfc_finish_block (&block
);
11197 /* Handle the array. */
11198 gfc_init_se (&argse
, NULL
);
11199 if (code
->ext
.actual
->expr
->rank
== 0)
11201 symbol_attribute attr
;
11202 gfc_clear_attr (&attr
);
11203 gfc_init_se (&argse
, NULL
);
11204 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
11205 gfc_add_block_to_block (&block
, &argse
.pre
);
11206 gfc_add_block_to_block (&post_block
, &argse
.post
);
11207 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
11208 array
= gfc_build_addr_expr (NULL_TREE
, array
);
11212 argse
.want_pointer
= 1;
11213 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
11214 array
= argse
.expr
;
11217 gfc_add_block_to_block (&block
, &argse
.pre
);
11218 gfc_add_block_to_block (&post_block
, &argse
.post
);
11220 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
11221 strlen
= argse
.string_length
;
11223 strlen
= integer_zero_node
;
11226 if (image_idx_expr
)
11228 gfc_init_se (&argse
, NULL
);
11229 gfc_conv_expr (&argse
, image_idx_expr
);
11230 gfc_add_block_to_block (&block
, &argse
.pre
);
11231 gfc_add_block_to_block (&post_block
, &argse
.post
);
11232 image_index
= fold_convert (integer_type_node
, argse
.expr
);
11235 image_index
= integer_zero_node
;
11240 gfc_init_se (&argse
, NULL
);
11241 gfc_conv_expr (&argse
, errmsg_expr
);
11242 gfc_add_block_to_block (&block
, &argse
.pre
);
11243 gfc_add_block_to_block (&post_block
, &argse
.post
);
11244 errmsg
= argse
.expr
;
11245 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
11249 errmsg
= null_pointer_node
;
11250 errmsg_len
= build_zero_cst (size_type_node
);
11253 /* Generate the function call. */
11254 switch (code
->resolved_isym
->id
)
11256 case GFC_ISYM_CO_BROADCAST
:
11257 fndecl
= gfor_fndecl_co_broadcast
;
11259 case GFC_ISYM_CO_MAX
:
11260 fndecl
= gfor_fndecl_co_max
;
11262 case GFC_ISYM_CO_MIN
:
11263 fndecl
= gfor_fndecl_co_min
;
11265 case GFC_ISYM_CO_REDUCE
:
11266 fndecl
= gfor_fndecl_co_reduce
;
11268 case GFC_ISYM_CO_SUM
:
11269 fndecl
= gfor_fndecl_co_sum
;
11272 gcc_unreachable ();
11275 gfc_symbol
*derived
= code
->ext
.actual
->expr
->ts
.type
== BT_DERIVED
11276 ? code
->ext
.actual
->expr
->ts
.u
.derived
: NULL
;
11278 if (derived
&& derived
->attr
.alloc_comp
11279 && code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
11280 /* The derived type has the attribute 'alloc_comp'. */
11282 tree tmp
= gfc_bcast_alloc_comp (derived
, code
->ext
.actual
->expr
,
11283 code
->ext
.actual
->expr
->rank
,
11284 image_index
, stat
, errmsg
, errmsg_len
);
11285 gfc_add_expr_to_block (&block
, tmp
);
11289 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
11290 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
11291 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
11292 image_index
, stat
, errmsg
, errmsg_len
);
11293 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
11294 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
,
11295 image_index
, stat
, errmsg
,
11296 strlen
, errmsg_len
);
11299 tree opr
, opr_flags
;
11301 // FIXME: Handle TS29113's bind(C) strings with descriptor.
11303 if (gfc_is_proc_ptr_comp (opr_expr
))
11305 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
11306 opr_flag_int
= sym
->attr
.dimension
11307 || (sym
->ts
.type
== BT_CHARACTER
11308 && !sym
->attr
.is_bind_c
)
11309 ? GFC_CAF_BYREF
: 0;
11310 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
11311 && !sym
->attr
.is_bind_c
11312 ? GFC_CAF_HIDDENLEN
: 0;
11313 opr_flag_int
|= sym
->formal
->sym
->attr
.value
11314 ? GFC_CAF_ARG_VALUE
: 0;
11318 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
11319 ? GFC_CAF_BYREF
: 0;
11320 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
11321 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
11322 ? GFC_CAF_HIDDENLEN
: 0;
11323 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
11324 ? GFC_CAF_ARG_VALUE
: 0;
11326 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
11327 gfc_conv_expr (&argse
, opr_expr
);
11329 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
,
11330 opr_flags
, image_index
, stat
, errmsg
,
11331 strlen
, errmsg_len
);
11335 gfc_add_expr_to_block (&block
, fndecl
);
11336 gfc_add_block_to_block (&block
, &post_block
);
11338 return gfc_finish_block (&block
);
11343 conv_intrinsic_atomic_op (gfc_code
*code
)
11346 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
11347 stmtblock_t block
, post_block
;
11348 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
11349 gfc_expr
*stat_expr
;
11350 built_in_function fn
;
11352 if (atom_expr
->expr_type
== EXPR_FUNCTION
11353 && atom_expr
->value
.function
.isym
11354 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11355 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11357 gfc_start_block (&block
);
11358 gfc_init_block (&post_block
);
11360 gfc_init_se (&argse
, NULL
);
11361 argse
.want_pointer
= 1;
11362 gfc_conv_expr (&argse
, atom_expr
);
11363 gfc_add_block_to_block (&block
, &argse
.pre
);
11364 gfc_add_block_to_block (&post_block
, &argse
.post
);
11367 gfc_init_se (&argse
, NULL
);
11368 if (flag_coarray
== GFC_FCOARRAY_LIB
11369 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
11370 argse
.want_pointer
= 1;
11371 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
11372 gfc_add_block_to_block (&block
, &argse
.pre
);
11373 gfc_add_block_to_block (&post_block
, &argse
.post
);
11374 value
= argse
.expr
;
11376 switch (code
->resolved_isym
->id
)
11378 case GFC_ISYM_ATOMIC_ADD
:
11379 case GFC_ISYM_ATOMIC_AND
:
11380 case GFC_ISYM_ATOMIC_DEF
:
11381 case GFC_ISYM_ATOMIC_OR
:
11382 case GFC_ISYM_ATOMIC_XOR
:
11383 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
11384 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11385 old
= null_pointer_node
;
11388 gfc_init_se (&argse
, NULL
);
11389 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11390 argse
.want_pointer
= 1;
11391 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
11392 gfc_add_block_to_block (&block
, &argse
.pre
);
11393 gfc_add_block_to_block (&post_block
, &argse
.post
);
11395 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11399 if (stat_expr
!= NULL
)
11401 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
11402 gfc_init_se (&argse
, NULL
);
11403 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11404 argse
.want_pointer
= 1;
11405 gfc_conv_expr_val (&argse
, stat_expr
);
11406 gfc_add_block_to_block (&block
, &argse
.pre
);
11407 gfc_add_block_to_block (&post_block
, &argse
.post
);
11410 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11411 stat
= null_pointer_node
;
11413 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11415 tree image_index
, caf_decl
, offset
, token
;
11418 switch (code
->resolved_isym
->id
)
11420 case GFC_ISYM_ATOMIC_ADD
:
11421 case GFC_ISYM_ATOMIC_FETCH_ADD
:
11422 op
= (int) GFC_CAF_ATOMIC_ADD
;
11424 case GFC_ISYM_ATOMIC_AND
:
11425 case GFC_ISYM_ATOMIC_FETCH_AND
:
11426 op
= (int) GFC_CAF_ATOMIC_AND
;
11428 case GFC_ISYM_ATOMIC_OR
:
11429 case GFC_ISYM_ATOMIC_FETCH_OR
:
11430 op
= (int) GFC_CAF_ATOMIC_OR
;
11432 case GFC_ISYM_ATOMIC_XOR
:
11433 case GFC_ISYM_ATOMIC_FETCH_XOR
:
11434 op
= (int) GFC_CAF_ATOMIC_XOR
;
11436 case GFC_ISYM_ATOMIC_DEF
:
11437 op
= 0; /* Unused. */
11440 gcc_unreachable ();
11443 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
11444 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
11445 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
11447 if (gfc_is_coindexed (atom_expr
))
11448 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
11450 image_index
= integer_zero_node
;
11452 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
11454 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
11455 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
11456 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11459 gfc_init_se (&argse
, NULL
);
11460 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
11463 gfc_add_block_to_block (&block
, &argse
.pre
);
11464 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
11465 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
11466 token
, offset
, image_index
, value
, stat
,
11467 build_int_cst (integer_type_node
,
11468 (int) atom_expr
->ts
.type
),
11469 build_int_cst (integer_type_node
,
11470 (int) atom_expr
->ts
.kind
));
11472 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
11473 build_int_cst (integer_type_node
, op
),
11474 token
, offset
, image_index
, value
, old
, stat
,
11475 build_int_cst (integer_type_node
,
11476 (int) atom_expr
->ts
.type
),
11477 build_int_cst (integer_type_node
,
11478 (int) atom_expr
->ts
.kind
));
11480 gfc_add_expr_to_block (&block
, tmp
);
11481 gfc_add_block_to_block (&block
, &argse
.post
);
11482 gfc_add_block_to_block (&block
, &post_block
);
11483 return gfc_finish_block (&block
);
11487 switch (code
->resolved_isym
->id
)
11489 case GFC_ISYM_ATOMIC_ADD
:
11490 case GFC_ISYM_ATOMIC_FETCH_ADD
:
11491 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
11493 case GFC_ISYM_ATOMIC_AND
:
11494 case GFC_ISYM_ATOMIC_FETCH_AND
:
11495 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
11497 case GFC_ISYM_ATOMIC_DEF
:
11498 fn
= BUILT_IN_ATOMIC_STORE_N
;
11500 case GFC_ISYM_ATOMIC_OR
:
11501 case GFC_ISYM_ATOMIC_FETCH_OR
:
11502 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
11504 case GFC_ISYM_ATOMIC_XOR
:
11505 case GFC_ISYM_ATOMIC_FETCH_XOR
:
11506 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
11509 gcc_unreachable ();
11512 tmp
= TREE_TYPE (TREE_TYPE (atom
));
11513 fn
= (built_in_function
) ((int) fn
11514 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
11516 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
11517 tmp
= builtin_decl_explicit (fn
);
11519 switch (code
->resolved_isym
->id
)
11521 case GFC_ISYM_ATOMIC_ADD
:
11522 case GFC_ISYM_ATOMIC_AND
:
11523 case GFC_ISYM_ATOMIC_DEF
:
11524 case GFC_ISYM_ATOMIC_OR
:
11525 case GFC_ISYM_ATOMIC_XOR
:
11526 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
11527 fold_convert (itype
, value
),
11528 build_int_cst (NULL
, MEMMODEL_RELAXED
));
11529 gfc_add_expr_to_block (&block
, tmp
);
11532 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
11533 fold_convert (itype
, value
),
11534 build_int_cst (NULL
, MEMMODEL_RELAXED
));
11535 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
11539 if (stat
!= NULL_TREE
)
11540 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11541 gfc_add_block_to_block (&block
, &post_block
);
11542 return gfc_finish_block (&block
);
11547 conv_intrinsic_atomic_ref (gfc_code
*code
)
11550 tree tmp
, atom
, value
, stat
= NULL_TREE
;
11551 stmtblock_t block
, post_block
;
11552 built_in_function fn
;
11553 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
11555 if (atom_expr
->expr_type
== EXPR_FUNCTION
11556 && atom_expr
->value
.function
.isym
11557 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11558 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11560 gfc_start_block (&block
);
11561 gfc_init_block (&post_block
);
11562 gfc_init_se (&argse
, NULL
);
11563 argse
.want_pointer
= 1;
11564 gfc_conv_expr (&argse
, atom_expr
);
11565 gfc_add_block_to_block (&block
, &argse
.pre
);
11566 gfc_add_block_to_block (&post_block
, &argse
.post
);
11569 gfc_init_se (&argse
, NULL
);
11570 if (flag_coarray
== GFC_FCOARRAY_LIB
11571 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
11572 argse
.want_pointer
= 1;
11573 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
11574 gfc_add_block_to_block (&block
, &argse
.pre
);
11575 gfc_add_block_to_block (&post_block
, &argse
.post
);
11576 value
= argse
.expr
;
11579 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
11581 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
11583 gfc_init_se (&argse
, NULL
);
11584 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11585 argse
.want_pointer
= 1;
11586 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
11587 gfc_add_block_to_block (&block
, &argse
.pre
);
11588 gfc_add_block_to_block (&post_block
, &argse
.post
);
11591 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11592 stat
= null_pointer_node
;
11594 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11596 tree image_index
, caf_decl
, offset
, token
;
11597 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
11599 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
11600 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
11601 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
11603 if (gfc_is_coindexed (atom_expr
))
11604 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
11606 image_index
= integer_zero_node
;
11608 gfc_init_se (&argse
, NULL
);
11609 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
11611 gfc_add_block_to_block (&block
, &argse
.pre
);
11613 /* Different type, need type conversion. */
11614 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
11616 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
11617 orig_value
= value
;
11618 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
11621 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
11622 token
, offset
, image_index
, value
, stat
,
11623 build_int_cst (integer_type_node
,
11624 (int) atom_expr
->ts
.type
),
11625 build_int_cst (integer_type_node
,
11626 (int) atom_expr
->ts
.kind
));
11627 gfc_add_expr_to_block (&block
, tmp
);
11628 if (vardecl
!= NULL_TREE
)
11629 gfc_add_modify (&block
, orig_value
,
11630 fold_convert (TREE_TYPE (orig_value
), vardecl
));
11631 gfc_add_block_to_block (&block
, &argse
.post
);
11632 gfc_add_block_to_block (&block
, &post_block
);
11633 return gfc_finish_block (&block
);
11636 tmp
= TREE_TYPE (TREE_TYPE (atom
));
11637 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
11638 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
11640 tmp
= builtin_decl_explicit (fn
);
11641 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
11642 build_int_cst (integer_type_node
,
11643 MEMMODEL_RELAXED
));
11644 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
11646 if (stat
!= NULL_TREE
)
11647 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11648 gfc_add_block_to_block (&block
, &post_block
);
11649 return gfc_finish_block (&block
);
11654 conv_intrinsic_atomic_cas (gfc_code
*code
)
11657 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
11658 stmtblock_t block
, post_block
;
11659 built_in_function fn
;
11660 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
11662 if (atom_expr
->expr_type
== EXPR_FUNCTION
11663 && atom_expr
->value
.function
.isym
11664 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11665 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11667 gfc_init_block (&block
);
11668 gfc_init_block (&post_block
);
11669 gfc_init_se (&argse
, NULL
);
11670 argse
.want_pointer
= 1;
11671 gfc_conv_expr (&argse
, atom_expr
);
11674 gfc_init_se (&argse
, NULL
);
11675 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11676 argse
.want_pointer
= 1;
11677 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
11678 gfc_add_block_to_block (&block
, &argse
.pre
);
11679 gfc_add_block_to_block (&post_block
, &argse
.post
);
11682 gfc_init_se (&argse
, NULL
);
11683 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11684 argse
.want_pointer
= 1;
11685 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
11686 gfc_add_block_to_block (&block
, &argse
.pre
);
11687 gfc_add_block_to_block (&post_block
, &argse
.post
);
11690 gfc_init_se (&argse
, NULL
);
11691 if (flag_coarray
== GFC_FCOARRAY_LIB
11692 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
11693 == atom_expr
->ts
.kind
)
11694 argse
.want_pointer
= 1;
11695 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
11696 gfc_add_block_to_block (&block
, &argse
.pre
);
11697 gfc_add_block_to_block (&post_block
, &argse
.post
);
11698 new_val
= argse
.expr
;
11701 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
11703 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
11705 gfc_init_se (&argse
, NULL
);
11706 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11707 argse
.want_pointer
= 1;
11708 gfc_conv_expr_val (&argse
,
11709 code
->ext
.actual
->next
->next
->next
->next
->expr
);
11710 gfc_add_block_to_block (&block
, &argse
.pre
);
11711 gfc_add_block_to_block (&post_block
, &argse
.post
);
11714 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11715 stat
= null_pointer_node
;
11717 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11719 tree image_index
, caf_decl
, offset
, token
;
11721 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
11722 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
11723 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
11725 if (gfc_is_coindexed (atom_expr
))
11726 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
11728 image_index
= integer_zero_node
;
11730 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
11732 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
11733 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
11734 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11737 /* Convert a constant to a pointer. */
11738 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
11740 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
11741 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
11742 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11745 gfc_init_se (&argse
, NULL
);
11746 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
11748 gfc_add_block_to_block (&block
, &argse
.pre
);
11750 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
11751 token
, offset
, image_index
, old
, comp
, new_val
,
11752 stat
, build_int_cst (integer_type_node
,
11753 (int) atom_expr
->ts
.type
),
11754 build_int_cst (integer_type_node
,
11755 (int) atom_expr
->ts
.kind
));
11756 gfc_add_expr_to_block (&block
, tmp
);
11757 gfc_add_block_to_block (&block
, &argse
.post
);
11758 gfc_add_block_to_block (&block
, &post_block
);
11759 return gfc_finish_block (&block
);
11762 tmp
= TREE_TYPE (TREE_TYPE (atom
));
11763 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
11764 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
11766 tmp
= builtin_decl_explicit (fn
);
11768 gfc_add_modify (&block
, old
, comp
);
11769 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
11770 gfc_build_addr_expr (NULL
, old
),
11771 fold_convert (TREE_TYPE (old
), new_val
),
11772 boolean_false_node
,
11773 build_int_cst (NULL
, MEMMODEL_RELAXED
),
11774 build_int_cst (NULL
, MEMMODEL_RELAXED
));
11775 gfc_add_expr_to_block (&block
, tmp
);
11777 if (stat
!= NULL_TREE
)
11778 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11779 gfc_add_block_to_block (&block
, &post_block
);
11780 return gfc_finish_block (&block
);
11784 conv_intrinsic_event_query (gfc_code
*code
)
11787 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
11788 tree count
= NULL_TREE
, count2
= NULL_TREE
;
11790 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
11792 if (code
->ext
.actual
->next
->next
->expr
)
11794 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
11796 gfc_init_se (&argse
, NULL
);
11797 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
11800 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11801 stat
= null_pointer_node
;
11803 if (code
->ext
.actual
->next
->expr
)
11805 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
11806 gfc_init_se (&argse
, NULL
);
11807 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
11808 count
= argse
.expr
;
11811 gfc_start_block (&se
.pre
);
11812 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11814 tree tmp
, token
, image_index
;
11815 tree index
= build_zero_cst (gfc_array_index_type
);
11817 if (event_expr
->expr_type
== EXPR_FUNCTION
11818 && event_expr
->value
.function
.isym
11819 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11820 event_expr
= event_expr
->value
.function
.actual
->expr
;
11822 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
11824 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
11825 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
11826 != INTMOD_ISO_FORTRAN_ENV
11827 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
11828 != ISOFORTRAN_EVENT_TYPE
)
11830 gfc_error ("Sorry, the event component of derived type at %L is not "
11831 "yet supported", &event_expr
->where
);
11835 if (gfc_is_coindexed (event_expr
))
11837 gfc_error ("The event variable at %L shall not be coindexed",
11838 &event_expr
->where
);
11842 image_index
= integer_zero_node
;
11844 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
11847 /* For arrays, obtain the array index. */
11848 if (gfc_expr_attr (event_expr
).dimension
)
11850 tree desc
, tmp
, extent
, lbound
, ubound
;
11851 gfc_array_ref
*ar
, ar2
;
11854 /* TODO: Extend this, once DT components are supported. */
11855 ar
= &event_expr
->ref
->u
.ar
;
11857 memset (ar
, '\0', sizeof (*ar
));
11859 ar
->type
= AR_FULL
;
11861 gfc_init_se (&argse
, NULL
);
11862 argse
.descriptor_only
= 1;
11863 gfc_conv_expr_descriptor (&argse
, event_expr
);
11864 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
11868 extent
= build_one_cst (gfc_array_index_type
);
11869 for (i
= 0; i
< ar
->dimen
; i
++)
11871 gfc_init_se (&argse
, NULL
);
11872 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
11873 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
11874 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
11875 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
11876 TREE_TYPE (lbound
), argse
.expr
, lbound
);
11877 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
11878 TREE_TYPE (tmp
), extent
, tmp
);
11879 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
11880 TREE_TYPE (tmp
), index
, tmp
);
11881 if (i
< ar
->dimen
- 1)
11883 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
11884 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
11885 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
11886 TREE_TYPE (tmp
), extent
, tmp
);
11891 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
11894 count
= gfc_create_var (integer_type_node
, "count");
11897 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
11900 stat
= gfc_create_var (integer_type_node
, "stat");
11903 index
= fold_convert (size_type_node
, index
);
11904 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
11905 token
, index
, image_index
, count
11906 ? gfc_build_addr_expr (NULL
, count
) : count
,
11907 stat
!= null_pointer_node
11908 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
11909 gfc_add_expr_to_block (&se
.pre
, tmp
);
11911 if (count2
!= NULL_TREE
)
11912 gfc_add_modify (&se
.pre
, count2
,
11913 fold_convert (TREE_TYPE (count2
), count
));
11915 if (stat2
!= NULL_TREE
)
11916 gfc_add_modify (&se
.pre
, stat2
,
11917 fold_convert (TREE_TYPE (stat2
), stat
));
11919 return gfc_finish_block (&se
.pre
);
11922 gfc_init_se (&argse
, NULL
);
11923 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
11924 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
11926 if (stat
!= NULL_TREE
)
11927 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11929 return gfc_finish_block (&se
.pre
);
11933 /* This is a peculiar case because of the need to do dependency checking.
11934 It is called via trans-stmt.c(gfc_trans_call), where it is picked out as
11935 a special case and this function called instead of
11936 gfc_conv_procedure_call. */
11938 gfc_conv_intrinsic_mvbits (gfc_se
*se
, gfc_actual_arglist
*actual_args
,
11939 gfc_loopinfo
*loop
)
11941 gfc_actual_arglist
*actual
;
11947 tree from
, frompos
, len
, to
, topos
;
11948 tree lenmask
, oldbits
, newbits
, bitsize
;
11949 tree type
, utype
, above
, mask1
, mask2
;
11954 lss
= gfc_ss_terminator
;
11956 actual
= actual_args
;
11957 for (n
= 0; n
< 5; n
++, actual
= actual
->next
)
11959 arg
[n
] = actual
->expr
;
11960 gfc_init_se (&argse
[n
], NULL
);
11962 if (lss
!= gfc_ss_terminator
)
11964 gfc_copy_loopinfo_to_se (&argse
[n
], loop
);
11965 /* Find the ss for the expression if it is there. */
11967 gfc_mark_ss_chain_used (lss
, 1);
11970 gfc_conv_expr (&argse
[n
], arg
[n
]);
11976 from
= argse
[0].expr
;
11977 frompos
= argse
[1].expr
;
11978 len
= argse
[2].expr
;
11979 to
= argse
[3].expr
;
11980 topos
= argse
[4].expr
;
11982 /* The type of the result (TO). */
11983 type
= TREE_TYPE (to
);
11984 bitsize
= build_int_cst (integer_type_node
, TYPE_PRECISION (type
));
11986 /* Optionally generate code for runtime argument check. */
11987 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
11989 tree nbits
, below
, ccond
;
11990 tree fp
= fold_convert (long_integer_type_node
, frompos
);
11991 tree ln
= fold_convert (long_integer_type_node
, len
);
11992 tree tp
= fold_convert (long_integer_type_node
, topos
);
11993 below
= fold_build2_loc (input_location
, LT_EXPR
,
11994 logical_type_node
, frompos
,
11995 build_int_cst (TREE_TYPE (frompos
), 0));
11996 above
= fold_build2_loc (input_location
, GT_EXPR
,
11997 logical_type_node
, frompos
,
11998 fold_convert (TREE_TYPE (frompos
), bitsize
));
11999 ccond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
12000 logical_type_node
, below
, above
);
12001 gfc_trans_runtime_check (true, false, ccond
, &argse
[1].pre
,
12003 "FROMPOS argument (%ld) out of range 0:%d "
12004 "in intrinsic MVBITS", fp
, bitsize
);
12005 below
= fold_build2_loc (input_location
, LT_EXPR
,
12006 logical_type_node
, len
,
12007 build_int_cst (TREE_TYPE (len
), 0));
12008 above
= fold_build2_loc (input_location
, GT_EXPR
,
12009 logical_type_node
, len
,
12010 fold_convert (TREE_TYPE (len
), bitsize
));
12011 ccond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
12012 logical_type_node
, below
, above
);
12013 gfc_trans_runtime_check (true, false, ccond
, &argse
[2].pre
,
12015 "LEN argument (%ld) out of range 0:%d "
12016 "in intrinsic MVBITS", ln
, bitsize
);
12017 below
= fold_build2_loc (input_location
, LT_EXPR
,
12018 logical_type_node
, topos
,
12019 build_int_cst (TREE_TYPE (topos
), 0));
12020 above
= fold_build2_loc (input_location
, GT_EXPR
,
12021 logical_type_node
, topos
,
12022 fold_convert (TREE_TYPE (topos
), bitsize
));
12023 ccond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
12024 logical_type_node
, below
, above
);
12025 gfc_trans_runtime_check (true, false, ccond
, &argse
[4].pre
,
12027 "TOPOS argument (%ld) out of range 0:%d "
12028 "in intrinsic MVBITS", tp
, bitsize
);
12030 /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
12031 integers. Additions below cannot overflow. */
12032 nbits
= fold_convert (long_integer_type_node
, bitsize
);
12033 above
= fold_build2_loc (input_location
, PLUS_EXPR
,
12034 long_integer_type_node
, fp
, ln
);
12035 ccond
= fold_build2_loc (input_location
, GT_EXPR
,
12036 logical_type_node
, above
, nbits
);
12037 gfc_trans_runtime_check (true, false, ccond
, &argse
[1].pre
,
12039 "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12040 "in intrinsic MVBITS", fp
, ln
, bitsize
);
12041 above
= fold_build2_loc (input_location
, PLUS_EXPR
,
12042 long_integer_type_node
, tp
, ln
);
12043 ccond
= fold_build2_loc (input_location
, GT_EXPR
,
12044 logical_type_node
, above
, nbits
);
12045 gfc_trans_runtime_check (true, false, ccond
, &argse
[4].pre
,
12047 "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12048 "in intrinsic MVBITS", tp
, ln
, bitsize
);
12051 for (n
= 0; n
< 5; n
++)
12053 gfc_add_block_to_block (&se
->pre
, &argse
[n
].pre
);
12054 gfc_add_block_to_block (&se
->post
, &argse
[n
].post
);
12057 /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
12058 above
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
12059 len
, fold_convert (TREE_TYPE (len
), bitsize
));
12060 mask1
= build_int_cst (type
, -1);
12061 mask2
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
12062 build_int_cst (type
, 1), len
);
12063 mask2
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
12064 mask2
, build_int_cst (type
, 1));
12065 lenmask
= fold_build3_loc (input_location
, COND_EXPR
, type
,
12066 above
, mask1
, mask2
);
12068 /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
12069 * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
12070 * not strictly necessary; artificial bits from rshift will be masked. */
12071 utype
= unsigned_type_for (type
);
12072 newbits
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
12073 fold_convert (utype
, from
), frompos
);
12074 newbits
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
12075 fold_convert (type
, newbits
), lenmask
);
12076 newbits
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
12079 /* oldbits = TO & (~(lenmask << TOPOS)). */
12080 oldbits
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
12082 oldbits
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, oldbits
);
12083 oldbits
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, oldbits
, to
);
12085 /* TO = newbits | oldbits. */
12086 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
12089 /* Return the assignment. */
12090 se
->expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
12091 void_type_node
, to
, se
->expr
);
12096 conv_intrinsic_move_alloc (gfc_code
*code
)
12099 gfc_expr
*from_expr
, *to_expr
;
12100 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
12101 gfc_se from_se
, to_se
;
12105 gfc_start_block (&block
);
12107 from_expr
= code
->ext
.actual
->expr
;
12108 to_expr
= code
->ext
.actual
->next
->expr
;
12110 gfc_init_se (&from_se
, NULL
);
12111 gfc_init_se (&to_se
, NULL
);
12113 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
12114 || to_expr
->ts
.type
== BT_CLASS
);
12115 coarray
= gfc_get_corank (from_expr
) != 0;
12117 if (from_expr
->rank
== 0 && !coarray
)
12119 if (from_expr
->ts
.type
!= BT_CLASS
)
12120 from_expr2
= from_expr
;
12123 from_expr2
= gfc_copy_expr (from_expr
);
12124 gfc_add_data_component (from_expr2
);
12127 if (to_expr
->ts
.type
!= BT_CLASS
)
12128 to_expr2
= to_expr
;
12131 to_expr2
= gfc_copy_expr (to_expr
);
12132 gfc_add_data_component (to_expr2
);
12135 from_se
.want_pointer
= 1;
12136 to_se
.want_pointer
= 1;
12137 gfc_conv_expr (&from_se
, from_expr2
);
12138 gfc_conv_expr (&to_se
, to_expr2
);
12139 gfc_add_block_to_block (&block
, &from_se
.pre
);
12140 gfc_add_block_to_block (&block
, &to_se
.pre
);
12142 /* Deallocate "to". */
12143 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
12144 true, to_expr
, to_expr
->ts
);
12145 gfc_add_expr_to_block (&block
, tmp
);
12147 /* Assign (_data) pointers. */
12148 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
12149 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
12151 /* Set "from" to NULL. */
12152 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
12153 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
12155 gfc_add_block_to_block (&block
, &from_se
.post
);
12156 gfc_add_block_to_block (&block
, &to_se
.post
);
12159 if (to_expr
->ts
.type
== BT_CLASS
)
12163 gfc_free_expr (to_expr2
);
12164 gfc_init_se (&to_se
, NULL
);
12165 to_se
.want_pointer
= 1;
12166 gfc_add_vptr_component (to_expr
);
12167 gfc_conv_expr (&to_se
, to_expr
);
12169 if (from_expr
->ts
.type
== BT_CLASS
)
12171 if (UNLIMITED_POLY (from_expr
))
12175 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
12179 gfc_free_expr (from_expr2
);
12180 gfc_init_se (&from_se
, NULL
);
12181 from_se
.want_pointer
= 1;
12182 gfc_add_vptr_component (from_expr
);
12183 gfc_conv_expr (&from_se
, from_expr
);
12184 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
12185 fold_convert (TREE_TYPE (to_se
.expr
),
12188 /* Reset _vptr component to declared type. */
12190 /* Unlimited polymorphic. */
12191 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
12192 fold_convert (TREE_TYPE (from_se
.expr
),
12193 null_pointer_node
));
12196 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
12197 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
12198 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
12203 vtab
= gfc_find_vtab (&from_expr
->ts
);
12205 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
12206 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
12207 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
12211 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
12213 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
12214 fold_convert (TREE_TYPE (to_se
.string_length
),
12215 from_se
.string_length
));
12216 if (from_expr
->ts
.deferred
)
12217 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
12218 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
12221 return gfc_finish_block (&block
);
12224 /* Update _vptr component. */
12225 if (to_expr
->ts
.type
== BT_CLASS
)
12229 to_se
.want_pointer
= 1;
12230 to_expr2
= gfc_copy_expr (to_expr
);
12231 gfc_add_vptr_component (to_expr2
);
12232 gfc_conv_expr (&to_se
, to_expr2
);
12234 if (from_expr
->ts
.type
== BT_CLASS
)
12236 if (UNLIMITED_POLY (from_expr
))
12240 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
12244 from_se
.want_pointer
= 1;
12245 from_expr2
= gfc_copy_expr (from_expr
);
12246 gfc_add_vptr_component (from_expr2
);
12247 gfc_conv_expr (&from_se
, from_expr2
);
12248 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
12249 fold_convert (TREE_TYPE (to_se
.expr
),
12252 /* Reset _vptr component to declared type. */
12254 /* Unlimited polymorphic. */
12255 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
12256 fold_convert (TREE_TYPE (from_se
.expr
),
12257 null_pointer_node
));
12260 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
12261 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
12262 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
12267 vtab
= gfc_find_vtab (&from_expr
->ts
);
12269 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
12270 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
12271 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
12274 gfc_free_expr (to_expr2
);
12275 gfc_init_se (&to_se
, NULL
);
12277 if (from_expr
->ts
.type
== BT_CLASS
)
12279 gfc_free_expr (from_expr2
);
12280 gfc_init_se (&from_se
, NULL
);
12285 /* Deallocate "to". */
12286 if (from_expr
->rank
== 0)
12288 to_se
.want_coarray
= 1;
12289 from_se
.want_coarray
= 1;
12291 gfc_conv_expr_descriptor (&to_se
, to_expr
);
12292 gfc_conv_expr_descriptor (&from_se
, from_expr
);
12294 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
12295 is an image control "statement", cf. IR F08/0040 in 12-006A. */
12296 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
12300 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
12301 NULL_TREE
, NULL_TREE
, true, to_expr
,
12302 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
12303 gfc_add_expr_to_block (&block
, tmp
);
12305 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
12306 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
12307 logical_type_node
, tmp
,
12308 fold_convert (TREE_TYPE (tmp
),
12309 null_pointer_node
));
12310 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
12311 3, null_pointer_node
, null_pointer_node
,
12312 build_int_cst (integer_type_node
, 0));
12314 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
12315 tmp
, build_empty_stmt (input_location
));
12316 gfc_add_expr_to_block (&block
, tmp
);
12320 if (to_expr
->ts
.type
== BT_DERIVED
12321 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
12323 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
12324 to_se
.expr
, to_expr
->rank
);
12325 gfc_add_expr_to_block (&block
, tmp
);
12328 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
12329 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
12330 NULL_TREE
, true, to_expr
,
12331 GFC_CAF_COARRAY_NOCOARRAY
);
12332 gfc_add_expr_to_block (&block
, tmp
);
12335 /* Move the pointer and update the array descriptor data. */
12336 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
12338 /* Set "from" to NULL. */
12339 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
12340 gfc_add_modify_loc (input_location
, &block
, tmp
,
12341 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
12344 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
12346 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
12347 fold_convert (TREE_TYPE (to_se
.string_length
),
12348 from_se
.string_length
));
12349 if (from_expr
->ts
.deferred
)
12350 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
12351 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
12354 return gfc_finish_block (&block
);
12359 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
12363 gcc_assert (code
->resolved_isym
);
12365 switch (code
->resolved_isym
->id
)
12367 case GFC_ISYM_MOVE_ALLOC
:
12368 res
= conv_intrinsic_move_alloc (code
);
12371 case GFC_ISYM_ATOMIC_CAS
:
12372 res
= conv_intrinsic_atomic_cas (code
);
12375 case GFC_ISYM_ATOMIC_ADD
:
12376 case GFC_ISYM_ATOMIC_AND
:
12377 case GFC_ISYM_ATOMIC_DEF
:
12378 case GFC_ISYM_ATOMIC_OR
:
12379 case GFC_ISYM_ATOMIC_XOR
:
12380 case GFC_ISYM_ATOMIC_FETCH_ADD
:
12381 case GFC_ISYM_ATOMIC_FETCH_AND
:
12382 case GFC_ISYM_ATOMIC_FETCH_OR
:
12383 case GFC_ISYM_ATOMIC_FETCH_XOR
:
12384 res
= conv_intrinsic_atomic_op (code
);
12387 case GFC_ISYM_ATOMIC_REF
:
12388 res
= conv_intrinsic_atomic_ref (code
);
12391 case GFC_ISYM_EVENT_QUERY
:
12392 res
= conv_intrinsic_event_query (code
);
12395 case GFC_ISYM_C_F_POINTER
:
12396 case GFC_ISYM_C_F_PROCPOINTER
:
12397 res
= conv_isocbinding_subroutine (code
);
12400 case GFC_ISYM_CAF_SEND
:
12401 res
= conv_caf_send (code
);
12404 case GFC_ISYM_CO_BROADCAST
:
12405 case GFC_ISYM_CO_MIN
:
12406 case GFC_ISYM_CO_MAX
:
12407 case GFC_ISYM_CO_REDUCE
:
12408 case GFC_ISYM_CO_SUM
:
12409 res
= conv_co_collective (code
);
12412 case GFC_ISYM_FREE
:
12413 res
= conv_intrinsic_free (code
);
12416 case GFC_ISYM_RANDOM_INIT
:
12417 res
= conv_intrinsic_random_init (code
);
12420 case GFC_ISYM_KILL
:
12421 res
= conv_intrinsic_kill_sub (code
);
12424 case GFC_ISYM_MVBITS
:
12428 case GFC_ISYM_SYSTEM_CLOCK
:
12429 res
= conv_intrinsic_system_clock (code
);
12440 #include "gt-fortran-trans-intrinsic.h"