1 /* Intrinsic translation
2 Copyright (C) 2002-2024 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.cc-- 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. */
46 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
48 /* This maps Fortran intrinsic math functions to external library or GCC
50 typedef struct GTY(()) gfc_intrinsic_map_t
{
51 /* The explicit enum is required to work around inadequacies in the
52 garbage collection/gengtype parsing mechanism. */
55 /* Enum value from the "language-independent", aka C-centric, part
56 of gcc, or END_BUILTINS of no such value set. */
57 enum built_in_function float_built_in
;
58 enum built_in_function double_built_in
;
59 enum built_in_function long_double_built_in
;
60 enum built_in_function complex_float_built_in
;
61 enum built_in_function complex_double_built_in
;
62 enum built_in_function complex_long_double_built_in
;
64 /* True if the naming pattern is to prepend "c" for complex and
65 append "f" for kind=4. False if the naming pattern is to
66 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
69 /* True if a complex version of the function exists. */
70 bool complex_available
;
72 /* True if the function should be marked const. */
75 /* The base library name of this function. */
78 /* Cache decls created for the various operand types. */
90 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
91 defines complex variants of all of the entries in mathbuiltins.def
93 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
94 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
95 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
96 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
97 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
100 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
101 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
102 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
103 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
105 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
106 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
109 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
111 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
112 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
113 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
114 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
115 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
117 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
119 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
120 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
121 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
122 #include "mathbuiltins.def"
124 /* Functions in libgfortran. */
125 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
126 LIB_FUNCTION (SIND
, "sind", false),
127 LIB_FUNCTION (COSD
, "cosd", false),
128 LIB_FUNCTION (TAND
, "tand", false),
131 LIB_FUNCTION (NONE
, NULL
, false)
136 #undef DEFINE_MATH_BUILTIN
137 #undef DEFINE_MATH_BUILTIN_C
140 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
143 /* Find the correct variant of a given builtin from its argument. */
145 builtin_decl_for_precision (enum built_in_function base_built_in
,
148 enum built_in_function i
= END_BUILTINS
;
150 gfc_intrinsic_map_t
*m
;
151 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
154 if (precision
== TYPE_PRECISION (float_type_node
))
155 i
= m
->float_built_in
;
156 else if (precision
== TYPE_PRECISION (double_type_node
))
157 i
= m
->double_built_in
;
158 else if (precision
== TYPE_PRECISION (long_double_type_node
)
159 && (!gfc_real16_is_float128
160 || long_double_type_node
!= gfc_float128_type_node
))
161 i
= m
->long_double_built_in
;
162 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
164 /* Special treatment, because it is not exactly a built-in, but
165 a library function. */
166 return m
->real16_decl
;
169 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
174 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
177 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
179 if (gfc_real_kinds
[i
].c_float128
)
181 /* For _Float128, the story is a bit different, because we return
182 a decl to a library function rather than a built-in. */
183 gfc_intrinsic_map_t
*m
;
184 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
187 return m
->real16_decl
;
190 return builtin_decl_for_precision (double_built_in
,
191 gfc_real_kinds
[i
].mode_precision
);
195 /* Evaluate the arguments to an intrinsic function. The value
196 of NARGS may be less than the actual number of arguments in EXPR
197 to allow optional "KIND" arguments that are not included in the
198 generated code to be ignored. */
201 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
202 tree
*argarray
, int nargs
)
204 gfc_actual_arglist
*actual
;
206 gfc_intrinsic_arg
*formal
;
210 formal
= expr
->value
.function
.isym
->formal
;
211 actual
= expr
->value
.function
.actual
;
213 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
214 actual
= actual
->next
,
215 formal
= formal
? formal
->next
: NULL
)
219 /* Skip omitted optional arguments. */
226 /* Evaluate the parameter. This will substitute scalarized
227 references automatically. */
228 gfc_init_se (&argse
, se
);
230 if (e
->ts
.type
== BT_CHARACTER
)
232 gfc_conv_expr (&argse
, e
);
233 gfc_conv_string_parameter (&argse
);
234 argarray
[curr_arg
++] = argse
.string_length
;
235 gcc_assert (curr_arg
< nargs
);
238 gfc_conv_expr_val (&argse
, e
);
240 /* If an optional argument is itself an optional dummy argument,
241 check its presence and substitute a null if absent. */
242 if (e
->expr_type
== EXPR_VARIABLE
243 && e
->symtree
->n
.sym
->attr
.optional
246 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
248 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
249 gfc_add_block_to_block (&se
->post
, &argse
.post
);
250 argarray
[curr_arg
] = argse
.expr
;
254 /* Count the number of actual arguments to the intrinsic function EXPR
255 including any "hidden" string length arguments. */
258 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
261 gfc_actual_arglist
*actual
;
263 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
268 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
278 /* Conversions between different types are output by the frontend as
279 intrinsic functions. We implement these directly with inline code. */
282 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
288 nargs
= gfc_intrinsic_argument_list_length (expr
);
289 args
= XALLOCAVEC (tree
, nargs
);
291 /* Evaluate all the arguments passed. Whilst we're only interested in the
292 first one here, there are other parts of the front-end that assume this
293 and will trigger an ICE if it's not the case. */
294 type
= gfc_typenode_for_spec (&expr
->ts
);
295 gcc_assert (expr
->value
.function
.actual
->expr
);
296 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
298 /* Conversion between character kinds involves a call to a library
300 if (expr
->ts
.type
== BT_CHARACTER
)
302 tree fndecl
, var
, addr
, tmp
;
304 if (expr
->ts
.kind
== 1
305 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
306 fndecl
= gfor_fndecl_convert_char4_to_char1
;
307 else if (expr
->ts
.kind
== 4
308 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
309 fndecl
= gfor_fndecl_convert_char1_to_char4
;
313 /* Create the variable storing the converted value. */
314 type
= gfc_get_pchar_type (expr
->ts
.kind
);
315 var
= gfc_create_var (type
, "str");
316 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
318 /* Call the library function that will perform the conversion. */
319 gcc_assert (nargs
>= 2);
320 tmp
= build_call_expr_loc (input_location
,
321 fndecl
, 3, addr
, args
[0], args
[1]);
322 gfc_add_expr_to_block (&se
->pre
, tmp
);
324 /* Free the temporary afterwards. */
325 tmp
= gfc_call_free (var
);
326 gfc_add_expr_to_block (&se
->post
, tmp
);
329 se
->string_length
= args
[0];
334 /* Conversion from complex to non-complex involves taking the real
335 component of the value. */
336 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
337 && expr
->ts
.type
!= BT_COMPLEX
)
341 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
342 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
346 se
->expr
= convert (type
, args
[0]);
349 /* This is needed because the gcc backend only implements
350 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
351 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
352 Similarly for CEILING. */
355 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
362 argtype
= TREE_TYPE (arg
);
363 arg
= gfc_evaluate_now (arg
, pblock
);
365 intval
= convert (type
, arg
);
366 intval
= gfc_evaluate_now (intval
, pblock
);
368 tmp
= convert (argtype
, intval
);
369 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
370 logical_type_node
, tmp
, arg
);
372 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
373 intval
, build_int_cst (type
, 1));
374 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
379 /* Round to nearest integer, away from zero. */
382 build_round_expr (tree arg
, tree restype
)
386 int argprec
, resprec
;
388 argtype
= TREE_TYPE (arg
);
389 argprec
= TYPE_PRECISION (argtype
);
390 resprec
= TYPE_PRECISION (restype
);
392 /* Depending on the type of the result, choose the int intrinsic (iround,
393 available only as a builtin, therefore cannot use it for _Float128), long
394 int intrinsic (lround family) or long long intrinsic (llround). If we
395 don't have an appropriate function that converts directly to the integer
396 type (such as kind == 16), just use ROUND, and then convert the result to
397 an integer. We might also need to convert the result afterwards. */
398 if (resprec
<= INT_TYPE_SIZE
399 && argprec
<= TYPE_PRECISION (long_double_type_node
))
400 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
401 else if (resprec
<= LONG_TYPE_SIZE
)
402 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
403 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
404 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
405 else if (resprec
>= argprec
)
406 fn
= builtin_decl_for_precision (BUILT_IN_ROUND
, argprec
);
410 return convert (restype
, build_call_expr_loc (input_location
,
415 /* Convert a real to an integer using a specific rounding mode.
416 Ideally we would just build the corresponding GENERIC node,
417 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
420 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
421 enum rounding_mode op
)
426 return build_fixbound_expr (pblock
, arg
, type
, 0);
429 return build_fixbound_expr (pblock
, arg
, type
, 1);
432 return build_round_expr (arg
, type
);
435 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
443 /* Round a real value using the specified rounding mode.
444 We use a temporary integer of that same kind size as the result.
445 Values larger than those that can be represented by this kind are
446 unchanged, as they will not be accurate enough to represent the
448 huge = HUGE (KIND (a))
449 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
453 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
465 kind
= expr
->ts
.kind
;
466 nargs
= gfc_intrinsic_argument_list_length (expr
);
469 /* We have builtin functions for some cases. */
473 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
477 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
484 /* Evaluate the argument. */
485 gcc_assert (expr
->value
.function
.actual
->expr
);
486 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
488 /* Use a builtin function if one exists. */
489 if (decl
!= NULL_TREE
)
491 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
495 /* This code is probably redundant, but we'll keep it lying around just
497 type
= gfc_typenode_for_spec (&expr
->ts
);
498 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
500 /* Test if the value is too large to handle sensibly. */
501 gfc_set_model_kind (kind
);
503 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
504 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
505 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
506 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, arg
[0],
509 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
510 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
511 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, arg
[0],
513 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, logical_type_node
,
515 itype
= gfc_get_int_type (kind
);
517 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
518 tmp
= convert (type
, tmp
);
519 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
525 /* Convert to an integer using the specified rounding mode. */
528 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
534 nargs
= gfc_intrinsic_argument_list_length (expr
);
535 args
= XALLOCAVEC (tree
, nargs
);
537 /* Evaluate the argument, we process all arguments even though we only
538 use the first one for code generation purposes. */
539 type
= gfc_typenode_for_spec (&expr
->ts
);
540 gcc_assert (expr
->value
.function
.actual
->expr
);
541 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
543 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
545 /* Conversion to a different integer kind. */
546 se
->expr
= convert (type
, args
[0]);
550 /* Conversion from complex to non-complex involves taking the real
551 component of the value. */
552 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
553 && expr
->ts
.type
!= BT_COMPLEX
)
557 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
558 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
562 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
567 /* Get the imaginary component of a value. */
570 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
574 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
575 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
576 TREE_TYPE (TREE_TYPE (arg
)), arg
);
580 /* Get the complex conjugate of a value. */
583 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
587 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
588 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
594 define_quad_builtin (const char *name
, tree type
, bool is_const
)
597 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
600 /* Mark the decl as external. */
601 DECL_EXTERNAL (fndecl
) = 1;
602 TREE_PUBLIC (fndecl
) = 1;
604 /* Mark it __attribute__((const)). */
605 TREE_READONLY (fndecl
) = is_const
;
607 rest_of_decl_compilation (fndecl
, 1, 0);
612 /* Add SIMD attribute for FNDECL built-in if the built-in
613 name is in VECTORIZED_BUILTINS. */
616 add_simd_flag_for_built_in (tree fndecl
)
618 if (gfc_vectorized_builtins
== NULL
619 || fndecl
== NULL_TREE
)
622 const char *name
= IDENTIFIER_POINTER (DECL_NAME (fndecl
));
623 int *clauses
= gfc_vectorized_builtins
->get (name
);
626 for (unsigned i
= 0; i
< 3; i
++)
627 if (*clauses
& (1 << i
))
629 gfc_simd_clause simd_type
= (gfc_simd_clause
)*clauses
;
630 tree omp_clause
= NULL_TREE
;
631 if (simd_type
== SIMD_NONE
)
632 ; /* No SIMD clause. */
636 = (simd_type
== SIMD_INBRANCH
637 ? OMP_CLAUSE_INBRANCH
: OMP_CLAUSE_NOTINBRANCH
);
638 omp_clause
= build_omp_clause (UNKNOWN_LOCATION
, code
);
639 omp_clause
= build_tree_list (NULL_TREE
, omp_clause
);
642 DECL_ATTRIBUTES (fndecl
)
643 = tree_cons (get_identifier ("omp declare simd"), omp_clause
,
644 DECL_ATTRIBUTES (fndecl
));
649 /* Set SIMD attribute to all built-in functions that are mentioned
650 in gfc_vectorized_builtins vector. */
653 gfc_adjust_builtins (void)
655 gfc_intrinsic_map_t
*m
;
656 for (m
= gfc_intrinsic_map
;
657 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
659 add_simd_flag_for_built_in (m
->real4_decl
);
660 add_simd_flag_for_built_in (m
->complex4_decl
);
661 add_simd_flag_for_built_in (m
->real8_decl
);
662 add_simd_flag_for_built_in (m
->complex8_decl
);
663 add_simd_flag_for_built_in (m
->real10_decl
);
664 add_simd_flag_for_built_in (m
->complex10_decl
);
665 add_simd_flag_for_built_in (m
->real16_decl
);
666 add_simd_flag_for_built_in (m
->complex16_decl
);
667 add_simd_flag_for_built_in (m
->real16_decl
);
668 add_simd_flag_for_built_in (m
->complex16_decl
);
671 /* Release all strings. */
672 if (gfc_vectorized_builtins
!= NULL
)
674 for (hash_map
<nofree_string_hash
, int>::iterator it
675 = gfc_vectorized_builtins
->begin ();
676 it
!= gfc_vectorized_builtins
->end (); ++it
)
677 free (CONST_CAST (char *, (*it
).first
));
679 delete gfc_vectorized_builtins
;
680 gfc_vectorized_builtins
= NULL
;
684 /* Initialize function decls for library functions. The external functions
685 are created as required. Builtin functions are added here. */
688 gfc_build_intrinsic_lib_fndecls (void)
690 gfc_intrinsic_map_t
*m
;
691 tree quad_decls
[END_BUILTINS
+ 1];
693 if (gfc_real16_is_float128
)
695 /* If we have soft-float types, we create the decls for their
696 C99-like library functions. For now, we only handle _Float128
697 q-suffixed or IEC 60559 f128-suffixed functions. */
699 tree type
, complex_type
, func_1
, func_2
, func_3
, func_cabs
, func_frexp
;
700 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
702 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
704 type
= gfc_float128_type_node
;
705 complex_type
= gfc_complex_float128_type_node
;
706 /* type (*) (type) */
707 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
709 func_iround
= build_function_type_list (integer_type_node
,
711 /* long (*) (type) */
712 func_lround
= build_function_type_list (long_integer_type_node
,
714 /* long long (*) (type) */
715 func_llround
= build_function_type_list (long_long_integer_type_node
,
717 /* type (*) (type, type) */
718 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
719 /* type (*) (type, type, type) */
720 func_3
= build_function_type_list (type
, type
, type
, type
, NULL_TREE
);
721 /* type (*) (type, &int) */
723 = build_function_type_list (type
,
725 build_pointer_type (integer_type_node
),
727 /* type (*) (type, int) */
728 func_scalbn
= build_function_type_list (type
,
729 type
, integer_type_node
, NULL_TREE
);
730 /* type (*) (complex type) */
731 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
732 /* complex type (*) (complex type, complex type) */
734 = build_function_type_list (complex_type
,
735 complex_type
, complex_type
, NULL_TREE
);
737 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
738 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
739 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
741 /* Only these built-ins are actually needed here. These are used directly
742 from the code, when calling builtin_decl_for_precision() or
743 builtin_decl_for_float_type(). The others are all constructed by
744 gfc_get_intrinsic_lib_fndecl(). */
745 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
746 quad_decls[BUILT_IN_ ## ID] \
747 = define_quad_builtin (gfc_real16_use_iec_60559 \
748 ? NAME "f128" : NAME "q", func_ ## TYPE, \
751 #include "mathbuiltins.def"
755 #undef DEFINE_MATH_BUILTIN
756 #undef DEFINE_MATH_BUILTIN_C
758 /* There is one built-in we defined manually, because it gets called
759 with builtin_decl_for_precision() or builtin_decl_for_float_type()
760 even though it is not an OTHER_BUILTIN: it is SQRT. */
761 quad_decls
[BUILT_IN_SQRT
]
762 = define_quad_builtin (gfc_real16_use_iec_60559
763 ? "sqrtf128" : "sqrtq", func_1
, true);
766 /* Add GCC builtin functions. */
767 for (m
= gfc_intrinsic_map
;
768 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
770 if (m
->float_built_in
!= END_BUILTINS
)
771 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
772 if (m
->complex_float_built_in
!= END_BUILTINS
)
773 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
774 if (m
->double_built_in
!= END_BUILTINS
)
775 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
776 if (m
->complex_double_built_in
!= END_BUILTINS
)
777 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
779 /* If real(kind=10) exists, it is always long double. */
780 if (m
->long_double_built_in
!= END_BUILTINS
)
781 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
782 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
784 = builtin_decl_explicit (m
->complex_long_double_built_in
);
786 if (!gfc_real16_is_float128
)
788 if (m
->long_double_built_in
!= END_BUILTINS
)
789 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
790 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
792 = builtin_decl_explicit (m
->complex_long_double_built_in
);
794 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
796 /* Quad-precision function calls are constructed when first
797 needed by builtin_decl_for_precision(), except for those
798 that will be used directly (define by OTHER_BUILTIN). */
799 m
->real16_decl
= quad_decls
[m
->double_built_in
];
801 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
803 /* Same thing for the complex ones. */
804 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
810 /* Create a fndecl for a simple intrinsic library function. */
813 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
816 vec
<tree
, va_gc
> *argtypes
;
818 gfc_actual_arglist
*actual
;
821 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
824 if (ts
->type
== BT_REAL
)
829 pdecl
= &m
->real4_decl
;
832 pdecl
= &m
->real8_decl
;
835 pdecl
= &m
->real10_decl
;
838 pdecl
= &m
->real16_decl
;
844 else if (ts
->type
== BT_COMPLEX
)
846 gcc_assert (m
->complex_available
);
851 pdecl
= &m
->complex4_decl
;
854 pdecl
= &m
->complex8_decl
;
857 pdecl
= &m
->complex10_decl
;
860 pdecl
= &m
->complex16_decl
;
874 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
875 if (gfc_real_kinds
[n
].c_float
)
876 snprintf (name
, sizeof (name
), "%s%s%s",
877 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
878 else if (gfc_real_kinds
[n
].c_double
)
879 snprintf (name
, sizeof (name
), "%s%s",
880 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
881 else if (gfc_real_kinds
[n
].c_long_double
)
882 snprintf (name
, sizeof (name
), "%s%s%s",
883 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
884 else if (gfc_real_kinds
[n
].c_float128
)
885 snprintf (name
, sizeof (name
), "%s%s%s",
886 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
,
887 gfc_real_kinds
[n
].use_iec_60559
? "f128" : "q");
893 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
894 ts
->type
== BT_COMPLEX
? 'c' : 'r',
895 gfc_type_abi_kind (ts
));
899 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
901 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
902 vec_safe_push (argtypes
, type
);
904 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
905 fndecl
= build_decl (input_location
,
906 FUNCTION_DECL
, get_identifier (name
), type
);
908 /* Mark the decl as external. */
909 DECL_EXTERNAL (fndecl
) = 1;
910 TREE_PUBLIC (fndecl
) = 1;
912 /* Mark it __attribute__((const)), if possible. */
913 TREE_READONLY (fndecl
) = m
->is_constant
;
915 rest_of_decl_compilation (fndecl
, 1, 0);
922 /* Convert an intrinsic function into an external or builtin call. */
925 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
927 gfc_intrinsic_map_t
*m
;
931 unsigned int num_args
;
934 id
= expr
->value
.function
.isym
->id
;
935 /* Find the entry for this function. */
936 for (m
= gfc_intrinsic_map
;
937 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
943 if (m
->id
== GFC_ISYM_NONE
)
945 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
946 expr
->value
.function
.name
, id
);
949 /* Get the decl and generate the call. */
950 num_args
= gfc_intrinsic_argument_list_length (expr
);
951 args
= XALLOCAVEC (tree
, num_args
);
953 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
954 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
955 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
957 fndecl
= build_addr (fndecl
);
958 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
962 /* If bounds-checking is enabled, create code to verify at runtime that the
963 string lengths for both expressions are the same (needed for e.g. MERGE).
964 If bounds-checking is not enabled, does nothing. */
967 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
968 tree a
, tree b
, stmtblock_t
* target
)
973 /* If bounds-checking is disabled, do nothing. */
974 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
977 /* Compare the two string lengths. */
978 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, a
, b
);
980 /* Output the runtime-check. */
981 name
= gfc_build_cstring_const (intr_name
);
982 name
= gfc_build_addr_expr (pchar_type_node
, name
);
983 gfc_trans_runtime_check (true, false, cond
, target
, where
,
984 "Unequal character lengths (%ld/%ld) in %s",
985 fold_convert (long_integer_type_node
, a
),
986 fold_convert (long_integer_type_node
, b
), name
);
990 /* The EXPONENT(X) intrinsic function is translated into
992 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
993 so that if X is a NaN or infinity, the result is HUGE(0).
997 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
999 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
1002 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
1003 expr
->value
.function
.actual
->expr
->ts
.kind
);
1005 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1006 arg
= gfc_evaluate_now (arg
, &se
->pre
);
1008 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
1009 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
1010 cond
= build_call_expr_loc (input_location
,
1011 builtin_decl_explicit (BUILT_IN_ISFINITE
),
1014 res
= gfc_create_var (integer_type_node
, NULL
);
1015 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
1016 gfc_build_addr_expr (NULL_TREE
, res
));
1017 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
1019 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
1022 type
= gfc_typenode_for_spec (&expr
->ts
);
1023 se
->expr
= fold_convert (type
, se
->expr
);
1027 /* Fill in the following structure
1028 struct caf_vector_t {
1029 size_t nvec; // size of the vector
1036 ptrdiff_t lower_bound;
1037 ptrdiff_t upper_bound;
1044 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
1045 tree lower
, tree upper
, tree stride
,
1046 tree vector
, int kind
, tree nvec
)
1048 tree field
, type
, tmp
;
1050 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
1051 type
= TREE_TYPE (desc
);
1053 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1054 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1055 desc
, field
, NULL_TREE
);
1056 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
1059 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1060 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1061 desc
, field
, NULL_TREE
);
1062 type
= TREE_TYPE (desc
);
1064 /* Access the inner struct. */
1065 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
1066 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1067 desc
, field
, NULL_TREE
);
1068 type
= TREE_TYPE (desc
);
1070 if (vector
!= NULL_TREE
)
1072 /* Set vector and kind. */
1073 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1074 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1075 desc
, field
, NULL_TREE
);
1076 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
1077 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1078 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1079 desc
, field
, NULL_TREE
);
1080 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
1084 /* Set dim.lower/upper/stride. */
1085 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1086 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1087 desc
, field
, NULL_TREE
);
1088 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1090 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1091 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1092 desc
, field
, NULL_TREE
);
1093 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1095 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1096 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1097 desc
, field
, NULL_TREE
);
1098 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1104 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1107 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1108 tree lbound
, ubound
, tmp
;
1111 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1113 for (i
= 0; i
< ar
->dimen
; i
++)
1114 switch (ar
->dimen_type
[i
])
1119 gfc_init_se (&argse
, NULL
);
1120 gfc_conv_expr (&argse
, ar
->end
[i
]);
1121 gfc_add_block_to_block (block
, &argse
.pre
);
1122 upper
= gfc_evaluate_now (argse
.expr
, block
);
1125 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1128 gfc_init_se (&argse
, NULL
);
1129 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1130 gfc_add_block_to_block (block
, &argse
.pre
);
1131 stride
= gfc_evaluate_now (argse
.expr
, block
);
1134 stride
= gfc_index_one_node
;
1140 gfc_init_se (&argse
, NULL
);
1141 gfc_conv_expr (&argse
, ar
->start
[i
]);
1142 gfc_add_block_to_block (block
, &argse
.pre
);
1143 lower
= gfc_evaluate_now (argse
.expr
, block
);
1146 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1147 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1150 stride
= gfc_index_one_node
;
1153 nvec
= size_zero_node
;
1154 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1159 gfc_init_se (&argse
, NULL
);
1160 argse
.descriptor_only
= 1;
1161 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1162 gfc_add_block_to_block (block
, &argse
.pre
);
1163 vector
= argse
.expr
;
1164 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1165 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1166 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1167 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1168 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1169 TREE_TYPE (nvec
), nvec
, tmp
);
1170 lower
= gfc_index_zero_node
;
1171 upper
= gfc_index_zero_node
;
1172 stride
= gfc_index_zero_node
;
1173 vector
= gfc_conv_descriptor_data_get (vector
);
1174 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1175 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1180 return gfc_build_addr_expr (NULL_TREE
, var
);
1185 compute_component_offset (tree field
, tree type
)
1188 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1189 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1191 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1192 DECL_FIELD_BIT_OFFSET (field
),
1194 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1197 return DECL_FIELD_OFFSET (field
);
1202 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1204 gfc_ref
*ref
= expr
->ref
, *last_comp_ref
;
1205 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1206 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1207 start
, end
, stride
, vector
, nvec
;
1209 bool ref_static_array
= false;
1210 tree last_component_ref_tree
= NULL_TREE
;
1215 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1216 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
1217 && !expr
->symtree
->n
.sym
->attr
.pointer
;
1220 /* Prevent uninit-warning. */
1221 reference_type
= NULL_TREE
;
1223 /* Skip refs upto the first coarray-ref. */
1224 last_comp_ref
= NULL
;
1225 while (ref
&& (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
== 0))
1227 /* Remember the type of components skipped. */
1228 if (ref
->type
== REF_COMPONENT
)
1229 last_comp_ref
= ref
;
1232 /* When a component was skipped, get the type information of the last
1233 component ref, else get the type from the symbol. */
1236 last_type
= gfc_typenode_for_spec (&last_comp_ref
->u
.c
.component
->ts
);
1237 last_type_n
= last_comp_ref
->u
.c
.component
->ts
.type
;
1241 last_type
= gfc_typenode_for_spec (&expr
->symtree
->n
.sym
->ts
);
1242 last_type_n
= expr
->symtree
->n
.sym
->ts
.type
;
1247 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0
1248 && ref
->u
.ar
.dimen
== 0)
1250 /* Skip pure coindexes. */
1254 tmp
= gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1255 reference_type
= TREE_TYPE (tmp
);
1257 if (caf_ref
== NULL_TREE
)
1260 /* Construct the chain of refs. */
1261 if (prev_caf_ref
!= NULL_TREE
)
1263 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1264 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1265 TREE_TYPE (field
), prev_caf_ref
, field
,
1267 gfc_add_modify (block
, tmp2
, gfc_build_addr_expr (TREE_TYPE (field
),
1275 last_type
= gfc_typenode_for_spec (&ref
->u
.c
.component
->ts
);
1276 last_type_n
= ref
->u
.c
.component
->ts
.type
;
1277 /* Set the type of the ref. */
1278 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1279 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1280 TREE_TYPE (field
), prev_caf_ref
, field
,
1282 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1283 GFC_CAF_REF_COMPONENT
));
1285 /* Ref the c in union u. */
1286 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1287 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1288 TREE_TYPE (field
), prev_caf_ref
, field
,
1290 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 0);
1291 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1292 TREE_TYPE (field
), tmp
, field
,
1295 /* Set the offset. */
1296 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1297 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1298 TREE_TYPE (field
), inner_struct
, field
,
1300 /* Computing the offset is somewhat harder. The bit_offset has to be
1301 taken into account. When the bit_offset in the field_decl is non-
1302 null, divide it by the bitsize_unit and add it to the regular
1304 tmp2
= compute_component_offset (ref
->u
.c
.component
->backend_decl
,
1306 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1308 /* Set caf_token_offset. */
1309 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 1);
1310 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1311 TREE_TYPE (field
), inner_struct
, field
,
1313 if ((ref
->u
.c
.component
->attr
.allocatable
1314 || ref
->u
.c
.component
->attr
.pointer
)
1315 && ref
->u
.c
.component
->attr
.dimension
)
1317 tree arr_desc_token_offset
;
1318 /* Get the token field from the descriptor. */
1319 arr_desc_token_offset
= TREE_OPERAND (
1320 gfc_conv_descriptor_token (ref
->u
.c
.component
->backend_decl
), 1);
1321 arr_desc_token_offset
1322 = compute_component_offset (arr_desc_token_offset
,
1324 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
,
1325 TREE_TYPE (tmp2
), tmp2
,
1326 arr_desc_token_offset
);
1328 else if (ref
->u
.c
.component
->caf_token
)
1329 tmp2
= compute_component_offset (ref
->u
.c
.component
->caf_token
,
1332 tmp2
= integer_zero_node
;
1333 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1335 /* Remember whether this ref was to a non-allocatable/non-pointer
1336 component so the next array ref can be tailored correctly. */
1337 ref_static_array
= !ref
->u
.c
.component
->attr
.allocatable
1338 && !ref
->u
.c
.component
->attr
.pointer
;
1339 last_component_ref_tree
= ref_static_array
1340 ? ref
->u
.c
.component
->backend_decl
: NULL_TREE
;
1343 if (ref_static_array
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
)
1344 ref_static_array
= false;
1345 /* Set the type of the ref. */
1346 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1347 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1348 TREE_TYPE (field
), prev_caf_ref
, field
,
1350 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1352 ? GFC_CAF_REF_STATIC_ARRAY
1353 : GFC_CAF_REF_ARRAY
));
1355 /* Ref the a in union u. */
1356 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1357 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1358 TREE_TYPE (field
), prev_caf_ref
, field
,
1360 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 1);
1361 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1362 TREE_TYPE (field
), tmp
, field
,
1365 /* Set the static_array_type in a for static arrays. */
1366 if (ref_static_array
)
1368 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)),
1370 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1371 TREE_TYPE (field
), inner_struct
, field
,
1373 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (tmp
),
1376 /* Ref the mode in the inner_struct. */
1377 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1378 mode
= fold_build3_loc (input_location
, COMPONENT_REF
,
1379 TREE_TYPE (field
), inner_struct
, field
,
1381 /* Ref the dim in the inner_struct. */
1382 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 2);
1383 dim_array
= fold_build3_loc (input_location
, COMPONENT_REF
,
1384 TREE_TYPE (field
), inner_struct
, field
,
1386 for (i
= 0; i
< ref
->u
.ar
.dimen
; ++i
)
1389 dim
= gfc_build_array_ref (dim_array
, gfc_rank_cst
[i
], NULL_TREE
);
1390 dim_type
= TREE_TYPE (dim
);
1391 mode_rhs
= start
= end
= stride
= NULL_TREE
;
1392 switch (ref
->u
.ar
.dimen_type
[i
])
1395 if (ref
->u
.ar
.end
[i
])
1397 gfc_init_se (&se
, NULL
);
1398 gfc_conv_expr (&se
, ref
->u
.ar
.end
[i
]);
1399 gfc_add_block_to_block (block
, &se
.pre
);
1400 if (ref_static_array
)
1402 /* Make the index zero-based, when reffing a static
1405 gfc_init_se (&se
, NULL
);
1406 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1407 gfc_add_block_to_block (block
, &se
.pre
);
1408 se
.expr
= fold_build2 (MINUS_EXPR
,
1409 gfc_array_index_type
,
1411 gfc_array_index_type
,
1414 end
= gfc_evaluate_now (fold_convert (
1415 gfc_array_index_type
,
1419 else if (ref_static_array
)
1420 end
= fold_build2 (MINUS_EXPR
,
1421 gfc_array_index_type
,
1422 gfc_conv_array_ubound (
1423 last_component_ref_tree
, i
),
1424 gfc_conv_array_lbound (
1425 last_component_ref_tree
, i
));
1429 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1430 GFC_CAF_ARR_REF_OPEN_END
);
1432 if (ref
->u
.ar
.stride
[i
])
1434 gfc_init_se (&se
, NULL
);
1435 gfc_conv_expr (&se
, ref
->u
.ar
.stride
[i
]);
1436 gfc_add_block_to_block (block
, &se
.pre
);
1437 stride
= gfc_evaluate_now (fold_convert (
1438 gfc_array_index_type
,
1441 if (ref_static_array
)
1443 /* Make the index zero-based, when reffing a static
1445 stride
= fold_build2 (MULT_EXPR
,
1446 gfc_array_index_type
,
1447 gfc_conv_array_stride (
1448 last_component_ref_tree
,
1451 gcc_assert (end
!= NULL_TREE
);
1452 /* Multiply with the product of array's stride and
1453 the step of the ref to a virtual upper bound.
1454 We cannot compute the actual upper bound here or
1455 the caflib would compute the extend
1457 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1458 end
, gfc_conv_array_stride (
1459 last_component_ref_tree
,
1461 end
= gfc_evaluate_now (end
, block
);
1462 stride
= gfc_evaluate_now (stride
, block
);
1465 else if (ref_static_array
)
1467 stride
= gfc_conv_array_stride (last_component_ref_tree
,
1469 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1471 end
= gfc_evaluate_now (end
, block
);
1474 /* Always set a ref stride of one to make caflib's
1476 stride
= gfc_index_one_node
;
1480 if (ref
->u
.ar
.start
[i
])
1482 gfc_init_se (&se
, NULL
);
1483 gfc_conv_expr (&se
, ref
->u
.ar
.start
[i
]);
1484 gfc_add_block_to_block (block
, &se
.pre
);
1485 if (ref_static_array
)
1487 /* Make the index zero-based, when reffing a static
1489 start
= fold_convert (gfc_array_index_type
, se
.expr
);
1490 gfc_init_se (&se
, NULL
);
1491 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1492 gfc_add_block_to_block (block
, &se
.pre
);
1493 se
.expr
= fold_build2 (MINUS_EXPR
,
1494 gfc_array_index_type
,
1495 start
, fold_convert (
1496 gfc_array_index_type
,
1498 /* Multiply with the stride. */
1499 se
.expr
= fold_build2 (MULT_EXPR
,
1500 gfc_array_index_type
,
1502 gfc_conv_array_stride (
1503 last_component_ref_tree
,
1506 start
= gfc_evaluate_now (fold_convert (
1507 gfc_array_index_type
,
1510 if (mode_rhs
== NULL_TREE
)
1511 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1512 ref
->u
.ar
.dimen_type
[i
]
1514 ? GFC_CAF_ARR_REF_SINGLE
1515 : GFC_CAF_ARR_REF_RANGE
);
1517 else if (ref_static_array
)
1519 start
= integer_zero_node
;
1520 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1521 ref
->u
.ar
.start
[i
] == NULL
1522 ? GFC_CAF_ARR_REF_FULL
1523 : GFC_CAF_ARR_REF_RANGE
);
1525 else if (end
== NULL_TREE
)
1526 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1527 GFC_CAF_ARR_REF_FULL
);
1529 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1530 GFC_CAF_ARR_REF_OPEN_START
);
1532 /* Ref the s in dim. */
1533 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 0);
1534 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1535 TREE_TYPE (field
), dim
, field
,
1538 /* Set start in s. */
1539 if (start
!= NULL_TREE
)
1541 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1543 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1544 TREE_TYPE (field
), tmp
, field
,
1546 gfc_add_modify (block
, tmp2
,
1547 fold_convert (TREE_TYPE (tmp2
), start
));
1551 if (end
!= NULL_TREE
)
1553 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1555 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1556 TREE_TYPE (field
), tmp
, field
,
1558 gfc_add_modify (block
, tmp2
,
1559 fold_convert (TREE_TYPE (tmp2
), end
));
1563 if (stride
!= NULL_TREE
)
1565 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1567 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1568 TREE_TYPE (field
), tmp
, field
,
1570 gfc_add_modify (block
, tmp2
,
1571 fold_convert (TREE_TYPE (tmp2
), stride
));
1575 /* TODO: In case of static array. */
1576 gcc_assert (!ref_static_array
);
1577 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1578 GFC_CAF_ARR_REF_VECTOR
);
1579 gfc_init_se (&se
, NULL
);
1580 se
.descriptor_only
= 1;
1581 gfc_conv_expr_descriptor (&se
, ref
->u
.ar
.start
[i
]);
1582 gfc_add_block_to_block (block
, &se
.pre
);
1584 tmp
= gfc_conv_descriptor_lbound_get (vector
,
1586 tmp2
= gfc_conv_descriptor_ubound_get (vector
,
1588 nvec
= gfc_conv_array_extent_dim (tmp
, tmp2
, NULL
);
1589 tmp
= gfc_conv_descriptor_stride_get (vector
,
1591 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1592 TREE_TYPE (nvec
), nvec
, tmp
);
1593 vector
= gfc_conv_descriptor_data_get (vector
);
1595 /* Ref the v in dim. */
1596 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 1);
1597 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1598 TREE_TYPE (field
), dim
, field
,
1601 /* Set vector in v. */
1602 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 0);
1603 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1604 TREE_TYPE (field
), tmp
, field
,
1606 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1609 /* Set nvec in v. */
1610 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 1);
1611 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1612 TREE_TYPE (field
), tmp
, field
,
1614 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1617 /* Set kind in v. */
1618 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 2);
1619 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1620 TREE_TYPE (field
), tmp
, field
,
1622 gfc_add_modify (block
, tmp2
, build_int_cst (integer_type_node
,
1623 ref
->u
.ar
.start
[i
]->ts
.kind
));
1628 /* Set the mode for dim i. */
1629 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1630 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
),
1634 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1635 if (i
< GFC_MAX_DIMENSIONS
)
1637 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1638 gfc_add_modify (block
, tmp
,
1639 build_int_cst (unsigned_char_type_node
,
1640 GFC_CAF_ARR_REF_NONE
));
1647 /* Set the size of the current type. */
1648 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 2);
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 TYPE_SIZE_UNIT (last_type
)));
1657 if (prev_caf_ref
!= NULL_TREE
)
1659 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1660 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1661 prev_caf_ref
, field
, NULL_TREE
);
1662 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1663 null_pointer_node
));
1665 return caf_ref
!= NULL_TREE
? gfc_build_addr_expr (NULL_TREE
, caf_ref
)
1669 /* Get data from a remote coarray. */
1672 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1673 tree may_require_tmp
, bool may_realloc
,
1674 symbol_attribute
*caf_attr
)
1676 gfc_expr
*array_expr
, *tmp_stat
;
1678 tree caf_decl
, token
, offset
, image_index
, tmp
;
1679 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
1681 symbol_attribute caf_attr_store
;
1683 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1685 if (se
->ss
&& se
->ss
->info
->useflags
)
1687 /* Access the previously obtained result. */
1688 gfc_conv_tmp_array_ref (se
);
1692 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1693 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1694 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1696 if (caf_attr
== NULL
)
1698 caf_attr_store
= gfc_caf_attr (array_expr
);
1699 caf_attr
= &caf_attr_store
;
1705 vec
= null_pointer_node
;
1706 tmp_stat
= gfc_find_stat_co (expr
);
1711 gfc_init_se (&stat_se
, NULL
);
1712 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1713 stat
= stat_se
.expr
;
1714 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1715 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1718 stat
= null_pointer_node
;
1720 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1721 is reallocatable or the right-hand side has allocatable components. */
1722 if (caf_attr
->alloc_comp
|| caf_attr
->pointer_comp
|| may_realloc
)
1724 /* Get using caf_get_by_ref. */
1725 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, array_expr
);
1727 if (caf_reference
!= NULL_TREE
)
1729 if (lhs
== NULL_TREE
)
1731 if (array_expr
->ts
.type
== BT_CHARACTER
)
1732 gfc_init_se (&argse
, NULL
);
1733 if (array_expr
->rank
== 0)
1735 symbol_attribute attr
;
1736 gfc_clear_attr (&attr
);
1737 if (array_expr
->ts
.type
== BT_CHARACTER
)
1739 res_var
= gfc_conv_string_tmp (se
,
1740 build_pointer_type (type
),
1741 array_expr
->ts
.u
.cl
->backend_decl
);
1742 argse
.string_length
= array_expr
->ts
.u
.cl
->backend_decl
;
1745 res_var
= gfc_create_var (type
, "caf_res");
1746 dst_var
= gfc_conv_scalar_to_descriptor (se
, res_var
, attr
);
1747 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1751 /* Create temporary. */
1752 if (array_expr
->ts
.type
== BT_CHARACTER
)
1753 gfc_conv_expr_descriptor (&argse
, array_expr
);
1754 may_realloc
= gfc_trans_create_temp_array (&se
->pre
,
1761 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1762 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1765 tmp
= gfc_conv_descriptor_data_get (res_var
);
1766 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
,
1767 NULL_TREE
, NULL_TREE
,
1770 GFC_CAF_COARRAY_NOCOARRAY
);
1771 gfc_add_expr_to_block (&se
->post
, tmp
);
1776 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1777 if (lhs_kind
== NULL_TREE
)
1780 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1781 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1782 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1783 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1785 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1788 /* No overlap possible as we have generated a temporary. */
1789 if (lhs
== NULL_TREE
)
1790 may_require_tmp
= boolean_false_node
;
1792 /* It guarantees memory consistency within the same segment. */
1793 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1794 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1795 gfc_build_string_const (1, ""), NULL_TREE
,
1796 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1798 ASM_VOLATILE_P (tmp
) = 1;
1799 gfc_add_expr_to_block (&se
->pre
, tmp
);
1801 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1802 10, token
, image_index
, dst_var
,
1803 caf_reference
, lhs_kind
, kind
,
1805 may_realloc
? boolean_true_node
:
1807 stat
, build_int_cst (integer_type_node
,
1808 array_expr
->ts
.type
));
1810 gfc_add_expr_to_block (&se
->pre
, tmp
);
1813 gfc_advance_se_ss_chain (se
);
1816 if (array_expr
->ts
.type
== BT_CHARACTER
)
1817 se
->string_length
= argse
.string_length
;
1823 gfc_init_se (&argse
, NULL
);
1824 if (array_expr
->rank
== 0)
1826 symbol_attribute attr
;
1828 gfc_clear_attr (&attr
);
1829 gfc_conv_expr (&argse
, array_expr
);
1831 if (lhs
== NULL_TREE
)
1833 gfc_clear_attr (&attr
);
1834 if (array_expr
->ts
.type
== BT_CHARACTER
)
1835 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1836 argse
.string_length
);
1838 res_var
= gfc_create_var (type
, "caf_res");
1839 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1840 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1842 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1843 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1847 /* If has_vector, pass descriptor for whole array and the
1848 vector bounds separately. */
1849 gfc_array_ref
*ar
, ar2
;
1850 bool has_vector
= false;
1852 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1855 ar
= gfc_find_array_ref (expr
);
1857 memset (ar
, '\0', sizeof (*ar
));
1861 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1862 gfc_conv_expr_descriptor (&argse
, array_expr
);
1863 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1864 has the wrong type if component references are done. */
1865 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1866 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1871 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1875 if (lhs
== NULL_TREE
)
1877 /* Create temporary. */
1878 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1879 if (se
->loop
->to
[n
] == NULL_TREE
)
1881 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1883 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1886 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1887 NULL_TREE
, false, true, false,
1888 &array_expr
->where
);
1889 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1890 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1892 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1895 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1896 if (lhs_kind
== NULL_TREE
)
1899 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1900 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1902 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1903 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1904 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1905 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1906 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1909 /* No overlap possible as we have generated a temporary. */
1910 if (lhs
== NULL_TREE
)
1911 may_require_tmp
= boolean_false_node
;
1913 /* It guarantees memory consistency within the same segment. */
1914 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1915 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1916 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1917 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1918 ASM_VOLATILE_P (tmp
) = 1;
1919 gfc_add_expr_to_block (&se
->pre
, tmp
);
1921 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1922 token
, offset
, image_index
, argse
.expr
, vec
,
1923 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1925 gfc_add_expr_to_block (&se
->pre
, tmp
);
1928 gfc_advance_se_ss_chain (se
);
1931 if (array_expr
->ts
.type
== BT_CHARACTER
)
1932 se
->string_length
= argse
.string_length
;
1936 /* Send data to a remote coarray. */
1939 conv_caf_send (gfc_code
*code
) {
1940 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
, *tmp_team
;
1941 gfc_se lhs_se
, rhs_se
;
1943 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1944 tree may_require_tmp
, src_stat
, dst_stat
, dst_team
;
1945 tree lhs_type
= NULL_TREE
;
1946 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1947 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1949 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1951 lhs_expr
= code
->ext
.actual
->expr
;
1952 rhs_expr
= code
->ext
.actual
->next
->expr
;
1953 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, true) == 0
1954 ? boolean_false_node
: boolean_true_node
;
1955 gfc_init_block (&block
);
1957 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1958 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1959 src_stat
= dst_stat
= null_pointer_node
;
1960 dst_team
= null_pointer_node
;
1963 gfc_init_se (&lhs_se
, NULL
);
1964 if (lhs_expr
->rank
== 0)
1966 if (lhs_expr
->ts
.type
== BT_CHARACTER
&& lhs_expr
->ts
.deferred
)
1968 lhs_se
.expr
= gfc_get_tree_for_caf_expr (lhs_expr
);
1969 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1973 symbol_attribute attr
;
1974 gfc_clear_attr (&attr
);
1975 gfc_conv_expr (&lhs_se
, lhs_expr
);
1976 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1977 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
,
1979 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1982 else if ((lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
1983 && lhs_caf_attr
.codimension
)
1985 lhs_se
.want_pointer
= 1;
1986 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1987 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1988 has the wrong type if component references are done. */
1989 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1990 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1991 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1992 gfc_get_dtype_rank_type (
1993 gfc_has_vector_subscript (lhs_expr
)
1994 ? gfc_find_array_ref (lhs_expr
)->dimen
2000 bool has_vector
= gfc_has_vector_subscript (lhs_expr
);
2002 if (gfc_is_coindexed (lhs_expr
) || !has_vector
)
2004 /* If has_vector, pass descriptor for whole array and the
2005 vector bounds separately. */
2006 gfc_array_ref
*ar
, ar2
;
2007 bool has_tmp_lhs_array
= false;
2010 has_tmp_lhs_array
= true;
2011 ar
= gfc_find_array_ref (lhs_expr
);
2013 memset (ar
, '\0', sizeof (*ar
));
2017 lhs_se
.want_pointer
= 1;
2018 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
2019 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
2020 that has the wrong type if component references are done. */
2021 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
2022 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
2023 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2024 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2027 if (has_tmp_lhs_array
)
2029 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
2035 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
2036 indexed array expression. This is rewritten to:
2038 tmp_array = arr2[...]
2039 arr1 ([...]) = tmp_array
2041 because using the standard gfc_conv_expr (lhs_expr) did the
2042 assignment with lhs and rhs exchanged. */
2044 gfc_ss
*lss_for_tmparray
, *lss_real
;
2048 tree tmparr_desc
, src
;
2049 tree index
= gfc_index_zero_node
;
2050 tree stride
= gfc_index_zero_node
;
2053 /* Walk both sides of the assignment, once to get the shape of the
2054 temporary array to create right. */
2055 lss_for_tmparray
= gfc_walk_expr (lhs_expr
);
2056 /* And a second time to be able to create an assignment of the
2057 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
2058 the tree in the descriptor with the one for the temporary
2060 lss_real
= gfc_walk_expr (lhs_expr
);
2061 gfc_init_loopinfo (&loop
);
2062 gfc_add_ss_to_loop (&loop
, lss_for_tmparray
);
2063 gfc_add_ss_to_loop (&loop
, lss_real
);
2064 gfc_conv_ss_startstride (&loop
);
2065 gfc_conv_loop_setup (&loop
, &lhs_expr
->where
);
2066 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
2067 gfc_trans_create_temp_array (&lhs_se
.pre
, &lhs_se
.post
,
2068 lss_for_tmparray
, lhs_type
, NULL_TREE
,
2071 tmparr_desc
= lss_for_tmparray
->info
->data
.array
.descriptor
;
2072 gfc_start_scalarized_body (&loop
, &body
);
2073 gfc_init_se (&se
, NULL
);
2074 gfc_copy_loopinfo_to_se (&se
, &loop
);
2076 gfc_conv_expr (&se
, lhs_expr
);
2077 gfc_add_block_to_block (&body
, &se
.pre
);
2079 /* Walk over all indexes of the loop. */
2080 for (n
= loop
.dimen
- 1; n
> 0; --n
)
2082 tmp
= loop
.loopvar
[n
];
2083 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2084 gfc_array_index_type
, tmp
, loop
.from
[n
]);
2085 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2086 gfc_array_index_type
, tmp
, index
);
2088 stride
= fold_build2_loc (input_location
, MINUS_EXPR
,
2089 gfc_array_index_type
,
2090 loop
.to
[n
- 1], loop
.from
[n
- 1]);
2091 stride
= fold_build2_loc (input_location
, PLUS_EXPR
,
2092 gfc_array_index_type
,
2093 stride
, gfc_index_one_node
);
2095 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2096 gfc_array_index_type
, tmp
, stride
);
2099 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2100 gfc_array_index_type
,
2101 index
, loop
.from
[0]);
2103 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2104 gfc_array_index_type
,
2105 loop
.loopvar
[0], index
);
2107 src
= build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc
));
2108 src
= gfc_build_array_ref (src
, index
, NULL
);
2109 /* Now create the assignment of lhs_expr = tmp_array. */
2110 gfc_add_modify (&body
, se
.expr
, src
);
2111 gfc_add_block_to_block (&body
, &se
.post
);
2112 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, tmparr_desc
);
2113 gfc_trans_scalarizing_loops (&loop
, &body
);
2114 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2115 gfc_add_expr_to_block (&lhs_se
.post
, gfc_finish_block (&loop
.pre
));
2116 gfc_free_ss (lss_for_tmparray
);
2117 gfc_free_ss (lss_real
);
2121 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
2123 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2124 temporary and a loop. */
2125 if (!gfc_is_coindexed (lhs_expr
)
2126 && (!lhs_caf_attr
.codimension
2127 || !(lhs_expr
->rank
> 0
2128 && (lhs_caf_attr
.allocatable
|| lhs_caf_attr
.pointer
))))
2130 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
2131 gcc_assert (gfc_is_coindexed (rhs_expr
));
2132 gfc_init_se (&rhs_se
, NULL
);
2133 if (lhs_expr
->rank
== 0 && lhs_caf_attr
.allocatable
)
2136 gfc_init_se (&scal_se
, NULL
);
2137 scal_se
.want_pointer
= 1;
2138 gfc_conv_expr (&scal_se
, lhs_expr
);
2139 /* Ensure scalar on lhs is allocated. */
2140 gfc_add_block_to_block (&block
, &scal_se
.pre
);
2142 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
2144 gfc_typenode_for_spec (&lhs_expr
->ts
)),
2146 tmp
= fold_build2 (EQ_EXPR
, logical_type_node
, scal_se
.expr
,
2148 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2149 tmp
, gfc_finish_block (&scal_se
.pre
),
2150 build_empty_stmt (input_location
));
2151 gfc_add_expr_to_block (&block
, tmp
);
2154 lhs_may_realloc
= lhs_may_realloc
2155 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
2156 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2157 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
2158 may_require_tmp
, lhs_may_realloc
,
2160 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2161 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2162 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2163 return gfc_finish_block (&block
);
2166 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2168 /* Obtain token, offset and image index for the LHS. */
2169 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
2170 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2171 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2172 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
2174 if (lhs_caf_attr
.alloc_comp
)
2175 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
2178 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
2183 gfc_init_se (&rhs_se
, NULL
);
2184 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
2185 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2186 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
2187 if (rhs_expr
->rank
== 0)
2189 symbol_attribute attr
;
2190 gfc_clear_attr (&attr
);
2191 gfc_conv_expr (&rhs_se
, rhs_expr
);
2192 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
2193 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2195 else if ((rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2196 && rhs_caf_attr
.codimension
)
2199 rhs_se
.want_pointer
= 1;
2200 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2201 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2202 has the wrong type if component references are done. */
2203 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2204 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2205 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2206 gfc_get_dtype_rank_type (
2207 gfc_has_vector_subscript (rhs_expr
)
2208 ? gfc_find_array_ref (rhs_expr
)->dimen
2214 /* If has_vector, pass descriptor for whole array and the
2215 vector bounds separately. */
2216 gfc_array_ref
*ar
, ar2
;
2217 bool has_vector
= false;
2220 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2223 ar
= gfc_find_array_ref (rhs_expr
);
2225 memset (ar
, '\0', sizeof (*ar
));
2229 rhs_se
.want_pointer
= 1;
2230 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2231 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2232 has the wrong type if component references are done. */
2233 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2234 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2235 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2236 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2241 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2246 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2248 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2250 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2255 gfc_init_se (&stat_se
, NULL
);
2256 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2257 dst_stat
= stat_se
.expr
;
2258 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2259 gfc_add_block_to_block (&block
, &stat_se
.post
);
2262 tmp_team
= gfc_find_team_co (lhs_expr
);
2267 gfc_init_se (&team_se
, NULL
);
2268 gfc_conv_expr_reference (&team_se
, tmp_team
);
2269 dst_team
= team_se
.expr
;
2270 gfc_add_block_to_block (&block
, &team_se
.pre
);
2271 gfc_add_block_to_block (&block
, &team_se
.post
);
2274 if (!gfc_is_coindexed (rhs_expr
))
2276 if (lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
2278 tree reference
, dst_realloc
;
2279 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2280 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2281 : boolean_false_node
;
2282 tmp
= build_call_expr_loc (input_location
,
2283 gfor_fndecl_caf_send_by_ref
,
2284 10, token
, image_index
, rhs_se
.expr
,
2285 reference
, lhs_kind
, rhs_kind
,
2286 may_require_tmp
, dst_realloc
, src_stat
,
2287 build_int_cst (integer_type_node
,
2288 lhs_expr
->ts
.type
));
2291 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 11,
2292 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2293 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2294 may_require_tmp
, src_stat
, dst_team
);
2298 tree rhs_token
, rhs_offset
, rhs_image_index
;
2300 /* It guarantees memory consistency within the same segment. */
2301 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2302 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2303 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2304 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2305 ASM_VOLATILE_P (tmp
) = 1;
2306 gfc_add_expr_to_block (&block
, tmp
);
2308 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2309 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2310 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2311 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2313 if (rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2315 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2320 gfc_init_se (&stat_se
, NULL
);
2321 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2322 src_stat
= stat_se
.expr
;
2323 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2324 gfc_add_block_to_block (&block
, &stat_se
.post
);
2327 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2329 tree lhs_reference
, rhs_reference
;
2330 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2331 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2332 tmp
= build_call_expr_loc (input_location
,
2333 gfor_fndecl_caf_sendget_by_ref
, 13,
2334 token
, image_index
, lhs_reference
,
2335 rhs_token
, rhs_image_index
, rhs_reference
,
2336 lhs_kind
, rhs_kind
, may_require_tmp
,
2338 build_int_cst (integer_type_node
,
2340 build_int_cst (integer_type_node
,
2341 rhs_expr
->ts
.type
));
2345 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2347 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2348 14, token
, offset
, image_index
,
2349 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2350 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2351 rhs_kind
, may_require_tmp
, src_stat
);
2354 gfc_add_expr_to_block (&block
, tmp
);
2355 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2356 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2358 /* It guarantees memory consistency within the same segment. */
2359 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2360 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2361 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2362 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2363 ASM_VOLATILE_P (tmp
) = 1;
2364 gfc_add_expr_to_block (&block
, tmp
);
2366 return gfc_finish_block (&block
);
2371 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2374 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2375 lbound
, ubound
, extent
, ml
;
2378 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2380 if (expr
->value
.function
.actual
->expr
2381 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2382 distance
= expr
->value
.function
.actual
->expr
;
2384 /* The case -fcoarray=single is handled elsewhere. */
2385 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2387 /* Argument-free version: THIS_IMAGE(). */
2388 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2392 gfc_init_se (&argse
, NULL
);
2393 gfc_conv_expr_val (&argse
, distance
);
2394 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2395 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2396 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2399 tmp
= integer_zero_node
;
2400 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2402 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2407 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2409 type
= gfc_get_int_type (gfc_default_integer_kind
);
2410 corank
= expr
->value
.function
.actual
->expr
->corank
;
2411 rank
= expr
->value
.function
.actual
->expr
->rank
;
2413 /* Obtain the descriptor of the COARRAY. */
2414 gfc_init_se (&argse
, NULL
);
2415 argse
.want_coarray
= 1;
2416 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2417 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2418 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2423 /* Create an implicit second parameter from the loop variable. */
2424 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2425 gcc_assert (corank
> 0);
2426 gcc_assert (se
->loop
->dimen
== 1);
2427 gcc_assert (se
->ss
->info
->expr
== expr
);
2429 dim_arg
= se
->loop
->loopvar
[0];
2430 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2431 gfc_array_index_type
, dim_arg
,
2432 build_int_cst (TREE_TYPE (dim_arg
), 1));
2433 gfc_advance_se_ss_chain (se
);
2437 /* Use the passed DIM= argument. */
2438 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2439 gfc_init_se (&argse
, NULL
);
2440 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2441 gfc_array_index_type
);
2442 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2443 dim_arg
= argse
.expr
;
2445 if (INTEGER_CST_P (dim_arg
))
2447 if (wi::ltu_p (wi::to_wide (dim_arg
), 1)
2448 || wi::gtu_p (wi::to_wide (dim_arg
),
2449 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2450 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2451 "dimension index", expr
->value
.function
.isym
->name
,
2454 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2456 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2457 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2459 build_int_cst (TREE_TYPE (dim_arg
), 1));
2460 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2461 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2463 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2464 logical_type_node
, cond
, tmp
);
2465 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2470 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2471 one always has a dim_arg argument.
2473 m = this_image() - 1
2476 sub(1) = m + lcobound(corank)
2480 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2483 extent = gfc_extent(i)
2491 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2492 : m + lcobound(corank)
2495 /* this_image () - 1. */
2496 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2498 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2499 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2502 /* sub(1) = m + lcobound(corank). */
2503 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2504 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2506 lbound
= fold_convert (type
, lbound
);
2507 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2513 m
= gfc_create_var (type
, NULL
);
2514 ml
= gfc_create_var (type
, NULL
);
2515 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2516 min_var
= gfc_create_var (integer_type_node
, NULL
);
2518 /* m = this_image () - 1. */
2519 gfc_add_modify (&se
->pre
, m
, tmp
);
2521 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2522 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2523 fold_convert (integer_type_node
, dim_arg
),
2524 build_int_cst (integer_type_node
, rank
- 1));
2525 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2526 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2528 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2531 tmp
= build_int_cst (integer_type_node
, rank
);
2532 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2534 exit_label
= gfc_build_label_decl (NULL_TREE
);
2535 TREE_USED (exit_label
) = 1;
2538 gfc_init_block (&loop
);
2541 gfc_add_modify (&loop
, ml
, m
);
2544 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2545 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2546 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2547 extent
= fold_convert (type
, extent
);
2550 gfc_add_modify (&loop
, m
,
2551 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2554 /* Exit condition: if (i >= min_var) goto exit_label. */
2555 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, loop_var
,
2557 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2558 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2559 build_empty_stmt (input_location
));
2560 gfc_add_expr_to_block (&loop
, tmp
);
2562 /* Increment loop variable: i++. */
2563 gfc_add_modify (&loop
, loop_var
,
2564 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2568 /* Making the loop... actually loop! */
2569 tmp
= gfc_finish_block (&loop
);
2570 tmp
= build1_v (LOOP_EXPR
, tmp
);
2571 gfc_add_expr_to_block (&se
->pre
, tmp
);
2573 /* The exit label. */
2574 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2575 gfc_add_expr_to_block (&se
->pre
, tmp
);
2577 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2578 : m + lcobound(corank) */
2580 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, dim_arg
,
2581 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2583 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2584 fold_build2_loc (input_location
, PLUS_EXPR
,
2585 gfc_array_index_type
, dim_arg
,
2586 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2587 lbound
= fold_convert (type
, lbound
);
2589 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2590 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2592 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2594 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2595 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2600 /* Convert a call to image_status. */
2603 conv_intrinsic_image_status (gfc_se
*se
, gfc_expr
*expr
)
2605 unsigned int num_args
;
2608 num_args
= gfc_intrinsic_argument_list_length (expr
);
2609 args
= XALLOCAVEC (tree
, num_args
);
2610 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2611 /* In args[0] the number of the image the status is desired for has to be
2614 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2617 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2618 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2619 fold_convert (integer_type_node
, arg
),
2621 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2622 tmp
, integer_zero_node
,
2623 build_int_cst (integer_type_node
,
2624 GFC_STAT_STOPPED_IMAGE
));
2626 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2627 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_image_status
, 2,
2628 args
[0], build_int_cst (integer_type_node
, -1));
2632 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2636 conv_intrinsic_team_number (gfc_se
*se
, gfc_expr
*expr
)
2638 unsigned int num_args
;
2642 num_args
= gfc_intrinsic_argument_list_length (expr
);
2643 args
= XALLOCAVEC (tree
, num_args
);
2644 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2647 GFC_FCOARRAY_SINGLE
&& expr
->value
.function
.actual
->expr
)
2651 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2652 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2653 fold_convert (integer_type_node
, arg
),
2655 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2656 tmp
, integer_zero_node
,
2657 build_int_cst (integer_type_node
,
2658 GFC_STAT_STOPPED_IMAGE
));
2660 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2662 // the value -1 represents that no team has been created yet
2663 tmp
= build_int_cst (integer_type_node
, -1);
2665 else if (flag_coarray
== GFC_FCOARRAY_LIB
&& expr
->value
.function
.actual
->expr
)
2666 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2667 args
[0], build_int_cst (integer_type_node
, -1));
2668 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2669 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2670 integer_zero_node
, build_int_cst (integer_type_node
, -1));
2674 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2679 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2681 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2683 gfc_se argse
, subse
;
2684 int rank
, corank
, codim
;
2686 type
= gfc_get_int_type (gfc_default_integer_kind
);
2687 corank
= expr
->value
.function
.actual
->expr
->corank
;
2688 rank
= expr
->value
.function
.actual
->expr
->rank
;
2690 /* Obtain the descriptor of the COARRAY. */
2691 gfc_init_se (&argse
, NULL
);
2692 argse
.want_coarray
= 1;
2693 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2694 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2695 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2698 /* Obtain a handle to the SUB argument. */
2699 gfc_init_se (&subse
, NULL
);
2700 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2701 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2702 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2703 subdesc
= build_fold_indirect_ref_loc (input_location
,
2704 gfc_conv_descriptor_data_get (subse
.expr
));
2706 /* Fortran 2008 does not require that the values remain in the cobounds,
2707 thus we need explicitly check this - and return 0 if they are exceeded. */
2709 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2710 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2711 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2712 fold_convert (gfc_array_index_type
, tmp
),
2715 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2717 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2718 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2719 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2720 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2721 fold_convert (gfc_array_index_type
, tmp
),
2723 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2724 logical_type_node
, invalid_bound
, cond
);
2725 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2726 fold_convert (gfc_array_index_type
, tmp
),
2728 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2729 logical_type_node
, invalid_bound
, cond
);
2732 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2734 /* See Fortran 2008, C.10 for the following algorithm. */
2736 /* coindex = sub(corank) - lcobound(n). */
2737 coindex
= fold_convert (gfc_array_index_type
,
2738 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2740 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2741 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2742 fold_convert (gfc_array_index_type
, coindex
),
2745 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2747 tree extent
, ubound
;
2749 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2750 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2751 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2752 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2754 /* coindex *= extent. */
2755 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2756 gfc_array_index_type
, coindex
, extent
);
2758 /* coindex += sub(codim). */
2759 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2760 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2761 gfc_array_index_type
, coindex
,
2762 fold_convert (gfc_array_index_type
, tmp
));
2764 /* coindex -= lbound(codim). */
2765 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2766 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2767 gfc_array_index_type
, coindex
, lbound
);
2770 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2771 fold_convert(type
, coindex
),
2772 build_int_cst (type
, 1));
2774 /* Return 0 if "coindex" exceeds num_images(). */
2776 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2777 num_images
= build_int_cst (type
, 1);
2780 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2782 build_int_cst (integer_type_node
, -1));
2783 num_images
= fold_convert (type
, tmp
);
2786 tmp
= gfc_create_var (type
, NULL
);
2787 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2789 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, tmp
,
2791 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
2793 fold_convert (logical_type_node
, invalid_bound
));
2794 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2795 build_int_cst (type
, 0), tmp
);
2799 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2801 tree tmp
, distance
, failed
;
2804 if (expr
->value
.function
.actual
->expr
)
2806 gfc_init_se (&argse
, NULL
);
2807 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2808 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2809 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2810 distance
= fold_convert (integer_type_node
, argse
.expr
);
2813 distance
= integer_zero_node
;
2815 if (expr
->value
.function
.actual
->next
->expr
)
2817 gfc_init_se (&argse
, NULL
);
2818 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2819 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2820 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2821 failed
= fold_convert (integer_type_node
, argse
.expr
);
2824 failed
= build_int_cst (integer_type_node
, -1);
2825 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2827 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2832 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2836 gfc_init_se (&argse
, NULL
);
2837 argse
.data_not_needed
= 1;
2838 argse
.descriptor_only
= 1;
2840 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2841 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2842 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2844 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2845 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2851 gfc_conv_intrinsic_is_contiguous (gfc_se
* se
, gfc_expr
* expr
)
2854 arg
= expr
->value
.function
.actual
->expr
;
2855 gfc_conv_is_contiguous_expr (se
, arg
);
2856 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2859 /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2860 plus it can be called directly. */
2863 gfc_conv_is_contiguous_expr (gfc_se
*se
, gfc_expr
*arg
)
2867 tree desc
, tmp
, stride
, extent
, cond
;
2872 if (arg
->ts
.type
== BT_CLASS
)
2873 gfc_add_class_array_ref (arg
);
2875 ss
= gfc_walk_expr (arg
);
2876 gcc_assert (ss
!= gfc_ss_terminator
);
2877 gfc_init_se (&argse
, NULL
);
2878 argse
.data_not_needed
= 1;
2879 gfc_conv_expr_descriptor (&argse
, arg
);
2881 as
= gfc_get_full_arrayspec_from_expr (arg
);
2883 /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2884 Note in addition that zero-sized arrays don't count as contiguous. */
2886 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2888 /* Build the call to is_contiguous0. */
2889 argse
.want_pointer
= 1;
2890 gfc_conv_expr_descriptor (&argse
, arg
);
2891 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2892 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2893 desc
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2894 fncall0
= build_call_expr_loc (input_location
,
2895 gfor_fndecl_is_contiguous0
, 1, desc
);
2897 se
->expr
= convert (logical_type_node
, se
->expr
);
2901 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2902 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2903 desc
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2905 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[0]);
2906 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2907 stride
, build_int_cst (TREE_TYPE (stride
), 1));
2909 for (i
= 0; i
< arg
->rank
- 1; i
++)
2911 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2912 extent
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2913 extent
= fold_build2_loc (input_location
, MINUS_EXPR
,
2914 gfc_array_index_type
, extent
, tmp
);
2915 extent
= fold_build2_loc (input_location
, PLUS_EXPR
,
2916 gfc_array_index_type
, extent
,
2917 gfc_index_one_node
);
2918 tmp
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[i
]);
2919 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2921 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[i
+1]);
2922 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2924 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2925 boolean_type_node
, cond
, tmp
);
2932 /* Evaluate a single upper or lower bound. */
2933 /* TODO: bound intrinsic generates way too much unnecessary code. */
2936 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, enum gfc_isym_id op
)
2938 gfc_actual_arglist
*arg
;
2939 gfc_actual_arglist
*arg2
;
2949 gfc_array_spec
* as
;
2950 bool assumed_rank_lb_one
;
2952 arg
= expr
->value
.function
.actual
;
2957 /* Create an implicit second parameter from the loop variable. */
2958 gcc_assert (!arg2
->expr
|| op
== GFC_ISYM_SHAPE
);
2959 gcc_assert (se
->loop
->dimen
== 1);
2960 gcc_assert (se
->ss
->info
->expr
== expr
);
2961 gfc_advance_se_ss_chain (se
);
2962 bound
= se
->loop
->loopvar
[0];
2963 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2964 gfc_array_index_type
, bound
,
2969 /* use the passed argument. */
2970 gcc_assert (arg2
->expr
);
2971 gfc_init_se (&argse
, NULL
);
2972 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2973 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2975 /* Convert from one based to zero based. */
2976 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2977 gfc_array_index_type
, bound
,
2978 gfc_index_one_node
);
2981 /* TODO: don't re-evaluate the descriptor on each iteration. */
2982 /* Get a descriptor for the first parameter. */
2983 gfc_init_se (&argse
, NULL
);
2984 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2985 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2986 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2990 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2992 if (INTEGER_CST_P (bound
))
2994 gcc_assert (op
!= GFC_ISYM_SHAPE
);
2995 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2996 && wi::geu_p (wi::to_wide (bound
),
2997 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2998 || wi::gtu_p (wi::to_wide (bound
), GFC_MAX_DIMENSIONS
))
2999 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3001 (op
== GFC_ISYM_UBOUND
) ? "UBOUND" : "LBOUND",
3005 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
3007 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3009 bound
= gfc_evaluate_now (bound
, &se
->pre
);
3010 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3011 bound
, build_int_cst (TREE_TYPE (bound
), 0));
3012 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3013 tmp
= gfc_conv_descriptor_rank (desc
);
3015 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
3016 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3017 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
3018 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3019 logical_type_node
, cond
, tmp
);
3020 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
3025 /* Take care of the lbound shift for assumed-rank arrays that are
3026 nonallocatable and nonpointers. Those have a lbound of 1. */
3027 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
3028 && ((arg
->expr
->ts
.type
!= BT_CLASS
3029 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
3030 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
3031 || (arg
->expr
->ts
.type
== BT_CLASS
3032 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
3033 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
3035 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3036 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3037 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
3038 gfc_array_index_type
, ubound
, lbound
);
3039 size
= fold_build2_loc (input_location
, PLUS_EXPR
,
3040 gfc_array_index_type
, size
, gfc_index_one_node
);
3042 /* 13.14.53: Result value for LBOUND
3044 Case (i): For an array section or for an array expression other than a
3045 whole array or array structure component, LBOUND(ARRAY, DIM)
3046 has the value 1. For a whole array or array structure
3047 component, LBOUND(ARRAY, DIM) has the value:
3048 (a) equal to the lower bound for subscript DIM of ARRAY if
3049 dimension DIM of ARRAY does not have extent zero
3050 or if ARRAY is an assumed-size array of rank DIM,
3053 13.14.113: Result value for UBOUND
3055 Case (i): For an array section or for an array expression other than a
3056 whole array or array structure component, UBOUND(ARRAY, DIM)
3057 has the value equal to the number of elements in the given
3058 dimension; otherwise, it has a value equal to the upper bound
3059 for subscript DIM of ARRAY if dimension DIM of ARRAY does
3060 not have size zero and has value zero if dimension DIM has
3063 if (op
== GFC_ISYM_LBOUND
&& assumed_rank_lb_one
)
3064 se
->expr
= gfc_index_one_node
;
3067 if (op
== GFC_ISYM_UBOUND
)
3069 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3070 size
, gfc_index_zero_node
);
3071 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3072 gfc_array_index_type
, cond
,
3073 (assumed_rank_lb_one
? size
: ubound
),
3074 gfc_index_zero_node
);
3076 else if (op
== GFC_ISYM_LBOUND
)
3078 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3079 size
, gfc_index_zero_node
);
3080 if (as
->type
== AS_ASSUMED_SIZE
)
3082 cond1
= fold_build2_loc (input_location
, EQ_EXPR
,
3083 logical_type_node
, bound
,
3084 build_int_cst (TREE_TYPE (bound
),
3085 arg
->expr
->rank
- 1));
3086 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3087 logical_type_node
, cond
, cond1
);
3089 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3090 gfc_array_index_type
, cond
,
3091 lbound
, gfc_index_one_node
);
3093 else if (op
== GFC_ISYM_SHAPE
)
3094 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
3095 gfc_array_index_type
, size
,
3096 gfc_index_zero_node
);
3100 /* According to F2018 16.9.172, para 5, an assumed rank object,
3101 argument associated with and assumed size array, has the ubound
3102 of the final dimension set to -1 and UBOUND must return this.
3103 Similarly for the SHAPE intrinsic. */
3104 if (op
!= GFC_ISYM_LBOUND
&& assumed_rank_lb_one
)
3106 tree minus_one
= build_int_cst (gfc_array_index_type
, -1);
3107 tree rank
= fold_convert (gfc_array_index_type
,
3108 gfc_conv_descriptor_rank (desc
));
3109 rank
= fold_build2_loc (input_location
, PLUS_EXPR
,
3110 gfc_array_index_type
, rank
, minus_one
);
3112 /* Fix the expression to stop it from becoming even more
3114 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3116 /* Descriptors for assumed-size arrays have ubound = -1
3117 in the last dimension. */
3118 cond1
= fold_build2_loc (input_location
, EQ_EXPR
,
3119 logical_type_node
, ubound
, minus_one
);
3120 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
3121 logical_type_node
, bound
, rank
);
3122 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3123 logical_type_node
, cond
, cond1
);
3124 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3125 gfc_array_index_type
, cond
,
3126 minus_one
, se
->expr
);
3129 else /* as is null; this is an old-fashioned 1-based array. */
3131 if (op
!= GFC_ISYM_LBOUND
)
3133 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
3134 gfc_array_index_type
, size
,
3135 gfc_index_zero_node
);
3138 se
->expr
= gfc_index_one_node
;
3142 type
= gfc_typenode_for_spec (&expr
->ts
);
3143 se
->expr
= convert (type
, se
->expr
);
3148 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
3150 gfc_actual_arglist
*arg
;
3151 gfc_actual_arglist
*arg2
;
3153 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
3157 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
3158 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
3159 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
3161 arg
= expr
->value
.function
.actual
;
3164 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
3165 corank
= arg
->expr
->corank
;
3167 gfc_init_se (&argse
, NULL
);
3168 argse
.want_coarray
= 1;
3170 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
3171 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3172 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3177 /* Create an implicit second parameter from the loop variable. */
3178 gcc_assert (!arg2
->expr
);
3179 gcc_assert (corank
> 0);
3180 gcc_assert (se
->loop
->dimen
== 1);
3181 gcc_assert (se
->ss
->info
->expr
== expr
);
3183 bound
= se
->loop
->loopvar
[0];
3184 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3185 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
3186 gfc_advance_se_ss_chain (se
);
3190 /* use the passed argument. */
3191 gcc_assert (arg2
->expr
);
3192 gfc_init_se (&argse
, NULL
);
3193 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
3194 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3197 if (INTEGER_CST_P (bound
))
3199 if (wi::ltu_p (wi::to_wide (bound
), 1)
3200 || wi::gtu_p (wi::to_wide (bound
),
3201 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
3202 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3203 "dimension index", expr
->value
.function
.isym
->name
,
3206 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3208 bound
= gfc_evaluate_now (bound
, &se
->pre
);
3209 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3210 bound
, build_int_cst (TREE_TYPE (bound
), 1));
3211 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
3212 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3214 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3215 logical_type_node
, cond
, tmp
);
3216 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
3221 /* Subtract 1 to get to zero based and add dimensions. */
3222 switch (arg
->expr
->rank
)
3225 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
3226 gfc_array_index_type
, bound
,
3227 gfc_index_one_node
);
3231 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3232 gfc_array_index_type
, bound
,
3233 gfc_rank_cst
[arg
->expr
->rank
- 1]);
3237 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3239 /* Handle UCOBOUND with special handling of the last codimension. */
3240 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
3242 /* Last codimension: For -fcoarray=single just return
3243 the lcobound - otherwise add
3244 ceiling (real (num_images ()) / real (size)) - 1
3245 = (num_images () + size - 1) / size - 1
3246 = (num_images - 1) / size(),
3247 where size is the product of the extent of all but the last
3250 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
3254 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
3255 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3256 2, integer_zero_node
,
3257 build_int_cst (integer_type_node
, -1));
3258 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3259 gfc_array_index_type
,
3260 fold_convert (gfc_array_index_type
, tmp
),
3261 build_int_cst (gfc_array_index_type
, 1));
3262 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
3263 gfc_array_index_type
, tmp
,
3264 fold_convert (gfc_array_index_type
, cosize
));
3265 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3266 gfc_array_index_type
, resbound
, tmp
);
3268 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
3270 /* ubound = lbound + num_images() - 1. */
3271 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3272 2, integer_zero_node
,
3273 build_int_cst (integer_type_node
, -1));
3274 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3275 gfc_array_index_type
,
3276 fold_convert (gfc_array_index_type
, tmp
),
3277 build_int_cst (gfc_array_index_type
, 1));
3278 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3279 gfc_array_index_type
, resbound
, tmp
);
3284 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3286 build_int_cst (TREE_TYPE (bound
),
3287 arg
->expr
->rank
+ corank
- 1));
3289 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3290 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3291 gfc_array_index_type
, cond
,
3292 resbound
, resbound2
);
3295 se
->expr
= resbound
;
3298 se
->expr
= resbound
;
3300 type
= gfc_typenode_for_spec (&expr
->ts
);
3301 se
->expr
= convert (type
, se
->expr
);
3306 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
3308 gfc_actual_arglist
*array_arg
;
3309 gfc_actual_arglist
*dim_arg
;
3313 array_arg
= expr
->value
.function
.actual
;
3314 dim_arg
= array_arg
->next
;
3316 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
3318 gfc_init_se (&argse
, NULL
);
3319 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
3320 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3321 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3324 gcc_assert (dim_arg
->expr
);
3325 gfc_init_se (&argse
, NULL
);
3326 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
3327 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3328 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3329 argse
.expr
, gfc_index_one_node
);
3330 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
3334 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
3338 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3340 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
3344 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
3349 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
3350 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
3359 /* Create a complex value from one or two real components. */
3362 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
3368 unsigned int num_args
;
3370 num_args
= gfc_intrinsic_argument_list_length (expr
);
3371 args
= XALLOCAVEC (tree
, num_args
);
3373 type
= gfc_typenode_for_spec (&expr
->ts
);
3374 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3375 real
= convert (TREE_TYPE (type
), args
[0]);
3377 imag
= convert (TREE_TYPE (type
), args
[1]);
3378 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
3380 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
3381 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
3382 imag
= convert (TREE_TYPE (type
), imag
);
3385 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3387 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3391 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3392 MODULO(A, P) = A - FLOOR (A / P) * P
3394 The obvious algorithms above are numerically instable for large
3395 arguments, hence these intrinsics are instead implemented via calls
3396 to the fmod family of functions. It is the responsibility of the
3397 user to ensure that the second argument is non-zero. */
3400 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3410 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3412 switch (expr
->ts
.type
)
3415 /* Integer case is easy, we've got a builtin op. */
3416 type
= TREE_TYPE (args
[0]);
3419 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3422 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3428 /* Check if we have a builtin fmod. */
3429 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3431 /* The builtin should always be available. */
3432 gcc_assert (fmod
!= NULL_TREE
);
3434 tmp
= build_addr (fmod
);
3435 se
->expr
= build_call_array_loc (input_location
,
3436 TREE_TYPE (TREE_TYPE (fmod
)),
3441 type
= TREE_TYPE (args
[0]);
3443 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3444 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3447 modulo = arg - floor (arg/arg2) * arg2
3449 In order to calculate the result accurately, we use the fmod
3450 function as follows.
3452 res = fmod (arg, arg2);
3455 if ((arg < 0) xor (arg2 < 0))
3459 res = copysign (0., arg2);
3461 => As two nested ternary exprs:
3463 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3464 : copysign (0., arg2);
3468 zero
= gfc_build_const (type
, integer_zero_node
);
3469 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3470 if (!flag_signed_zeros
)
3472 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3474 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3476 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3477 logical_type_node
, test
, test2
);
3478 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3480 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3481 logical_type_node
, test
, test2
);
3482 test
= gfc_evaluate_now (test
, &se
->pre
);
3483 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3484 fold_build2_loc (input_location
,
3486 type
, tmp
, args
[1]),
3491 tree expr1
, copysign
, cscall
;
3492 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3494 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3496 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3498 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3499 logical_type_node
, test
, test2
);
3500 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3501 fold_build2_loc (input_location
,
3503 type
, tmp
, args
[1]),
3505 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3507 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3509 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3519 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3520 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3521 where the right shifts are logical (i.e. 0's are shifted in).
3522 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3523 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3525 DSHIFTL(I,J,BITSIZE) = J
3527 DSHIFTR(I,J,BITSIZE) = I. */
3530 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3532 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3533 tree args
[3], cond
, tmp
;
3536 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3538 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3539 type
= TREE_TYPE (args
[0]);
3540 bitsize
= TYPE_PRECISION (type
);
3541 utype
= unsigned_type_for (type
);
3542 stype
= TREE_TYPE (args
[2]);
3544 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3545 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3546 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3548 /* The generic case. */
3549 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3550 build_int_cst (stype
, bitsize
), shift
);
3551 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3552 arg1
, dshiftl
? shift
: tmp
);
3554 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3555 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3556 right
= fold_convert (type
, right
);
3558 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3560 /* Special cases. */
3561 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3562 build_int_cst (stype
, 0));
3563 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3564 dshiftl
? arg1
: arg2
, res
);
3566 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3567 build_int_cst (stype
, bitsize
));
3568 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3569 dshiftl
? arg2
: arg1
, res
);
3575 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3578 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3586 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3587 type
= TREE_TYPE (args
[0]);
3589 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3590 val
= gfc_evaluate_now (val
, &se
->pre
);
3592 zero
= gfc_build_const (type
, integer_zero_node
);
3593 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, val
, zero
);
3594 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3598 /* SIGN(A, B) is absolute value of A times sign of B.
3599 The real value versions use library functions to ensure the correct
3600 handling of negative zero. Integer case implemented as:
3601 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3605 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3611 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3612 if (expr
->ts
.type
== BT_REAL
)
3616 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3617 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3619 /* We explicitly have to ignore the minus sign. We do so by using
3620 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3622 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3625 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3626 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3628 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3629 TREE_TYPE (args
[0]), cond
,
3630 build_call_expr_loc (input_location
, abs
, 1,
3632 build_call_expr_loc (input_location
, tmp
, 2,
3636 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3641 /* Having excluded floating point types, we know we are now dealing
3642 with signed integer types. */
3643 type
= TREE_TYPE (args
[0]);
3645 /* Args[0] is used multiple times below. */
3646 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3648 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3649 the signs of A and B are the same, and of all ones if they differ. */
3650 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3651 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3652 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3653 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3655 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3656 is all ones (i.e. -1). */
3657 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3658 fold_build2_loc (input_location
, PLUS_EXPR
,
3659 type
, args
[0], tmp
), tmp
);
3663 /* Test for the presence of an optional argument. */
3666 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3670 arg
= expr
->value
.function
.actual
->expr
;
3671 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3672 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3673 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3677 /* Calculate the double precision product of two single precision values. */
3680 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3685 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3687 /* Convert the args to double precision before multiplying. */
3688 type
= gfc_typenode_for_spec (&expr
->ts
);
3689 args
[0] = convert (type
, args
[0]);
3690 args
[1] = convert (type
, args
[1]);
3691 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3696 /* Return a length one character string containing an ascii character. */
3699 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3704 unsigned int num_args
;
3706 num_args
= gfc_intrinsic_argument_list_length (expr
);
3707 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3709 type
= gfc_get_char_type (expr
->ts
.kind
);
3710 var
= gfc_create_var (type
, "char");
3712 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3713 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3714 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3715 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3720 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3728 unsigned int num_args
;
3730 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3731 args
= XALLOCAVEC (tree
, num_args
);
3733 var
= gfc_create_var (pchar_type_node
, "pstr");
3734 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3736 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3737 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3738 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3740 fndecl
= build_addr (gfor_fndecl_ctime
);
3741 tmp
= build_call_array_loc (input_location
,
3742 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3743 fndecl
, num_args
, args
);
3744 gfc_add_expr_to_block (&se
->pre
, tmp
);
3746 /* Free the temporary afterwards, if necessary. */
3747 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3748 len
, build_int_cst (TREE_TYPE (len
), 0));
3749 tmp
= gfc_call_free (var
);
3750 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3751 gfc_add_expr_to_block (&se
->post
, tmp
);
3754 se
->string_length
= len
;
3759 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3767 unsigned int num_args
;
3769 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3770 args
= XALLOCAVEC (tree
, num_args
);
3772 var
= gfc_create_var (pchar_type_node
, "pstr");
3773 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3775 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3776 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3777 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3779 fndecl
= build_addr (gfor_fndecl_fdate
);
3780 tmp
= build_call_array_loc (input_location
,
3781 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3782 fndecl
, num_args
, args
);
3783 gfc_add_expr_to_block (&se
->pre
, tmp
);
3785 /* Free the temporary afterwards, if necessary. */
3786 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3787 len
, build_int_cst (TREE_TYPE (len
), 0));
3788 tmp
= gfc_call_free (var
);
3789 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3790 gfc_add_expr_to_block (&se
->post
, tmp
);
3793 se
->string_length
= len
;
3797 /* Generate a direct call to free() for the FREE subroutine. */
3800 conv_intrinsic_free (gfc_code
*code
)
3806 gfc_init_se (&argse
, NULL
);
3807 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3808 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3810 gfc_init_block (&block
);
3811 call
= build_call_expr_loc (input_location
,
3812 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3813 gfc_add_expr_to_block (&block
, call
);
3814 return gfc_finish_block (&block
);
3818 /* Call the RANDOM_INIT library subroutine with a hidden argument for
3819 handling seeding on coarray images. */
3822 conv_intrinsic_random_init (gfc_code
*code
)
3826 tree arg1
, arg2
, tmp
;
3827 /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3828 tree used_bool_type_node
= flag_coarray
== GFC_FCOARRAY_LIB
3830 : gfc_get_logical_type (4);
3832 /* Make the function call. */
3833 gfc_init_block (&block
);
3834 gfc_init_se (&se
, NULL
);
3836 /* Convert REPEATABLE to the desired LOGICAL entity. */
3837 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
3838 gfc_add_block_to_block (&block
, &se
.pre
);
3839 arg1
= fold_convert (used_bool_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3840 gfc_add_block_to_block (&block
, &se
.post
);
3842 /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3843 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
3844 gfc_add_block_to_block (&block
, &se
.pre
);
3845 arg2
= fold_convert (used_bool_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3846 gfc_add_block_to_block (&block
, &se
.post
);
3848 if (flag_coarray
== GFC_FCOARRAY_LIB
)
3850 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_random_init
,
3855 /* The ABI for libgfortran needs to be maintained, so a hidden
3856 argument must be include if code is compiled with -fcoarray=single
3857 or without the option. Set to 0. */
3858 tree arg3
= build_int_cst (gfc_get_int_type (4), 0);
3859 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_random_init
,
3860 3, arg1
, arg2
, arg3
);
3863 gfc_add_expr_to_block (&block
, tmp
);
3865 return gfc_finish_block (&block
);
3869 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3873 conv_intrinsic_system_clock (gfc_code
*code
)
3876 gfc_se count_se
, count_rate_se
, count_max_se
;
3877 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3881 gfc_expr
*count
= code
->ext
.actual
->expr
;
3882 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3883 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3885 /* Evaluate our arguments. */
3888 gfc_init_se (&count_se
, NULL
);
3889 gfc_conv_expr (&count_se
, count
);
3894 gfc_init_se (&count_rate_se
, NULL
);
3895 gfc_conv_expr (&count_rate_se
, count_rate
);
3900 gfc_init_se (&count_max_se
, NULL
);
3901 gfc_conv_expr (&count_max_se
, count_max
);
3904 /* Find the smallest kind found of the arguments. */
3906 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3907 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3909 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3912 /* Prepare temporary variables. */
3917 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3918 else if (least
== 4)
3919 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3920 else if (count
->ts
.kind
== 1)
3921 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3924 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3931 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3932 else if (least
== 4)
3933 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3935 arg2
= integer_zero_node
;
3941 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3942 else if (least
== 4)
3943 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3945 arg3
= integer_zero_node
;
3948 /* Make the function call. */
3949 gfc_init_block (&block
);
3955 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3956 : null_pointer_node
;
3957 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3958 : null_pointer_node
;
3959 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3960 : null_pointer_node
;
3965 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3966 : null_pointer_node
;
3967 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3968 : null_pointer_node
;
3969 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3970 : null_pointer_node
;
3977 tmp
= build_call_expr_loc (input_location
,
3978 gfor_fndecl_system_clock4
, 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
);
3987 /* Handle kind>=8, 10, or 16 arguments */
3990 tmp
= build_call_expr_loc (input_location
,
3991 gfor_fndecl_system_clock8
, 3,
3992 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3993 : null_pointer_node
,
3994 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3995 : null_pointer_node
,
3996 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3997 : null_pointer_node
);
3998 gfc_add_expr_to_block (&block
, tmp
);
4002 /* And store values back if needed. */
4003 if (arg1
&& arg1
!= count_se
.expr
)
4004 gfc_add_modify (&block
, count_se
.expr
,
4005 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
4006 if (arg2
&& arg2
!= count_rate_se
.expr
)
4007 gfc_add_modify (&block
, count_rate_se
.expr
,
4008 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
4009 if (arg3
&& arg3
!= count_max_se
.expr
)
4010 gfc_add_modify (&block
, count_max_se
.expr
,
4011 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
4013 return gfc_finish_block (&block
);
4017 /* Return a character string containing the tty name. */
4020 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
4028 unsigned int num_args
;
4030 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
4031 args
= XALLOCAVEC (tree
, num_args
);
4033 var
= gfc_create_var (pchar_type_node
, "pstr");
4034 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4036 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
4037 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
4038 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
4040 fndecl
= build_addr (gfor_fndecl_ttynam
);
4041 tmp
= build_call_array_loc (input_location
,
4042 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
4043 fndecl
, num_args
, args
);
4044 gfc_add_expr_to_block (&se
->pre
, tmp
);
4046 /* Free the temporary afterwards, if necessary. */
4047 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4048 len
, build_int_cst (TREE_TYPE (len
), 0));
4049 tmp
= gfc_call_free (var
);
4050 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4051 gfc_add_expr_to_block (&se
->post
, tmp
);
4054 se
->string_length
= len
;
4058 /* Get the minimum/maximum value of all the parameters.
4059 minmax (a1, a2, a3, ...)
4062 mvar = COMP (mvar, a2)
4063 mvar = COMP (mvar, a3)
4067 Where COMP is MIN/MAX_EXPR for integral types or when we don't
4068 care about NaNs, or IFN_FMIN/MAX when the target has support for
4069 fast NaN-honouring min/max. When neither holds expand a sequence
4070 of explicit comparisons. */
4072 /* TODO: Mismatching types can occur when specific names are used.
4073 These should be handled during resolution. */
4075 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4083 gfc_actual_arglist
*argexpr
;
4084 unsigned int i
, nargs
;
4086 nargs
= gfc_intrinsic_argument_list_length (expr
);
4087 args
= XALLOCAVEC (tree
, nargs
);
4089 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
4090 type
= gfc_typenode_for_spec (&expr
->ts
);
4092 /* Only evaluate the argument once. */
4093 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
4094 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4096 /* Determine suitable type of temporary, as a GNU extension allows
4097 different argument kinds. */
4098 argtype
= TREE_TYPE (args
[0]);
4099 argexpr
= expr
->value
.function
.actual
;
4100 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++, argexpr
= argexpr
->next
)
4102 tree tmptype
= TREE_TYPE (args
[i
]);
4103 if (TYPE_PRECISION (tmptype
) > TYPE_PRECISION (argtype
))
4106 mvar
= gfc_create_var (argtype
, "M");
4107 gfc_add_modify (&se
->pre
, mvar
, convert (argtype
, args
[0]));
4109 argexpr
= expr
->value
.function
.actual
;
4110 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++, argexpr
= argexpr
->next
)
4112 tree cond
= NULL_TREE
;
4115 /* Handle absent optional arguments by ignoring the comparison. */
4116 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
4117 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
4118 && INDIRECT_REF_P (val
))
4120 cond
= fold_build2_loc (input_location
,
4121 NE_EXPR
, logical_type_node
,
4122 TREE_OPERAND (val
, 0),
4123 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
4125 else if (!VAR_P (val
) && !TREE_CONSTANT (val
))
4126 /* Only evaluate the argument once. */
4127 val
= gfc_evaluate_now (val
, &se
->pre
);
4130 /* For floating point types, the question is what MAX(a, NaN) or
4131 MIN(a, NaN) should return (where "a" is a normal number).
4132 There are valid use case for returning either one, but the
4133 Fortran standard doesn't specify which one should be chosen.
4134 Also, there is no consensus among other tested compilers. In
4135 short, it's a mess. So lets just do whatever is fastest. */
4136 tree_code code
= op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
;
4137 calc
= fold_build2_loc (input_location
, code
, argtype
,
4138 convert (argtype
, val
), mvar
);
4139 tmp
= build2_v (MODIFY_EXPR
, mvar
, calc
);
4141 if (cond
!= NULL_TREE
)
4142 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
4143 build_empty_stmt (input_location
));
4144 gfc_add_expr_to_block (&se
->pre
, tmp
);
4146 se
->expr
= convert (type
, mvar
);
4150 /* Generate library calls for MIN and MAX intrinsics for character
4153 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
4156 tree var
, len
, fndecl
, tmp
, cond
, function
;
4159 nargs
= gfc_intrinsic_argument_list_length (expr
);
4160 args
= XALLOCAVEC (tree
, nargs
+ 4);
4161 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
4163 /* Create the result variables. */
4164 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4165 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
4166 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
4167 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
4168 args
[2] = build_int_cst (integer_type_node
, op
);
4169 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
4171 if (expr
->ts
.kind
== 1)
4172 function
= gfor_fndecl_string_minmax
;
4173 else if (expr
->ts
.kind
== 4)
4174 function
= gfor_fndecl_string_minmax_char4
;
4178 /* Make the function call. */
4179 fndecl
= build_addr (function
);
4180 tmp
= build_call_array_loc (input_location
,
4181 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4183 gfc_add_expr_to_block (&se
->pre
, tmp
);
4185 /* Free the temporary afterwards, if necessary. */
4186 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4187 len
, build_int_cst (TREE_TYPE (len
), 0));
4188 tmp
= gfc_call_free (var
);
4189 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4190 gfc_add_expr_to_block (&se
->post
, tmp
);
4193 se
->string_length
= len
;
4197 /* Create a symbol node for this intrinsic. The symbol from the frontend
4198 has the generic name. */
4201 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
4205 /* TODO: Add symbols for intrinsic function to the global namespace. */
4206 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
4207 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
4210 sym
->attr
.external
= 1;
4211 sym
->attr
.function
= 1;
4212 sym
->attr
.always_explicit
= 1;
4213 sym
->attr
.proc
= PROC_INTRINSIC
;
4214 sym
->attr
.flavor
= FL_PROCEDURE
;
4218 sym
->attr
.dimension
= 1;
4219 sym
->as
= gfc_get_array_spec ();
4220 sym
->as
->type
= AS_ASSUMED_SHAPE
;
4221 sym
->as
->rank
= expr
->rank
;
4224 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
4225 ignore_optional
? expr
->value
.function
.actual
4231 /* Remove empty actual arguments. */
4234 remove_empty_actual_arguments (gfc_actual_arglist
**ap
)
4238 if ((*ap
)->expr
== NULL
)
4240 gfc_actual_arglist
*r
= *ap
;
4243 gfc_free_actual_arglist (r
);
4246 ap
= &((*ap
)->next
);
4250 #define MAX_SPEC_ARG 12
4252 /* Make up an fn spec that's right for intrinsic functions that we
4256 intrinsic_fnspec (gfc_expr
*expr
)
4258 static char fnspec_buf
[MAX_SPEC_ARG
*2+1];
4263 #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
4265 /* Set the fndecl. */
4267 /* Function return value. FIXME: Check if the second letter could
4268 be something other than a space, for further optimization. */
4270 if (expr
->rank
== 0)
4272 if (expr
->ts
.type
== BT_CHARACTER
)
4274 ADD_CHAR ('w'); /* Address of character. */
4275 ADD_CHAR ('.'); /* Length of character. */
4279 ADD_CHAR ('w'); /* Return value is a descriptor. */
4282 for (gfc_actual_arglist
*a
= expr
->value
.function
.actual
; a
; a
= a
->next
)
4284 if (a
->expr
== NULL
)
4287 if (a
->name
&& strcmp (a
->name
,"%VAL") == 0)
4291 if (a
->expr
->rank
> 0)
4296 num_char_args
+= a
->expr
->ts
.type
== BT_CHARACTER
;
4297 gcc_assert (fp
- fnspec_buf
+ num_char_args
<= MAX_SPEC_ARG
*2);
4300 for (i
= 0; i
< num_char_args
; i
++)
4310 /* Generate the right symbol for the specific intrinsic function and
4311 modify the expr accordingly. This assumes that absent optional
4312 arguments should be removed. */
4315 specific_intrinsic_symbol (gfc_expr
*expr
)
4319 sym
= gfc_find_intrinsic_symbol (expr
);
4322 sym
= gfc_get_intrinsic_function_symbol (expr
);
4324 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
)
4325 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
4327 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
4328 expr
->value
.function
.actual
, true);
4330 = gfc_get_extern_function_decl (sym
, expr
->value
.function
.actual
,
4331 intrinsic_fnspec (expr
));
4334 remove_empty_actual_arguments (&(expr
->value
.function
.actual
));
4339 /* Generate a call to an external intrinsic function. FIXME: So far,
4340 this only works for functions which are called with well-defined
4341 types; CSHIFT and friends will come later. */
4344 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
4347 vec
<tree
, va_gc
> *append_args
;
4348 bool specific_symbol
;
4350 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
4353 gcc_assert (expr
->rank
> 0);
4355 gcc_assert (expr
->rank
== 0);
4357 switch (expr
->value
.function
.isym
->id
)
4361 case GFC_ISYM_FINDLOC
:
4362 case GFC_ISYM_MAXLOC
:
4363 case GFC_ISYM_MINLOC
:
4364 case GFC_ISYM_MAXVAL
:
4365 case GFC_ISYM_MINVAL
:
4366 case GFC_ISYM_NORM2
:
4367 case GFC_ISYM_PRODUCT
:
4369 specific_symbol
= true;
4372 specific_symbol
= false;
4375 if (specific_symbol
)
4377 /* Need to copy here because specific_intrinsic_symbol modifies
4378 expr to omit the absent optional arguments. */
4379 expr
= gfc_copy_expr (expr
);
4380 sym
= specific_intrinsic_symbol (expr
);
4383 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
4385 /* Calls to libgfortran_matmul need to be appended special arguments,
4386 to be able to call the BLAS ?gemm functions if required and possible. */
4388 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
4389 && !expr
->external_blas
4390 && sym
->ts
.type
!= BT_LOGICAL
)
4392 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
4394 if (flag_external_blas
4395 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
4396 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
4400 if (sym
->ts
.type
== BT_REAL
)
4402 if (sym
->ts
.kind
== 4)
4403 gemm_fndecl
= gfor_fndecl_sgemm
;
4405 gemm_fndecl
= gfor_fndecl_dgemm
;
4409 if (sym
->ts
.kind
== 4)
4410 gemm_fndecl
= gfor_fndecl_cgemm
;
4412 gemm_fndecl
= gfor_fndecl_zgemm
;
4415 vec_alloc (append_args
, 3);
4416 append_args
->quick_push (build_int_cst (cint
, 1));
4417 append_args
->quick_push (build_int_cst (cint
,
4418 flag_blas_matmul_limit
));
4419 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
4424 vec_alloc (append_args
, 3);
4425 append_args
->quick_push (build_int_cst (cint
, 0));
4426 append_args
->quick_push (build_int_cst (cint
, 0));
4427 append_args
->quick_push (null_pointer_node
);
4431 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4434 if (specific_symbol
)
4435 gfc_free_expr (expr
);
4437 gfc_free_symbol (sym
);
4440 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4460 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4469 gfc_actual_arglist
*actual
;
4476 gfc_conv_intrinsic_funcall (se
, expr
);
4480 actual
= expr
->value
.function
.actual
;
4481 type
= gfc_typenode_for_spec (&expr
->ts
);
4482 /* Initialize the result. */
4483 resvar
= gfc_create_var (type
, "test");
4485 tmp
= convert (type
, boolean_true_node
);
4487 tmp
= convert (type
, boolean_false_node
);
4488 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4490 /* Walk the arguments. */
4491 arrayss
= gfc_walk_expr (actual
->expr
);
4492 gcc_assert (arrayss
!= gfc_ss_terminator
);
4494 /* Initialize the scalarizer. */
4495 gfc_init_loopinfo (&loop
);
4496 exit_label
= gfc_build_label_decl (NULL_TREE
);
4497 TREE_USED (exit_label
) = 1;
4498 gfc_add_ss_to_loop (&loop
, arrayss
);
4500 /* Initialize the loop. */
4501 gfc_conv_ss_startstride (&loop
);
4502 gfc_conv_loop_setup (&loop
, &expr
->where
);
4504 gfc_mark_ss_chain_used (arrayss
, 1);
4505 /* Generate the loop body. */
4506 gfc_start_scalarized_body (&loop
, &body
);
4508 /* If the condition matches then set the return value. */
4509 gfc_start_block (&block
);
4511 tmp
= convert (type
, boolean_false_node
);
4513 tmp
= convert (type
, boolean_true_node
);
4514 gfc_add_modify (&block
, resvar
, tmp
);
4516 /* And break out of the loop. */
4517 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4518 gfc_add_expr_to_block (&block
, tmp
);
4520 found
= gfc_finish_block (&block
);
4522 /* Check this element. */
4523 gfc_init_se (&arrayse
, NULL
);
4524 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4525 arrayse
.ss
= arrayss
;
4526 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4528 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4529 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
, arrayse
.expr
,
4530 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
4531 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
4532 gfc_add_expr_to_block (&body
, tmp
);
4533 gfc_add_block_to_block (&body
, &arrayse
.post
);
4535 gfc_trans_scalarizing_loops (&loop
, &body
);
4537 /* Add the exit label. */
4538 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4539 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4541 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4542 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4543 gfc_cleanup_loop (&loop
);
4549 /* Generate the constant 180 / pi, which is used in the conversion
4550 of acosd(), asind(), atand(), atan2d(). */
4558 gfc_set_model_kind (kind
);
4561 mpfr_set_si (t0
, 180, GFC_RND_MODE
);
4562 mpfr_const_pi (pi
, GFC_RND_MODE
);
4563 mpfr_div (t0
, t0
, pi
, GFC_RND_MODE
);
4564 retval
= gfc_conv_mpfr_to_tree (t0
, kind
, 0);
4571 static gfc_intrinsic_map_t
*
4572 gfc_lookup_intrinsic (gfc_isym_id id
)
4574 gfc_intrinsic_map_t
*m
= gfc_intrinsic_map
;
4575 for (; m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
4578 gcc_assert (id
== m
->id
);
4583 /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4584 ASIND(x) is translated into ASIN(x) * 180 / pi.
4585 ATAND(x) is translated into ATAN(x) * 180 / pi. */
4588 gfc_conv_intrinsic_atrigd (gfc_se
* se
, gfc_expr
* expr
, gfc_isym_id id
)
4593 gfc_intrinsic_map_t
*m
;
4595 type
= gfc_typenode_for_spec (&expr
->ts
);
4597 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4601 case GFC_ISYM_ACOSD
:
4602 m
= gfc_lookup_intrinsic (GFC_ISYM_ACOS
);
4604 case GFC_ISYM_ASIND
:
4605 m
= gfc_lookup_intrinsic (GFC_ISYM_ASIN
);
4607 case GFC_ISYM_ATAND
:
4608 m
= gfc_lookup_intrinsic (GFC_ISYM_ATAN
);
4613 atrigd
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4614 atrigd
= build_call_expr_loc (input_location
, atrigd
, 1, arg
);
4616 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, atrigd
,
4617 fold_convert (type
, rad2deg (expr
->ts
.kind
)));
4621 /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4622 COS(X) / SIN(X) for COMPLEX argument. */
4625 gfc_conv_intrinsic_cotan (gfc_se
*se
, gfc_expr
*expr
)
4627 gfc_intrinsic_map_t
*m
;
4631 type
= gfc_typenode_for_spec (&expr
->ts
);
4632 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4634 if (expr
->ts
.type
== BT_REAL
)
4641 gfc_set_model_kind (expr
->ts
.kind
);
4643 mpfr_const_pi (pio2
, GFC_RND_MODE
);
4644 mpfr_div_ui (pio2
, pio2
, 2, GFC_RND_MODE
);
4645 tmp
= gfc_conv_mpfr_to_tree (pio2
, expr
->ts
.kind
, 0);
4648 /* Find tan builtin function. */
4649 m
= gfc_lookup_intrinsic (GFC_ISYM_TAN
);
4650 tan
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4651 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, arg
, tmp
);
4652 tan
= build_call_expr_loc (input_location
, tan
, 1, tmp
);
4653 se
->expr
= fold_build1_loc (input_location
, NEGATE_EXPR
, type
, tan
);
4660 /* Find cos builtin function. */
4661 m
= gfc_lookup_intrinsic (GFC_ISYM_COS
);
4662 cos
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4663 cos
= build_call_expr_loc (input_location
, cos
, 1, arg
);
4665 /* Find sin builtin function. */
4666 m
= gfc_lookup_intrinsic (GFC_ISYM_SIN
);
4667 sin
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4668 sin
= build_call_expr_loc (input_location
, sin
, 1, arg
);
4670 /* Divide cos by sin. */
4671 se
->expr
= fold_build2_loc (input_location
, RDIV_EXPR
, type
, cos
, sin
);
4676 /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4679 gfc_conv_intrinsic_cotand (gfc_se
*se
, gfc_expr
*expr
)
4686 type
= gfc_typenode_for_spec (&expr
->ts
);
4687 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4689 gfc_set_model_kind (expr
->ts
.kind
);
4691 /* Build the tree for x + 90. */
4692 mpfr_init_set_ui (ninety
, 90, GFC_RND_MODE
);
4693 ninety_tree
= gfc_conv_mpfr_to_tree (ninety
, expr
->ts
.kind
, 0);
4694 arg
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, arg
, ninety_tree
);
4695 mpfr_clear (ninety
);
4698 gfc_intrinsic_map_t
*m
= gfc_lookup_intrinsic (GFC_ISYM_TAND
);
4699 tree tand
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4700 tand
= build_call_expr_loc (input_location
, tand
, 1, arg
);
4702 se
->expr
= fold_build1_loc (input_location
, NEGATE_EXPR
, type
, tand
);
4706 /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4709 gfc_conv_intrinsic_atan2d (gfc_se
*se
, gfc_expr
*expr
)
4715 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4716 type
= TREE_TYPE (args
[0]);
4718 gfc_intrinsic_map_t
*m
= gfc_lookup_intrinsic (GFC_ISYM_ATAN2
);
4719 atan2d
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4720 atan2d
= build_call_expr_loc (input_location
, atan2d
, 2, args
[0], args
[1]);
4722 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, atan2d
,
4723 rad2deg (expr
->ts
.kind
));
4727 /* COUNT(A) = Number of true elements in A. */
4729 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4736 gfc_actual_arglist
*actual
;
4742 gfc_conv_intrinsic_funcall (se
, expr
);
4746 actual
= expr
->value
.function
.actual
;
4748 type
= gfc_typenode_for_spec (&expr
->ts
);
4749 /* Initialize the result. */
4750 resvar
= gfc_create_var (type
, "count");
4751 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4753 /* Walk the arguments. */
4754 arrayss
= gfc_walk_expr (actual
->expr
);
4755 gcc_assert (arrayss
!= gfc_ss_terminator
);
4757 /* Initialize the scalarizer. */
4758 gfc_init_loopinfo (&loop
);
4759 gfc_add_ss_to_loop (&loop
, arrayss
);
4761 /* Initialize the loop. */
4762 gfc_conv_ss_startstride (&loop
);
4763 gfc_conv_loop_setup (&loop
, &expr
->where
);
4765 gfc_mark_ss_chain_used (arrayss
, 1);
4766 /* Generate the loop body. */
4767 gfc_start_scalarized_body (&loop
, &body
);
4769 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4770 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4771 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4773 gfc_init_se (&arrayse
, NULL
);
4774 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4775 arrayse
.ss
= arrayss
;
4776 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4777 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4778 build_empty_stmt (input_location
));
4780 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4781 gfc_add_expr_to_block (&body
, tmp
);
4782 gfc_add_block_to_block (&body
, &arrayse
.post
);
4784 gfc_trans_scalarizing_loops (&loop
, &body
);
4786 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4787 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4788 gfc_cleanup_loop (&loop
);
4794 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4795 struct and return the corresponding loopinfo. */
4797 static gfc_loopinfo
*
4798 enter_nested_loop (gfc_se
*se
)
4800 se
->ss
= se
->ss
->nested_ss
;
4801 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4803 return se
->ss
->loop
;
4806 /* Build the condition for a mask, which may be optional. */
4809 conv_mask_condition (gfc_se
*maskse
, gfc_expr
*maskexpr
,
4817 type
= TREE_TYPE (maskse
->expr
);
4818 present
= gfc_conv_expr_present (maskexpr
->symtree
->n
.sym
);
4819 present
= convert (type
, present
);
4820 present
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, type
,
4822 return fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4823 type
, present
, maskse
->expr
);
4826 return maskse
->expr
;
4829 /* Inline implementation of the sum and product intrinsics. */
4831 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4835 tree scale
= NULL_TREE
;
4840 gfc_loopinfo loop
, *ploop
;
4841 gfc_actual_arglist
*arg_array
, *arg_mask
;
4842 gfc_ss
*arrayss
= NULL
;
4843 gfc_ss
*maskss
= NULL
;
4847 gfc_expr
*arrayexpr
;
4853 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4859 type
= gfc_typenode_for_spec (&expr
->ts
);
4860 /* Initialize the result. */
4861 resvar
= gfc_create_var (type
, "val");
4866 scale
= gfc_create_var (type
, "scale");
4867 gfc_add_modify (&se
->pre
, scale
,
4868 gfc_build_const (type
, integer_one_node
));
4869 tmp
= gfc_build_const (type
, integer_zero_node
);
4871 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4872 tmp
= gfc_build_const (type
, integer_zero_node
);
4873 else if (op
== NE_EXPR
)
4875 tmp
= convert (type
, boolean_false_node
);
4876 else if (op
== BIT_AND_EXPR
)
4877 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4878 type
, integer_one_node
));
4880 tmp
= gfc_build_const (type
, integer_one_node
);
4882 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4884 arg_array
= expr
->value
.function
.actual
;
4886 arrayexpr
= arg_array
->expr
;
4888 if (op
== NE_EXPR
|| norm2
)
4890 /* PARITY and NORM2. */
4892 optional_mask
= false;
4896 arg_mask
= arg_array
->next
->next
;
4897 gcc_assert (arg_mask
!= NULL
);
4898 maskexpr
= arg_mask
->expr
;
4899 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
4900 && maskexpr
->symtree
->n
.sym
->attr
.dummy
4901 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
4904 if (expr
->rank
== 0)
4906 /* Walk the arguments. */
4907 arrayss
= gfc_walk_expr (arrayexpr
);
4908 gcc_assert (arrayss
!= gfc_ss_terminator
);
4910 if (maskexpr
&& maskexpr
->rank
> 0)
4912 maskss
= gfc_walk_expr (maskexpr
);
4913 gcc_assert (maskss
!= gfc_ss_terminator
);
4918 /* Initialize the scalarizer. */
4919 gfc_init_loopinfo (&loop
);
4921 /* We add the mask first because the number of iterations is
4922 taken from the last ss, and this breaks if an absent
4923 optional argument is used for mask. */
4925 if (maskexpr
&& maskexpr
->rank
> 0)
4926 gfc_add_ss_to_loop (&loop
, maskss
);
4927 gfc_add_ss_to_loop (&loop
, arrayss
);
4929 /* Initialize the loop. */
4930 gfc_conv_ss_startstride (&loop
);
4931 gfc_conv_loop_setup (&loop
, &expr
->where
);
4933 if (maskexpr
&& maskexpr
->rank
> 0)
4934 gfc_mark_ss_chain_used (maskss
, 1);
4935 gfc_mark_ss_chain_used (arrayss
, 1);
4940 /* All the work has been done in the parent loops. */
4941 ploop
= enter_nested_loop (se
);
4945 /* Generate the loop body. */
4946 gfc_start_scalarized_body (ploop
, &body
);
4948 /* If we have a mask, only add this element if the mask is set. */
4949 if (maskexpr
&& maskexpr
->rank
> 0)
4951 gfc_init_se (&maskse
, parent_se
);
4952 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4953 if (expr
->rank
== 0)
4955 gfc_conv_expr_val (&maskse
, maskexpr
);
4956 gfc_add_block_to_block (&body
, &maskse
.pre
);
4958 gfc_start_block (&block
);
4961 gfc_init_block (&block
);
4963 /* Do the actual summation/product. */
4964 gfc_init_se (&arrayse
, parent_se
);
4965 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4966 if (expr
->rank
== 0)
4967 arrayse
.ss
= arrayss
;
4968 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4969 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4973 /* if (x (i) != 0.0)
4979 result = 1.0 + result * val * val;
4985 result += val * val;
4988 tree res1
, res2
, cond
, absX
, val
;
4989 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4991 gfc_init_block (&ifblock1
);
4993 absX
= gfc_create_var (type
, "absX");
4994 gfc_add_modify (&ifblock1
, absX
,
4995 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4997 val
= gfc_create_var (type
, "val");
4998 gfc_add_expr_to_block (&ifblock1
, val
);
5000 gfc_init_block (&ifblock2
);
5001 gfc_add_modify (&ifblock2
, val
,
5002 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
5004 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
5005 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
5006 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
5007 gfc_build_const (type
, integer_one_node
));
5008 gfc_add_modify (&ifblock2
, resvar
, res1
);
5009 gfc_add_modify (&ifblock2
, scale
, absX
);
5010 res1
= gfc_finish_block (&ifblock2
);
5012 gfc_init_block (&ifblock3
);
5013 gfc_add_modify (&ifblock3
, val
,
5014 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
5016 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
5017 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
5018 gfc_add_modify (&ifblock3
, resvar
, res2
);
5019 res2
= gfc_finish_block (&ifblock3
);
5021 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
5023 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
5024 gfc_add_expr_to_block (&ifblock1
, tmp
);
5025 tmp
= gfc_finish_block (&ifblock1
);
5027 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
5029 gfc_build_const (type
, integer_zero_node
));
5031 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
5032 gfc_add_expr_to_block (&block
, tmp
);
5036 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
5037 gfc_add_modify (&block
, resvar
, tmp
);
5040 gfc_add_block_to_block (&block
, &arrayse
.post
);
5042 if (maskexpr
&& maskexpr
->rank
> 0)
5044 /* We enclose the above in if (mask) {...} . If the mask is an
5045 optional argument, generate
5046 IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
5048 tmp
= gfc_finish_block (&block
);
5049 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5050 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5051 build_empty_stmt (input_location
));
5054 tmp
= gfc_finish_block (&block
);
5055 gfc_add_expr_to_block (&body
, tmp
);
5057 gfc_trans_scalarizing_loops (ploop
, &body
);
5059 /* For a scalar mask, enclose the loop in an if statement. */
5060 if (maskexpr
&& maskexpr
->rank
== 0)
5062 gfc_init_block (&block
);
5063 gfc_add_block_to_block (&block
, &ploop
->pre
);
5064 gfc_add_block_to_block (&block
, &ploop
->post
);
5065 tmp
= gfc_finish_block (&block
);
5069 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
5070 build_empty_stmt (input_location
));
5071 gfc_advance_se_ss_chain (se
);
5077 gcc_assert (expr
->rank
== 0);
5078 gfc_init_se (&maskse
, NULL
);
5079 gfc_conv_expr_val (&maskse
, maskexpr
);
5080 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5081 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5082 build_empty_stmt (input_location
));
5085 gfc_add_expr_to_block (&block
, tmp
);
5086 gfc_add_block_to_block (&se
->pre
, &block
);
5087 gcc_assert (se
->post
.head
== NULL
);
5091 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
5092 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
5095 if (expr
->rank
== 0)
5096 gfc_cleanup_loop (ploop
);
5100 /* result = scale * sqrt(result). */
5102 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
5103 resvar
= build_call_expr_loc (input_location
,
5105 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
5112 /* Inline implementation of the dot_product intrinsic. This function
5113 is based on gfc_conv_intrinsic_arith (the previous function). */
5115 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
5123 gfc_actual_arglist
*actual
;
5124 gfc_ss
*arrayss1
, *arrayss2
;
5125 gfc_se arrayse1
, arrayse2
;
5126 gfc_expr
*arrayexpr1
, *arrayexpr2
;
5128 type
= gfc_typenode_for_spec (&expr
->ts
);
5130 /* Initialize the result. */
5131 resvar
= gfc_create_var (type
, "val");
5132 if (expr
->ts
.type
== BT_LOGICAL
)
5133 tmp
= build_int_cst (type
, 0);
5135 tmp
= gfc_build_const (type
, integer_zero_node
);
5137 gfc_add_modify (&se
->pre
, resvar
, tmp
);
5139 /* Walk argument #1. */
5140 actual
= expr
->value
.function
.actual
;
5141 arrayexpr1
= actual
->expr
;
5142 arrayss1
= gfc_walk_expr (arrayexpr1
);
5143 gcc_assert (arrayss1
!= gfc_ss_terminator
);
5145 /* Walk argument #2. */
5146 actual
= actual
->next
;
5147 arrayexpr2
= actual
->expr
;
5148 arrayss2
= gfc_walk_expr (arrayexpr2
);
5149 gcc_assert (arrayss2
!= gfc_ss_terminator
);
5151 /* Initialize the scalarizer. */
5152 gfc_init_loopinfo (&loop
);
5153 gfc_add_ss_to_loop (&loop
, arrayss1
);
5154 gfc_add_ss_to_loop (&loop
, arrayss2
);
5156 /* Initialize the loop. */
5157 gfc_conv_ss_startstride (&loop
);
5158 gfc_conv_loop_setup (&loop
, &expr
->where
);
5160 gfc_mark_ss_chain_used (arrayss1
, 1);
5161 gfc_mark_ss_chain_used (arrayss2
, 1);
5163 /* Generate the loop body. */
5164 gfc_start_scalarized_body (&loop
, &body
);
5165 gfc_init_block (&block
);
5167 /* Make the tree expression for [conjg(]array1[)]. */
5168 gfc_init_se (&arrayse1
, NULL
);
5169 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
5170 arrayse1
.ss
= arrayss1
;
5171 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
5172 if (expr
->ts
.type
== BT_COMPLEX
)
5173 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
5175 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
5177 /* Make the tree expression for array2. */
5178 gfc_init_se (&arrayse2
, NULL
);
5179 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
5180 arrayse2
.ss
= arrayss2
;
5181 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
5182 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
5184 /* Do the actual product and sum. */
5185 if (expr
->ts
.type
== BT_LOGICAL
)
5187 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
5188 arrayse1
.expr
, arrayse2
.expr
);
5189 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
5193 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
5195 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
5197 gfc_add_modify (&block
, resvar
, tmp
);
5199 /* Finish up the loop block and the loop. */
5200 tmp
= gfc_finish_block (&block
);
5201 gfc_add_expr_to_block (&body
, tmp
);
5203 gfc_trans_scalarizing_loops (&loop
, &body
);
5204 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5205 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5206 gfc_cleanup_loop (&loop
);
5212 /* Tells whether the expression E is a reference to an optional variable whose
5213 presence is not known at compile time. Those are variable references without
5214 subreference; if there is a subreference, we can assume the variable is
5215 present. We have to special case full arrays, which we represent with a fake
5216 "full" reference, and class descriptors for which a reference to data is not
5217 really a subreference. */
5220 maybe_absent_optional_variable (gfc_expr
*e
)
5222 if (!(e
&& e
->expr_type
== EXPR_VARIABLE
))
5225 gfc_symbol
*sym
= e
->symtree
->n
.sym
;
5226 if (!sym
->attr
.optional
)
5229 gfc_ref
*ref
= e
->ref
;
5233 if (ref
->type
== REF_ARRAY
5234 && ref
->u
.ar
.type
== AR_FULL
5235 && ref
->next
== nullptr)
5238 if (!(sym
->ts
.type
== BT_CLASS
5239 && ref
->type
== REF_COMPONENT
5240 && ref
->u
.c
.component
== CLASS_DATA (sym
)))
5243 gfc_ref
*next_ref
= ref
->next
;
5244 if (next_ref
== nullptr)
5247 if (next_ref
->type
== REF_ARRAY
5248 && next_ref
->u
.ar
.type
== AR_FULL
5249 && next_ref
->next
== nullptr)
5256 /* Remove unneeded kind= argument from actual argument list when the
5257 result conversion is dealt with in a different place. */
5260 strip_kind_from_actual (gfc_actual_arglist
* actual
)
5262 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
5264 if (a
&& a
->name
&& strcmp (a
->name
, "kind") == 0)
5266 gfc_free_expr (a
->expr
);
5272 /* Emit code for minloc or maxloc intrinsic. There are many different cases
5273 we need to handle. For performance reasons we sometimes create two
5274 loops instead of one, where the second one is much simpler.
5275 Examples for minloc intrinsic:
5276 1) Result is an array, a call is generated
5277 2) Array mask is used and NaNs need to be supported:
5283 if (pos == 0) pos = S + (1 - from);
5284 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5291 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5295 3) NaNs need to be supported, but it is known at compile time or cheaply
5296 at runtime whether array is nonempty or not:
5301 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5304 if (from <= to) pos = 1;
5308 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5312 4) NaNs aren't supported, array mask is used:
5313 limit = infinities_supported ? Infinity : huge (limit);
5317 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5323 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5327 5) Same without array mask:
5328 limit = infinities_supported ? Infinity : huge (limit);
5329 pos = (from <= to) ? 1 : 0;
5332 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5335 For 3) and 5), if mask is scalar, this all goes into a conditional,
5336 setting pos = 0; in the else branch.
5338 Since we now also support the BACK argument, instead of using
5339 if (a[S] < limit), we now use
5342 cond = a[S] <= limit;
5344 cond = a[S] < limit;
5348 The optimizer is smart enough to move the condition out of the loop.
5349 The are now marked as unlikely to for further speedup. */
5352 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5356 stmtblock_t ifblock
;
5357 stmtblock_t elseblock
;
5370 gfc_actual_arglist
*actual
;
5375 gfc_expr
*arrayexpr
;
5383 actual
= expr
->value
.function
.actual
;
5385 /* The last argument, BACK, is passed by value. Ensure that
5386 by setting its name to %VAL. */
5387 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
5389 if (a
->next
== NULL
)
5395 gfc_conv_intrinsic_funcall (se
, expr
);
5399 arrayexpr
= actual
->expr
;
5401 /* Special case for character maxloc. Remove unneeded actual
5402 arguments, then call a library function. */
5404 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5406 gfc_actual_arglist
*a
;
5408 strip_kind_from_actual (a
);
5411 if (a
->name
&& strcmp (a
->name
, "dim") == 0)
5413 gfc_free_expr (a
->expr
);
5418 gfc_conv_intrinsic_funcall (se
, expr
);
5422 /* Initialize the result. */
5423 pos
= gfc_create_var (gfc_array_index_type
, "pos");
5424 offset
= gfc_create_var (gfc_array_index_type
, "offset");
5425 type
= gfc_typenode_for_spec (&expr
->ts
);
5427 /* Walk the arguments. */
5428 arrayss
= gfc_walk_expr (arrayexpr
);
5429 gcc_assert (arrayss
!= gfc_ss_terminator
);
5431 actual
= actual
->next
->next
;
5432 gcc_assert (actual
);
5433 maskexpr
= actual
->expr
;
5434 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5435 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5436 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5437 backexpr
= actual
->next
->next
->expr
;
5439 gfc_init_se (&backse
, NULL
);
5440 if (backexpr
== nullptr)
5441 back
= logical_false_node
;
5442 else if (maybe_absent_optional_variable (backexpr
))
5444 /* This should have been checked already by
5445 maybe_absent_optional_variable. */
5446 gcc_checking_assert (backexpr
->expr_type
== EXPR_VARIABLE
);
5448 gfc_conv_expr (&backse
, backexpr
);
5449 tree present
= gfc_conv_expr_present (backexpr
->symtree
->n
.sym
, false);
5450 back
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5451 logical_type_node
, present
, backse
.expr
);
5455 gfc_conv_expr (&backse
, backexpr
);
5458 gfc_add_block_to_block (&se
->pre
, &backse
.pre
);
5459 back
= gfc_evaluate_now_loc (input_location
, back
, &se
->pre
);
5460 gfc_add_block_to_block (&se
->pre
, &backse
.post
);
5463 if (maskexpr
&& maskexpr
->rank
!= 0)
5465 maskss
= gfc_walk_expr (maskexpr
);
5466 gcc_assert (maskss
!= gfc_ss_terminator
);
5471 if (gfc_array_size (arrayexpr
, &asize
))
5473 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5475 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5476 logical_type_node
, nonempty
,
5477 gfc_index_zero_node
);
5482 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
5483 switch (arrayexpr
->ts
.type
)
5486 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
5490 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
5491 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
5492 arrayexpr
->ts
.kind
);
5499 /* We start with the most negative possible value for MAXLOC, and the most
5500 positive possible value for MINLOC. The most negative possible value is
5501 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5502 possible value is HUGE in both cases. */
5504 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5505 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
5506 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
5507 build_int_cst (TREE_TYPE (tmp
), 1));
5509 gfc_add_modify (&se
->pre
, limit
, tmp
);
5511 /* Initialize the scalarizer. */
5512 gfc_init_loopinfo (&loop
);
5514 /* We add the mask first because the number of iterations is taken
5515 from the last ss, and this breaks if an absent optional argument
5516 is used for mask. */
5519 gfc_add_ss_to_loop (&loop
, maskss
);
5521 gfc_add_ss_to_loop (&loop
, arrayss
);
5523 /* Initialize the loop. */
5524 gfc_conv_ss_startstride (&loop
);
5526 /* The code generated can have more than one loop in sequence (see the
5527 comment at the function header). This doesn't work well with the
5528 scalarizer, which changes arrays' offset when the scalarization loops
5529 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
5530 are currently inlined in the scalar case only (for which loop is of rank
5531 one). As there is no dependency to care about in that case, there is no
5532 temporary, so that we can use the scalarizer temporary code to handle
5533 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
5534 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
5536 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
5537 should eventually go away. We could either create two loops properly,
5538 or find another way to save/restore the array offsets between the two
5539 loops (without conflicting with temporary management), or use a single
5540 loop minmaxloc implementation. See PR 31067. */
5541 loop
.temp_dim
= loop
.dimen
;
5542 gfc_conv_loop_setup (&loop
, &expr
->where
);
5544 gcc_assert (loop
.dimen
== 1);
5545 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
5546 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5547 loop
.from
[0], loop
.to
[0]);
5551 /* Initialize the position to zero, following Fortran 2003. We are free
5552 to do this because Fortran 95 allows the result of an entirely false
5553 mask to be processor dependent. If we know at compile time the array
5554 is non-empty and no MASK is used, we can initialize to 1 to simplify
5556 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
5557 gfc_add_modify (&loop
.pre
, pos
,
5558 fold_build3_loc (input_location
, COND_EXPR
,
5559 gfc_array_index_type
,
5560 nonempty
, gfc_index_one_node
,
5561 gfc_index_zero_node
));
5564 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
5565 lab1
= gfc_build_label_decl (NULL_TREE
);
5566 TREE_USED (lab1
) = 1;
5567 lab2
= gfc_build_label_decl (NULL_TREE
);
5568 TREE_USED (lab2
) = 1;
5571 /* An offset must be added to the loop
5572 counter to obtain the required position. */
5573 gcc_assert (loop
.from
[0]);
5575 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5576 gfc_index_one_node
, loop
.from
[0]);
5577 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5579 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
5581 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
5582 /* Generate the loop body. */
5583 gfc_start_scalarized_body (&loop
, &body
);
5585 /* If we have a mask, only check this element if the mask is set. */
5588 gfc_init_se (&maskse
, NULL
);
5589 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5591 gfc_conv_expr_val (&maskse
, maskexpr
);
5592 gfc_add_block_to_block (&body
, &maskse
.pre
);
5594 gfc_start_block (&block
);
5597 gfc_init_block (&block
);
5599 /* Compare with the current limit. */
5600 gfc_init_se (&arrayse
, NULL
);
5601 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5602 arrayse
.ss
= arrayss
;
5603 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5604 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5606 /* We do the following if this is a more extreme value. */
5607 gfc_start_block (&ifblock
);
5609 /* Assign the value to the limit... */
5610 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5612 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
5614 stmtblock_t ifblock2
;
5617 gfc_start_block (&ifblock2
);
5618 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5619 loop
.loopvar
[0], offset
);
5620 gfc_add_modify (&ifblock2
, pos
, tmp
);
5621 ifbody2
= gfc_finish_block (&ifblock2
);
5622 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pos
,
5623 gfc_index_zero_node
);
5624 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
5625 build_empty_stmt (input_location
));
5626 gfc_add_expr_to_block (&block
, tmp
);
5629 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5630 loop
.loopvar
[0], offset
);
5631 gfc_add_modify (&ifblock
, pos
, tmp
);
5634 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
5636 ifbody
= gfc_finish_block (&ifblock
);
5638 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
5641 cond
= fold_build2_loc (input_location
,
5642 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5643 logical_type_node
, arrayse
.expr
, limit
);
5646 tree ifbody2
, elsebody2
;
5648 /* We switch to > or >= depending on the value of the BACK argument. */
5649 cond
= gfc_create_var (logical_type_node
, "cond");
5651 gfc_start_block (&ifblock
);
5652 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5653 logical_type_node
, arrayse
.expr
, limit
);
5655 gfc_add_modify (&ifblock
, cond
, b_if
);
5656 ifbody2
= gfc_finish_block (&ifblock
);
5658 gfc_start_block (&elseblock
);
5659 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5660 arrayse
.expr
, limit
);
5662 gfc_add_modify (&elseblock
, cond
, b_else
);
5663 elsebody2
= gfc_finish_block (&elseblock
);
5665 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5666 back
, ifbody2
, elsebody2
);
5668 gfc_add_expr_to_block (&block
, tmp
);
5671 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5672 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
5673 build_empty_stmt (input_location
));
5675 gfc_add_expr_to_block (&block
, ifbody
);
5679 /* We enclose the above in if (mask) {...}. If the mask is an
5680 optional argument, generate IF (.NOT. PRESENT(MASK)
5684 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5685 tmp
= gfc_finish_block (&block
);
5686 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5687 build_empty_stmt (input_location
));
5690 tmp
= gfc_finish_block (&block
);
5691 gfc_add_expr_to_block (&body
, tmp
);
5695 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5697 if (HONOR_NANS (DECL_MODE (limit
)))
5699 if (nonempty
!= NULL
)
5701 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
5702 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
5703 build_empty_stmt (input_location
));
5704 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
5708 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
5709 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
5711 /* If we have a mask, only check this element if the mask is set. */
5714 gfc_init_se (&maskse
, NULL
);
5715 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5717 gfc_conv_expr_val (&maskse
, maskexpr
);
5718 gfc_add_block_to_block (&body
, &maskse
.pre
);
5720 gfc_start_block (&block
);
5723 gfc_init_block (&block
);
5725 /* Compare with the current limit. */
5726 gfc_init_se (&arrayse
, NULL
);
5727 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5728 arrayse
.ss
= arrayss
;
5729 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5730 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5732 /* We do the following if this is a more extreme value. */
5733 gfc_start_block (&ifblock
);
5735 /* Assign the value to the limit... */
5736 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5738 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5739 loop
.loopvar
[0], offset
);
5740 gfc_add_modify (&ifblock
, pos
, tmp
);
5742 ifbody
= gfc_finish_block (&ifblock
);
5744 /* We switch to > or >= depending on the value of the BACK argument. */
5746 tree ifbody2
, elsebody2
;
5748 cond
= gfc_create_var (logical_type_node
, "cond");
5750 gfc_start_block (&ifblock
);
5751 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5752 logical_type_node
, arrayse
.expr
, limit
);
5754 gfc_add_modify (&ifblock
, cond
, b_if
);
5755 ifbody2
= gfc_finish_block (&ifblock
);
5757 gfc_start_block (&elseblock
);
5758 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5759 arrayse
.expr
, limit
);
5761 gfc_add_modify (&elseblock
, cond
, b_else
);
5762 elsebody2
= gfc_finish_block (&elseblock
);
5764 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5765 back
, ifbody2
, elsebody2
);
5768 gfc_add_expr_to_block (&block
, tmp
);
5769 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5770 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
5771 build_empty_stmt (input_location
));
5773 gfc_add_expr_to_block (&block
, tmp
);
5777 /* We enclose the above in if (mask) {...}. If the mask is
5778 an optional argument, generate IF (.NOT. PRESENT(MASK)
5782 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5783 tmp
= gfc_finish_block (&block
);
5784 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5785 build_empty_stmt (input_location
));
5788 tmp
= gfc_finish_block (&block
);
5789 gfc_add_expr_to_block (&body
, tmp
);
5790 /* Avoid initializing loopvar[0] again, it should be left where
5791 it finished by the first loop. */
5792 loop
.from
[0] = loop
.loopvar
[0];
5795 gfc_trans_scalarizing_loops (&loop
, &body
);
5798 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
5800 /* For a scalar mask, enclose the loop in an if statement. */
5801 if (maskexpr
&& maskss
== NULL
)
5805 gfc_init_se (&maskse
, NULL
);
5806 gfc_conv_expr_val (&maskse
, maskexpr
);
5807 gfc_add_block_to_block (&se
->pre
, &maskse
.pre
);
5808 gfc_init_block (&block
);
5809 gfc_add_block_to_block (&block
, &loop
.pre
);
5810 gfc_add_block_to_block (&block
, &loop
.post
);
5811 tmp
= gfc_finish_block (&block
);
5813 /* For the else part of the scalar mask, just initialize
5814 the pos variable the same way as above. */
5816 gfc_init_block (&elseblock
);
5817 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
5818 elsetmp
= gfc_finish_block (&elseblock
);
5819 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5820 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
, elsetmp
);
5821 gfc_add_expr_to_block (&block
, tmp
);
5822 gfc_add_block_to_block (&se
->pre
, &block
);
5826 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5827 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5829 gfc_cleanup_loop (&loop
);
5831 se
->expr
= convert (type
, pos
);
5834 /* Emit code for findloc. */
5837 gfc_conv_intrinsic_findloc (gfc_se
*se
, gfc_expr
*expr
)
5839 gfc_actual_arglist
*array_arg
, *value_arg
, *dim_arg
, *mask_arg
,
5840 *kind_arg
, *back_arg
;
5841 gfc_expr
*value_expr
;
5846 stmtblock_t loopblock
;
5850 tree forward_branch
= NULL_TREE
;
5865 array_arg
= expr
->value
.function
.actual
;
5866 value_arg
= array_arg
->next
;
5867 dim_arg
= value_arg
->next
;
5868 mask_arg
= dim_arg
->next
;
5869 kind_arg
= mask_arg
->next
;
5870 back_arg
= kind_arg
->next
;
5872 /* Remove kind and set ikind. */
5875 ikind
= mpz_get_si (kind_arg
->expr
->value
.integer
);
5876 gfc_free_expr (kind_arg
->expr
);
5877 kind_arg
->expr
= NULL
;
5880 ikind
= gfc_default_integer_kind
;
5882 value_expr
= value_arg
->expr
;
5884 /* Unless it's a string, pass VALUE by value. */
5885 if (value_expr
->ts
.type
!= BT_CHARACTER
)
5886 value_arg
->name
= "%VAL";
5888 /* Pass BACK argument by value. */
5889 back_arg
->name
= "%VAL";
5891 /* Call the library if we have a character function or if
5893 if (se
->ss
|| array_arg
->expr
->ts
.type
== BT_CHARACTER
)
5895 se
->ignore_optional
= 1;
5896 if (expr
->rank
== 0)
5898 /* Remove dim argument. */
5899 gfc_free_expr (dim_arg
->expr
);
5900 dim_arg
->expr
= NULL
;
5902 gfc_conv_intrinsic_funcall (se
, expr
);
5906 type
= gfc_get_int_type (ikind
);
5908 /* Initialize the result. */
5909 resvar
= gfc_create_var (gfc_array_index_type
, "pos");
5910 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (gfc_array_index_type
, 0));
5911 offset
= gfc_create_var (gfc_array_index_type
, "offset");
5913 maskexpr
= mask_arg
->expr
;
5914 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5915 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5916 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5918 /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5920 for (i
= 0 ; i
< 2; i
++)
5922 /* Walk the arguments. */
5923 arrayss
= gfc_walk_expr (array_arg
->expr
);
5924 gcc_assert (arrayss
!= gfc_ss_terminator
);
5926 if (maskexpr
&& maskexpr
->rank
!= 0)
5928 maskss
= gfc_walk_expr (maskexpr
);
5929 gcc_assert (maskss
!= gfc_ss_terminator
);
5934 /* Initialize the scalarizer. */
5935 gfc_init_loopinfo (&loop
);
5936 exit_label
= gfc_build_label_decl (NULL_TREE
);
5937 TREE_USED (exit_label
) = 1;
5939 /* We add the mask first because the number of iterations is
5940 taken from the last ss, and this breaks if an absent
5941 optional argument is used for mask. */
5944 gfc_add_ss_to_loop (&loop
, maskss
);
5945 gfc_add_ss_to_loop (&loop
, arrayss
);
5947 /* Initialize the loop. */
5948 gfc_conv_ss_startstride (&loop
);
5949 gfc_conv_loop_setup (&loop
, &expr
->where
);
5951 /* Calculate the offset. */
5952 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5953 gfc_index_one_node
, loop
.from
[0]);
5954 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5956 gfc_mark_ss_chain_used (arrayss
, 1);
5958 gfc_mark_ss_chain_used (maskss
, 1);
5960 /* The first loop is for BACK=.true. */
5962 loop
.reverse
[0] = GFC_REVERSE_SET
;
5964 /* Generate the loop body. */
5965 gfc_start_scalarized_body (&loop
, &body
);
5967 /* If we have an array mask, only add the element if it is
5971 gfc_init_se (&maskse
, NULL
);
5972 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5974 gfc_conv_expr_val (&maskse
, maskexpr
);
5975 gfc_add_block_to_block (&body
, &maskse
.pre
);
5978 /* If the condition matches then set the return value. */
5979 gfc_start_block (&block
);
5981 /* Add the offset. */
5982 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5984 loop
.loopvar
[0], offset
);
5985 gfc_add_modify (&block
, resvar
, tmp
);
5986 /* And break out of the loop. */
5987 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5988 gfc_add_expr_to_block (&block
, tmp
);
5990 found
= gfc_finish_block (&block
);
5992 /* Check this element. */
5993 gfc_init_se (&arrayse
, NULL
);
5994 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5995 arrayse
.ss
= arrayss
;
5996 gfc_conv_expr_val (&arrayse
, array_arg
->expr
);
5997 gfc_add_block_to_block (&body
, &arrayse
.pre
);
5999 gfc_init_se (&valuese
, NULL
);
6000 gfc_conv_expr_val (&valuese
, value_arg
->expr
);
6001 gfc_add_block_to_block (&body
, &valuese
.pre
);
6003 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6004 arrayse
.expr
, valuese
.expr
);
6006 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
6009 /* We enclose the above in if (mask) {...}. If the mask is
6010 an optional argument, generate IF (.NOT. PRESENT(MASK)
6014 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6015 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6016 build_empty_stmt (input_location
));
6019 gfc_add_expr_to_block (&body
, tmp
);
6020 gfc_add_block_to_block (&body
, &arrayse
.post
);
6022 gfc_trans_scalarizing_loops (&loop
, &body
);
6024 /* Add the exit label. */
6025 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6026 gfc_add_expr_to_block (&loop
.pre
, tmp
);
6027 gfc_start_block (&loopblock
);
6028 gfc_add_block_to_block (&loopblock
, &loop
.pre
);
6029 gfc_add_block_to_block (&loopblock
, &loop
.post
);
6031 forward_branch
= gfc_finish_block (&loopblock
);
6033 back_branch
= gfc_finish_block (&loopblock
);
6035 gfc_cleanup_loop (&loop
);
6038 /* Enclose the two loops in an IF statement. */
6040 gfc_init_se (&backse
, NULL
);
6041 gfc_conv_expr_val (&backse
, back_arg
->expr
);
6042 gfc_add_block_to_block (&se
->pre
, &backse
.pre
);
6043 tmp
= build3_v (COND_EXPR
, backse
.expr
, forward_branch
, back_branch
);
6045 /* For a scalar mask, enclose the loop in an if statement. */
6046 if (maskexpr
&& maskss
== NULL
)
6051 gfc_init_se (&maskse
, NULL
);
6052 gfc_conv_expr_val (&maskse
, maskexpr
);
6053 gfc_init_block (&block
);
6054 gfc_add_expr_to_block (&block
, maskse
.expr
);
6055 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6056 if_stmt
= build3_v (COND_EXPR
, ifmask
, tmp
,
6057 build_empty_stmt (input_location
));
6058 gfc_add_expr_to_block (&block
, if_stmt
);
6059 tmp
= gfc_finish_block (&block
);
6062 gfc_add_expr_to_block (&se
->pre
, tmp
);
6063 se
->expr
= convert (type
, resvar
);
6067 /* Emit code for minval or maxval intrinsic. There are many different cases
6068 we need to handle. For performance reasons we sometimes create two
6069 loops instead of one, where the second one is much simpler.
6070 Examples for minval intrinsic:
6071 1) Result is an array, a call is generated
6072 2) Array mask is used and NaNs need to be supported, rank 1:
6077 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
6080 limit = nonempty ? NaN : huge (limit);
6082 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6083 3) NaNs need to be supported, but it is known at compile time or cheaply
6084 at runtime whether array is nonempty or not, rank 1:
6087 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
6088 limit = (from <= to) ? NaN : huge (limit);
6090 while (S <= to) { limit = min (a[S], limit); S++; }
6091 4) Array mask is used and NaNs need to be supported, rank > 1:
6100 if (fast) limit = min (a[S1][S2], limit);
6103 if (a[S1][S2] <= limit) {
6114 limit = nonempty ? NaN : huge (limit);
6115 5) NaNs need to be supported, but it is known at compile time or cheaply
6116 at runtime whether array is nonempty or not, rank > 1:
6123 if (fast) limit = min (a[S1][S2], limit);
6125 if (a[S1][S2] <= limit) {
6135 limit = (nonempty_array) ? NaN : huge (limit);
6136 6) NaNs aren't supported, but infinities are. Array mask is used:
6141 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6144 limit = nonempty ? limit : huge (limit);
6145 7) Same without array mask:
6148 while (S <= to) { limit = min (a[S], limit); S++; }
6149 limit = (from <= to) ? limit : huge (limit);
6150 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6151 limit = huge (limit);
6153 while (S <= to) { limit = min (a[S], limit); S++); }
6155 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6156 with array mask instead).
6157 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6158 setting limit = huge (limit); in the else branch. */
6161 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6171 tree huge_cst
= NULL
, nan_cst
= NULL
;
6173 stmtblock_t block
, block2
;
6175 gfc_actual_arglist
*actual
;
6180 gfc_expr
*arrayexpr
;
6187 gfc_conv_intrinsic_funcall (se
, expr
);
6191 actual
= expr
->value
.function
.actual
;
6192 arrayexpr
= actual
->expr
;
6194 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
6196 gfc_actual_arglist
*dim
= actual
->next
;
6197 if (expr
->rank
== 0 && dim
->expr
!= 0)
6199 gfc_free_expr (dim
->expr
);
6202 gfc_conv_intrinsic_funcall (se
, expr
);
6206 type
= gfc_typenode_for_spec (&expr
->ts
);
6207 /* Initialize the result. */
6208 limit
= gfc_create_var (type
, "limit");
6209 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
6210 switch (expr
->ts
.type
)
6213 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
6215 if (HONOR_INFINITIES (DECL_MODE (limit
)))
6217 REAL_VALUE_TYPE real
;
6219 tmp
= build_real (type
, real
);
6223 if (HONOR_NANS (DECL_MODE (limit
)))
6224 nan_cst
= gfc_build_nan (type
, "");
6228 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
6235 /* We start with the most negative possible value for MAXVAL, and the most
6236 positive possible value for MINVAL. The most negative possible value is
6237 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6238 possible value is HUGE in both cases. */
6241 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
6243 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
6244 TREE_TYPE (huge_cst
), huge_cst
);
6247 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
6248 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6249 tmp
, build_int_cst (type
, 1));
6251 gfc_add_modify (&se
->pre
, limit
, tmp
);
6253 /* Walk the arguments. */
6254 arrayss
= gfc_walk_expr (arrayexpr
);
6255 gcc_assert (arrayss
!= gfc_ss_terminator
);
6257 actual
= actual
->next
->next
;
6258 gcc_assert (actual
);
6259 maskexpr
= actual
->expr
;
6260 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
6261 && maskexpr
->symtree
->n
.sym
->attr
.dummy
6262 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
6264 if (maskexpr
&& maskexpr
->rank
!= 0)
6266 maskss
= gfc_walk_expr (maskexpr
);
6267 gcc_assert (maskss
!= gfc_ss_terminator
);
6272 if (gfc_array_size (arrayexpr
, &asize
))
6274 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
6276 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
6277 logical_type_node
, nonempty
,
6278 gfc_index_zero_node
);
6283 /* Initialize the scalarizer. */
6284 gfc_init_loopinfo (&loop
);
6286 /* We add the mask first because the number of iterations is taken
6287 from the last ss, and this breaks if an absent optional argument
6288 is used for mask. */
6291 gfc_add_ss_to_loop (&loop
, maskss
);
6292 gfc_add_ss_to_loop (&loop
, arrayss
);
6294 /* Initialize the loop. */
6295 gfc_conv_ss_startstride (&loop
);
6297 /* The code generated can have more than one loop in sequence (see the
6298 comment at the function header). This doesn't work well with the
6299 scalarizer, which changes arrays' offset when the scalarization loops
6300 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6301 are currently inlined in the scalar case only. As there is no dependency
6302 to care about in that case, there is no temporary, so that we can use the
6303 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6304 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6305 gfc_trans_scalarized_loop_boundary even later to restore offset.
6306 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6307 should eventually go away. We could either create two loops properly,
6308 or find another way to save/restore the array offsets between the two
6309 loops (without conflicting with temporary management), or use a single
6310 loop minmaxval implementation. See PR 31067. */
6311 loop
.temp_dim
= loop
.dimen
;
6312 gfc_conv_loop_setup (&loop
, &expr
->where
);
6314 if (nonempty
== NULL
&& maskss
== NULL
6315 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
6316 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
6317 loop
.from
[0], loop
.to
[0]);
6318 nonempty_var
= NULL
;
6319 if (nonempty
== NULL
6320 && (HONOR_INFINITIES (DECL_MODE (limit
))
6321 || HONOR_NANS (DECL_MODE (limit
))))
6323 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
6324 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
6325 nonempty
= nonempty_var
;
6329 if (HONOR_NANS (DECL_MODE (limit
)))
6331 if (loop
.dimen
== 1)
6333 lab
= gfc_build_label_decl (NULL_TREE
);
6334 TREE_USED (lab
) = 1;
6338 fast
= gfc_create_var (logical_type_node
, "fast");
6339 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
6343 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
6345 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
6346 /* Generate the loop body. */
6347 gfc_start_scalarized_body (&loop
, &body
);
6349 /* If we have a mask, only add this element if the mask is set. */
6352 gfc_init_se (&maskse
, NULL
);
6353 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
6355 gfc_conv_expr_val (&maskse
, maskexpr
);
6356 gfc_add_block_to_block (&body
, &maskse
.pre
);
6358 gfc_start_block (&block
);
6361 gfc_init_block (&block
);
6363 /* Compare with the current limit. */
6364 gfc_init_se (&arrayse
, NULL
);
6365 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
6366 arrayse
.ss
= arrayss
;
6367 gfc_conv_expr_val (&arrayse
, arrayexpr
);
6368 gfc_add_block_to_block (&block
, &arrayse
.pre
);
6370 gfc_init_block (&block2
);
6373 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
6375 if (HONOR_NANS (DECL_MODE (limit
)))
6377 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
6378 logical_type_node
, arrayse
.expr
, limit
);
6380 ifbody
= build1_v (GOTO_EXPR
, lab
);
6383 stmtblock_t ifblock
;
6385 gfc_init_block (&ifblock
);
6386 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
6387 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
6388 ifbody
= gfc_finish_block (&ifblock
);
6390 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
6391 build_empty_stmt (input_location
));
6392 gfc_add_expr_to_block (&block2
, tmp
);
6396 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6398 tmp
= fold_build2_loc (input_location
,
6399 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6400 type
, arrayse
.expr
, limit
);
6401 gfc_add_modify (&block2
, limit
, tmp
);
6406 tree elsebody
= gfc_finish_block (&block2
);
6408 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6410 if (HONOR_NANS (DECL_MODE (limit
)))
6412 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
6413 arrayse
.expr
, limit
);
6414 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
6415 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
6416 build_empty_stmt (input_location
));
6420 tmp
= fold_build2_loc (input_location
,
6421 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6422 type
, arrayse
.expr
, limit
);
6423 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
6425 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
6426 gfc_add_expr_to_block (&block
, tmp
);
6429 gfc_add_block_to_block (&block
, &block2
);
6431 gfc_add_block_to_block (&block
, &arrayse
.post
);
6433 tmp
= gfc_finish_block (&block
);
6436 /* We enclose the above in if (mask) {...}. If the mask is an
6437 optional argument, generate IF (.NOT. PRESENT(MASK)
6440 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6441 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6442 build_empty_stmt (input_location
));
6444 gfc_add_expr_to_block (&body
, tmp
);
6448 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
6450 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
6452 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
6453 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
6455 /* If we have a mask, only add this element if the mask is set. */
6458 gfc_init_se (&maskse
, NULL
);
6459 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
6461 gfc_conv_expr_val (&maskse
, maskexpr
);
6462 gfc_add_block_to_block (&body
, &maskse
.pre
);
6464 gfc_start_block (&block
);
6467 gfc_init_block (&block
);
6469 /* Compare with the current limit. */
6470 gfc_init_se (&arrayse
, NULL
);
6471 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
6472 arrayse
.ss
= arrayss
;
6473 gfc_conv_expr_val (&arrayse
, arrayexpr
);
6474 gfc_add_block_to_block (&block
, &arrayse
.pre
);
6476 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6478 if (HONOR_NANS (DECL_MODE (limit
)))
6480 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
6481 arrayse
.expr
, limit
);
6482 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
6483 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
6484 build_empty_stmt (input_location
));
6485 gfc_add_expr_to_block (&block
, tmp
);
6489 tmp
= fold_build2_loc (input_location
,
6490 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6491 type
, arrayse
.expr
, limit
);
6492 gfc_add_modify (&block
, limit
, tmp
);
6495 gfc_add_block_to_block (&block
, &arrayse
.post
);
6497 tmp
= gfc_finish_block (&block
);
6499 /* We enclose the above in if (mask) {...}. */
6502 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6503 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6504 build_empty_stmt (input_location
));
6507 gfc_add_expr_to_block (&body
, tmp
);
6508 /* Avoid initializing loopvar[0] again, it should be left where
6509 it finished by the first loop. */
6510 loop
.from
[0] = loop
.loopvar
[0];
6512 gfc_trans_scalarizing_loops (&loop
, &body
);
6516 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
6518 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
6519 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
6521 gfc_add_expr_to_block (&loop
.pre
, tmp
);
6523 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
6525 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
6527 gfc_add_modify (&loop
.pre
, limit
, tmp
);
6530 /* For a scalar mask, enclose the loop in an if statement. */
6531 if (maskexpr
&& maskss
== NULL
)
6536 gfc_init_se (&maskse
, NULL
);
6537 gfc_conv_expr_val (&maskse
, maskexpr
);
6538 gfc_init_block (&block
);
6539 gfc_add_block_to_block (&block
, &loop
.pre
);
6540 gfc_add_block_to_block (&block
, &loop
.post
);
6541 tmp
= gfc_finish_block (&block
);
6543 if (HONOR_INFINITIES (DECL_MODE (limit
)))
6544 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
6546 else_stmt
= build_empty_stmt (input_location
);
6548 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6549 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
, else_stmt
);
6550 gfc_add_expr_to_block (&block
, tmp
);
6551 gfc_add_block_to_block (&se
->pre
, &block
);
6555 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6556 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
6559 gfc_cleanup_loop (&loop
);
6564 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6566 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
6572 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6573 type
= TREE_TYPE (args
[0]);
6575 /* Optionally generate code for runtime argument check. */
6576 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6578 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6579 logical_type_node
, args
[1],
6580 build_int_cst (TREE_TYPE (args
[1]), 0));
6581 tree nbits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6582 tree above
= fold_build2_loc (input_location
, GE_EXPR
,
6583 logical_type_node
, args
[1], nbits
);
6584 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6585 logical_type_node
, below
, above
);
6586 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6587 "POS argument (%ld) out of range 0:%ld "
6588 "in intrinsic BTEST",
6589 fold_convert (long_integer_type_node
, args
[1]),
6590 fold_convert (long_integer_type_node
, nbits
));
6593 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
6594 build_int_cst (type
, 1), args
[1]);
6595 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
6596 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
6597 build_int_cst (type
, 0));
6598 type
= gfc_typenode_for_spec (&expr
->ts
);
6599 se
->expr
= convert (type
, tmp
);
6603 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6605 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6609 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6611 /* Convert both arguments to the unsigned type of the same size. */
6612 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
6613 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
6615 /* If they have unequal type size, convert to the larger one. */
6616 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
6617 > TYPE_PRECISION (TREE_TYPE (args
[1])))
6618 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
6619 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
6620 > TYPE_PRECISION (TREE_TYPE (args
[0])))
6621 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
6623 /* Now, we compare them. */
6624 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
6629 /* Generate code to perform the specified operation. */
6631 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6635 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6636 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
6642 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
6646 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6647 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6648 TREE_TYPE (arg
), arg
);
6651 /* Set or clear a single bit. */
6653 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
6660 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6661 type
= TREE_TYPE (args
[0]);
6663 /* Optionally generate code for runtime argument check. */
6664 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6666 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6667 logical_type_node
, args
[1],
6668 build_int_cst (TREE_TYPE (args
[1]), 0));
6669 tree nbits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6670 tree above
= fold_build2_loc (input_location
, GE_EXPR
,
6671 logical_type_node
, args
[1], nbits
);
6672 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6673 logical_type_node
, below
, above
);
6674 size_t len_name
= strlen (expr
->value
.function
.isym
->name
);
6675 char *name
= XALLOCAVEC (char, len_name
+ 1);
6676 for (size_t i
= 0; i
< len_name
; i
++)
6677 name
[i
] = TOUPPER (expr
->value
.function
.isym
->name
[i
]);
6678 name
[len_name
] = '\0';
6679 tree iname
= gfc_build_addr_expr (pchar_type_node
,
6680 gfc_build_cstring_const (name
));
6681 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6682 "POS argument (%ld) out of range 0:%ld "
6684 fold_convert (long_integer_type_node
, args
[1]),
6685 fold_convert (long_integer_type_node
, nbits
),
6689 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
6690 build_int_cst (type
, 1), args
[1]);
6696 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
6698 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
6701 /* Extract a sequence of bits.
6702 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6704 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
6710 tree num_bits
, cond
;
6712 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6713 type
= TREE_TYPE (args
[0]);
6715 /* Optionally generate code for runtime argument check. */
6716 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6718 tree tmp1
= fold_convert (long_integer_type_node
, args
[1]);
6719 tree tmp2
= fold_convert (long_integer_type_node
, args
[2]);
6720 tree nbits
= build_int_cst (long_integer_type_node
,
6721 TYPE_PRECISION (type
));
6722 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6723 logical_type_node
, args
[1],
6724 build_int_cst (TREE_TYPE (args
[1]), 0));
6725 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6726 logical_type_node
, tmp1
, nbits
);
6727 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6728 logical_type_node
, below
, above
);
6729 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6730 "POS argument (%ld) out of range 0:%ld "
6731 "in intrinsic IBITS", tmp1
, nbits
);
6732 below
= fold_build2_loc (input_location
, LT_EXPR
,
6733 logical_type_node
, args
[2],
6734 build_int_cst (TREE_TYPE (args
[2]), 0));
6735 above
= fold_build2_loc (input_location
, GT_EXPR
,
6736 logical_type_node
, tmp2
, nbits
);
6737 scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6738 logical_type_node
, below
, above
);
6739 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6740 "LEN argument (%ld) out of range 0:%ld "
6741 "in intrinsic IBITS", tmp2
, nbits
);
6742 above
= fold_build2_loc (input_location
, PLUS_EXPR
,
6743 long_integer_type_node
, tmp1
, tmp2
);
6744 scond
= fold_build2_loc (input_location
, GT_EXPR
,
6745 logical_type_node
, above
, nbits
);
6746 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6747 "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6748 "in intrinsic IBITS", tmp1
, tmp2
, nbits
);
6751 /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
6752 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6753 special case. See also gfc_conv_intrinsic_ishft (). */
6754 num_bits
= build_int_cst (TREE_TYPE (args
[2]), TYPE_PRECISION (type
));
6756 mask
= build_int_cst (type
, -1);
6757 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
6758 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[2],
6760 mask
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6761 build_int_cst (type
, 0), mask
);
6762 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
6764 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
6766 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
6770 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
6773 tree args
[2], type
, num_bits
, cond
;
6776 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6778 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6779 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6780 type
= TREE_TYPE (args
[0]);
6783 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
6785 gcc_assert (right_shift
);
6787 se
->expr
= fold_build2_loc (input_location
,
6788 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
6789 TREE_TYPE (args
[0]), args
[0], args
[1]);
6792 se
->expr
= fold_convert (type
, se
->expr
);
6795 bigshift
= build_int_cst (type
, 0);
6798 tree nonneg
= fold_build2_loc (input_location
, GE_EXPR
,
6799 logical_type_node
, args
[0],
6800 build_int_cst (TREE_TYPE (args
[0]), 0));
6801 bigshift
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonneg
,
6802 build_int_cst (type
, 0),
6803 build_int_cst (type
, -1));
6806 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6807 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6809 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6811 /* Optionally generate code for runtime argument check. */
6812 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6814 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6815 logical_type_node
, args
[1],
6816 build_int_cst (TREE_TYPE (args
[1]), 0));
6817 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6818 logical_type_node
, args
[1], num_bits
);
6819 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6820 logical_type_node
, below
, above
);
6821 size_t len_name
= strlen (expr
->value
.function
.isym
->name
);
6822 char *name
= XALLOCAVEC (char, len_name
+ 1);
6823 for (size_t i
= 0; i
< len_name
; i
++)
6824 name
[i
] = TOUPPER (expr
->value
.function
.isym
->name
[i
]);
6825 name
[len_name
] = '\0';
6826 tree iname
= gfc_build_addr_expr (pchar_type_node
,
6827 gfc_build_cstring_const (name
));
6828 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6829 "SHIFT argument (%ld) out of range 0:%ld "
6831 fold_convert (long_integer_type_node
, args
[1]),
6832 fold_convert (long_integer_type_node
, num_bits
),
6836 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6839 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6840 bigshift
, se
->expr
);
6843 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
6845 : ((shift >= 0) ? i << shift : i >> -shift)
6846 where all shifts are logical shifts. */
6848 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
6860 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6862 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6863 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6865 type
= TREE_TYPE (args
[0]);
6866 utype
= unsigned_type_for (type
);
6868 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
6871 /* Left shift if positive. */
6872 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
6874 /* Right shift if negative.
6875 We convert to an unsigned type because we want a logical shift.
6876 The standard doesn't define the case of shifting negative
6877 numbers, and we try to be compatible with other compilers, most
6878 notably g77, here. */
6879 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
6880 utype
, convert (utype
, args
[0]), width
));
6882 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
6883 build_int_cst (TREE_TYPE (args
[1]), 0));
6884 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
6886 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6887 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6889 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6891 /* Optionally generate code for runtime argument check. */
6892 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6894 tree outside
= fold_build2_loc (input_location
, GT_EXPR
,
6895 logical_type_node
, width
, num_bits
);
6896 gfc_trans_runtime_check (true, false, outside
, &se
->pre
, &expr
->where
,
6897 "SHIFT argument (%ld) out of range -%ld:%ld "
6898 "in intrinsic ISHFT",
6899 fold_convert (long_integer_type_node
, args
[1]),
6900 fold_convert (long_integer_type_node
, num_bits
),
6901 fold_convert (long_integer_type_node
, num_bits
));
6904 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
6906 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6907 build_int_cst (type
, 0), tmp
);
6911 /* Circular shift. AKA rotate or barrel shift. */
6914 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
6923 unsigned int num_args
;
6925 num_args
= gfc_intrinsic_argument_list_length (expr
);
6926 args
= XALLOCAVEC (tree
, num_args
);
6928 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6930 type
= TREE_TYPE (args
[0]);
6931 nbits
= build_int_cst (long_integer_type_node
, TYPE_PRECISION (type
));
6935 gfc_expr
*size
= expr
->value
.function
.actual
->next
->next
->expr
;
6937 /* Use a library function for the 3 parameter version. */
6938 tree int4type
= gfc_get_int_type (4);
6940 /* Treat optional SIZE argument when it is passed as an optional
6941 dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
6942 if (size
->expr_type
== EXPR_VARIABLE
6943 && size
->symtree
->n
.sym
->attr
.dummy
6944 && size
->symtree
->n
.sym
->attr
.optional
)
6946 tree type_of_size
= TREE_TYPE (args
[2]);
6947 args
[2] = build3_loc (input_location
, COND_EXPR
, type_of_size
,
6948 gfc_conv_expr_present (size
->symtree
->n
.sym
),
6949 args
[2], fold_convert (type_of_size
, nbits
));
6952 /* We convert the first argument to at least 4 bytes, and
6953 convert back afterwards. This removes the need for library
6954 functions for all argument sizes, and function will be
6955 aligned to at least 32 bits, so there's no loss. */
6956 if (expr
->ts
.kind
< 4)
6957 args
[0] = convert (int4type
, args
[0]);
6959 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
6960 need loads of library functions. They cannot have values >
6961 BIT_SIZE (I) so the conversion is safe. */
6962 args
[1] = convert (int4type
, args
[1]);
6963 args
[2] = convert (int4type
, args
[2]);
6965 /* Optionally generate code for runtime argument check. */
6966 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6968 tree size
= fold_convert (long_integer_type_node
, args
[2]);
6969 tree below
= fold_build2_loc (input_location
, LE_EXPR
,
6970 logical_type_node
, size
,
6971 build_int_cst (TREE_TYPE (args
[1]), 0));
6972 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6973 logical_type_node
, size
, nbits
);
6974 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6975 logical_type_node
, below
, above
);
6976 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6977 "SIZE argument (%ld) out of range 1:%ld "
6978 "in intrinsic ISHFTC", size
, nbits
);
6979 tree width
= fold_convert (long_integer_type_node
, args
[1]);
6980 width
= fold_build1_loc (input_location
, ABS_EXPR
,
6981 long_integer_type_node
, width
);
6982 scond
= fold_build2_loc (input_location
, GT_EXPR
,
6983 logical_type_node
, width
, size
);
6984 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6985 "SHIFT argument (%ld) out of range -%ld:%ld "
6986 "in intrinsic ISHFTC",
6987 fold_convert (long_integer_type_node
, args
[1]),
6991 switch (expr
->ts
.kind
)
6996 tmp
= gfor_fndecl_math_ishftc4
;
6999 tmp
= gfor_fndecl_math_ishftc8
;
7002 tmp
= gfor_fndecl_math_ishftc16
;
7007 se
->expr
= build_call_expr_loc (input_location
,
7008 tmp
, 3, args
[0], args
[1], args
[2]);
7009 /* Convert the result back to the original type, if we extended
7010 the first argument's width above. */
7011 if (expr
->ts
.kind
< 4)
7012 se
->expr
= convert (type
, se
->expr
);
7017 /* Evaluate arguments only once. */
7018 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
7019 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
7021 /* Optionally generate code for runtime argument check. */
7022 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
7024 tree width
= fold_convert (long_integer_type_node
, args
[1]);
7025 width
= fold_build1_loc (input_location
, ABS_EXPR
,
7026 long_integer_type_node
, width
);
7027 tree outside
= fold_build2_loc (input_location
, GT_EXPR
,
7028 logical_type_node
, width
, nbits
);
7029 gfc_trans_runtime_check (true, false, outside
, &se
->pre
, &expr
->where
,
7030 "SHIFT argument (%ld) out of range -%ld:%ld "
7031 "in intrinsic ISHFTC",
7032 fold_convert (long_integer_type_node
, args
[1]),
7036 /* Rotate left if positive. */
7037 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
7039 /* Rotate right if negative. */
7040 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
7042 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
7044 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
7045 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
7047 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
7049 /* Do nothing if shift == 0. */
7050 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
7052 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
7057 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7058 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7060 The conditional expression is necessary because the result of LEADZ(0)
7061 is defined, but the result of __builtin_clz(0) is undefined for most
7064 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7065 difference in bit size between the argument of LEADZ and the C int. */
7068 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
7080 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7081 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
7083 /* Which variant of __builtin_clz* should we call? */
7084 if (argsize
<= INT_TYPE_SIZE
)
7086 arg_type
= unsigned_type_node
;
7087 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
7089 else if (argsize
<= LONG_TYPE_SIZE
)
7091 arg_type
= long_unsigned_type_node
;
7092 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
7094 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
7096 arg_type
= long_long_unsigned_type_node
;
7097 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
7101 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
7102 arg_type
= gfc_build_uint_type (argsize
);
7106 /* Convert the actual argument twice: first, to the unsigned type of the
7107 same size; then, to the proper argument type for the built-in
7108 function. But the return type is of the default INTEGER kind. */
7109 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7110 arg
= fold_convert (arg_type
, arg
);
7111 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7112 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7114 /* Compute LEADZ for the case i .ne. 0. */
7117 s
= TYPE_PRECISION (arg_type
) - argsize
;
7118 tmp
= fold_convert (result_type
,
7119 build_call_expr_loc (input_location
, func
,
7121 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
7122 tmp
, build_int_cst (result_type
, s
));
7126 /* We end up here if the argument type is larger than 'long long'.
7127 We generate this code:
7129 if (x & (ULL_MAX << ULL_SIZE) != 0)
7130 return clzll ((unsigned long long) (x >> ULLSIZE));
7132 return ULL_SIZE + clzll ((unsigned long long) x);
7133 where ULL_MAX is the largest value that a ULL_MAX can hold
7134 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7135 is the bit-size of the long long type (64 in this example). */
7136 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
7138 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
7139 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7140 long_long_unsigned_type_node
,
7141 build_int_cst (long_long_unsigned_type_node
,
7144 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
7145 fold_convert (arg_type
, ullmax
), ullsize
);
7146 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
7148 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7149 cond
, build_int_cst (arg_type
, 0));
7151 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
7153 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
7154 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
7155 tmp1
= fold_convert (result_type
,
7156 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
7158 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
7159 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
7160 tmp2
= fold_convert (result_type
,
7161 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
7162 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7165 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
7169 /* Build BIT_SIZE. */
7170 bit_size
= build_int_cst (result_type
, argsize
);
7172 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7173 arg
, build_int_cst (arg_type
, 0));
7174 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
7179 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7181 The conditional expression is necessary because the result of TRAILZ(0)
7182 is defined, but the result of __builtin_ctz(0) is undefined for most
7186 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
7197 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7198 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
7200 /* Which variant of __builtin_ctz* should we call? */
7201 if (argsize
<= INT_TYPE_SIZE
)
7203 arg_type
= unsigned_type_node
;
7204 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
7206 else if (argsize
<= LONG_TYPE_SIZE
)
7208 arg_type
= long_unsigned_type_node
;
7209 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
7211 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
7213 arg_type
= long_long_unsigned_type_node
;
7214 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7218 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
7219 arg_type
= gfc_build_uint_type (argsize
);
7223 /* Convert the actual argument twice: first, to the unsigned type of the
7224 same size; then, to the proper argument type for the built-in
7225 function. But the return type is of the default INTEGER kind. */
7226 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7227 arg
= fold_convert (arg_type
, arg
);
7228 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7229 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7231 /* Compute TRAILZ for the case i .ne. 0. */
7233 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
7237 /* We end up here if the argument type is larger than 'long long'.
7238 We generate this code:
7240 if ((x & ULL_MAX) == 0)
7241 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7243 return ctzll ((unsigned long long) x);
7245 where ULL_MAX is the largest value that a ULL_MAX can hold
7246 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7247 is the bit-size of the long long type (64 in this example). */
7248 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
7250 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
7251 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7252 long_long_unsigned_type_node
,
7253 build_int_cst (long_long_unsigned_type_node
, 0));
7255 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
7256 fold_convert (arg_type
, ullmax
));
7257 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
7258 build_int_cst (arg_type
, 0));
7260 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
7262 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
7263 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7264 tmp1
= fold_convert (result_type
,
7265 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
7266 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7269 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
7270 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7271 tmp2
= fold_convert (result_type
,
7272 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
7274 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
7278 /* Build BIT_SIZE. */
7279 bit_size
= build_int_cst (result_type
, argsize
);
7281 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7282 arg
, build_int_cst (arg_type
, 0));
7283 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
7287 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7288 for types larger than "long long", we call the long long built-in for
7289 the lower and higher bits and combine the result. */
7292 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
7300 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7301 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
7302 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7304 /* Which variant of the builtin should we call? */
7305 if (argsize
<= INT_TYPE_SIZE
)
7307 arg_type
= unsigned_type_node
;
7308 func
= builtin_decl_explicit (parity
7310 : BUILT_IN_POPCOUNT
);
7312 else if (argsize
<= LONG_TYPE_SIZE
)
7314 arg_type
= long_unsigned_type_node
;
7315 func
= builtin_decl_explicit (parity
7317 : BUILT_IN_POPCOUNTL
);
7319 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
7321 arg_type
= long_long_unsigned_type_node
;
7322 func
= builtin_decl_explicit (parity
7324 : BUILT_IN_POPCOUNTLL
);
7328 /* Our argument type is larger than 'long long', which mean none
7329 of the POPCOUNT builtins covers it. We thus call the 'long long'
7330 variant multiple times, and add the results. */
7331 tree utype
, arg2
, call1
, call2
;
7333 /* For now, we only cover the case where argsize is twice as large
7335 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
7337 func
= builtin_decl_explicit (parity
7339 : BUILT_IN_POPCOUNTLL
);
7341 /* Convert it to an integer, and store into a variable. */
7342 utype
= gfc_build_uint_type (argsize
);
7343 arg
= fold_convert (utype
, arg
);
7344 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7346 /* Call the builtin twice. */
7347 call1
= build_call_expr_loc (input_location
, func
, 1,
7348 fold_convert (long_long_unsigned_type_node
,
7351 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
7352 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
7353 call2
= build_call_expr_loc (input_location
, func
, 1,
7354 fold_convert (long_long_unsigned_type_node
,
7357 /* Combine the results. */
7359 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
,
7360 integer_type_node
, call1
, call2
);
7362 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
7363 integer_type_node
, call1
, call2
);
7365 se
->expr
= convert (result_type
, se
->expr
);
7369 /* Convert the actual argument twice: first, to the unsigned type of the
7370 same size; then, to the proper argument type for the built-in
7372 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7373 arg
= fold_convert (arg_type
, arg
);
7375 se
->expr
= fold_convert (result_type
,
7376 build_call_expr_loc (input_location
, func
, 1, arg
));
7380 /* Process an intrinsic with unspecified argument-types that has an optional
7381 argument (which could be of type character), e.g. EOSHIFT. For those, we
7382 need to append the string length of the optional argument if it is not
7383 present and the type is really character.
7384 primary specifies the position (starting at 1) of the non-optional argument
7385 specifying the type and optional gives the position of the optional
7386 argument in the arglist. */
7389 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
7390 unsigned primary
, unsigned optional
)
7392 gfc_actual_arglist
* prim_arg
;
7393 gfc_actual_arglist
* opt_arg
;
7395 gfc_actual_arglist
* arg
;
7397 vec
<tree
, va_gc
> *append_args
;
7399 /* Find the two arguments given as position. */
7403 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
7407 if (cur_pos
== primary
)
7409 if (cur_pos
== optional
)
7412 if (cur_pos
>= primary
&& cur_pos
>= optional
)
7415 gcc_assert (prim_arg
);
7416 gcc_assert (prim_arg
->expr
);
7417 gcc_assert (opt_arg
);
7419 /* If we do have type CHARACTER and the optional argument is really absent,
7420 append a dummy 0 as string length. */
7422 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
7426 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
7427 vec_alloc (append_args
, 1);
7428 append_args
->quick_push (dummy
);
7431 /* Build the call itself. */
7432 gcc_assert (!se
->ignore_optional
);
7433 sym
= gfc_get_symbol_for_expr (expr
, false);
7434 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
7436 gfc_free_symbol (sym
);
7439 /* The length of a character string. */
7441 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
7450 gcc_assert (!se
->ss
);
7452 arg
= expr
->value
.function
.actual
->expr
;
7454 type
= gfc_typenode_for_spec (&expr
->ts
);
7455 switch (arg
->expr_type
)
7458 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
7462 /* Obtain the string length from the function used by
7463 trans-array.cc(gfc_trans_array_constructor). */
7465 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
7469 if (arg
->ref
== NULL
7470 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
7472 /* This doesn't catch all cases.
7473 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7474 and the surrounding thread. */
7475 sym
= arg
->symtree
->n
.sym
;
7476 decl
= gfc_get_symbol_decl (sym
);
7477 if (decl
== current_function_decl
&& sym
->attr
.function
7478 && (sym
->result
== sym
))
7479 decl
= gfc_get_fake_result_decl (sym
, 0);
7481 len
= sym
->ts
.u
.cl
->backend_decl
;
7489 gfc_init_se (&argse
, se
);
7491 gfc_conv_expr (&argse
, arg
);
7493 gfc_conv_expr_descriptor (&argse
, arg
);
7494 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7495 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7496 len
= argse
.string_length
;
7499 se
->expr
= convert (type
, len
);
7502 /* The length of a character string not including trailing blanks. */
7504 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
7506 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7507 tree args
[2], type
, fndecl
;
7509 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7510 type
= gfc_typenode_for_spec (&expr
->ts
);
7513 fndecl
= gfor_fndecl_string_len_trim
;
7515 fndecl
= gfor_fndecl_string_len_trim_char4
;
7519 se
->expr
= build_call_expr_loc (input_location
,
7520 fndecl
, 2, args
[0], args
[1]);
7521 se
->expr
= convert (type
, se
->expr
);
7525 /* Returns the starting position of a substring within a string. */
7528 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
7531 tree logical4_type_node
= gfc_get_logical_type (4);
7535 unsigned int num_args
;
7537 args
= XALLOCAVEC (tree
, 5);
7539 /* Get number of arguments; characters count double due to the
7540 string length argument. Kind= is not passed to the library
7541 and thus ignored. */
7542 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
7547 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
7548 type
= gfc_typenode_for_spec (&expr
->ts
);
7551 args
[4] = build_int_cst (logical4_type_node
, 0);
7553 args
[4] = convert (logical4_type_node
, args
[4]);
7555 fndecl
= build_addr (function
);
7556 se
->expr
= build_call_array_loc (input_location
,
7557 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7559 se
->expr
= convert (type
, se
->expr
);
7563 /* The ascii value for a single character. */
7565 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
7567 tree args
[3], type
, pchartype
;
7570 nargs
= gfc_intrinsic_argument_list_length (expr
);
7571 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
7572 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
7573 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
7574 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
7575 type
= gfc_typenode_for_spec (&expr
->ts
);
7577 se
->expr
= build_fold_indirect_ref_loc (input_location
,
7579 se
->expr
= convert (type
, se
->expr
);
7583 /* Intrinsic ISNAN calls __builtin_isnan. */
7586 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
7590 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7591 se
->expr
= build_call_expr_loc (input_location
,
7592 builtin_decl_explicit (BUILT_IN_ISNAN
),
7594 STRIP_TYPE_NOPS (se
->expr
);
7595 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7599 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7600 their argument against a constant integer value. */
7603 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
7607 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7608 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
7609 gfc_typenode_for_spec (&expr
->ts
),
7610 arg
, build_int_cst (TREE_TYPE (arg
), value
));
7615 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7618 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
7626 unsigned int num_args
;
7628 num_args
= gfc_intrinsic_argument_list_length (expr
);
7629 args
= XALLOCAVEC (tree
, num_args
);
7631 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
7632 if (expr
->ts
.type
!= BT_CHARACTER
)
7640 /* We do the same as in the non-character case, but the argument
7641 list is different because of the string length arguments. We
7642 also have to set the string length for the result. */
7649 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
7651 se
->string_length
= len
;
7653 tsource
= gfc_evaluate_now (tsource
, &se
->pre
);
7654 fsource
= gfc_evaluate_now (fsource
, &se
->pre
);
7655 mask
= gfc_evaluate_now (mask
, &se
->pre
);
7656 type
= TREE_TYPE (tsource
);
7657 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
7658 fold_convert (type
, fsource
));
7662 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7665 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
7667 tree args
[3], mask
, type
;
7669 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7670 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
7672 type
= TREE_TYPE (args
[0]);
7673 gcc_assert (TREE_TYPE (args
[1]) == type
);
7674 gcc_assert (TREE_TYPE (mask
) == type
);
7676 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
7677 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
7678 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7680 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
7685 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7686 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7689 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
7691 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
7694 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7695 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7697 type
= gfc_get_int_type (expr
->ts
.kind
);
7698 utype
= unsigned_type_for (type
);
7700 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
7701 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
7703 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
7704 build_int_cst (utype
, 0));
7708 /* Left-justified mask. */
7709 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
7711 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
7712 fold_convert (utype
, res
));
7714 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7715 smaller than type width. */
7716 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
7717 build_int_cst (TREE_TYPE (arg
), 0));
7718 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
7719 build_int_cst (utype
, 0), res
);
7723 /* Right-justified mask. */
7724 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
7725 fold_convert (utype
, arg
));
7726 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
7728 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7729 strictly smaller than type width. */
7730 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7732 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
7733 cond
, allones
, res
);
7736 se
->expr
= fold_convert (type
, res
);
7740 /* FRACTION (s) is translated into:
7741 isfinite (s) ? frexp (s, &dummy_int) : NaN */
7743 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
7745 tree arg
, type
, tmp
, res
, frexp
, cond
;
7747 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7749 type
= gfc_typenode_for_spec (&expr
->ts
);
7750 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7751 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7753 cond
= build_call_expr_loc (input_location
,
7754 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7757 tmp
= gfc_create_var (integer_type_node
, NULL
);
7758 res
= build_call_expr_loc (input_location
, frexp
, 2,
7759 fold_convert (type
, arg
),
7760 gfc_build_addr_expr (NULL_TREE
, tmp
));
7761 res
= fold_convert (type
, res
);
7763 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
7764 cond
, res
, gfc_build_nan (type
, ""));
7768 /* NEAREST (s, dir) is translated into
7769 tmp = copysign (HUGE_VAL, dir);
7770 return nextafter (s, tmp);
7773 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
7775 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
7777 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
7778 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
7780 type
= gfc_typenode_for_spec (&expr
->ts
);
7781 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7783 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
7784 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
7785 fold_convert (type
, args
[1]));
7786 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
7787 fold_convert (type
, args
[0]), tmp
);
7788 se
->expr
= fold_convert (type
, se
->expr
);
7792 /* SPACING (s) is translated into
7802 e = MAX_EXPR (e, emin);
7803 res = scalbn (1., e);
7807 where prec is the precision of s, gfc_real_kinds[k].digits,
7808 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7809 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7812 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
7814 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
7815 tree cond
, nan
, tmp
, frexp
, scalbn
;
7819 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7820 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
7821 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
7822 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
7824 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7825 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7827 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7828 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7830 type
= gfc_typenode_for_spec (&expr
->ts
);
7831 e
= gfc_create_var (integer_type_node
, NULL
);
7832 res
= gfc_create_var (type
, NULL
);
7835 /* Build the block for s /= 0. */
7836 gfc_start_block (&block
);
7837 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7838 gfc_build_addr_expr (NULL_TREE
, e
));
7839 gfc_add_expr_to_block (&block
, tmp
);
7841 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
7843 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
7844 integer_type_node
, tmp
, emin
));
7846 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
7847 build_real_from_int_cst (type
, integer_one_node
), e
);
7848 gfc_add_modify (&block
, res
, tmp
);
7850 /* Finish by building the IF statement for value zero. */
7851 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
7852 build_real_from_int_cst (type
, integer_zero_node
));
7853 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
7854 gfc_finish_block (&block
));
7856 /* And deal with infinities and NaNs. */
7857 cond
= build_call_expr_loc (input_location
,
7858 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7860 nan
= gfc_build_nan (type
, "");
7861 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
7863 gfc_add_expr_to_block (&se
->pre
, tmp
);
7868 /* RRSPACING (s) is translated into
7877 x = scalbn (x, precision - e);
7884 where precision is gfc_real_kinds[k].digits. */
7887 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
7889 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
7893 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7894 prec
= gfc_real_kinds
[k
].digits
;
7896 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7897 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7898 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
7900 type
= gfc_typenode_for_spec (&expr
->ts
);
7901 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7902 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7904 e
= gfc_create_var (integer_type_node
, NULL
);
7905 x
= gfc_create_var (type
, NULL
);
7906 gfc_add_modify (&se
->pre
, x
,
7907 build_call_expr_loc (input_location
, fabs
, 1, arg
));
7910 gfc_start_block (&block
);
7911 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7912 gfc_build_addr_expr (NULL_TREE
, e
));
7913 gfc_add_expr_to_block (&block
, tmp
);
7915 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
7916 build_int_cst (integer_type_node
, prec
), e
);
7917 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
7918 gfc_add_modify (&block
, x
, tmp
);
7919 stmt
= gfc_finish_block (&block
);
7922 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
7923 build_real_from_int_cst (type
, integer_zero_node
));
7924 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
7926 /* And deal with infinities and NaNs. */
7927 cond
= build_call_expr_loc (input_location
,
7928 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7930 nan
= gfc_build_nan (type
, "");
7931 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
7933 gfc_add_expr_to_block (&se
->pre
, tmp
);
7934 se
->expr
= fold_convert (type
, x
);
7938 /* SCALE (s, i) is translated into scalbn (s, i). */
7940 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
7942 tree args
[2], type
, scalbn
;
7944 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7946 type
= gfc_typenode_for_spec (&expr
->ts
);
7947 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7948 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
7949 fold_convert (type
, args
[0]),
7950 fold_convert (integer_type_node
, args
[1]));
7951 se
->expr
= fold_convert (type
, se
->expr
);
7955 /* SET_EXPONENT (s, i) is translated into
7956 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
7958 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
7960 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
7962 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7963 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7965 type
= gfc_typenode_for_spec (&expr
->ts
);
7966 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7967 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
7969 tmp
= gfc_create_var (integer_type_node
, NULL
);
7970 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
7971 fold_convert (type
, args
[0]),
7972 gfc_build_addr_expr (NULL_TREE
, tmp
));
7973 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
7974 fold_convert (integer_type_node
, args
[1]));
7975 res
= fold_convert (type
, res
);
7977 /* Call to isfinite */
7978 cond
= build_call_expr_loc (input_location
,
7979 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7981 nan
= gfc_build_nan (type
, "");
7983 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
7989 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
7991 gfc_actual_arglist
*actual
;
7997 gfc_symbol
*sym
= NULL
;
7999 gfc_init_se (&argse
, NULL
);
8000 actual
= expr
->value
.function
.actual
;
8002 if (actual
->expr
->ts
.type
== BT_CLASS
)
8003 gfc_add_class_array_ref (actual
->expr
);
8007 /* These are emerging from the interface mapping, when a class valued
8008 function appears as the rhs in a realloc on assign statement, where
8009 the size of the result is that of one of the actual arguments. */
8010 if (e
->expr_type
== EXPR_VARIABLE
8011 && e
->symtree
->n
.sym
->ns
== NULL
/* This is distinctive! */
8012 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
8013 && e
->ref
&& e
->ref
->type
== REF_COMPONENT
8014 && strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0)
8015 sym
= e
->symtree
->n
.sym
;
8017 if ((gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
)
8019 && (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
))
8021 symbol_attribute attr
;
8026 if (e
->symtree
->n
.sym
&& IS_CLASS_ARRAY (e
->symtree
->n
.sym
))
8028 attr
= CLASS_DATA (e
->symtree
->n
.sym
)->attr
;
8029 attr
.pointer
= attr
.class_pointer
;
8032 attr
= gfc_expr_attr (e
);
8034 if (attr
.allocatable
)
8035 msg
= xasprintf ("Allocatable argument '%s' is not allocated",
8036 e
->symtree
->n
.sym
->name
);
8037 else if (attr
.pointer
)
8038 msg
= xasprintf ("Pointer argument '%s' is not associated",
8039 e
->symtree
->n
.sym
->name
);
8045 temp
= gfc_class_data_get (sym
->backend_decl
);
8046 temp
= gfc_conv_descriptor_data_get (temp
);
8050 argse
.descriptor_only
= 1;
8051 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
8052 temp
= gfc_conv_descriptor_data_get (argse
.expr
);
8055 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8056 logical_type_node
, temp
,
8057 fold_convert (TREE_TYPE (temp
),
8058 null_pointer_node
));
8059 gfc_trans_runtime_check (true, false, cond
, &argse
.pre
, &e
->where
, msg
);
8065 argse
.data_not_needed
= 1;
8066 if (gfc_is_class_array_function (e
))
8068 /* For functions that return a class array conv_expr_descriptor is not
8069 able to get the descriptor right. Therefore this special case. */
8070 gfc_conv_expr_reference (&argse
, e
);
8071 argse
.expr
= gfc_class_data_get (argse
.expr
);
8073 else if (sym
&& sym
->backend_decl
)
8075 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
8076 argse
.expr
= gfc_class_data_get (sym
->backend_decl
);
8079 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
8080 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8081 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8084 actual
= actual
->next
;
8088 gfc_init_block (&block
);
8089 gfc_init_se (&argse
, NULL
);
8090 gfc_conv_expr_type (&argse
, actual
->expr
,
8091 gfc_array_index_type
);
8092 gfc_add_block_to_block (&block
, &argse
.pre
);
8093 tree tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8094 argse
.expr
, gfc_index_one_node
);
8095 size
= gfc_tree_array_size (&block
, arg1
, e
, tmp
);
8097 /* Unusually, for an intrinsic, size does not exclude
8098 an optional arg2, so we must test for it. */
8099 if (actual
->expr
->expr_type
== EXPR_VARIABLE
8100 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
8101 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
8105 gfc_init_block (&block2
);
8106 gfc_init_se (&argse
, NULL
);
8107 argse
.want_pointer
= 1;
8108 argse
.data_not_needed
= 1;
8109 gfc_conv_expr (&argse
, actual
->expr
);
8110 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8111 /* 'block2' contains the arg2 absent case, 'block' the arg2 present
8112 case; size_var can be used in both blocks. */
8113 tree size_var
= gfc_create_var (TREE_TYPE (size
), "size");
8114 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8115 TREE_TYPE (size_var
), size_var
, size
);
8116 gfc_add_expr_to_block (&block
, tmp
);
8117 size
= gfc_tree_array_size (&block2
, arg1
, e
, NULL_TREE
);
8118 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8119 TREE_TYPE (size_var
), size_var
, size
);
8120 gfc_add_expr_to_block (&block2
, tmp
);
8121 cond
= gfc_conv_expr_present (actual
->expr
->symtree
->n
.sym
);
8122 tmp
= build3_v (COND_EXPR
, cond
, gfc_finish_block (&block
),
8123 gfc_finish_block (&block2
));
8124 gfc_add_expr_to_block (&se
->pre
, tmp
);
8128 gfc_add_block_to_block (&se
->pre
, &block
);
8131 size
= gfc_tree_array_size (&se
->pre
, arg1
, e
, NULL_TREE
);
8132 type
= gfc_typenode_for_spec (&expr
->ts
);
8133 se
->expr
= convert (type
, size
);
8137 /* Helper function to compute the size of a character variable,
8138 excluding the terminating null characters. The result has
8139 gfc_array_index_type type. */
8142 size_of_string_in_bytes (int kind
, tree string_length
)
8145 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
8147 bytesize
= build_int_cst (gfc_array_index_type
,
8148 gfc_character_kinds
[i
].bit_size
/ 8);
8150 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8152 fold_convert (gfc_array_index_type
, string_length
));
8157 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
8169 gfc_init_se (&argse
, NULL
);
8170 arg
= expr
->value
.function
.actual
->expr
;
8172 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
8173 gfc_conv_expr_descriptor (&argse
, arg
);
8175 gfc_conv_expr_reference (&argse
, arg
);
8177 if (arg
->ts
.type
== BT_ASSUMED
)
8179 /* This only works if an array descriptor has been passed; thus, extract
8180 the size from the descriptor. */
8181 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
8182 == TYPE_PRECISION (size_type_node
));
8183 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
8184 tmp
= DECL_LANG_SPECIFIC (tmp
)
8185 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
8186 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
8187 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
8188 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8190 tmp
= gfc_conv_descriptor_dtype (tmp
);
8191 field
= gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8192 GFC_DTYPE_ELEM_LEN
);
8193 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
8194 tmp
, field
, NULL_TREE
);
8196 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
8198 else if (arg
->ts
.type
== BT_CLASS
)
8200 /* Conv_expr_descriptor returns a component_ref to _data component of the
8201 class object. The class object may be a non-pointer object, e.g.
8202 located on the stack, or a memory location pointed to, e.g. a
8203 parameter, i.e., an indirect_ref. */
8204 if (POINTER_TYPE_P (TREE_TYPE (argse
.expr
))
8205 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse
.expr
))))
8207 = gfc_class_vtab_size_get (build_fold_indirect_ref (argse
.expr
));
8208 else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse
.expr
)))
8209 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
8210 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse
.expr
))
8211 && TREE_CODE (argse
.expr
) == COMPONENT_REF
)
8212 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
8213 else if (arg
->rank
> 0
8215 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
8216 /* The scalarizer added an additional temp. To get the class' vptr
8217 one has to look at the original backend_decl. */
8218 byte_size
= gfc_class_vtab_size_get (
8219 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
8225 if (arg
->ts
.type
== BT_CHARACTER
)
8226 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
8230 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8233 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8234 byte_size
= fold_convert (gfc_array_index_type
,
8235 size_in_bytes (byte_size
));
8240 se
->expr
= byte_size
;
8243 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
8244 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
8246 if (arg
->rank
== -1)
8248 tree cond
, loop_var
, exit_label
;
8251 tmp
= fold_convert (gfc_array_index_type
,
8252 gfc_conv_descriptor_rank (argse
.expr
));
8253 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
8254 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
8255 exit_label
= gfc_build_label_decl (NULL_TREE
);
8262 source_bytes = source_bytes * array.dim[i].extent;
8266 gfc_start_block (&body
);
8267 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
8269 tmp
= build1_v (GOTO_EXPR
, exit_label
);
8270 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
8271 cond
, tmp
, build_empty_stmt (input_location
));
8272 gfc_add_expr_to_block (&body
, tmp
);
8274 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
8275 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
8276 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
8277 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8278 gfc_array_index_type
, tmp
, source_bytes
);
8279 gfc_add_modify (&body
, source_bytes
, tmp
);
8281 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8282 gfc_array_index_type
, loop_var
,
8283 gfc_index_one_node
);
8284 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
8286 tmp
= gfc_finish_block (&body
);
8288 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
8290 gfc_add_expr_to_block (&argse
.pre
, tmp
);
8292 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8293 gfc_add_expr_to_block (&argse
.pre
, tmp
);
8297 /* Obtain the size of the array in bytes. */
8298 for (n
= 0; n
< arg
->rank
; n
++)
8301 idx
= gfc_rank_cst
[n
];
8302 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
8303 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
8304 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
8305 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8306 gfc_array_index_type
, tmp
, source_bytes
);
8307 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8310 se
->expr
= source_bytes
;
8313 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8318 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
8322 tree type
, result_type
, tmp
, class_decl
= NULL
;
8324 bool unlimited
= false;
8326 arg
= expr
->value
.function
.actual
->expr
;
8328 gfc_init_se (&argse
, NULL
);
8329 result_type
= gfc_get_int_type (expr
->ts
.kind
);
8333 if (arg
->ts
.type
== BT_CLASS
)
8335 unlimited
= UNLIMITED_POLY (arg
);
8336 gfc_add_vptr_component (arg
);
8337 gfc_add_size_component (arg
);
8338 gfc_conv_expr (&argse
, arg
);
8339 tmp
= fold_convert (result_type
, argse
.expr
);
8340 class_decl
= gfc_get_class_from_expr (argse
.expr
);
8344 gfc_conv_expr_reference (&argse
, arg
);
8345 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8350 argse
.want_pointer
= 0;
8351 gfc_conv_expr_descriptor (&argse
, arg
);
8352 sym
= arg
->expr_type
== EXPR_VARIABLE
? arg
->symtree
->n
.sym
: NULL
;
8353 if (arg
->ts
.type
== BT_CLASS
)
8355 unlimited
= UNLIMITED_POLY (arg
);
8356 if (TREE_CODE (argse
.expr
) == COMPONENT_REF
)
8357 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
8358 else if (arg
->rank
> 0 && sym
8359 && DECL_LANG_SPECIFIC (sym
->backend_decl
))
8360 tmp
= gfc_class_vtab_size_get (
8361 GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
));
8364 tmp
= fold_convert (result_type
, tmp
);
8365 class_decl
= gfc_get_class_from_expr (argse
.expr
);
8368 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8371 /* Obtain the argument's word length. */
8372 if (arg
->ts
.type
== BT_CHARACTER
)
8373 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
8375 tmp
= size_in_bytes (type
);
8376 tmp
= fold_convert (result_type
, tmp
);
8379 if (unlimited
&& class_decl
)
8380 tmp
= gfc_resize_class_size_with_len (NULL
, class_decl
, tmp
);
8382 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
8383 build_int_cst (result_type
, BITS_PER_UNIT
));
8384 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8388 /* Intrinsic string comparison functions. */
8391 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
8395 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
8398 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
8399 expr
->value
.function
.actual
->expr
->ts
.kind
,
8401 se
->expr
= fold_build2_loc (input_location
, op
,
8402 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
8403 build_int_cst (TREE_TYPE (se
->expr
), 0));
8406 /* Generate a call to the adjustl/adjustr library function. */
8408 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
8416 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
8419 type
= TREE_TYPE (args
[2]);
8420 var
= gfc_conv_string_tmp (se
, type
, len
);
8423 tmp
= build_call_expr_loc (input_location
,
8424 fndecl
, 3, args
[0], args
[1], args
[2]);
8425 gfc_add_expr_to_block (&se
->pre
, tmp
);
8427 se
->string_length
= len
;
8431 /* Generate code for the TRANSFER intrinsic:
8433 DEST = TRANSFER (SOURCE, MOLD)
8435 typeof<DEST> = typeof<MOLD>
8440 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8442 typeof<DEST> = typeof<MOLD>
8444 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8445 sizeof (DEST(0) * SIZE). */
8447 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
8463 tree class_ref
= NULL_TREE
;
8464 gfc_actual_arglist
*arg
;
8466 gfc_array_info
*info
;
8470 gfc_expr
*source_expr
, *mold_expr
, *class_expr
;
8474 info
= &se
->ss
->info
->data
.array
;
8476 /* Convert SOURCE. The output from this stage is:-
8477 source_bytes = length of the source in bytes
8478 source = pointer to the source data. */
8479 arg
= expr
->value
.function
.actual
;
8480 source_expr
= arg
->expr
;
8482 /* Ensure double transfer through LOGICAL preserves all
8484 if (arg
->expr
->expr_type
== EXPR_FUNCTION
8485 && arg
->expr
->value
.function
.esym
== NULL
8486 && arg
->expr
->value
.function
.isym
!= NULL
8487 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
8488 && arg
->expr
->ts
.type
== BT_LOGICAL
8489 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
8490 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
8492 gfc_init_se (&argse
, NULL
);
8494 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
8496 /* Obtain the pointer to source and the length of source in bytes. */
8497 if (arg
->expr
->rank
== 0)
8499 gfc_conv_expr_reference (&argse
, arg
->expr
);
8500 if (arg
->expr
->ts
.type
== BT_CLASS
)
8502 tmp
= build_fold_indirect_ref_loc (input_location
, argse
.expr
);
8503 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
8505 source
= gfc_class_data_get (tmp
);
8510 /* Array elements are evaluated as a reference to the data.
8511 To obtain the vptr for the element size, the argument
8512 expression must be stripped to the class reference and
8513 re-evaluated. The pre and post blocks are not needed. */
8514 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
8515 source
= argse
.expr
;
8516 class_expr
= gfc_find_and_cut_at_last_class_ref (arg
->expr
);
8517 gfc_init_se (&argse
, NULL
);
8518 gfc_conv_expr (&argse
, class_expr
);
8519 class_ref
= argse
.expr
;
8523 source
= argse
.expr
;
8525 /* Obtain the source word length. */
8526 switch (arg
->expr
->ts
.type
)
8529 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
8530 argse
.string_length
);
8533 if (class_ref
!= NULL_TREE
)
8535 tmp
= gfc_class_vtab_size_get (class_ref
);
8536 if (UNLIMITED_POLY (source_expr
))
8537 tmp
= gfc_resize_class_size_with_len (NULL
, class_ref
, tmp
);
8541 tmp
= gfc_class_vtab_size_get (argse
.expr
);
8542 if (UNLIMITED_POLY (source_expr
))
8543 tmp
= gfc_resize_class_size_with_len (NULL
, argse
.expr
, tmp
);
8547 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8549 tmp
= fold_convert (gfc_array_index_type
,
8550 size_in_bytes (source_type
));
8556 argse
.want_pointer
= 0;
8557 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
8558 source
= gfc_conv_descriptor_data_get (argse
.expr
);
8559 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8561 /* Repack the source if not simply contiguous. */
8562 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
8564 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
8566 if (warn_array_temporaries
)
8567 gfc_warning (OPT_Warray_temporaries
,
8568 "Creating array temporary at %L", &expr
->where
);
8570 source
= build_call_expr_loc (input_location
,
8571 gfor_fndecl_in_pack
, 1, tmp
);
8572 source
= gfc_evaluate_now (source
, &argse
.pre
);
8574 /* Free the temporary. */
8575 gfc_start_block (&block
);
8576 tmp
= gfc_call_free (source
);
8577 gfc_add_expr_to_block (&block
, tmp
);
8578 stmt
= gfc_finish_block (&block
);
8580 /* Clean up if it was repacked. */
8581 gfc_init_block (&block
);
8582 tmp
= gfc_conv_array_data (argse
.expr
);
8583 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8585 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
8586 build_empty_stmt (input_location
));
8587 gfc_add_expr_to_block (&block
, tmp
);
8588 gfc_add_block_to_block (&block
, &se
->post
);
8589 gfc_init_block (&se
->post
);
8590 gfc_add_block_to_block (&se
->post
, &block
);
8593 /* Obtain the source word length. */
8594 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
8595 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
8596 argse
.string_length
);
8597 else if (arg
->expr
->ts
.type
== BT_CLASS
)
8599 class_ref
= TREE_OPERAND (argse
.expr
, 0);
8600 tmp
= gfc_class_vtab_size_get (class_ref
);
8601 if (UNLIMITED_POLY (arg
->expr
))
8602 tmp
= gfc_resize_class_size_with_len (&argse
.pre
, class_ref
, tmp
);
8605 tmp
= fold_convert (gfc_array_index_type
,
8606 size_in_bytes (source_type
));
8608 /* Obtain the size of the array in bytes. */
8609 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
8610 for (n
= 0; n
< arg
->expr
->rank
; n
++)
8613 idx
= gfc_rank_cst
[n
];
8614 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8615 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
8616 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
8617 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8618 gfc_array_index_type
, upper
, lower
);
8619 gfc_add_modify (&argse
.pre
, extent
, tmp
);
8620 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8621 gfc_array_index_type
, extent
,
8622 gfc_index_one_node
);
8623 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8624 gfc_array_index_type
, tmp
, source_bytes
);
8628 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8629 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8630 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8632 /* Now convert MOLD. The outputs are:
8633 mold_type = the TREE type of MOLD
8634 dest_word_len = destination word length in bytes. */
8636 mold_expr
= arg
->expr
;
8638 gfc_init_se (&argse
, NULL
);
8640 scalar_mold
= arg
->expr
->rank
== 0;
8642 if (arg
->expr
->rank
== 0)
8644 gfc_conv_expr_reference (&argse
, mold_expr
);
8645 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8650 argse
.want_pointer
= 0;
8651 gfc_conv_expr_descriptor (&argse
, mold_expr
);
8652 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8655 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8656 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8658 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
8660 /* If this TRANSFER is nested in another TRANSFER, use a type
8661 that preserves all bits. */
8662 if (mold_expr
->ts
.type
== BT_LOGICAL
)
8663 mold_type
= gfc_get_int_type (mold_expr
->ts
.kind
);
8666 /* Obtain the destination word length. */
8667 switch (mold_expr
->ts
.type
)
8670 tmp
= size_of_string_in_bytes (mold_expr
->ts
.kind
, argse
.string_length
);
8671 mold_type
= gfc_get_character_type_len (mold_expr
->ts
.kind
,
8672 argse
.string_length
);
8676 class_ref
= argse
.expr
;
8678 class_ref
= TREE_OPERAND (argse
.expr
, 0);
8679 tmp
= gfc_class_vtab_size_get (class_ref
);
8680 if (UNLIMITED_POLY (arg
->expr
))
8681 tmp
= gfc_resize_class_size_with_len (&argse
.pre
, class_ref
, tmp
);
8684 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
8688 /* Do not fix dest_word_len if it is a variable, since the temporary can wind
8689 up being used before the assignment. */
8690 if (mold_expr
->ts
.type
== BT_CHARACTER
&& mold_expr
->ts
.deferred
)
8691 dest_word_len
= tmp
;
8694 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
8695 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
8698 /* Finally convert SIZE, if it is present. */
8700 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
8704 gfc_init_se (&argse
, NULL
);
8705 gfc_conv_expr_reference (&argse
, arg
->expr
);
8706 tmp
= convert (gfc_array_index_type
,
8707 build_fold_indirect_ref_loc (input_location
,
8709 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8710 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8715 /* Separate array and scalar results. */
8716 if (scalar_mold
&& tmp
== NULL_TREE
)
8717 goto scalar_transfer
;
8719 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
8720 if (tmp
!= NULL_TREE
)
8721 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8722 tmp
, dest_word_len
);
8726 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
8727 gfc_add_modify (&se
->pre
, size_words
,
8728 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
8729 gfc_array_index_type
,
8730 size_bytes
, dest_word_len
));
8732 /* Evaluate the bounds of the result. If the loop range exists, we have
8733 to check if it is too large. If so, we modify loop->to be consistent
8734 with min(size, size(source)). Otherwise, size is made consistent with
8735 the loop range, so that the right number of bytes is transferred.*/
8736 n
= se
->loop
->order
[0];
8737 if (se
->loop
->to
[n
] != NULL_TREE
)
8739 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8740 se
->loop
->to
[n
], se
->loop
->from
[n
]);
8741 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8742 tmp
, gfc_index_one_node
);
8743 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
8745 gfc_add_modify (&se
->pre
, size_words
, tmp
);
8746 gfc_add_modify (&se
->pre
, size_bytes
,
8747 fold_build2_loc (input_location
, MULT_EXPR
,
8748 gfc_array_index_type
,
8749 size_words
, dest_word_len
));
8750 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8751 size_words
, se
->loop
->from
[n
]);
8752 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8753 upper
, gfc_index_one_node
);
8757 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8758 size_words
, gfc_index_one_node
);
8759 se
->loop
->from
[n
] = gfc_index_zero_node
;
8762 se
->loop
->to
[n
] = upper
;
8764 /* Build a destination descriptor, using the pointer, source, as the
8766 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
8767 NULL_TREE
, false, true, false, &expr
->where
);
8769 /* Cast the pointer to the result. */
8770 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
8771 tmp
= fold_convert (pvoid_type_node
, tmp
);
8773 /* Use memcpy to do the transfer. */
8775 = build_call_expr_loc (input_location
,
8776 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
8777 fold_convert (pvoid_type_node
, source
),
8778 fold_convert (size_type_node
,
8779 fold_build2_loc (input_location
,
8781 gfc_array_index_type
,
8784 gfc_add_expr_to_block (&se
->pre
, tmp
);
8786 se
->expr
= info
->descriptor
;
8787 if (expr
->ts
.type
== BT_CHARACTER
)
8789 tmp
= fold_convert (gfc_charlen_type_node
,
8790 TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
)));
8791 se
->string_length
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
8792 gfc_charlen_type_node
,
8793 dest_word_len
, tmp
);
8798 /* Deal with scalar results. */
8800 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
8801 dest_word_len
, source_bytes
);
8802 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
8803 extent
, gfc_index_zero_node
);
8805 if (expr
->ts
.type
== BT_CHARACTER
)
8807 tree direct
, indirect
, free
;
8809 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
8810 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
8813 /* If source is longer than the destination, use a pointer to
8814 the source directly. */
8815 gfc_init_block (&block
);
8816 gfc_add_modify (&block
, tmpdecl
, ptr
);
8817 direct
= gfc_finish_block (&block
);
8819 /* Otherwise, allocate a string with the length of the destination
8820 and copy the source into it. */
8821 gfc_init_block (&block
);
8822 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
8823 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
8824 gfc_add_modify (&block
, tmpdecl
,
8825 fold_convert (TREE_TYPE (ptr
), tmp
));
8826 tmp
= build_call_expr_loc (input_location
,
8827 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
8828 fold_convert (pvoid_type_node
, tmpdecl
),
8829 fold_convert (pvoid_type_node
, ptr
),
8830 fold_convert (size_type_node
, extent
));
8831 gfc_add_expr_to_block (&block
, tmp
);
8832 indirect
= gfc_finish_block (&block
);
8834 /* Wrap it up with the condition. */
8835 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
8836 dest_word_len
, source_bytes
);
8837 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
8838 gfc_add_expr_to_block (&se
->pre
, tmp
);
8840 /* Free the temporary string, if necessary. */
8841 free
= gfc_call_free (tmpdecl
);
8842 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8843 dest_word_len
, source_bytes
);
8844 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
8845 gfc_add_expr_to_block (&se
->post
, tmp
);
8848 tmp
= fold_convert (gfc_charlen_type_node
,
8849 TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
)));
8850 se
->string_length
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
8851 gfc_charlen_type_node
,
8852 dest_word_len
, tmp
);
8856 tmpdecl
= gfc_create_var (mold_type
, "transfer");
8858 ptr
= convert (build_pointer_type (mold_type
), source
);
8860 /* For CLASS results, allocate the needed memory first. */
8861 if (mold_expr
->ts
.type
== BT_CLASS
)
8864 cdata
= gfc_class_data_get (tmpdecl
);
8865 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
8866 gfc_add_modify (&se
->pre
, cdata
, tmp
);
8869 /* Use memcpy to do the transfer. */
8870 if (mold_expr
->ts
.type
== BT_CLASS
)
8871 tmp
= gfc_class_data_get (tmpdecl
);
8873 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
8875 tmp
= build_call_expr_loc (input_location
,
8876 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
8877 fold_convert (pvoid_type_node
, tmp
),
8878 fold_convert (pvoid_type_node
, ptr
),
8879 fold_convert (size_type_node
, extent
));
8880 gfc_add_expr_to_block (&se
->pre
, tmp
);
8882 /* For CLASS results, set the _vptr. */
8883 if (mold_expr
->ts
.type
== BT_CLASS
)
8884 gfc_reset_vptr (&se
->pre
, nullptr, tmpdecl
, source_expr
->ts
.u
.derived
);
8891 /* Generate a call to caf_is_present. */
8894 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
8896 tree caf_reference
, caf_decl
, token
, image_index
;
8898 /* Compile the reference chain. */
8899 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
8900 gcc_assert (caf_reference
!= NULL_TREE
);
8902 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
8903 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8904 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8905 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
8906 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
8909 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
8910 3, token
, image_index
, caf_reference
);
8914 /* Test whether this ref-chain refs this image only. */
8917 caf_this_image_ref (gfc_ref
*ref
)
8919 for ( ; ref
; ref
= ref
->next
)
8920 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
8921 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
8927 /* Generate code for the ALLOCATED intrinsic.
8928 Generate inline code that directly check the address of the argument. */
8931 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
8935 bool coindexed_caf_comp
= false;
8936 gfc_expr
*e
= expr
->value
.function
.actual
->expr
;
8938 gfc_init_se (&arg1se
, NULL
);
8939 if (e
->ts
.type
== BT_CLASS
)
8941 /* Make sure that class array expressions have both a _data
8942 component reference and an array reference.... */
8943 if (CLASS_DATA (e
)->attr
.dimension
)
8944 gfc_add_class_array_ref (e
);
8945 /* .... whilst scalars only need the _data component. */
8947 gfc_add_data_component (e
);
8950 /* When 'e' references an allocatable component in a coarray, then call
8951 the caf-library function caf_is_present (). */
8952 if (flag_coarray
== GFC_FCOARRAY_LIB
&& e
->expr_type
== EXPR_FUNCTION
8953 && e
->value
.function
.isym
8954 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8956 e
= e
->value
.function
.actual
->expr
;
8957 if (gfc_expr_attr (e
).codimension
)
8959 /* Last partref is the coindexed coarray. As coarrays are collectively
8960 (de)allocated, the allocation status must be the same as the one of
8961 the local allocation. Convert to local access. */
8962 for (gfc_ref
*ref
= e
->ref
; ref
; ref
= ref
->next
)
8963 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
8965 for (int i
= ref
->u
.ar
.dimen
;
8966 i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; ++i
)
8967 ref
->u
.ar
.dimen_type
[i
] = DIMEN_THIS_IMAGE
;
8971 else if (!caf_this_image_ref (e
->ref
))
8972 coindexed_caf_comp
= true;
8974 if (coindexed_caf_comp
)
8975 tmp
= trans_caf_is_present (se
, e
);
8980 /* Allocatable scalar. */
8981 arg1se
.want_pointer
= 1;
8982 gfc_conv_expr (&arg1se
, e
);
8987 /* Allocatable array. */
8988 arg1se
.descriptor_only
= 1;
8989 gfc_conv_expr_descriptor (&arg1se
, e
);
8990 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8993 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
8994 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
8997 /* Components of pointer array references sometimes come back with a pre block. */
8998 if (arg1se
.pre
.head
)
8999 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
9001 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
9005 /* Generate code for the ASSOCIATED intrinsic.
9006 If both POINTER and TARGET are arrays, generate a call to library function
9007 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
9008 In other cases, generate inline code that directly compare the address of
9009 POINTER with the address of TARGET. */
9012 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
9014 gfc_actual_arglist
*arg1
;
9015 gfc_actual_arglist
*arg2
;
9020 tree nonzero_arraylen
= NULL_TREE
;
9024 gfc_init_se (&arg1se
, NULL
);
9025 gfc_init_se (&arg2se
, NULL
);
9026 arg1
= expr
->value
.function
.actual
;
9029 /* Check whether the expression is a scalar or not; we cannot use
9030 arg1->expr->rank as it can be nonzero for proc pointers. */
9031 ss
= gfc_walk_expr (arg1
->expr
);
9032 scalar
= ss
== gfc_ss_terminator
;
9034 gfc_free_ss_chain (ss
);
9038 /* No optional target. */
9041 /* A pointer to a scalar. */
9042 arg1se
.want_pointer
= 1;
9043 gfc_conv_expr (&arg1se
, arg1
->expr
);
9044 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
9045 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
9046 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
9048 if (arg1
->expr
->ts
.type
== BT_CLASS
)
9050 tmp2
= gfc_class_data_get (arg1se
.expr
);
9051 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
9052 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
9059 /* A pointer to an array. */
9060 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
9061 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
9063 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
9064 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
9065 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
9066 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
9071 /* An optional target. */
9072 if (arg2
->expr
->ts
.type
== BT_CLASS
9073 && arg2
->expr
->expr_type
!= EXPR_FUNCTION
)
9074 gfc_add_data_component (arg2
->expr
);
9078 /* A pointer to a scalar. */
9079 arg1se
.want_pointer
= 1;
9080 gfc_conv_expr (&arg1se
, arg1
->expr
);
9081 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
9082 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
9083 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
9085 if (arg1
->expr
->ts
.type
== BT_CLASS
)
9086 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
9088 arg2se
.want_pointer
= 1;
9089 gfc_conv_expr (&arg2se
, arg2
->expr
);
9090 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
9091 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
9092 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
9094 if (arg2
->expr
->ts
.type
== BT_CLASS
)
9096 arg2se
.expr
= gfc_evaluate_now (arg2se
.expr
, &arg2se
.pre
);
9097 arg2se
.expr
= gfc_class_data_get (arg2se
.expr
);
9099 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
9100 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
9101 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
9102 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
9103 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9104 arg1se
.expr
, arg2se
.expr
);
9105 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9106 arg1se
.expr
, null_pointer_node
);
9107 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9108 logical_type_node
, tmp
, tmp2
);
9112 /* An array pointer of zero length is not associated if target is
9114 arg1se
.descriptor_only
= 1;
9115 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
9116 if (arg1
->expr
->rank
== -1)
9118 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
9119 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9120 TREE_TYPE (tmp
), tmp
,
9121 build_int_cst (TREE_TYPE (tmp
), 1));
9124 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
9125 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
9126 if (arg2
->expr
->rank
!= 0)
9127 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
9128 logical_type_node
, tmp
,
9129 build_int_cst (TREE_TYPE (tmp
), 0));
9131 /* A pointer to an array, call library function _gfor_associated. */
9132 arg1se
.want_pointer
= 1;
9133 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
9134 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
9135 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
9137 arg2se
.want_pointer
= 1;
9138 arg2se
.force_no_tmp
= 1;
9139 if (arg2
->expr
->rank
!= 0)
9140 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
9143 gfc_conv_expr (&arg2se
, arg2
->expr
);
9145 = gfc_conv_scalar_to_descriptor (&arg2se
, arg2se
.expr
,
9146 gfc_expr_attr (arg2
->expr
));
9147 arg2se
.expr
= gfc_build_addr_expr (NULL_TREE
, arg2se
.expr
);
9149 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
9150 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
9151 se
->expr
= build_call_expr_loc (input_location
,
9152 gfor_fndecl_associated
, 2,
9153 arg1se
.expr
, arg2se
.expr
);
9154 se
->expr
= convert (logical_type_node
, se
->expr
);
9155 if (arg2
->expr
->rank
!= 0)
9156 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9157 logical_type_node
, se
->expr
,
9161 /* If target is present zero character length pointers cannot
9163 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
9165 tmp
= arg1se
.string_length
;
9166 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9167 logical_type_node
, tmp
,
9168 build_zero_cst (TREE_TYPE (tmp
)));
9169 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9170 logical_type_node
, se
->expr
, tmp
);
9174 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9178 /* Generate code for the SAME_TYPE_AS intrinsic.
9179 Generate inline code that directly checks the vindices. */
9182 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
9187 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
9189 gfc_init_se (&se1
, NULL
);
9190 gfc_init_se (&se2
, NULL
);
9192 a
= expr
->value
.function
.actual
->expr
;
9193 b
= expr
->value
.function
.actual
->next
->expr
;
9195 bool unlimited_poly_a
= UNLIMITED_POLY (a
);
9196 bool unlimited_poly_b
= UNLIMITED_POLY (b
);
9197 if (unlimited_poly_a
)
9199 se1
.want_pointer
= 1;
9200 gfc_add_vptr_component (a
);
9202 else if (a
->ts
.type
== BT_CLASS
)
9204 gfc_add_vptr_component (a
);
9205 gfc_add_hash_component (a
);
9207 else if (a
->ts
.type
== BT_DERIVED
)
9208 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
9209 a
->ts
.u
.derived
->hash_value
);
9211 if (unlimited_poly_b
)
9213 se2
.want_pointer
= 1;
9214 gfc_add_vptr_component (b
);
9216 else if (b
->ts
.type
== BT_CLASS
)
9218 gfc_add_vptr_component (b
);
9219 gfc_add_hash_component (b
);
9221 else if (b
->ts
.type
== BT_DERIVED
)
9222 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
9223 b
->ts
.u
.derived
->hash_value
);
9225 gfc_conv_expr (&se1
, a
);
9226 gfc_conv_expr (&se2
, b
);
9228 if (unlimited_poly_a
)
9230 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9232 build_int_cst (TREE_TYPE (se1
.expr
), 0));
9233 se1
.expr
= gfc_vptr_hash_get (se1
.expr
);
9236 if (unlimited_poly_b
)
9238 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9240 build_int_cst (TREE_TYPE (se2
.expr
), 0));
9241 se2
.expr
= gfc_vptr_hash_get (se2
.expr
);
9244 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
9245 logical_type_node
, se1
.expr
,
9246 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
9249 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
9250 logical_type_node
, conda
, tmp
);
9253 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
9254 logical_type_node
, condb
, tmp
);
9256 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
9260 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9263 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
9267 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
9268 se
->expr
= build_call_expr_loc (input_location
,
9269 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
9270 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9274 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9277 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
9281 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
9283 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9284 type
= gfc_get_int_type (4);
9285 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
9287 /* Convert it to the required type. */
9288 type
= gfc_typenode_for_spec (&expr
->ts
);
9289 se
->expr
= build_call_expr_loc (input_location
,
9290 gfor_fndecl_si_kind
, 1, arg
);
9291 se
->expr
= fold_convert (type
, se
->expr
);
9295 /* Generate code for SELECTED_LOGICAL_KIND (BITS) intrinsic function. */
9298 gfc_conv_intrinsic_sl_kind (gfc_se
*se
, gfc_expr
*expr
)
9302 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
9304 /* The argument to SELECTED_LOGICAL_KIND is INTEGER(4). */
9305 type
= gfc_get_int_type (4);
9306 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
9308 /* Convert it to the required type. */
9309 type
= gfc_typenode_for_spec (&expr
->ts
);
9310 se
->expr
= build_call_expr_loc (input_location
,
9311 gfor_fndecl_sl_kind
, 1, arg
);
9312 se
->expr
= fold_convert (type
, se
->expr
);
9316 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9319 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
9321 gfc_actual_arglist
*actual
;
9324 vec
<tree
, va_gc
> *args
= NULL
;
9326 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
9328 gfc_init_se (&argse
, se
);
9330 /* Pass a NULL pointer for an absent arg. */
9331 if (actual
->expr
== NULL
)
9332 argse
.expr
= null_pointer_node
;
9338 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
9340 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9341 ts
.type
= BT_INTEGER
;
9342 ts
.kind
= gfc_c_int_kind
;
9343 gfc_convert_type (actual
->expr
, &ts
, 2);
9345 gfc_conv_expr_reference (&argse
, actual
->expr
);
9348 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
9349 gfc_add_block_to_block (&se
->post
, &argse
.post
);
9350 vec_safe_push (args
, argse
.expr
);
9353 /* Convert it to the required type. */
9354 type
= gfc_typenode_for_spec (&expr
->ts
);
9355 se
->expr
= build_call_expr_loc_vec (input_location
,
9356 gfor_fndecl_sr_kind
, args
);
9357 se
->expr
= fold_convert (type
, se
->expr
);
9361 /* Generate code for TRIM (A) intrinsic function. */
9364 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
9374 unsigned int num_args
;
9376 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
9377 args
= XALLOCAVEC (tree
, num_args
);
9379 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
9380 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
9381 len
= gfc_create_var (gfc_charlen_type_node
, "len");
9383 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
9384 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
9387 if (expr
->ts
.kind
== 1)
9388 function
= gfor_fndecl_string_trim
;
9389 else if (expr
->ts
.kind
== 4)
9390 function
= gfor_fndecl_string_trim_char4
;
9394 fndecl
= build_addr (function
);
9395 tmp
= build_call_array_loc (input_location
,
9396 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
9398 gfc_add_expr_to_block (&se
->pre
, tmp
);
9400 /* Free the temporary afterwards, if necessary. */
9401 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
9402 len
, build_int_cst (TREE_TYPE (len
), 0));
9403 tmp
= gfc_call_free (var
);
9404 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
9405 gfc_add_expr_to_block (&se
->post
, tmp
);
9408 se
->string_length
= len
;
9412 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9415 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
9417 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
9418 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
9420 stmtblock_t block
, body
;
9423 /* We store in charsize the size of a character. */
9424 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
9425 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
9427 /* Get the arguments. */
9428 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
9429 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
9431 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
9432 ncopies_type
= TREE_TYPE (ncopies
);
9434 /* Check that NCOPIES is not negative. */
9435 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
9436 build_int_cst (ncopies_type
, 0));
9437 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
9438 "Argument NCOPIES of REPEAT intrinsic is negative "
9439 "(its value is %ld)",
9440 fold_convert (long_integer_type_node
, ncopies
));
9442 /* If the source length is zero, any non negative value of NCOPIES
9443 is valid, and nothing happens. */
9444 n
= gfc_create_var (ncopies_type
, "ncopies");
9445 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
9447 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
9448 build_int_cst (ncopies_type
, 0), ncopies
);
9449 gfc_add_modify (&se
->pre
, n
, tmp
);
9452 /* Check that ncopies is not too large: ncopies should be less than
9453 (or equal to) MAX / slen, where MAX is the maximal integer of
9454 the gfc_charlen_type_node type. If slen == 0, we need a special
9455 case to avoid the division by zero. */
9456 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
9457 fold_convert (sizetype
,
9458 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
9460 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
9461 ? sizetype
: ncopies_type
;
9462 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
9463 fold_convert (largest
, ncopies
),
9464 fold_convert (largest
, max
));
9465 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
9467 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
9468 logical_false_node
, cond
);
9469 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
9470 "Argument NCOPIES of REPEAT intrinsic is too large");
9472 /* Compute the destination length. */
9473 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
9474 fold_convert (gfc_charlen_type_node
, slen
),
9475 fold_convert (gfc_charlen_type_node
, ncopies
));
9476 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
9477 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
9479 /* Generate the code to do the repeat operation:
9480 for (i = 0; i < ncopies; i++)
9481 memmove (dest + (i * slen * size), src, slen*size); */
9482 gfc_start_block (&block
);
9483 count
= gfc_create_var (sizetype
, "count");
9484 gfc_add_modify (&block
, count
, size_zero_node
);
9485 exit_label
= gfc_build_label_decl (NULL_TREE
);
9487 /* Start the loop body. */
9488 gfc_start_block (&body
);
9490 /* Exit the loop if count >= ncopies. */
9491 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
9492 fold_convert (sizetype
, ncopies
));
9493 tmp
= build1_v (GOTO_EXPR
, exit_label
);
9494 TREE_USED (exit_label
) = 1;
9495 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
9496 build_empty_stmt (input_location
));
9497 gfc_add_expr_to_block (&body
, tmp
);
9499 /* Call memmove (dest + (i*slen*size), src, slen*size). */
9500 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
9502 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
9504 tmp
= fold_build_pointer_plus_loc (input_location
,
9505 fold_convert (pvoid_type_node
, dest
), tmp
);
9506 tmp
= build_call_expr_loc (input_location
,
9507 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
9509 fold_build2_loc (input_location
, MULT_EXPR
,
9510 size_type_node
, slen
, size
));
9511 gfc_add_expr_to_block (&body
, tmp
);
9513 /* Increment count. */
9514 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
9515 count
, size_one_node
);
9516 gfc_add_modify (&body
, count
, tmp
);
9518 /* Build the loop. */
9519 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
9520 gfc_add_expr_to_block (&block
, tmp
);
9522 /* Add the exit label. */
9523 tmp
= build1_v (LABEL_EXPR
, exit_label
);
9524 gfc_add_expr_to_block (&block
, tmp
);
9526 /* Finish the block. */
9527 tmp
= gfc_finish_block (&block
);
9528 gfc_add_expr_to_block (&se
->pre
, tmp
);
9530 /* Set the result value. */
9532 se
->string_length
= dlen
;
9536 /* Generate code for the IARGC intrinsic. */
9539 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
9545 /* Call the library function. This always returns an INTEGER(4). */
9546 fndecl
= gfor_fndecl_iargc
;
9547 tmp
= build_call_expr_loc (input_location
,
9550 /* Convert it to the required type. */
9551 type
= gfc_typenode_for_spec (&expr
->ts
);
9552 tmp
= fold_convert (type
, tmp
);
9558 /* Generate code for the KILL intrinsic. */
9561 conv_intrinsic_kill (gfc_se
*se
, gfc_expr
*expr
)
9564 tree int4_type_node
= gfc_get_int_type (4);
9568 unsigned int num_args
;
9570 num_args
= gfc_intrinsic_argument_list_length (expr
);
9571 args
= XALLOCAVEC (tree
, num_args
);
9572 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
9574 /* Convert PID to a INTEGER(4) entity. */
9575 pid
= convert (int4_type_node
, args
[0]);
9577 /* Convert SIG to a INTEGER(4) entity. */
9578 sig
= convert (int4_type_node
, args
[1]);
9580 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill
, 2, pid
, sig
);
9582 se
->expr
= fold_convert (TREE_TYPE (args
[0]), tmp
);
9587 conv_intrinsic_kill_sub (gfc_code
*code
)
9591 tree int4_type_node
= gfc_get_int_type (4);
9597 /* Make the function call. */
9598 gfc_init_block (&block
);
9599 gfc_init_se (&se
, NULL
);
9601 /* Convert PID to a INTEGER(4) entity. */
9602 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
9603 gfc_add_block_to_block (&block
, &se
.pre
);
9604 pid
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
9605 gfc_add_block_to_block (&block
, &se
.post
);
9607 /* Convert SIG to a INTEGER(4) entity. */
9608 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
9609 gfc_add_block_to_block (&block
, &se
.pre
);
9610 sig
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
9611 gfc_add_block_to_block (&block
, &se
.post
);
9613 /* Deal with an optional STATUS. */
9614 if (code
->ext
.actual
->next
->next
->expr
)
9616 gfc_init_se (&se_stat
, NULL
);
9617 gfc_conv_expr (&se_stat
, code
->ext
.actual
->next
->next
->expr
);
9618 statp
= gfc_create_var (gfc_get_int_type (4), "_statp");
9623 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill_sub
, 3, pid
, sig
,
9624 statp
? gfc_build_addr_expr (NULL_TREE
, statp
) : null_pointer_node
);
9626 gfc_add_expr_to_block (&block
, tmp
);
9628 if (statp
&& statp
!= se_stat
.expr
)
9629 gfc_add_modify (&block
, se_stat
.expr
,
9630 fold_convert (TREE_TYPE (se_stat
.expr
), statp
));
9632 return gfc_finish_block (&block
);
9637 /* The loc intrinsic returns the address of its argument as
9638 gfc_index_integer_kind integer. */
9641 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
9646 gcc_assert (!se
->ss
);
9648 arg_expr
= expr
->value
.function
.actual
->expr
;
9649 if (arg_expr
->rank
== 0)
9651 if (arg_expr
->ts
.type
== BT_CLASS
)
9652 gfc_add_data_component (arg_expr
);
9653 gfc_conv_expr_reference (se
, arg_expr
);
9656 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
9657 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
9659 /* Create a temporary variable for loc return value. Without this,
9660 we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9661 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
9662 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
9663 se
->expr
= temp_var
;
9667 /* The following routine generates code for the intrinsic
9668 functions from the ISO_C_BINDING module:
9674 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
9676 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
9678 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
9680 if (arg
->expr
->rank
== 0)
9681 gfc_conv_expr_reference (se
, arg
->expr
);
9682 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
9683 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
9686 gfc_conv_expr_descriptor (se
, arg
->expr
);
9687 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
9690 /* TODO -- the following two lines shouldn't be necessary, but if
9691 they're removed, a bug is exposed later in the code path.
9692 This workaround was thus introduced, but will have to be
9693 removed; please see PR 35150 for details about the issue. */
9694 se
->expr
= convert (pvoid_type_node
, se
->expr
);
9695 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
9697 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
9698 gfc_conv_expr_reference (se
, arg
->expr
);
9699 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
9704 /* Build the addr_expr for the first argument. The argument is
9705 already an *address* so we don't need to set want_pointer in
9707 gfc_init_se (&arg1se
, NULL
);
9708 gfc_conv_expr (&arg1se
, arg
->expr
);
9709 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
9710 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
9712 /* See if we were given two arguments. */
9713 if (arg
->next
->expr
== NULL
)
9714 /* Only given one arg so generate a null and do a
9715 not-equal comparison against the first arg. */
9716 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9718 fold_convert (TREE_TYPE (arg1se
.expr
),
9719 null_pointer_node
));
9725 /* Given two arguments so build the arg2se from second arg. */
9726 gfc_init_se (&arg2se
, NULL
);
9727 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
9728 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
9729 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
9731 /* Generate test to compare that the two args are equal. */
9732 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9733 arg1se
.expr
, arg2se
.expr
);
9734 /* Generate test to ensure that the first arg is not null. */
9735 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
9737 arg1se
.expr
, null_pointer_node
);
9739 /* Finally, the generated test must check that both arg1 is not
9740 NULL and that it is equal to the second arg. */
9741 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9743 not_null_expr
, eq_expr
);
9751 /* The following routine generates code for the intrinsic
9752 subroutines from the ISO_C_BINDING module:
9754 * C_F_PROCPOINTER. */
9757 conv_isocbinding_subroutine (gfc_code
*code
)
9764 tree desc
, dim
, tmp
, stride
, offset
;
9765 stmtblock_t body
, block
;
9767 gfc_actual_arglist
*arg
= code
->ext
.actual
;
9769 gfc_init_se (&se
, NULL
);
9770 gfc_init_se (&cptrse
, NULL
);
9771 gfc_conv_expr (&cptrse
, arg
->expr
);
9772 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
9773 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
9775 gfc_init_se (&fptrse
, NULL
);
9776 if (arg
->next
->expr
->rank
== 0)
9778 fptrse
.want_pointer
= 1;
9779 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
9780 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
9781 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
9782 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
9783 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
9784 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
9786 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9787 TREE_TYPE (fptrse
.expr
),
9789 fold_convert (TREE_TYPE (fptrse
.expr
),
9791 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
9792 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9793 return gfc_finish_block (&se
.pre
);
9796 gfc_start_block (&block
);
9798 /* Get the descriptor of the Fortran pointer. */
9799 fptrse
.descriptor_only
= 1;
9800 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
9801 gfc_add_block_to_block (&block
, &fptrse
.pre
);
9804 /* Set the span field. */
9805 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
9806 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9807 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
9809 /* Set data value, dtype, and offset. */
9810 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
9811 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
9812 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
9813 gfc_get_dtype (TREE_TYPE (desc
)));
9815 /* Start scalarization of the bounds, using the shape argument. */
9817 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
9818 gcc_assert (shape_ss
!= gfc_ss_terminator
);
9819 gfc_init_se (&shapese
, NULL
);
9821 gfc_init_loopinfo (&loop
);
9822 gfc_add_ss_to_loop (&loop
, shape_ss
);
9823 gfc_conv_ss_startstride (&loop
);
9824 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
9825 gfc_mark_ss_chain_used (shape_ss
, 1);
9827 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
9828 shapese
.ss
= shape_ss
;
9830 stride
= gfc_create_var (gfc_array_index_type
, "stride");
9831 offset
= gfc_create_var (gfc_array_index_type
, "offset");
9832 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
9833 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
9836 gfc_start_scalarized_body (&loop
, &body
);
9838 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
9839 loop
.loopvar
[0], loop
.from
[0]);
9841 /* Set bounds and stride. */
9842 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
9843 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
9845 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
9846 gfc_add_block_to_block (&body
, &shapese
.pre
);
9847 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
9848 gfc_add_block_to_block (&body
, &shapese
.post
);
9850 /* Calculate offset. */
9851 gfc_add_modify (&body
, offset
,
9852 fold_build2_loc (input_location
, PLUS_EXPR
,
9853 gfc_array_index_type
, offset
, stride
));
9854 /* Update stride. */
9855 gfc_add_modify (&body
, stride
,
9856 fold_build2_loc (input_location
, MULT_EXPR
,
9857 gfc_array_index_type
, stride
,
9858 fold_convert (gfc_array_index_type
,
9860 /* Finish scalarization loop. */
9861 gfc_trans_scalarizing_loops (&loop
, &body
);
9862 gfc_add_block_to_block (&block
, &loop
.pre
);
9863 gfc_add_block_to_block (&block
, &loop
.post
);
9864 gfc_add_block_to_block (&block
, &fptrse
.post
);
9865 gfc_cleanup_loop (&loop
);
9867 gfc_add_modify (&block
, offset
,
9868 fold_build1_loc (input_location
, NEGATE_EXPR
,
9869 gfc_array_index_type
, offset
));
9870 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
9872 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
9873 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9874 return gfc_finish_block (&se
.pre
);
9878 /* Save and restore floating-point state. */
9881 gfc_save_fp_state (stmtblock_t
*block
)
9883 tree type
, fpstate
, tmp
;
9885 type
= build_array_type (char_type_node
,
9886 build_range_type (size_type_node
, size_zero_node
,
9887 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
9888 fpstate
= gfc_create_var (type
, "fpstate");
9889 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
9891 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
9893 gfc_add_expr_to_block (block
, tmp
);
9900 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
9904 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
9906 gfc_add_expr_to_block (block
, tmp
);
9910 /* Generate code for arguments of IEEE functions. */
9913 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
9916 gfc_actual_arglist
*actual
;
9921 actual
= expr
->value
.function
.actual
;
9922 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
9924 gcc_assert (actual
);
9927 gfc_init_se (&argse
, se
);
9928 gfc_conv_expr_val (&argse
, e
);
9930 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
9931 gfc_add_block_to_block (&se
->post
, &argse
.post
);
9932 argarray
[arg
] = argse
.expr
;
9937 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
9938 and IEEE_UNORDERED, which translate directly to GCC type-generic
9942 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
9943 enum built_in_function code
, int nargs
)
9946 gcc_assert ((unsigned) nargs
<= ARRAY_SIZE (args
));
9948 conv_ieee_function_args (se
, expr
, args
, nargs
);
9949 se
->expr
= build_call_expr_loc_array (input_location
,
9950 builtin_decl_explicit (code
),
9952 STRIP_TYPE_NOPS (se
->expr
);
9953 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9957 /* Generate code for intrinsics IEEE_SIGNBIT. */
9960 conv_intrinsic_ieee_signbit (gfc_se
* se
, gfc_expr
* expr
)
9964 conv_ieee_function_args (se
, expr
, &arg
, 1);
9965 signbit
= build_call_expr_loc (input_location
,
9966 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
9968 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9969 signbit
, integer_zero_node
);
9970 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), signbit
);
9974 /* Generate code for IEEE_IS_NORMAL intrinsic:
9975 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
9978 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
9980 tree arg
, isnormal
, iszero
;
9982 /* Convert arg, evaluate it only once. */
9983 conv_ieee_function_args (se
, expr
, &arg
, 1);
9984 arg
= gfc_evaluate_now (arg
, &se
->pre
);
9986 isnormal
= build_call_expr_loc (input_location
,
9987 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
9989 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
9990 build_real_from_int_cst (TREE_TYPE (arg
),
9991 integer_zero_node
));
9992 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9993 logical_type_node
, isnormal
, iszero
);
9994 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9998 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
9999 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
10002 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
10004 tree arg
, signbit
, isnan
;
10006 /* Convert arg, evaluate it only once. */
10007 conv_ieee_function_args (se
, expr
, &arg
, 1);
10008 arg
= gfc_evaluate_now (arg
, &se
->pre
);
10010 isnan
= build_call_expr_loc (input_location
,
10011 builtin_decl_explicit (BUILT_IN_ISNAN
),
10013 STRIP_TYPE_NOPS (isnan
);
10015 signbit
= build_call_expr_loc (input_location
,
10016 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
10018 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10019 signbit
, integer_zero_node
);
10021 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
10022 logical_type_node
, signbit
,
10023 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
10024 TREE_TYPE(isnan
), isnan
));
10026 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
10030 /* Generate code for IEEE_LOGB and IEEE_RINT. */
10033 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
10034 enum built_in_function code
)
10036 tree arg
, decl
, call
, fpstate
;
10039 conv_ieee_function_args (se
, expr
, &arg
, 1);
10040 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
10041 decl
= builtin_decl_for_precision (code
, argprec
);
10043 /* Save floating-point state. */
10044 fpstate
= gfc_save_fp_state (&se
->pre
);
10046 /* Make the function call. */
10047 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
10048 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
10050 /* Restore floating-point state. */
10051 gfc_restore_fp_state (&se
->post
, fpstate
);
10055 /* Generate code for IEEE_REM. */
10058 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
10060 tree args
[2], decl
, call
, fpstate
;
10063 conv_ieee_function_args (se
, expr
, args
, 2);
10065 /* If arguments have unequal size, convert them to the larger. */
10066 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
10067 > TYPE_PRECISION (TREE_TYPE (args
[1])))
10068 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
10069 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
10070 > TYPE_PRECISION (TREE_TYPE (args
[0])))
10071 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
10073 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
10074 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
10076 /* Save floating-point state. */
10077 fpstate
= gfc_save_fp_state (&se
->pre
);
10079 /* Make the function call. */
10080 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
10081 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
10083 /* Restore floating-point state. */
10084 gfc_restore_fp_state (&se
->post
, fpstate
);
10088 /* Generate code for IEEE_NEXT_AFTER. */
10091 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
10093 tree args
[2], decl
, call
, fpstate
;
10096 conv_ieee_function_args (se
, expr
, args
, 2);
10098 /* Result has the characteristics of first argument. */
10099 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
10100 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
10101 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
10103 /* Save floating-point state. */
10104 fpstate
= gfc_save_fp_state (&se
->pre
);
10106 /* Make the function call. */
10107 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
10108 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
10110 /* Restore floating-point state. */
10111 gfc_restore_fp_state (&se
->post
, fpstate
);
10115 /* Generate code for IEEE_SCALB. */
10118 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
10120 tree args
[2], decl
, call
, huge
, type
;
10123 conv_ieee_function_args (se
, expr
, args
, 2);
10125 /* Result has the characteristics of first argument. */
10126 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
10127 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
10129 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
10131 /* We need to fold the integer into the range of a C int. */
10132 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
10133 type
= TREE_TYPE (args
[1]);
10135 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
10136 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
10138 huge
= fold_convert (type
, huge
);
10139 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
10141 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
10142 fold_build1_loc (input_location
, NEGATE_EXPR
,
10146 args
[1] = fold_convert (integer_type_node
, args
[1]);
10148 /* Make the function call. */
10149 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
10150 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
10154 /* Generate code for IEEE_COPY_SIGN. */
10157 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
10159 tree args
[2], decl
, sign
;
10162 conv_ieee_function_args (se
, expr
, args
, 2);
10164 /* Get the sign of the second argument. */
10165 sign
= build_call_expr_loc (input_location
,
10166 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
10168 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10169 sign
, integer_zero_node
);
10171 /* Create a value of one, with the right sign. */
10172 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
10174 fold_build1_loc (input_location
, NEGATE_EXPR
,
10178 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
10180 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
10181 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
10183 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
10187 /* Generate code for IEEE_CLASS. */
10190 conv_intrinsic_ieee_class (gfc_se
*se
, gfc_expr
*expr
)
10192 tree arg
, c
, t1
, t2
, t3
, t4
;
10194 /* Convert arg, evaluate it only once. */
10195 conv_ieee_function_args (se
, expr
, &arg
, 1);
10196 arg
= gfc_evaluate_now (arg
, &se
->pre
);
10198 c
= build_call_expr_loc (input_location
,
10199 builtin_decl_explicit (BUILT_IN_FPCLASSIFY
), 6,
10200 build_int_cst (integer_type_node
, IEEE_QUIET_NAN
),
10201 build_int_cst (integer_type_node
,
10202 IEEE_POSITIVE_INF
),
10203 build_int_cst (integer_type_node
,
10204 IEEE_POSITIVE_NORMAL
),
10205 build_int_cst (integer_type_node
,
10206 IEEE_POSITIVE_DENORMAL
),
10207 build_int_cst (integer_type_node
,
10208 IEEE_POSITIVE_ZERO
),
10210 c
= gfc_evaluate_now (c
, &se
->pre
);
10211 t1
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10212 c
, build_int_cst (integer_type_node
,
10214 t2
= build_call_expr_loc (input_location
,
10215 builtin_decl_explicit (BUILT_IN_ISSIGNALING
), 1,
10217 t2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10218 t2
, build_zero_cst (TREE_TYPE (t2
)));
10219 t1
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
10220 logical_type_node
, t1
, t2
);
10221 t3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
10222 c
, build_int_cst (integer_type_node
,
10223 IEEE_POSITIVE_ZERO
));
10224 t4
= build_call_expr_loc (input_location
,
10225 builtin_decl_explicit (BUILT_IN_SIGNBIT
), 1,
10227 t4
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10228 t4
, build_zero_cst (TREE_TYPE (t4
)));
10229 t3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
10230 logical_type_node
, t3
, t4
);
10231 int s
= IEEE_NEGATIVE_ZERO
+ IEEE_POSITIVE_ZERO
;
10232 gcc_assert (IEEE_NEGATIVE_INF
== s
- IEEE_POSITIVE_INF
);
10233 gcc_assert (IEEE_NEGATIVE_NORMAL
== s
- IEEE_POSITIVE_NORMAL
);
10234 gcc_assert (IEEE_NEGATIVE_DENORMAL
== s
- IEEE_POSITIVE_DENORMAL
);
10235 gcc_assert (IEEE_NEGATIVE_SUBNORMAL
== s
- IEEE_POSITIVE_SUBNORMAL
);
10236 gcc_assert (IEEE_NEGATIVE_ZERO
== s
- IEEE_POSITIVE_ZERO
);
10237 t4
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (c
),
10238 build_int_cst (TREE_TYPE (c
), s
), c
);
10239 t3
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (c
),
10241 t1
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (c
), t1
,
10242 build_int_cst (TREE_TYPE (c
), IEEE_SIGNALING_NAN
),
10244 tree type
= gfc_typenode_for_spec (&expr
->ts
);
10245 /* Perform a quick sanity check that the return type is
10246 IEEE_CLASS_TYPE derived type defined in
10247 libgfortran/ieee/ieee_arithmetic.F90
10248 Primarily check that it is a derived type with a single
10250 gcc_assert (TREE_CODE (type
) == RECORD_TYPE
);
10251 tree field
= NULL_TREE
;
10252 for (tree f
= TYPE_FIELDS (type
); f
!= NULL_TREE
; f
= DECL_CHAIN (f
))
10253 if (TREE_CODE (f
) == FIELD_DECL
)
10255 gcc_assert (field
== NULL_TREE
);
10258 gcc_assert (field
);
10259 t1
= fold_convert (TREE_TYPE (field
), t1
);
10260 se
->expr
= build_constructor_single (type
, field
, t1
);
10264 /* Generate code for IEEE_VALUE. */
10267 conv_intrinsic_ieee_value (gfc_se
*se
, gfc_expr
*expr
)
10269 tree args
[2], arg
, ret
, tmp
;
10272 /* Convert args, evaluate the second one only once. */
10273 conv_ieee_function_args (se
, expr
, args
, 2);
10274 arg
= gfc_evaluate_now (args
[1], &se
->pre
);
10276 tree type
= TREE_TYPE (arg
);
10277 /* Perform a quick sanity check that the second argument's type is
10278 IEEE_CLASS_TYPE derived type defined in
10279 libgfortran/ieee/ieee_arithmetic.F90
10280 Primarily check that it is a derived type with a single
10282 gcc_assert (TREE_CODE (type
) == RECORD_TYPE
);
10283 tree field
= NULL_TREE
;
10284 for (tree f
= TYPE_FIELDS (type
); f
!= NULL_TREE
; f
= DECL_CHAIN (f
))
10285 if (TREE_CODE (f
) == FIELD_DECL
)
10287 gcc_assert (field
== NULL_TREE
);
10290 gcc_assert (field
);
10291 arg
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
10292 arg
, field
, NULL_TREE
);
10293 arg
= gfc_evaluate_now (arg
, &se
->pre
);
10295 type
= gfc_typenode_for_spec (&expr
->ts
);
10296 gcc_assert (SCALAR_FLOAT_TYPE_P (type
));
10297 ret
= gfc_create_var (type
, NULL
);
10299 gfc_init_block (&body
);
10301 tree end_label
= gfc_build_label_decl (NULL_TREE
);
10302 for (int c
= IEEE_SIGNALING_NAN
; c
<= IEEE_POSITIVE_INF
; ++c
)
10304 tree label
= gfc_build_label_decl (NULL_TREE
);
10305 tree low
= build_int_cst (TREE_TYPE (arg
), c
);
10306 tmp
= build_case_label (low
, low
, label
);
10307 gfc_add_expr_to_block (&body
, tmp
);
10309 REAL_VALUE_TYPE real
;
10313 case IEEE_SIGNALING_NAN
:
10314 real_nan (&real
, "", 0, TYPE_MODE (type
));
10316 case IEEE_QUIET_NAN
:
10317 real_nan (&real
, "", 1, TYPE_MODE (type
));
10319 case IEEE_NEGATIVE_INF
:
10321 real
= real_value_negate (&real
);
10323 case IEEE_NEGATIVE_NORMAL
:
10324 real_from_integer (&real
, TYPE_MODE (type
), -42, SIGNED
);
10326 case IEEE_NEGATIVE_DENORMAL
:
10327 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
10328 real_from_mpfr (&real
, gfc_real_kinds
[k
].tiny
,
10329 type
, GFC_RND_MODE
);
10330 real_arithmetic (&real
, RDIV_EXPR
, &real
, &dconst2
);
10331 real
= real_value_negate (&real
);
10333 case IEEE_NEGATIVE_ZERO
:
10334 real_from_integer (&real
, TYPE_MODE (type
), 0, SIGNED
);
10335 real
= real_value_negate (&real
);
10337 case IEEE_POSITIVE_ZERO
:
10338 /* Make this also the default: label. The other possibility
10339 would be to add a separate default: label followed by
10340 __builtin_unreachable (). */
10341 label
= gfc_build_label_decl (NULL_TREE
);
10342 tmp
= build_case_label (NULL_TREE
, NULL_TREE
, label
);
10343 gfc_add_expr_to_block (&body
, tmp
);
10344 real_from_integer (&real
, TYPE_MODE (type
), 0, SIGNED
);
10346 case IEEE_POSITIVE_DENORMAL
:
10347 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
10348 real_from_mpfr (&real
, gfc_real_kinds
[k
].tiny
,
10349 type
, GFC_RND_MODE
);
10350 real_arithmetic (&real
, RDIV_EXPR
, &real
, &dconst2
);
10352 case IEEE_POSITIVE_NORMAL
:
10353 real_from_integer (&real
, TYPE_MODE (type
), 42, SIGNED
);
10355 case IEEE_POSITIVE_INF
:
10359 gcc_unreachable ();
10362 tree val
= build_real (type
, real
);
10363 gfc_add_modify (&body
, ret
, val
);
10365 tmp
= build1_v (GOTO_EXPR
, end_label
);
10366 gfc_add_expr_to_block (&body
, tmp
);
10369 tmp
= gfc_finish_block (&body
);
10370 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
, arg
, tmp
);
10371 gfc_add_expr_to_block (&se
->pre
, tmp
);
10373 tmp
= build1_v (LABEL_EXPR
, end_label
);
10374 gfc_add_expr_to_block (&se
->pre
, tmp
);
10380 /* Generate code for IEEE_FMA. */
10383 conv_intrinsic_ieee_fma (gfc_se
* se
, gfc_expr
* expr
)
10385 tree args
[3], decl
, call
;
10388 conv_ieee_function_args (se
, expr
, args
, 3);
10390 /* All three arguments should have the same type. */
10391 gcc_assert (TYPE_PRECISION (TREE_TYPE (args
[0])) == TYPE_PRECISION (TREE_TYPE (args
[1])));
10392 gcc_assert (TYPE_PRECISION (TREE_TYPE (args
[0])) == TYPE_PRECISION (TREE_TYPE (args
[2])));
10394 /* Call the type-generic FMA built-in. */
10395 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
10396 decl
= builtin_decl_for_precision (BUILT_IN_FMA
, argprec
);
10397 call
= build_call_expr_loc_array (input_location
, decl
, 3, args
);
10399 /* Convert to the final type. */
10400 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
10404 /* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10407 conv_intrinsic_ieee_minmax (gfc_se
* se
, gfc_expr
* expr
, int max
,
10410 tree args
[2], func
;
10411 built_in_function fn
;
10413 conv_ieee_function_args (se
, expr
, args
, 2);
10414 gcc_assert (TYPE_PRECISION (TREE_TYPE (args
[0])) == TYPE_PRECISION (TREE_TYPE (args
[1])));
10415 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
10416 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
10418 if (startswith (name
, "mag"))
10420 /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10421 fminmag() and fmaxmag(), which do not exist as built-ins.
10423 Following glibc, we emit this:
10428 if (isless (ax, ay))
10430 else if (isgreater (ax, ay))
10433 return x < y ? x : y;
10434 else if (issignaling (x) || issignaling (y))
10437 return isnan (y) ? x : y;
10443 if (isgreater (ax, ay))
10445 else if (isless (ax, ay))
10448 return x > y ? x : y;
10449 else if (issignaling (x) || issignaling (y))
10452 return isnan (y) ? x : y;
10457 tree abs0
, abs1
, sig0
, sig1
;
10458 tree cond1
, cond2
, cond3
, cond4
, cond5
;
10460 tree type
= TREE_TYPE (args
[0]);
10462 func
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
10463 abs0
= build_call_expr_loc (input_location
, func
, 1, args
[0]);
10464 abs1
= build_call_expr_loc (input_location
, func
, 1, args
[1]);
10465 abs0
= gfc_evaluate_now (abs0
, &se
->pre
);
10466 abs1
= gfc_evaluate_now (abs1
, &se
->pre
);
10468 cond5
= build_call_expr_loc (input_location
,
10469 builtin_decl_explicit (BUILT_IN_ISNAN
),
10471 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond5
,
10474 sig0
= build_call_expr_loc (input_location
,
10475 builtin_decl_explicit (BUILT_IN_ISSIGNALING
),
10477 sig1
= build_call_expr_loc (input_location
,
10478 builtin_decl_explicit (BUILT_IN_ISSIGNALING
),
10480 cond4
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
10481 logical_type_node
, sig0
, sig1
);
10482 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond4
,
10483 fold_build2_loc (input_location
, PLUS_EXPR
,
10484 type
, args
[0], args
[1]),
10487 cond3
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10489 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond3
,
10490 fold_build2_loc (input_location
,
10491 max
? MAX_EXPR
: MIN_EXPR
,
10492 type
, args
[0], args
[1]),
10495 func
= builtin_decl_explicit (max
? BUILT_IN_ISLESS
: BUILT_IN_ISGREATER
);
10496 cond2
= build_call_expr_loc (input_location
, func
, 2, abs0
, abs1
);
10497 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond2
,
10500 func
= builtin_decl_explicit (max
? BUILT_IN_ISGREATER
: BUILT_IN_ISLESS
);
10501 cond1
= build_call_expr_loc (input_location
, func
, 2, abs0
, abs1
);
10502 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond1
,
10509 /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
10510 fn
= max
? BUILT_IN_FMAX
: BUILT_IN_FMIN
;
10511 func
= gfc_builtin_decl_for_float_kind (fn
, expr
->ts
.kind
);
10512 se
->expr
= build_call_expr_loc_array (input_location
, func
, 2, args
);
10517 /* Generate code for comparison functions IEEE_QUIET_* and
10518 IEEE_SIGNALING_*. */
10521 conv_intrinsic_ieee_comparison (gfc_se
* se
, gfc_expr
* expr
, int signaling
,
10525 tree arg1
, arg2
, res
;
10527 /* Evaluate arguments only once. */
10528 conv_ieee_function_args (se
, expr
, args
, 2);
10529 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
10530 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
10532 if (startswith (name
, "eq"))
10535 res
= build_call_expr_loc (input_location
,
10536 builtin_decl_explicit (BUILT_IN_ISEQSIG
),
10539 res
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10542 else if (startswith (name
, "ne"))
10546 res
= build_call_expr_loc (input_location
,
10547 builtin_decl_explicit (BUILT_IN_ISEQSIG
),
10549 res
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
10550 logical_type_node
, res
);
10553 res
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10556 else if (startswith (name
, "ge"))
10559 res
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
10562 res
= build_call_expr_loc (input_location
,
10563 builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL
),
10566 else if (startswith (name
, "gt"))
10569 res
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
10572 res
= build_call_expr_loc (input_location
,
10573 builtin_decl_explicit (BUILT_IN_ISGREATER
),
10576 else if (startswith (name
, "le"))
10579 res
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
10582 res
= build_call_expr_loc (input_location
,
10583 builtin_decl_explicit (BUILT_IN_ISLESSEQUAL
),
10586 else if (startswith (name
, "lt"))
10589 res
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
10592 res
= build_call_expr_loc (input_location
,
10593 builtin_decl_explicit (BUILT_IN_ISLESS
),
10597 gcc_unreachable ();
10599 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), res
);
10603 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
10607 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
10609 const char *name
= expr
->value
.function
.name
;
10611 if (startswith (name
, "_gfortran_ieee_is_nan"))
10612 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
10613 else if (startswith (name
, "_gfortran_ieee_is_finite"))
10614 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
10615 else if (startswith (name
, "_gfortran_ieee_unordered"))
10616 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
10617 else if (startswith (name
, "_gfortran_ieee_signbit"))
10618 conv_intrinsic_ieee_signbit (se
, expr
);
10619 else if (startswith (name
, "_gfortran_ieee_is_normal"))
10620 conv_intrinsic_ieee_is_normal (se
, expr
);
10621 else if (startswith (name
, "_gfortran_ieee_is_negative"))
10622 conv_intrinsic_ieee_is_negative (se
, expr
);
10623 else if (startswith (name
, "_gfortran_ieee_copy_sign"))
10624 conv_intrinsic_ieee_copy_sign (se
, expr
);
10625 else if (startswith (name
, "_gfortran_ieee_scalb"))
10626 conv_intrinsic_ieee_scalb (se
, expr
);
10627 else if (startswith (name
, "_gfortran_ieee_next_after"))
10628 conv_intrinsic_ieee_next_after (se
, expr
);
10629 else if (startswith (name
, "_gfortran_ieee_rem"))
10630 conv_intrinsic_ieee_rem (se
, expr
);
10631 else if (startswith (name
, "_gfortran_ieee_logb"))
10632 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
10633 else if (startswith (name
, "_gfortran_ieee_rint"))
10634 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
10635 else if (startswith (name
, "ieee_class_") && ISDIGIT (name
[11]))
10636 conv_intrinsic_ieee_class (se
, expr
);
10637 else if (startswith (name
, "ieee_value_") && ISDIGIT (name
[11]))
10638 conv_intrinsic_ieee_value (se
, expr
);
10639 else if (startswith (name
, "_gfortran_ieee_fma"))
10640 conv_intrinsic_ieee_fma (se
, expr
);
10641 else if (startswith (name
, "_gfortran_ieee_min_num_"))
10642 conv_intrinsic_ieee_minmax (se
, expr
, 0, name
+ 23);
10643 else if (startswith (name
, "_gfortran_ieee_max_num_"))
10644 conv_intrinsic_ieee_minmax (se
, expr
, 1, name
+ 23);
10645 else if (startswith (name
, "_gfortran_ieee_quiet_"))
10646 conv_intrinsic_ieee_comparison (se
, expr
, 0, name
+ 21);
10647 else if (startswith (name
, "_gfortran_ieee_signaling_"))
10648 conv_intrinsic_ieee_comparison (se
, expr
, 1, name
+ 25);
10650 /* It is not among the functions we translate directly. We return
10651 false, so a library function call is emitted. */
10658 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
10661 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
10663 tree arg
, res
, restype
;
10665 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
10666 arg
= fold_convert (size_type_node
, arg
);
10667 res
= build_call_expr_loc (input_location
,
10668 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
10669 restype
= gfc_typenode_for_spec (&expr
->ts
);
10670 se
->expr
= fold_convert (restype
, res
);
10674 /* Generate code for an intrinsic function. Some map directly to library
10675 calls, others get special handling. In some cases the name of the function
10676 used depends on the type specifiers. */
10679 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
10685 name
= &expr
->value
.function
.name
[2];
10687 if (expr
->rank
> 0)
10689 lib
= gfc_is_intrinsic_libcall (expr
);
10693 se
->ignore_optional
= 1;
10695 switch (expr
->value
.function
.isym
->id
)
10697 case GFC_ISYM_EOSHIFT
:
10698 case GFC_ISYM_PACK
:
10699 case GFC_ISYM_RESHAPE
:
10700 /* For all of those the first argument specifies the type and the
10701 third is optional. */
10702 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
10705 case GFC_ISYM_FINDLOC
:
10706 gfc_conv_intrinsic_findloc (se
, expr
);
10709 case GFC_ISYM_MINLOC
:
10710 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
10713 case GFC_ISYM_MAXLOC
:
10714 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
10718 gfc_conv_intrinsic_funcall (se
, expr
);
10726 switch (expr
->value
.function
.isym
->id
)
10728 case GFC_ISYM_NONE
:
10729 gcc_unreachable ();
10731 case GFC_ISYM_REPEAT
:
10732 gfc_conv_intrinsic_repeat (se
, expr
);
10735 case GFC_ISYM_TRIM
:
10736 gfc_conv_intrinsic_trim (se
, expr
);
10739 case GFC_ISYM_SC_KIND
:
10740 gfc_conv_intrinsic_sc_kind (se
, expr
);
10743 case GFC_ISYM_SI_KIND
:
10744 gfc_conv_intrinsic_si_kind (se
, expr
);
10747 case GFC_ISYM_SL_KIND
:
10748 gfc_conv_intrinsic_sl_kind (se
, expr
);
10751 case GFC_ISYM_SR_KIND
:
10752 gfc_conv_intrinsic_sr_kind (se
, expr
);
10755 case GFC_ISYM_EXPONENT
:
10756 gfc_conv_intrinsic_exponent (se
, expr
);
10759 case GFC_ISYM_SCAN
:
10760 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10762 fndecl
= gfor_fndecl_string_scan
;
10763 else if (kind
== 4)
10764 fndecl
= gfor_fndecl_string_scan_char4
;
10766 gcc_unreachable ();
10768 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10771 case GFC_ISYM_VERIFY
:
10772 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10774 fndecl
= gfor_fndecl_string_verify
;
10775 else if (kind
== 4)
10776 fndecl
= gfor_fndecl_string_verify_char4
;
10778 gcc_unreachable ();
10780 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10783 case GFC_ISYM_ALLOCATED
:
10784 gfc_conv_allocated (se
, expr
);
10787 case GFC_ISYM_ASSOCIATED
:
10788 gfc_conv_associated(se
, expr
);
10791 case GFC_ISYM_SAME_TYPE_AS
:
10792 gfc_conv_same_type_as (se
, expr
);
10796 gfc_conv_intrinsic_abs (se
, expr
);
10799 case GFC_ISYM_ADJUSTL
:
10800 if (expr
->ts
.kind
== 1)
10801 fndecl
= gfor_fndecl_adjustl
;
10802 else if (expr
->ts
.kind
== 4)
10803 fndecl
= gfor_fndecl_adjustl_char4
;
10805 gcc_unreachable ();
10807 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
10810 case GFC_ISYM_ADJUSTR
:
10811 if (expr
->ts
.kind
== 1)
10812 fndecl
= gfor_fndecl_adjustr
;
10813 else if (expr
->ts
.kind
== 4)
10814 fndecl
= gfor_fndecl_adjustr_char4
;
10816 gcc_unreachable ();
10818 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
10821 case GFC_ISYM_AIMAG
:
10822 gfc_conv_intrinsic_imagpart (se
, expr
);
10825 case GFC_ISYM_AINT
:
10826 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
10830 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
10833 case GFC_ISYM_ANINT
:
10834 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
10838 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
10842 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
10845 case GFC_ISYM_ACOSD
:
10846 case GFC_ISYM_ASIND
:
10847 case GFC_ISYM_ATAND
:
10848 gfc_conv_intrinsic_atrigd (se
, expr
, expr
->value
.function
.isym
->id
);
10851 case GFC_ISYM_COTAN
:
10852 gfc_conv_intrinsic_cotan (se
, expr
);
10855 case GFC_ISYM_COTAND
:
10856 gfc_conv_intrinsic_cotand (se
, expr
);
10859 case GFC_ISYM_ATAN2D
:
10860 gfc_conv_intrinsic_atan2d (se
, expr
);
10863 case GFC_ISYM_BTEST
:
10864 gfc_conv_intrinsic_btest (se
, expr
);
10868 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
10872 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
10876 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
10880 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
10883 case GFC_ISYM_C_ASSOCIATED
:
10884 case GFC_ISYM_C_FUNLOC
:
10885 case GFC_ISYM_C_LOC
:
10886 conv_isocbinding_function (se
, expr
);
10889 case GFC_ISYM_ACHAR
:
10890 case GFC_ISYM_CHAR
:
10891 gfc_conv_intrinsic_char (se
, expr
);
10894 case GFC_ISYM_CONVERSION
:
10895 case GFC_ISYM_DBLE
:
10896 case GFC_ISYM_DFLOAT
:
10897 case GFC_ISYM_FLOAT
:
10898 case GFC_ISYM_LOGICAL
:
10899 case GFC_ISYM_REAL
:
10900 case GFC_ISYM_REALPART
:
10901 case GFC_ISYM_SNGL
:
10902 gfc_conv_intrinsic_conversion (se
, expr
);
10905 /* Integer conversions are handled separately to make sure we get the
10906 correct rounding mode. */
10908 case GFC_ISYM_INT2
:
10909 case GFC_ISYM_INT8
:
10910 case GFC_ISYM_LONG
:
10911 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
10914 case GFC_ISYM_NINT
:
10915 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
10918 case GFC_ISYM_CEILING
:
10919 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
10922 case GFC_ISYM_FLOOR
:
10923 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
10927 gfc_conv_intrinsic_mod (se
, expr
, 0);
10930 case GFC_ISYM_MODULO
:
10931 gfc_conv_intrinsic_mod (se
, expr
, 1);
10934 case GFC_ISYM_CAF_GET
:
10935 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10939 case GFC_ISYM_CMPLX
:
10940 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
10943 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
10944 gfc_conv_intrinsic_iargc (se
, expr
);
10947 case GFC_ISYM_COMPLEX
:
10948 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
10951 case GFC_ISYM_CONJG
:
10952 gfc_conv_intrinsic_conjg (se
, expr
);
10955 case GFC_ISYM_COUNT
:
10956 gfc_conv_intrinsic_count (se
, expr
);
10959 case GFC_ISYM_CTIME
:
10960 gfc_conv_intrinsic_ctime (se
, expr
);
10964 gfc_conv_intrinsic_dim (se
, expr
);
10967 case GFC_ISYM_DOT_PRODUCT
:
10968 gfc_conv_intrinsic_dot_product (se
, expr
);
10971 case GFC_ISYM_DPROD
:
10972 gfc_conv_intrinsic_dprod (se
, expr
);
10975 case GFC_ISYM_DSHIFTL
:
10976 gfc_conv_intrinsic_dshift (se
, expr
, true);
10979 case GFC_ISYM_DSHIFTR
:
10980 gfc_conv_intrinsic_dshift (se
, expr
, false);
10983 case GFC_ISYM_FDATE
:
10984 gfc_conv_intrinsic_fdate (se
, expr
);
10987 case GFC_ISYM_FRACTION
:
10988 gfc_conv_intrinsic_fraction (se
, expr
);
10991 case GFC_ISYM_IALL
:
10992 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
10995 case GFC_ISYM_IAND
:
10996 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
10999 case GFC_ISYM_IANY
:
11000 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
11003 case GFC_ISYM_IBCLR
:
11004 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
11007 case GFC_ISYM_IBITS
:
11008 gfc_conv_intrinsic_ibits (se
, expr
);
11011 case GFC_ISYM_IBSET
:
11012 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
11015 case GFC_ISYM_IACHAR
:
11016 case GFC_ISYM_ICHAR
:
11017 /* We assume ASCII character sequence. */
11018 gfc_conv_intrinsic_ichar (se
, expr
);
11021 case GFC_ISYM_IARGC
:
11022 gfc_conv_intrinsic_iargc (se
, expr
);
11025 case GFC_ISYM_IEOR
:
11026 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
11029 case GFC_ISYM_INDEX
:
11030 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
11032 fndecl
= gfor_fndecl_string_index
;
11033 else if (kind
== 4)
11034 fndecl
= gfor_fndecl_string_index_char4
;
11036 gcc_unreachable ();
11038 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
11042 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
11045 case GFC_ISYM_IPARITY
:
11046 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
11049 case GFC_ISYM_IS_IOSTAT_END
:
11050 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
11053 case GFC_ISYM_IS_IOSTAT_EOR
:
11054 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
11057 case GFC_ISYM_IS_CONTIGUOUS
:
11058 gfc_conv_intrinsic_is_contiguous (se
, expr
);
11061 case GFC_ISYM_ISNAN
:
11062 gfc_conv_intrinsic_isnan (se
, expr
);
11065 case GFC_ISYM_KILL
:
11066 conv_intrinsic_kill (se
, expr
);
11069 case GFC_ISYM_LSHIFT
:
11070 gfc_conv_intrinsic_shift (se
, expr
, false, false);
11073 case GFC_ISYM_RSHIFT
:
11074 gfc_conv_intrinsic_shift (se
, expr
, true, true);
11077 case GFC_ISYM_SHIFTA
:
11078 gfc_conv_intrinsic_shift (se
, expr
, true, true);
11081 case GFC_ISYM_SHIFTL
:
11082 gfc_conv_intrinsic_shift (se
, expr
, false, false);
11085 case GFC_ISYM_SHIFTR
:
11086 gfc_conv_intrinsic_shift (se
, expr
, true, false);
11089 case GFC_ISYM_ISHFT
:
11090 gfc_conv_intrinsic_ishft (se
, expr
);
11093 case GFC_ISYM_ISHFTC
:
11094 gfc_conv_intrinsic_ishftc (se
, expr
);
11097 case GFC_ISYM_LEADZ
:
11098 gfc_conv_intrinsic_leadz (se
, expr
);
11101 case GFC_ISYM_TRAILZ
:
11102 gfc_conv_intrinsic_trailz (se
, expr
);
11105 case GFC_ISYM_POPCNT
:
11106 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
11109 case GFC_ISYM_POPPAR
:
11110 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
11113 case GFC_ISYM_LBOUND
:
11114 gfc_conv_intrinsic_bound (se
, expr
, GFC_ISYM_LBOUND
);
11117 case GFC_ISYM_LCOBOUND
:
11118 conv_intrinsic_cobound (se
, expr
);
11121 case GFC_ISYM_TRANSPOSE
:
11122 /* The scalarizer has already been set up for reversed dimension access
11123 order ; now we just get the argument value normally. */
11124 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
11128 gfc_conv_intrinsic_len (se
, expr
);
11131 case GFC_ISYM_LEN_TRIM
:
11132 gfc_conv_intrinsic_len_trim (se
, expr
);
11136 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
11140 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
11144 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
11148 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
11151 case GFC_ISYM_MALLOC
:
11152 gfc_conv_intrinsic_malloc (se
, expr
);
11155 case GFC_ISYM_MASKL
:
11156 gfc_conv_intrinsic_mask (se
, expr
, 1);
11159 case GFC_ISYM_MASKR
:
11160 gfc_conv_intrinsic_mask (se
, expr
, 0);
11164 if (expr
->ts
.type
== BT_CHARACTER
)
11165 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
11167 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
11170 case GFC_ISYM_MAXLOC
:
11171 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
11174 case GFC_ISYM_FINDLOC
:
11175 gfc_conv_intrinsic_findloc (se
, expr
);
11178 case GFC_ISYM_MAXVAL
:
11179 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
11182 case GFC_ISYM_MERGE
:
11183 gfc_conv_intrinsic_merge (se
, expr
);
11186 case GFC_ISYM_MERGE_BITS
:
11187 gfc_conv_intrinsic_merge_bits (se
, expr
);
11191 if (expr
->ts
.type
== BT_CHARACTER
)
11192 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
11194 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
11197 case GFC_ISYM_MINLOC
:
11198 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
11201 case GFC_ISYM_MINVAL
:
11202 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
11205 case GFC_ISYM_NEAREST
:
11206 gfc_conv_intrinsic_nearest (se
, expr
);
11209 case GFC_ISYM_NORM2
:
11210 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
11214 gfc_conv_intrinsic_not (se
, expr
);
11218 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
11221 case GFC_ISYM_PARITY
:
11222 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
11225 case GFC_ISYM_PRESENT
:
11226 gfc_conv_intrinsic_present (se
, expr
);
11229 case GFC_ISYM_PRODUCT
:
11230 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
11233 case GFC_ISYM_RANK
:
11234 gfc_conv_intrinsic_rank (se
, expr
);
11237 case GFC_ISYM_RRSPACING
:
11238 gfc_conv_intrinsic_rrspacing (se
, expr
);
11241 case GFC_ISYM_SET_EXPONENT
:
11242 gfc_conv_intrinsic_set_exponent (se
, expr
);
11245 case GFC_ISYM_SCALE
:
11246 gfc_conv_intrinsic_scale (se
, expr
);
11249 case GFC_ISYM_SHAPE
:
11250 gfc_conv_intrinsic_bound (se
, expr
, GFC_ISYM_SHAPE
);
11253 case GFC_ISYM_SIGN
:
11254 gfc_conv_intrinsic_sign (se
, expr
);
11257 case GFC_ISYM_SIZE
:
11258 gfc_conv_intrinsic_size (se
, expr
);
11261 case GFC_ISYM_SIZEOF
:
11262 case GFC_ISYM_C_SIZEOF
:
11263 gfc_conv_intrinsic_sizeof (se
, expr
);
11266 case GFC_ISYM_STORAGE_SIZE
:
11267 gfc_conv_intrinsic_storage_size (se
, expr
);
11270 case GFC_ISYM_SPACING
:
11271 gfc_conv_intrinsic_spacing (se
, expr
);
11274 case GFC_ISYM_STRIDE
:
11275 conv_intrinsic_stride (se
, expr
);
11279 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
11282 case GFC_ISYM_TEAM_NUMBER
:
11283 conv_intrinsic_team_number (se
, expr
);
11286 case GFC_ISYM_TRANSFER
:
11287 if (se
->ss
&& se
->ss
->info
->useflags
)
11288 /* Access the previously obtained result. */
11289 gfc_conv_tmp_array_ref (se
);
11291 gfc_conv_intrinsic_transfer (se
, expr
);
11294 case GFC_ISYM_TTYNAM
:
11295 gfc_conv_intrinsic_ttynam (se
, expr
);
11298 case GFC_ISYM_UBOUND
:
11299 gfc_conv_intrinsic_bound (se
, expr
, GFC_ISYM_UBOUND
);
11302 case GFC_ISYM_UCOBOUND
:
11303 conv_intrinsic_cobound (se
, expr
);
11307 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
11311 gfc_conv_intrinsic_loc (se
, expr
);
11314 case GFC_ISYM_THIS_IMAGE
:
11315 /* For num_images() == 1, handle as LCOBOUND. */
11316 if (expr
->value
.function
.actual
->expr
11317 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
11318 conv_intrinsic_cobound (se
, expr
);
11320 trans_this_image (se
, expr
);
11323 case GFC_ISYM_IMAGE_INDEX
:
11324 trans_image_index (se
, expr
);
11327 case GFC_ISYM_IMAGE_STATUS
:
11328 conv_intrinsic_image_status (se
, expr
);
11331 case GFC_ISYM_NUM_IMAGES
:
11332 trans_num_images (se
, expr
);
11335 case GFC_ISYM_ACCESS
:
11336 case GFC_ISYM_CHDIR
:
11337 case GFC_ISYM_CHMOD
:
11338 case GFC_ISYM_DTIME
:
11339 case GFC_ISYM_ETIME
:
11340 case GFC_ISYM_EXTENDS_TYPE_OF
:
11341 case GFC_ISYM_FGET
:
11342 case GFC_ISYM_FGETC
:
11343 case GFC_ISYM_FNUM
:
11344 case GFC_ISYM_FPUT
:
11345 case GFC_ISYM_FPUTC
:
11346 case GFC_ISYM_FSTAT
:
11347 case GFC_ISYM_FTELL
:
11348 case GFC_ISYM_GETCWD
:
11349 case GFC_ISYM_GETGID
:
11350 case GFC_ISYM_GETPID
:
11351 case GFC_ISYM_GETUID
:
11352 case GFC_ISYM_HOSTNM
:
11353 case GFC_ISYM_IERRNO
:
11354 case GFC_ISYM_IRAND
:
11355 case GFC_ISYM_ISATTY
:
11357 case GFC_ISYM_LINK
:
11358 case GFC_ISYM_LSTAT
:
11359 case GFC_ISYM_MATMUL
:
11360 case GFC_ISYM_MCLOCK
:
11361 case GFC_ISYM_MCLOCK8
:
11362 case GFC_ISYM_RAND
:
11363 case GFC_ISYM_RENAME
:
11364 case GFC_ISYM_SECOND
:
11365 case GFC_ISYM_SECNDS
:
11366 case GFC_ISYM_SIGNAL
:
11367 case GFC_ISYM_STAT
:
11368 case GFC_ISYM_SYMLNK
:
11369 case GFC_ISYM_SYSTEM
:
11370 case GFC_ISYM_TIME
:
11371 case GFC_ISYM_TIME8
:
11372 case GFC_ISYM_UMASK
:
11373 case GFC_ISYM_UNLINK
:
11375 gfc_conv_intrinsic_funcall (se
, expr
);
11378 case GFC_ISYM_EOSHIFT
:
11379 case GFC_ISYM_PACK
:
11380 case GFC_ISYM_RESHAPE
:
11381 /* For those, expr->rank should always be >0 and thus the if above the
11382 switch should have matched. */
11383 gcc_unreachable ();
11387 gfc_conv_intrinsic_lib_function (se
, expr
);
11394 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
11396 gfc_ss
*arg_ss
, *tmp_ss
;
11397 gfc_actual_arglist
*arg
;
11399 arg
= expr
->value
.function
.actual
;
11401 gcc_assert (arg
->expr
);
11403 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
11404 gcc_assert (arg_ss
!= gfc_ss_terminator
);
11406 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
11408 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
11409 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
11411 gcc_assert (tmp_ss
->dimen
== 2);
11413 /* We just invert dimensions. */
11414 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
11417 /* Stop when tmp_ss points to the last valid element of the chain... */
11418 if (tmp_ss
->next
== gfc_ss_terminator
)
11422 /* ... so that we can attach the rest of the chain to it. */
11429 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11430 This has the side effect of reversing the nested list, so there is no
11431 need to call gfc_reverse_ss on it (the given list is assumed not to be
11435 nest_loop_dimension (gfc_ss
*ss
, int dim
)
11438 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
11439 gfc_loopinfo
*new_loop
;
11441 gcc_assert (ss
!= gfc_ss_terminator
);
11443 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
11445 new_ss
= gfc_get_ss ();
11446 new_ss
->next
= prev_ss
;
11447 new_ss
->parent
= ss
;
11448 new_ss
->info
= ss
->info
;
11449 new_ss
->info
->refcount
++;
11450 if (ss
->dimen
!= 0)
11452 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
11453 && ss
->info
->type
!= GFC_SS_REFERENCE
);
11456 new_ss
->dim
[0] = ss
->dim
[dim
];
11458 gcc_assert (dim
< ss
->dimen
);
11460 ss_dim
= --ss
->dimen
;
11461 for (i
= dim
; i
< ss_dim
; i
++)
11462 ss
->dim
[i
] = ss
->dim
[i
+ 1];
11464 ss
->dim
[ss_dim
] = 0;
11470 ss
->nested_ss
->parent
= new_ss
;
11471 new_ss
->nested_ss
= ss
->nested_ss
;
11473 ss
->nested_ss
= new_ss
;
11476 new_loop
= gfc_get_loopinfo ();
11477 gfc_init_loopinfo (new_loop
);
11479 gcc_assert (prev_ss
!= NULL
);
11480 gcc_assert (prev_ss
!= gfc_ss_terminator
);
11481 gfc_add_ss_to_loop (new_loop
, prev_ss
);
11482 return new_ss
->parent
;
11486 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
11487 is to be inlined. */
11490 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
11492 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
11493 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
11495 bool scalar_mask
= false;
11497 /* The rank of the result will be determined later. */
11498 arg1
= expr
->value
.function
.actual
;
11501 gcc_assert (arg3
!= NULL
);
11503 if (expr
->rank
== 0)
11506 tmp_ss
= gfc_ss_terminator
;
11512 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
11513 if (mask_ss
== tmp_ss
)
11519 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
11520 gcc_assert (array_ss
!= tmp_ss
);
11522 /* Odd thing: If the mask is scalar, it is used by the frontend after
11523 the array (to make an if around the nested loop). Thus it shall
11524 be after array_ss once the gfc_ss list is reversed. */
11526 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
11530 /* "Hide" the dimension on which we will sum in the first arg's scalarization
11532 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
11533 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
11541 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
11544 switch (expr
->value
.function
.isym
->id
)
11546 case GFC_ISYM_PRODUCT
:
11548 return walk_inline_intrinsic_arith (ss
, expr
);
11550 case GFC_ISYM_TRANSPOSE
:
11551 return walk_inline_intrinsic_transpose (ss
, expr
);
11554 gcc_unreachable ();
11556 gcc_unreachable ();
11560 /* This generates code to execute before entering the scalarization loop.
11561 Currently does nothing. */
11564 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
11566 switch (ss
->info
->expr
->value
.function
.isym
->id
)
11568 case GFC_ISYM_UBOUND
:
11569 case GFC_ISYM_LBOUND
:
11570 case GFC_ISYM_UCOBOUND
:
11571 case GFC_ISYM_LCOBOUND
:
11572 case GFC_ISYM_THIS_IMAGE
:
11573 case GFC_ISYM_SHAPE
:
11577 gcc_unreachable ();
11582 /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
11583 one parameter are expanded into code inside the scalarization loop. */
11586 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
11588 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
11589 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
11591 /* The two argument version returns a scalar. */
11592 if (expr
->value
.function
.isym
->id
!= GFC_ISYM_SHAPE
11593 && expr
->value
.function
.actual
->next
->expr
)
11596 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
11600 /* Walk an intrinsic array libcall. */
11603 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
11605 gcc_assert (expr
->rank
> 0);
11606 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
11610 /* Return whether the function call expression EXPR will be expanded
11611 inline by gfc_conv_intrinsic_function. */
11614 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
11616 gfc_actual_arglist
*args
, *dim_arg
, *mask_arg
;
11617 gfc_expr
*maskexpr
;
11619 if (!expr
->value
.function
.isym
)
11622 switch (expr
->value
.function
.isym
->id
)
11624 case GFC_ISYM_PRODUCT
:
11626 /* Disable inline expansion if code size matters. */
11630 args
= expr
->value
.function
.actual
;
11631 dim_arg
= args
->next
;
11633 /* We need to be able to subset the SUM argument at compile-time. */
11634 if (dim_arg
->expr
&& dim_arg
->expr
->expr_type
!= EXPR_CONSTANT
)
11637 /* FIXME: If MASK is optional for a more than two-dimensional
11638 argument, the scalarizer gets confused if the mask is
11639 absent. See PR 82995. For now, fall back to the library
11642 mask_arg
= dim_arg
->next
;
11643 maskexpr
= mask_arg
->expr
;
11645 if (expr
->rank
> 0 && maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
11646 && maskexpr
->symtree
->n
.sym
->attr
.dummy
11647 && maskexpr
->symtree
->n
.sym
->attr
.optional
)
11652 case GFC_ISYM_TRANSPOSE
:
11661 /* Returns nonzero if the specified intrinsic function call maps directly to
11662 an external library call. Should only be used for functions that return
11666 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
11668 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
11669 gcc_assert (expr
->rank
> 0);
11671 if (gfc_inline_intrinsic_function_p (expr
))
11674 switch (expr
->value
.function
.isym
->id
)
11678 case GFC_ISYM_COUNT
:
11679 case GFC_ISYM_FINDLOC
:
11681 case GFC_ISYM_IANY
:
11682 case GFC_ISYM_IALL
:
11683 case GFC_ISYM_IPARITY
:
11684 case GFC_ISYM_MATMUL
:
11685 case GFC_ISYM_MAXLOC
:
11686 case GFC_ISYM_MAXVAL
:
11687 case GFC_ISYM_MINLOC
:
11688 case GFC_ISYM_MINVAL
:
11689 case GFC_ISYM_NORM2
:
11690 case GFC_ISYM_PARITY
:
11691 case GFC_ISYM_PRODUCT
:
11693 case GFC_ISYM_SPREAD
:
11695 /* Ignore absent optional parameters. */
11698 case GFC_ISYM_CSHIFT
:
11699 case GFC_ISYM_EOSHIFT
:
11700 case GFC_ISYM_GET_TEAM
:
11701 case GFC_ISYM_FAILED_IMAGES
:
11702 case GFC_ISYM_STOPPED_IMAGES
:
11703 case GFC_ISYM_PACK
:
11704 case GFC_ISYM_RESHAPE
:
11705 case GFC_ISYM_UNPACK
:
11706 /* Pass absent optional parameters. */
11714 /* Walk an intrinsic function. */
11716 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
11717 gfc_intrinsic_sym
* isym
)
11721 if (isym
->elemental
)
11722 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
11723 expr
->value
.function
.isym
,
11726 if (expr
->rank
== 0 && expr
->corank
== 0)
11729 if (gfc_inline_intrinsic_function_p (expr
))
11730 return walk_inline_intrinsic_function (ss
, expr
);
11732 if (expr
->rank
!= 0 && gfc_is_intrinsic_libcall (expr
))
11733 return gfc_walk_intrinsic_libfunc (ss
, expr
);
11735 /* Special cases. */
11738 case GFC_ISYM_LBOUND
:
11739 case GFC_ISYM_LCOBOUND
:
11740 case GFC_ISYM_UBOUND
:
11741 case GFC_ISYM_UCOBOUND
:
11742 case GFC_ISYM_THIS_IMAGE
:
11743 case GFC_ISYM_SHAPE
:
11744 return gfc_walk_intrinsic_bound (ss
, expr
);
11746 case GFC_ISYM_TRANSFER
:
11747 case GFC_ISYM_CAF_GET
:
11748 return gfc_walk_intrinsic_libfunc (ss
, expr
);
11751 /* This probably meant someone forgot to add an intrinsic to the above
11752 list(s) when they implemented it, or something's gone horribly
11754 gcc_unreachable ();
11759 conv_co_collective (gfc_code
*code
)
11762 stmtblock_t block
, post_block
;
11763 tree fndecl
, array
= NULL_TREE
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
11764 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
11766 gfc_start_block (&block
);
11767 gfc_init_block (&post_block
);
11769 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
11771 opr_expr
= code
->ext
.actual
->next
->expr
;
11772 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
11773 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11774 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
11779 image_idx_expr
= code
->ext
.actual
->next
->expr
;
11780 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
11781 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11787 gfc_init_se (&argse
, NULL
);
11788 gfc_conv_expr (&argse
, stat_expr
);
11789 gfc_add_block_to_block (&block
, &argse
.pre
);
11790 gfc_add_block_to_block (&post_block
, &argse
.post
);
11792 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
11793 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
11795 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
11798 stat
= null_pointer_node
;
11800 /* Early exit for GFC_FCOARRAY_SINGLE. */
11801 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
11803 if (stat
!= NULL_TREE
)
11805 /* For optional stats, check the pointer is valid before zero'ing. */
11806 if (gfc_expr_attr (stat_expr
).optional
)
11809 stmtblock_t ass_block
;
11810 gfc_start_block (&ass_block
);
11811 gfc_add_modify (&ass_block
, stat
,
11812 fold_convert (TREE_TYPE (stat
),
11813 integer_zero_node
));
11814 tmp
= fold_build2 (NE_EXPR
, logical_type_node
,
11815 gfc_build_addr_expr (NULL_TREE
, stat
),
11816 null_pointer_node
);
11817 tmp
= fold_build3 (COND_EXPR
, void_type_node
, tmp
,
11818 gfc_finish_block (&ass_block
),
11819 build_empty_stmt (input_location
));
11820 gfc_add_expr_to_block (&block
, tmp
);
11823 gfc_add_modify (&block
, stat
,
11824 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
11826 return gfc_finish_block (&block
);
11829 gfc_symbol
*derived
= code
->ext
.actual
->expr
->ts
.type
== BT_DERIVED
11830 ? code
->ext
.actual
->expr
->ts
.u
.derived
: NULL
;
11832 /* Handle the array. */
11833 gfc_init_se (&argse
, NULL
);
11834 if (!derived
|| !derived
->attr
.alloc_comp
11835 || code
->resolved_isym
->id
!= GFC_ISYM_CO_BROADCAST
)
11837 if (code
->ext
.actual
->expr
->rank
== 0)
11839 symbol_attribute attr
;
11840 gfc_clear_attr (&attr
);
11841 gfc_init_se (&argse
, NULL
);
11842 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
11843 gfc_add_block_to_block (&block
, &argse
.pre
);
11844 gfc_add_block_to_block (&post_block
, &argse
.post
);
11845 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
11846 array
= gfc_build_addr_expr (NULL_TREE
, array
);
11850 argse
.want_pointer
= 1;
11851 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
11852 array
= argse
.expr
;
11856 gfc_add_block_to_block (&block
, &argse
.pre
);
11857 gfc_add_block_to_block (&post_block
, &argse
.post
);
11859 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
11860 strlen
= argse
.string_length
;
11862 strlen
= integer_zero_node
;
11865 if (image_idx_expr
)
11867 gfc_init_se (&argse
, NULL
);
11868 gfc_conv_expr (&argse
, image_idx_expr
);
11869 gfc_add_block_to_block (&block
, &argse
.pre
);
11870 gfc_add_block_to_block (&post_block
, &argse
.post
);
11871 image_index
= fold_convert (integer_type_node
, argse
.expr
);
11874 image_index
= integer_zero_node
;
11879 gfc_init_se (&argse
, NULL
);
11880 gfc_conv_expr (&argse
, errmsg_expr
);
11881 gfc_add_block_to_block (&block
, &argse
.pre
);
11882 gfc_add_block_to_block (&post_block
, &argse
.post
);
11883 errmsg
= argse
.expr
;
11884 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
11888 errmsg
= null_pointer_node
;
11889 errmsg_len
= build_zero_cst (size_type_node
);
11892 /* Generate the function call. */
11893 switch (code
->resolved_isym
->id
)
11895 case GFC_ISYM_CO_BROADCAST
:
11896 fndecl
= gfor_fndecl_co_broadcast
;
11898 case GFC_ISYM_CO_MAX
:
11899 fndecl
= gfor_fndecl_co_max
;
11901 case GFC_ISYM_CO_MIN
:
11902 fndecl
= gfor_fndecl_co_min
;
11904 case GFC_ISYM_CO_REDUCE
:
11905 fndecl
= gfor_fndecl_co_reduce
;
11907 case GFC_ISYM_CO_SUM
:
11908 fndecl
= gfor_fndecl_co_sum
;
11911 gcc_unreachable ();
11914 if (derived
&& derived
->attr
.alloc_comp
11915 && code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
11916 /* The derived type has the attribute 'alloc_comp'. */
11918 tree tmp
= gfc_bcast_alloc_comp (derived
, code
->ext
.actual
->expr
,
11919 code
->ext
.actual
->expr
->rank
,
11920 image_index
, stat
, errmsg
, errmsg_len
);
11921 gfc_add_expr_to_block (&block
, tmp
);
11925 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
11926 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
11927 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
11928 image_index
, stat
, errmsg
, errmsg_len
);
11929 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
11930 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
,
11931 image_index
, stat
, errmsg
,
11932 strlen
, errmsg_len
);
11935 tree opr
, opr_flags
;
11937 // FIXME: Handle TS29113's bind(C) strings with descriptor.
11939 if (gfc_is_proc_ptr_comp (opr_expr
))
11941 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
11942 opr_flag_int
= sym
->attr
.dimension
11943 || (sym
->ts
.type
== BT_CHARACTER
11944 && !sym
->attr
.is_bind_c
)
11945 ? GFC_CAF_BYREF
: 0;
11946 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
11947 && !sym
->attr
.is_bind_c
11948 ? GFC_CAF_HIDDENLEN
: 0;
11949 opr_flag_int
|= sym
->formal
->sym
->attr
.value
11950 ? GFC_CAF_ARG_VALUE
: 0;
11954 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
11955 ? GFC_CAF_BYREF
: 0;
11956 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
11957 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
11958 ? GFC_CAF_HIDDENLEN
: 0;
11959 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
11960 ? GFC_CAF_ARG_VALUE
: 0;
11962 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
11963 gfc_conv_expr (&argse
, opr_expr
);
11965 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
,
11966 opr_flags
, image_index
, stat
, errmsg
,
11967 strlen
, errmsg_len
);
11971 gfc_add_expr_to_block (&block
, fndecl
);
11972 gfc_add_block_to_block (&block
, &post_block
);
11974 return gfc_finish_block (&block
);
11979 conv_intrinsic_atomic_op (gfc_code
*code
)
11982 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
11983 stmtblock_t block
, post_block
;
11984 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
11985 gfc_expr
*stat_expr
;
11986 built_in_function fn
;
11988 if (atom_expr
->expr_type
== EXPR_FUNCTION
11989 && atom_expr
->value
.function
.isym
11990 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11991 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11993 gfc_start_block (&block
);
11994 gfc_init_block (&post_block
);
11996 gfc_init_se (&argse
, NULL
);
11997 argse
.want_pointer
= 1;
11998 gfc_conv_expr (&argse
, atom_expr
);
11999 gfc_add_block_to_block (&block
, &argse
.pre
);
12000 gfc_add_block_to_block (&post_block
, &argse
.post
);
12003 gfc_init_se (&argse
, NULL
);
12004 if (flag_coarray
== GFC_FCOARRAY_LIB
12005 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
12006 argse
.want_pointer
= 1;
12007 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
12008 gfc_add_block_to_block (&block
, &argse
.pre
);
12009 gfc_add_block_to_block (&post_block
, &argse
.post
);
12010 value
= argse
.expr
;
12012 switch (code
->resolved_isym
->id
)
12014 case GFC_ISYM_ATOMIC_ADD
:
12015 case GFC_ISYM_ATOMIC_AND
:
12016 case GFC_ISYM_ATOMIC_DEF
:
12017 case GFC_ISYM_ATOMIC_OR
:
12018 case GFC_ISYM_ATOMIC_XOR
:
12019 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
12020 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12021 old
= null_pointer_node
;
12024 gfc_init_se (&argse
, NULL
);
12025 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12026 argse
.want_pointer
= 1;
12027 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
12028 gfc_add_block_to_block (&block
, &argse
.pre
);
12029 gfc_add_block_to_block (&post_block
, &argse
.post
);
12031 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
12035 if (stat_expr
!= NULL
)
12037 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
12038 gfc_init_se (&argse
, NULL
);
12039 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12040 argse
.want_pointer
= 1;
12041 gfc_conv_expr_val (&argse
, stat_expr
);
12042 gfc_add_block_to_block (&block
, &argse
.pre
);
12043 gfc_add_block_to_block (&post_block
, &argse
.post
);
12046 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
12047 stat
= null_pointer_node
;
12049 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12051 tree image_index
, caf_decl
, offset
, token
;
12054 switch (code
->resolved_isym
->id
)
12056 case GFC_ISYM_ATOMIC_ADD
:
12057 case GFC_ISYM_ATOMIC_FETCH_ADD
:
12058 op
= (int) GFC_CAF_ATOMIC_ADD
;
12060 case GFC_ISYM_ATOMIC_AND
:
12061 case GFC_ISYM_ATOMIC_FETCH_AND
:
12062 op
= (int) GFC_CAF_ATOMIC_AND
;
12064 case GFC_ISYM_ATOMIC_OR
:
12065 case GFC_ISYM_ATOMIC_FETCH_OR
:
12066 op
= (int) GFC_CAF_ATOMIC_OR
;
12068 case GFC_ISYM_ATOMIC_XOR
:
12069 case GFC_ISYM_ATOMIC_FETCH_XOR
:
12070 op
= (int) GFC_CAF_ATOMIC_XOR
;
12072 case GFC_ISYM_ATOMIC_DEF
:
12073 op
= 0; /* Unused. */
12076 gcc_unreachable ();
12079 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
12080 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
12081 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
12083 if (gfc_is_coindexed (atom_expr
))
12084 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
12086 image_index
= integer_zero_node
;
12088 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
12090 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
12091 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
12092 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
12095 gfc_init_se (&argse
, NULL
);
12096 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
12099 gfc_add_block_to_block (&block
, &argse
.pre
);
12100 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
12101 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
12102 token
, offset
, image_index
, value
, stat
,
12103 build_int_cst (integer_type_node
,
12104 (int) atom_expr
->ts
.type
),
12105 build_int_cst (integer_type_node
,
12106 (int) atom_expr
->ts
.kind
));
12108 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
12109 build_int_cst (integer_type_node
, op
),
12110 token
, offset
, image_index
, value
, old
, stat
,
12111 build_int_cst (integer_type_node
,
12112 (int) atom_expr
->ts
.type
),
12113 build_int_cst (integer_type_node
,
12114 (int) atom_expr
->ts
.kind
));
12116 gfc_add_expr_to_block (&block
, tmp
);
12117 gfc_add_block_to_block (&block
, &argse
.post
);
12118 gfc_add_block_to_block (&block
, &post_block
);
12119 return gfc_finish_block (&block
);
12123 switch (code
->resolved_isym
->id
)
12125 case GFC_ISYM_ATOMIC_ADD
:
12126 case GFC_ISYM_ATOMIC_FETCH_ADD
:
12127 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
12129 case GFC_ISYM_ATOMIC_AND
:
12130 case GFC_ISYM_ATOMIC_FETCH_AND
:
12131 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
12133 case GFC_ISYM_ATOMIC_DEF
:
12134 fn
= BUILT_IN_ATOMIC_STORE_N
;
12136 case GFC_ISYM_ATOMIC_OR
:
12137 case GFC_ISYM_ATOMIC_FETCH_OR
:
12138 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
12140 case GFC_ISYM_ATOMIC_XOR
:
12141 case GFC_ISYM_ATOMIC_FETCH_XOR
:
12142 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
12145 gcc_unreachable ();
12148 tmp
= TREE_TYPE (TREE_TYPE (atom
));
12149 fn
= (built_in_function
) ((int) fn
12150 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
12152 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
12153 tmp
= builtin_decl_explicit (fn
);
12155 switch (code
->resolved_isym
->id
)
12157 case GFC_ISYM_ATOMIC_ADD
:
12158 case GFC_ISYM_ATOMIC_AND
:
12159 case GFC_ISYM_ATOMIC_DEF
:
12160 case GFC_ISYM_ATOMIC_OR
:
12161 case GFC_ISYM_ATOMIC_XOR
:
12162 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
12163 fold_convert (itype
, value
),
12164 build_int_cst (NULL
, MEMMODEL_RELAXED
));
12165 gfc_add_expr_to_block (&block
, tmp
);
12168 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
12169 fold_convert (itype
, value
),
12170 build_int_cst (NULL
, MEMMODEL_RELAXED
));
12171 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
12175 if (stat
!= NULL_TREE
)
12176 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
12177 gfc_add_block_to_block (&block
, &post_block
);
12178 return gfc_finish_block (&block
);
12183 conv_intrinsic_atomic_ref (gfc_code
*code
)
12186 tree tmp
, atom
, value
, stat
= NULL_TREE
;
12187 stmtblock_t block
, post_block
;
12188 built_in_function fn
;
12189 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
12191 if (atom_expr
->expr_type
== EXPR_FUNCTION
12192 && atom_expr
->value
.function
.isym
12193 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
12194 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
12196 gfc_start_block (&block
);
12197 gfc_init_block (&post_block
);
12198 gfc_init_se (&argse
, NULL
);
12199 argse
.want_pointer
= 1;
12200 gfc_conv_expr (&argse
, atom_expr
);
12201 gfc_add_block_to_block (&block
, &argse
.pre
);
12202 gfc_add_block_to_block (&post_block
, &argse
.post
);
12205 gfc_init_se (&argse
, NULL
);
12206 if (flag_coarray
== GFC_FCOARRAY_LIB
12207 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
12208 argse
.want_pointer
= 1;
12209 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
12210 gfc_add_block_to_block (&block
, &argse
.pre
);
12211 gfc_add_block_to_block (&post_block
, &argse
.post
);
12212 value
= argse
.expr
;
12215 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
12217 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
12219 gfc_init_se (&argse
, NULL
);
12220 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12221 argse
.want_pointer
= 1;
12222 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
12223 gfc_add_block_to_block (&block
, &argse
.pre
);
12224 gfc_add_block_to_block (&post_block
, &argse
.post
);
12227 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
12228 stat
= null_pointer_node
;
12230 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12232 tree image_index
, caf_decl
, offset
, token
;
12233 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
12235 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
12236 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
12237 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
12239 if (gfc_is_coindexed (atom_expr
))
12240 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
12242 image_index
= integer_zero_node
;
12244 gfc_init_se (&argse
, NULL
);
12245 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
12247 gfc_add_block_to_block (&block
, &argse
.pre
);
12249 /* Different type, need type conversion. */
12250 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
12252 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
12253 orig_value
= value
;
12254 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
12257 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
12258 token
, offset
, image_index
, value
, stat
,
12259 build_int_cst (integer_type_node
,
12260 (int) atom_expr
->ts
.type
),
12261 build_int_cst (integer_type_node
,
12262 (int) atom_expr
->ts
.kind
));
12263 gfc_add_expr_to_block (&block
, tmp
);
12264 if (vardecl
!= NULL_TREE
)
12265 gfc_add_modify (&block
, orig_value
,
12266 fold_convert (TREE_TYPE (orig_value
), vardecl
));
12267 gfc_add_block_to_block (&block
, &argse
.post
);
12268 gfc_add_block_to_block (&block
, &post_block
);
12269 return gfc_finish_block (&block
);
12272 tmp
= TREE_TYPE (TREE_TYPE (atom
));
12273 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
12274 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
12276 tmp
= builtin_decl_explicit (fn
);
12277 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
12278 build_int_cst (integer_type_node
,
12279 MEMMODEL_RELAXED
));
12280 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
12282 if (stat
!= NULL_TREE
)
12283 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
12284 gfc_add_block_to_block (&block
, &post_block
);
12285 return gfc_finish_block (&block
);
12290 conv_intrinsic_atomic_cas (gfc_code
*code
)
12293 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
12294 stmtblock_t block
, post_block
;
12295 built_in_function fn
;
12296 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
12298 if (atom_expr
->expr_type
== EXPR_FUNCTION
12299 && atom_expr
->value
.function
.isym
12300 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
12301 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
12303 gfc_init_block (&block
);
12304 gfc_init_block (&post_block
);
12305 gfc_init_se (&argse
, NULL
);
12306 argse
.want_pointer
= 1;
12307 gfc_conv_expr (&argse
, atom_expr
);
12310 gfc_init_se (&argse
, NULL
);
12311 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12312 argse
.want_pointer
= 1;
12313 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
12314 gfc_add_block_to_block (&block
, &argse
.pre
);
12315 gfc_add_block_to_block (&post_block
, &argse
.post
);
12318 gfc_init_se (&argse
, NULL
);
12319 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12320 argse
.want_pointer
= 1;
12321 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
12322 gfc_add_block_to_block (&block
, &argse
.pre
);
12323 gfc_add_block_to_block (&post_block
, &argse
.post
);
12326 gfc_init_se (&argse
, NULL
);
12327 if (flag_coarray
== GFC_FCOARRAY_LIB
12328 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
12329 == atom_expr
->ts
.kind
)
12330 argse
.want_pointer
= 1;
12331 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
12332 gfc_add_block_to_block (&block
, &argse
.pre
);
12333 gfc_add_block_to_block (&post_block
, &argse
.post
);
12334 new_val
= argse
.expr
;
12337 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
12339 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
12341 gfc_init_se (&argse
, NULL
);
12342 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12343 argse
.want_pointer
= 1;
12344 gfc_conv_expr_val (&argse
,
12345 code
->ext
.actual
->next
->next
->next
->next
->expr
);
12346 gfc_add_block_to_block (&block
, &argse
.pre
);
12347 gfc_add_block_to_block (&post_block
, &argse
.post
);
12350 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
12351 stat
= null_pointer_node
;
12353 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12355 tree image_index
, caf_decl
, offset
, token
;
12357 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
12358 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
12359 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
12361 if (gfc_is_coindexed (atom_expr
))
12362 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
12364 image_index
= integer_zero_node
;
12366 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
12368 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
12369 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
12370 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
12373 /* Convert a constant to a pointer. */
12374 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
12376 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
12377 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
12378 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
12381 gfc_init_se (&argse
, NULL
);
12382 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
12384 gfc_add_block_to_block (&block
, &argse
.pre
);
12386 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
12387 token
, offset
, image_index
, old
, comp
, new_val
,
12388 stat
, build_int_cst (integer_type_node
,
12389 (int) atom_expr
->ts
.type
),
12390 build_int_cst (integer_type_node
,
12391 (int) atom_expr
->ts
.kind
));
12392 gfc_add_expr_to_block (&block
, tmp
);
12393 gfc_add_block_to_block (&block
, &argse
.post
);
12394 gfc_add_block_to_block (&block
, &post_block
);
12395 return gfc_finish_block (&block
);
12398 tmp
= TREE_TYPE (TREE_TYPE (atom
));
12399 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
12400 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
12402 tmp
= builtin_decl_explicit (fn
);
12404 gfc_add_modify (&block
, old
, comp
);
12405 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
12406 gfc_build_addr_expr (NULL
, old
),
12407 fold_convert (TREE_TYPE (old
), new_val
),
12408 boolean_false_node
,
12409 build_int_cst (NULL
, MEMMODEL_RELAXED
),
12410 build_int_cst (NULL
, MEMMODEL_RELAXED
));
12411 gfc_add_expr_to_block (&block
, tmp
);
12413 if (stat
!= NULL_TREE
)
12414 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
12415 gfc_add_block_to_block (&block
, &post_block
);
12416 return gfc_finish_block (&block
);
12420 conv_intrinsic_event_query (gfc_code
*code
)
12423 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
12424 tree count
= NULL_TREE
, count2
= NULL_TREE
;
12426 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
12428 if (code
->ext
.actual
->next
->next
->expr
)
12430 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
12432 gfc_init_se (&argse
, NULL
);
12433 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
12436 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
12437 stat
= null_pointer_node
;
12439 if (code
->ext
.actual
->next
->expr
)
12441 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
12442 gfc_init_se (&argse
, NULL
);
12443 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
12444 count
= argse
.expr
;
12447 gfc_start_block (&se
.pre
);
12448 if (flag_coarray
== GFC_FCOARRAY_LIB
)
12450 tree tmp
, token
, image_index
;
12451 tree index
= build_zero_cst (gfc_array_index_type
);
12453 if (event_expr
->expr_type
== EXPR_FUNCTION
12454 && event_expr
->value
.function
.isym
12455 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
12456 event_expr
= event_expr
->value
.function
.actual
->expr
;
12458 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
12460 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
12461 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
12462 != INTMOD_ISO_FORTRAN_ENV
12463 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
12464 != ISOFORTRAN_EVENT_TYPE
)
12466 gfc_error ("Sorry, the event component of derived type at %L is not "
12467 "yet supported", &event_expr
->where
);
12471 if (gfc_is_coindexed (event_expr
))
12473 gfc_error ("The event variable at %L shall not be coindexed",
12474 &event_expr
->where
);
12478 image_index
= integer_zero_node
;
12480 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
12483 /* For arrays, obtain the array index. */
12484 if (gfc_expr_attr (event_expr
).dimension
)
12486 tree desc
, tmp
, extent
, lbound
, ubound
;
12487 gfc_array_ref
*ar
, ar2
;
12490 /* TODO: Extend this, once DT components are supported. */
12491 ar
= &event_expr
->ref
->u
.ar
;
12493 memset (ar
, '\0', sizeof (*ar
));
12495 ar
->type
= AR_FULL
;
12497 gfc_init_se (&argse
, NULL
);
12498 argse
.descriptor_only
= 1;
12499 gfc_conv_expr_descriptor (&argse
, event_expr
);
12500 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
12504 extent
= build_one_cst (gfc_array_index_type
);
12505 for (i
= 0; i
< ar
->dimen
; i
++)
12507 gfc_init_se (&argse
, NULL
);
12508 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
12509 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
12510 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
12511 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
12512 TREE_TYPE (lbound
), argse
.expr
, lbound
);
12513 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
12514 TREE_TYPE (tmp
), extent
, tmp
);
12515 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
12516 TREE_TYPE (tmp
), index
, tmp
);
12517 if (i
< ar
->dimen
- 1)
12519 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
12520 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
12521 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
12522 TREE_TYPE (tmp
), extent
, tmp
);
12527 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
12530 count
= gfc_create_var (integer_type_node
, "count");
12533 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
12536 stat
= gfc_create_var (integer_type_node
, "stat");
12539 index
= fold_convert (size_type_node
, index
);
12540 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
12541 token
, index
, image_index
, count
12542 ? gfc_build_addr_expr (NULL
, count
) : count
,
12543 stat
!= null_pointer_node
12544 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
12545 gfc_add_expr_to_block (&se
.pre
, tmp
);
12547 if (count2
!= NULL_TREE
)
12548 gfc_add_modify (&se
.pre
, count2
,
12549 fold_convert (TREE_TYPE (count2
), count
));
12551 if (stat2
!= NULL_TREE
)
12552 gfc_add_modify (&se
.pre
, stat2
,
12553 fold_convert (TREE_TYPE (stat2
), stat
));
12555 return gfc_finish_block (&se
.pre
);
12558 gfc_init_se (&argse
, NULL
);
12559 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
12560 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
12562 if (stat
!= NULL_TREE
)
12563 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
12565 return gfc_finish_block (&se
.pre
);
12569 /* This is a peculiar case because of the need to do dependency checking.
12570 It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
12571 a special case and this function called instead of
12572 gfc_conv_procedure_call. */
12574 gfc_conv_intrinsic_mvbits (gfc_se
*se
, gfc_actual_arglist
*actual_args
,
12575 gfc_loopinfo
*loop
)
12577 gfc_actual_arglist
*actual
;
12583 tree from
, frompos
, len
, to
, topos
;
12584 tree lenmask
, oldbits
, newbits
, bitsize
;
12585 tree type
, utype
, above
, mask1
, mask2
;
12590 lss
= gfc_ss_terminator
;
12592 actual
= actual_args
;
12593 for (n
= 0; n
< 5; n
++, actual
= actual
->next
)
12595 arg
[n
] = actual
->expr
;
12596 gfc_init_se (&argse
[n
], NULL
);
12598 if (lss
!= gfc_ss_terminator
)
12600 gfc_copy_loopinfo_to_se (&argse
[n
], loop
);
12601 /* Find the ss for the expression if it is there. */
12603 gfc_mark_ss_chain_used (lss
, 1);
12606 gfc_conv_expr (&argse
[n
], arg
[n
]);
12612 from
= argse
[0].expr
;
12613 frompos
= argse
[1].expr
;
12614 len
= argse
[2].expr
;
12615 to
= argse
[3].expr
;
12616 topos
= argse
[4].expr
;
12618 /* The type of the result (TO). */
12619 type
= TREE_TYPE (to
);
12620 bitsize
= build_int_cst (integer_type_node
, TYPE_PRECISION (type
));
12622 /* Optionally generate code for runtime argument check. */
12623 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
12625 tree nbits
, below
, ccond
;
12626 tree fp
= fold_convert (long_integer_type_node
, frompos
);
12627 tree ln
= fold_convert (long_integer_type_node
, len
);
12628 tree tp
= fold_convert (long_integer_type_node
, topos
);
12629 below
= fold_build2_loc (input_location
, LT_EXPR
,
12630 logical_type_node
, frompos
,
12631 build_int_cst (TREE_TYPE (frompos
), 0));
12632 above
= fold_build2_loc (input_location
, GT_EXPR
,
12633 logical_type_node
, frompos
,
12634 fold_convert (TREE_TYPE (frompos
), bitsize
));
12635 ccond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
12636 logical_type_node
, below
, above
);
12637 gfc_trans_runtime_check (true, false, ccond
, &argse
[1].pre
,
12639 "FROMPOS argument (%ld) out of range 0:%d "
12640 "in intrinsic MVBITS", fp
, bitsize
);
12641 below
= fold_build2_loc (input_location
, LT_EXPR
,
12642 logical_type_node
, len
,
12643 build_int_cst (TREE_TYPE (len
), 0));
12644 above
= fold_build2_loc (input_location
, GT_EXPR
,
12645 logical_type_node
, len
,
12646 fold_convert (TREE_TYPE (len
), bitsize
));
12647 ccond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
12648 logical_type_node
, below
, above
);
12649 gfc_trans_runtime_check (true, false, ccond
, &argse
[2].pre
,
12651 "LEN argument (%ld) out of range 0:%d "
12652 "in intrinsic MVBITS", ln
, bitsize
);
12653 below
= fold_build2_loc (input_location
, LT_EXPR
,
12654 logical_type_node
, topos
,
12655 build_int_cst (TREE_TYPE (topos
), 0));
12656 above
= fold_build2_loc (input_location
, GT_EXPR
,
12657 logical_type_node
, topos
,
12658 fold_convert (TREE_TYPE (topos
), bitsize
));
12659 ccond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
12660 logical_type_node
, below
, above
);
12661 gfc_trans_runtime_check (true, false, ccond
, &argse
[4].pre
,
12663 "TOPOS argument (%ld) out of range 0:%d "
12664 "in intrinsic MVBITS", tp
, bitsize
);
12666 /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
12667 integers. Additions below cannot overflow. */
12668 nbits
= fold_convert (long_integer_type_node
, bitsize
);
12669 above
= fold_build2_loc (input_location
, PLUS_EXPR
,
12670 long_integer_type_node
, fp
, ln
);
12671 ccond
= fold_build2_loc (input_location
, GT_EXPR
,
12672 logical_type_node
, above
, nbits
);
12673 gfc_trans_runtime_check (true, false, ccond
, &argse
[1].pre
,
12675 "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12676 "in intrinsic MVBITS", fp
, ln
, bitsize
);
12677 above
= fold_build2_loc (input_location
, PLUS_EXPR
,
12678 long_integer_type_node
, tp
, ln
);
12679 ccond
= fold_build2_loc (input_location
, GT_EXPR
,
12680 logical_type_node
, above
, nbits
);
12681 gfc_trans_runtime_check (true, false, ccond
, &argse
[4].pre
,
12683 "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12684 "in intrinsic MVBITS", tp
, ln
, bitsize
);
12687 for (n
= 0; n
< 5; n
++)
12689 gfc_add_block_to_block (&se
->pre
, &argse
[n
].pre
);
12690 gfc_add_block_to_block (&se
->post
, &argse
[n
].post
);
12693 /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
12694 above
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
12695 len
, fold_convert (TREE_TYPE (len
), bitsize
));
12696 mask1
= build_int_cst (type
, -1);
12697 mask2
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
12698 build_int_cst (type
, 1), len
);
12699 mask2
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
12700 mask2
, build_int_cst (type
, 1));
12701 lenmask
= fold_build3_loc (input_location
, COND_EXPR
, type
,
12702 above
, mask1
, mask2
);
12704 /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
12705 * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
12706 * not strictly necessary; artificial bits from rshift will be masked. */
12707 utype
= unsigned_type_for (type
);
12708 newbits
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
12709 fold_convert (utype
, from
), frompos
);
12710 newbits
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
12711 fold_convert (type
, newbits
), lenmask
);
12712 newbits
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
12715 /* oldbits = TO & (~(lenmask << TOPOS)). */
12716 oldbits
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
12718 oldbits
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, oldbits
);
12719 oldbits
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, oldbits
, to
);
12721 /* TO = newbits | oldbits. */
12722 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
12725 /* Return the assignment. */
12726 se
->expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
12727 void_type_node
, to
, se
->expr
);
12732 conv_intrinsic_move_alloc (gfc_code
*code
)
12735 gfc_expr
*from_expr
, *to_expr
;
12736 gfc_se from_se
, to_se
;
12737 tree tmp
, to_tree
, from_tree
;
12738 bool coarray
, from_is_class
, from_is_scalar
;
12740 gfc_start_block (&block
);
12742 from_expr
= code
->ext
.actual
->expr
;
12743 to_expr
= code
->ext
.actual
->next
->expr
;
12745 gfc_init_se (&from_se
, NULL
);
12746 gfc_init_se (&to_se
, NULL
);
12748 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
|| to_expr
->ts
.type
== BT_CLASS
);
12749 coarray
= from_expr
->corank
!= 0;
12751 from_is_class
= from_expr
->ts
.type
== BT_CLASS
;
12752 from_is_scalar
= from_expr
->rank
== 0 && !coarray
;
12753 if (to_expr
->ts
.type
== BT_CLASS
|| from_is_scalar
)
12755 from_se
.want_pointer
= 1;
12756 if (from_is_scalar
)
12757 gfc_conv_expr (&from_se
, from_expr
);
12759 gfc_conv_expr_descriptor (&from_se
, from_expr
);
12761 from_tree
= gfc_class_data_get (from_se
.expr
);
12765 from_tree
= from_se
.expr
;
12767 if (to_expr
->ts
.type
== BT_CLASS
)
12769 vtab
= gfc_find_vtab (&from_expr
->ts
);
12771 from_se
.expr
= gfc_get_symbol_decl (vtab
);
12774 gfc_add_block_to_block (&block
, &from_se
.pre
);
12776 to_se
.want_pointer
= 1;
12777 if (to_expr
->rank
== 0)
12778 gfc_conv_expr (&to_se
, to_expr
);
12780 gfc_conv_expr_descriptor (&to_se
, to_expr
);
12781 if (to_expr
->ts
.type
== BT_CLASS
)
12782 to_tree
= gfc_class_data_get (to_se
.expr
);
12784 to_tree
= to_se
.expr
;
12785 gfc_add_block_to_block (&block
, &to_se
.pre
);
12787 /* Deallocate "to". */
12788 if (to_expr
->rank
== 0)
12791 = gfc_deallocate_scalar_with_status (to_tree
, NULL_TREE
, NULL_TREE
,
12792 true, to_expr
, to_expr
->ts
);
12793 gfc_add_expr_to_block (&block
, tmp
);
12796 if (from_is_scalar
)
12798 /* Assign (_data) pointers. */
12799 gfc_add_modify_loc (input_location
, &block
, to_tree
,
12800 fold_convert (TREE_TYPE (to_tree
), from_tree
));
12802 /* Set "from" to NULL. */
12803 gfc_add_modify_loc (input_location
, &block
, from_tree
,
12804 fold_convert (TREE_TYPE (from_tree
),
12805 null_pointer_node
));
12807 gfc_add_block_to_block (&block
, &from_se
.post
);
12809 gfc_add_block_to_block (&block
, &to_se
.post
);
12812 if (to_expr
->ts
.type
== BT_CLASS
)
12814 gfc_class_set_vptr (&block
, to_se
.expr
, from_se
.expr
);
12816 gfc_reset_vptr (&block
, from_expr
);
12817 if (UNLIMITED_POLY (to_expr
))
12819 tree to_len
= gfc_class_len_get (to_se
.class_container
);
12820 tmp
= from_expr
->ts
.type
== BT_CHARACTER
&& from_se
.string_length
12821 ? from_se
.string_length
12823 gfc_add_modify_loc (input_location
, &block
, to_len
,
12824 fold_convert (TREE_TYPE (to_len
), tmp
));
12828 if (from_is_scalar
)
12830 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
12832 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
12833 fold_convert (TREE_TYPE (to_se
.string_length
),
12834 from_se
.string_length
));
12835 if (from_expr
->ts
.deferred
)
12836 gfc_add_modify_loc (
12837 input_location
, &block
, from_se
.string_length
,
12838 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
12840 if (UNLIMITED_POLY (from_expr
))
12841 gfc_reset_len (&block
, from_expr
);
12843 return gfc_finish_block (&block
);
12846 gfc_init_se (&to_se
, NULL
);
12847 gfc_init_se (&from_se
, NULL
);
12850 /* Deallocate "to". */
12851 if (from_expr
->rank
== 0)
12853 to_se
.want_coarray
= 1;
12854 from_se
.want_coarray
= 1;
12856 gfc_conv_expr_descriptor (&to_se
, to_expr
);
12857 gfc_conv_expr_descriptor (&from_se
, from_expr
);
12859 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
12860 is an image control "statement", cf. IR F08/0040 in 12-006A. */
12861 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
12865 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
12866 NULL_TREE
, NULL_TREE
, true, to_expr
,
12867 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
12868 gfc_add_expr_to_block (&block
, tmp
);
12870 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
12871 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
12872 logical_type_node
, tmp
,
12873 fold_convert (TREE_TYPE (tmp
),
12874 null_pointer_node
));
12875 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
12876 3, null_pointer_node
, null_pointer_node
,
12877 integer_zero_node
);
12879 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
12880 tmp
, build_empty_stmt (input_location
));
12881 gfc_add_expr_to_block (&block
, tmp
);
12885 if (to_expr
->ts
.type
== BT_DERIVED
12886 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
12888 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
12889 to_se
.expr
, to_expr
->rank
);
12890 gfc_add_expr_to_block (&block
, tmp
);
12893 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
12894 NULL_TREE
, NULL_TREE
, true, to_expr
,
12895 GFC_CAF_COARRAY_NOCOARRAY
);
12896 gfc_add_expr_to_block (&block
, tmp
);
12899 /* Move the pointer and update the array descriptor data. */
12900 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
12902 /* Set "from" to NULL. */
12903 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
12904 gfc_add_modify_loc (input_location
, &block
, tmp
,
12905 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
12908 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
12910 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
12911 fold_convert (TREE_TYPE (to_se
.string_length
),
12912 from_se
.string_length
));
12913 if (from_expr
->ts
.deferred
)
12914 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
12915 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
12918 return gfc_finish_block (&block
);
12923 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
12927 gcc_assert (code
->resolved_isym
);
12929 switch (code
->resolved_isym
->id
)
12931 case GFC_ISYM_MOVE_ALLOC
:
12932 res
= conv_intrinsic_move_alloc (code
);
12935 case GFC_ISYM_ATOMIC_CAS
:
12936 res
= conv_intrinsic_atomic_cas (code
);
12939 case GFC_ISYM_ATOMIC_ADD
:
12940 case GFC_ISYM_ATOMIC_AND
:
12941 case GFC_ISYM_ATOMIC_DEF
:
12942 case GFC_ISYM_ATOMIC_OR
:
12943 case GFC_ISYM_ATOMIC_XOR
:
12944 case GFC_ISYM_ATOMIC_FETCH_ADD
:
12945 case GFC_ISYM_ATOMIC_FETCH_AND
:
12946 case GFC_ISYM_ATOMIC_FETCH_OR
:
12947 case GFC_ISYM_ATOMIC_FETCH_XOR
:
12948 res
= conv_intrinsic_atomic_op (code
);
12951 case GFC_ISYM_ATOMIC_REF
:
12952 res
= conv_intrinsic_atomic_ref (code
);
12955 case GFC_ISYM_EVENT_QUERY
:
12956 res
= conv_intrinsic_event_query (code
);
12959 case GFC_ISYM_C_F_POINTER
:
12960 case GFC_ISYM_C_F_PROCPOINTER
:
12961 res
= conv_isocbinding_subroutine (code
);
12964 case GFC_ISYM_CAF_SEND
:
12965 res
= conv_caf_send (code
);
12968 case GFC_ISYM_CO_BROADCAST
:
12969 case GFC_ISYM_CO_MIN
:
12970 case GFC_ISYM_CO_MAX
:
12971 case GFC_ISYM_CO_REDUCE
:
12972 case GFC_ISYM_CO_SUM
:
12973 res
= conv_co_collective (code
);
12976 case GFC_ISYM_FREE
:
12977 res
= conv_intrinsic_free (code
);
12980 case GFC_ISYM_RANDOM_INIT
:
12981 res
= conv_intrinsic_random_init (code
);
12984 case GFC_ISYM_KILL
:
12985 res
= conv_intrinsic_kill_sub (code
);
12988 case GFC_ISYM_MVBITS
:
12992 case GFC_ISYM_SYSTEM_CLOCK
:
12993 res
= conv_intrinsic_system_clock (code
);
13004 #include "gt-fortran-trans-intrinsic.h"