1 /* Intrinsic translation
2 Copyright (C) 2002-2020 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "internal-fn.h"
35 #include "tree-nested.h"
36 #include "stor-layout.h"
37 #include "toplev.h" /* For rest_of_decl_compilation. */
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 #include "dependency.h" /* For CAF array alias analysis. */
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
45 /* This maps Fortran intrinsic math functions to external library or GCC
47 typedef struct GTY(()) gfc_intrinsic_map_t
{
48 /* The explicit enum is required to work around inadequacies in the
49 garbage collection/gengtype parsing mechanism. */
52 /* Enum value from the "language-independent", aka C-centric, part
53 of gcc, or END_BUILTINS of no such value set. */
54 enum built_in_function float_built_in
;
55 enum built_in_function double_built_in
;
56 enum built_in_function long_double_built_in
;
57 enum built_in_function complex_float_built_in
;
58 enum built_in_function complex_double_built_in
;
59 enum built_in_function complex_long_double_built_in
;
61 /* True if the naming pattern is to prepend "c" for complex and
62 append "f" for kind=4. False if the naming pattern is to
63 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 /* True if a complex version of the function exists. */
67 bool complex_available
;
69 /* True if the function should be marked const. */
72 /* The base library name of this function. */
75 /* Cache decls created for the various operand types. */
87 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
88 defines complex variants of all of the entries in mathbuiltins.def
90 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
91 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
92 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
93 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
94 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
96 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
97 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
98 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
99 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
100 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
102 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
108 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
109 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
110 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
116 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
117 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
118 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
119 #include "mathbuiltins.def"
121 /* Functions in libgfortran. */
122 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
123 LIB_FUNCTION (SIND
, "sind", false),
124 LIB_FUNCTION (COSD
, "cosd", false),
125 LIB_FUNCTION (TAND
, "tand", false),
128 LIB_FUNCTION (NONE
, NULL
, false)
133 #undef DEFINE_MATH_BUILTIN
134 #undef DEFINE_MATH_BUILTIN_C
137 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
140 /* Find the correct variant of a given builtin from its argument. */
142 builtin_decl_for_precision (enum built_in_function base_built_in
,
145 enum built_in_function i
= END_BUILTINS
;
147 gfc_intrinsic_map_t
*m
;
148 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
151 if (precision
== TYPE_PRECISION (float_type_node
))
152 i
= m
->float_built_in
;
153 else if (precision
== TYPE_PRECISION (double_type_node
))
154 i
= m
->double_built_in
;
155 else if (precision
== TYPE_PRECISION (long_double_type_node
))
156 i
= m
->long_double_built_in
;
157 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
159 /* Special treatment, because it is not exactly a built-in, but
160 a library function. */
161 return m
->real16_decl
;
164 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
169 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
172 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
174 if (gfc_real_kinds
[i
].c_float128
)
176 /* For __float128, the story is a bit different, because we return
177 a decl to a library function rather than a built-in. */
178 gfc_intrinsic_map_t
*m
;
179 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
182 return m
->real16_decl
;
185 return builtin_decl_for_precision (double_built_in
,
186 gfc_real_kinds
[i
].mode_precision
);
190 /* Evaluate the arguments to an intrinsic function. The value
191 of NARGS may be less than the actual number of arguments in EXPR
192 to allow optional "KIND" arguments that are not included in the
193 generated code to be ignored. */
196 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
197 tree
*argarray
, int nargs
)
199 gfc_actual_arglist
*actual
;
201 gfc_intrinsic_arg
*formal
;
205 formal
= expr
->value
.function
.isym
->formal
;
206 actual
= expr
->value
.function
.actual
;
208 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
209 actual
= actual
->next
,
210 formal
= formal
? formal
->next
: NULL
)
214 /* Skip omitted optional arguments. */
221 /* Evaluate the parameter. This will substitute scalarized
222 references automatically. */
223 gfc_init_se (&argse
, se
);
225 if (e
->ts
.type
== BT_CHARACTER
)
227 gfc_conv_expr (&argse
, e
);
228 gfc_conv_string_parameter (&argse
);
229 argarray
[curr_arg
++] = argse
.string_length
;
230 gcc_assert (curr_arg
< nargs
);
233 gfc_conv_expr_val (&argse
, e
);
235 /* If an optional argument is itself an optional dummy argument,
236 check its presence and substitute a null if absent. */
237 if (e
->expr_type
== EXPR_VARIABLE
238 && e
->symtree
->n
.sym
->attr
.optional
241 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
243 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
244 gfc_add_block_to_block (&se
->post
, &argse
.post
);
245 argarray
[curr_arg
] = argse
.expr
;
249 /* Count the number of actual arguments to the intrinsic function EXPR
250 including any "hidden" string length arguments. */
253 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
256 gfc_actual_arglist
*actual
;
258 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
263 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
273 /* Conversions between different types are output by the frontend as
274 intrinsic functions. We implement these directly with inline code. */
277 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
283 nargs
= gfc_intrinsic_argument_list_length (expr
);
284 args
= XALLOCAVEC (tree
, nargs
);
286 /* Evaluate all the arguments passed. Whilst we're only interested in the
287 first one here, there are other parts of the front-end that assume this
288 and will trigger an ICE if it's not the case. */
289 type
= gfc_typenode_for_spec (&expr
->ts
);
290 gcc_assert (expr
->value
.function
.actual
->expr
);
291 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
293 /* Conversion between character kinds involves a call to a library
295 if (expr
->ts
.type
== BT_CHARACTER
)
297 tree fndecl
, var
, addr
, tmp
;
299 if (expr
->ts
.kind
== 1
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
301 fndecl
= gfor_fndecl_convert_char4_to_char1
;
302 else if (expr
->ts
.kind
== 4
303 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
304 fndecl
= gfor_fndecl_convert_char1_to_char4
;
308 /* Create the variable storing the converted value. */
309 type
= gfc_get_pchar_type (expr
->ts
.kind
);
310 var
= gfc_create_var (type
, "str");
311 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
313 /* Call the library function that will perform the conversion. */
314 gcc_assert (nargs
>= 2);
315 tmp
= build_call_expr_loc (input_location
,
316 fndecl
, 3, addr
, args
[0], args
[1]);
317 gfc_add_expr_to_block (&se
->pre
, tmp
);
319 /* Free the temporary afterwards. */
320 tmp
= gfc_call_free (var
);
321 gfc_add_expr_to_block (&se
->post
, tmp
);
324 se
->string_length
= args
[0];
329 /* Conversion from complex to non-complex involves taking the real
330 component of the value. */
331 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
332 && expr
->ts
.type
!= BT_COMPLEX
)
336 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
337 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
341 se
->expr
= convert (type
, args
[0]);
344 /* This is needed because the gcc backend only implements
345 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
346 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
347 Similarly for CEILING. */
350 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
357 argtype
= TREE_TYPE (arg
);
358 arg
= gfc_evaluate_now (arg
, pblock
);
360 intval
= convert (type
, arg
);
361 intval
= gfc_evaluate_now (intval
, pblock
);
363 tmp
= convert (argtype
, intval
);
364 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
365 logical_type_node
, tmp
, arg
);
367 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
368 intval
, build_int_cst (type
, 1));
369 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
374 /* Round to nearest integer, away from zero. */
377 build_round_expr (tree arg
, tree restype
)
381 int argprec
, resprec
;
383 argtype
= TREE_TYPE (arg
);
384 argprec
= TYPE_PRECISION (argtype
);
385 resprec
= TYPE_PRECISION (restype
);
387 /* Depending on the type of the result, choose the int intrinsic
388 (iround, available only as a builtin, therefore cannot use it for
389 __float128), long int intrinsic (lround family) or long long
390 intrinsic (llround). We might also need to convert the result
392 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
393 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
394 else if (resprec
<= LONG_TYPE_SIZE
)
395 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
396 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
397 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
398 else if (resprec
>= argprec
&& resprec
== 128)
400 /* Search for a real kind suitable as temporary for conversion. */
402 for (int i
= 0; kind
< 0 && gfc_real_kinds
[i
].kind
!= 0; i
++)
403 if (gfc_real_kinds
[i
].mode_precision
>= resprec
)
404 kind
= gfc_real_kinds
[i
].kind
;
406 gfc_internal_error ("Could not find real kind with at least %d bits",
408 arg
= fold_convert (gfc_float128_type_node
, arg
);
409 fn
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
414 return convert (restype
, build_call_expr_loc (input_location
,
419 /* Convert a real to an integer using a specific rounding mode.
420 Ideally we would just build the corresponding GENERIC node,
421 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
424 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
425 enum rounding_mode op
)
430 return build_fixbound_expr (pblock
, arg
, type
, 0);
433 return build_fixbound_expr (pblock
, arg
, type
, 1);
436 return build_round_expr (arg
, type
);
439 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
447 /* Round a real value using the specified rounding mode.
448 We use a temporary integer of that same kind size as the result.
449 Values larger than those that can be represented by this kind are
450 unchanged, as they will not be accurate enough to represent the
452 huge = HUGE (KIND (a))
453 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
457 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
469 kind
= expr
->ts
.kind
;
470 nargs
= gfc_intrinsic_argument_list_length (expr
);
473 /* We have builtin functions for some cases. */
477 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
481 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
488 /* Evaluate the argument. */
489 gcc_assert (expr
->value
.function
.actual
->expr
);
490 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
492 /* Use a builtin function if one exists. */
493 if (decl
!= NULL_TREE
)
495 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
499 /* This code is probably redundant, but we'll keep it lying around just
501 type
= gfc_typenode_for_spec (&expr
->ts
);
502 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
504 /* Test if the value is too large to handle sensibly. */
505 gfc_set_model_kind (kind
);
507 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
508 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
509 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
510 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, arg
[0],
513 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
514 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
515 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, arg
[0],
517 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, logical_type_node
,
519 itype
= gfc_get_int_type (kind
);
521 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
522 tmp
= convert (type
, tmp
);
523 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
529 /* Convert to an integer using the specified rounding mode. */
532 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
538 nargs
= gfc_intrinsic_argument_list_length (expr
);
539 args
= XALLOCAVEC (tree
, nargs
);
541 /* Evaluate the argument, we process all arguments even though we only
542 use the first one for code generation purposes. */
543 type
= gfc_typenode_for_spec (&expr
->ts
);
544 gcc_assert (expr
->value
.function
.actual
->expr
);
545 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
547 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
549 /* Conversion to a different integer kind. */
550 se
->expr
= convert (type
, args
[0]);
554 /* Conversion from complex to non-complex involves taking the real
555 component of the value. */
556 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
557 && expr
->ts
.type
!= BT_COMPLEX
)
561 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
562 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
566 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
571 /* Get the imaginary component of a value. */
574 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
578 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
579 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
580 TREE_TYPE (TREE_TYPE (arg
)), arg
);
584 /* Get the complex conjugate of a value. */
587 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
591 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
592 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
598 define_quad_builtin (const char *name
, tree type
, bool is_const
)
601 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
604 /* Mark the decl as external. */
605 DECL_EXTERNAL (fndecl
) = 1;
606 TREE_PUBLIC (fndecl
) = 1;
608 /* Mark it __attribute__((const)). */
609 TREE_READONLY (fndecl
) = is_const
;
611 rest_of_decl_compilation (fndecl
, 1, 0);
616 /* Add SIMD attribute for FNDECL built-in if the built-in
617 name is in VECTORIZED_BUILTINS. */
620 add_simd_flag_for_built_in (tree fndecl
)
622 if (gfc_vectorized_builtins
== NULL
623 || fndecl
== NULL_TREE
)
626 const char *name
= IDENTIFIER_POINTER (DECL_NAME (fndecl
));
627 int *clauses
= gfc_vectorized_builtins
->get (name
);
630 for (unsigned i
= 0; i
< 3; i
++)
631 if (*clauses
& (1 << i
))
633 gfc_simd_clause simd_type
= (gfc_simd_clause
)*clauses
;
634 tree omp_clause
= NULL_TREE
;
635 if (simd_type
== SIMD_NONE
)
636 ; /* No SIMD clause. */
640 = (simd_type
== SIMD_INBRANCH
641 ? OMP_CLAUSE_INBRANCH
: OMP_CLAUSE_NOTINBRANCH
);
642 omp_clause
= build_omp_clause (UNKNOWN_LOCATION
, code
);
643 omp_clause
= build_tree_list (NULL_TREE
, omp_clause
);
646 DECL_ATTRIBUTES (fndecl
)
647 = tree_cons (get_identifier ("omp declare simd"), omp_clause
,
648 DECL_ATTRIBUTES (fndecl
));
653 /* Set SIMD attribute to all built-in functions that are mentioned
654 in gfc_vectorized_builtins vector. */
657 gfc_adjust_builtins (void)
659 gfc_intrinsic_map_t
*m
;
660 for (m
= gfc_intrinsic_map
;
661 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
663 add_simd_flag_for_built_in (m
->real4_decl
);
664 add_simd_flag_for_built_in (m
->complex4_decl
);
665 add_simd_flag_for_built_in (m
->real8_decl
);
666 add_simd_flag_for_built_in (m
->complex8_decl
);
667 add_simd_flag_for_built_in (m
->real10_decl
);
668 add_simd_flag_for_built_in (m
->complex10_decl
);
669 add_simd_flag_for_built_in (m
->real16_decl
);
670 add_simd_flag_for_built_in (m
->complex16_decl
);
671 add_simd_flag_for_built_in (m
->real16_decl
);
672 add_simd_flag_for_built_in (m
->complex16_decl
);
675 /* Release all strings. */
676 if (gfc_vectorized_builtins
!= NULL
)
678 for (hash_map
<nofree_string_hash
, int>::iterator it
679 = gfc_vectorized_builtins
->begin ();
680 it
!= gfc_vectorized_builtins
->end (); ++it
)
681 free (CONST_CAST (char *, (*it
).first
));
683 delete gfc_vectorized_builtins
;
684 gfc_vectorized_builtins
= NULL
;
688 /* Initialize function decls for library functions. The external functions
689 are created as required. Builtin functions are added here. */
692 gfc_build_intrinsic_lib_fndecls (void)
694 gfc_intrinsic_map_t
*m
;
695 tree quad_decls
[END_BUILTINS
+ 1];
697 if (gfc_real16_is_float128
)
699 /* If we have soft-float types, we create the decls for their
700 C99-like library functions. For now, we only handle __float128
701 q-suffixed functions. */
703 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
704 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
706 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
708 type
= gfc_float128_type_node
;
709 complex_type
= gfc_complex_float128_type_node
;
710 /* type (*) (type) */
711 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
713 func_iround
= build_function_type_list (integer_type_node
,
715 /* long (*) (type) */
716 func_lround
= build_function_type_list (long_integer_type_node
,
718 /* long long (*) (type) */
719 func_llround
= build_function_type_list (long_long_integer_type_node
,
721 /* type (*) (type, type) */
722 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
723 /* type (*) (type, &int) */
725 = build_function_type_list (type
,
727 build_pointer_type (integer_type_node
),
729 /* type (*) (type, int) */
730 func_scalbn
= build_function_type_list (type
,
731 type
, integer_type_node
, NULL_TREE
);
732 /* type (*) (complex type) */
733 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
734 /* complex type (*) (complex type, complex type) */
736 = build_function_type_list (complex_type
,
737 complex_type
, complex_type
, NULL_TREE
);
739 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
740 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
741 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
743 /* Only these built-ins are actually needed here. These are used directly
744 from the code, when calling builtin_decl_for_precision() or
745 builtin_decl_for_float_type(). The others are all constructed by
746 gfc_get_intrinsic_lib_fndecl(). */
747 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
748 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
750 #include "mathbuiltins.def"
754 #undef DEFINE_MATH_BUILTIN
755 #undef DEFINE_MATH_BUILTIN_C
757 /* There is one built-in we defined manually, because it gets called
758 with builtin_decl_for_precision() or builtin_decl_for_float_type()
759 even though it is not an OTHER_BUILTIN: it is SQRT. */
760 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
764 /* Add GCC builtin functions. */
765 for (m
= gfc_intrinsic_map
;
766 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
768 if (m
->float_built_in
!= END_BUILTINS
)
769 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
770 if (m
->complex_float_built_in
!= END_BUILTINS
)
771 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
772 if (m
->double_built_in
!= END_BUILTINS
)
773 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
774 if (m
->complex_double_built_in
!= END_BUILTINS
)
775 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
777 /* If real(kind=10) exists, it is always long double. */
778 if (m
->long_double_built_in
!= END_BUILTINS
)
779 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
780 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
782 = builtin_decl_explicit (m
->complex_long_double_built_in
);
784 if (!gfc_real16_is_float128
)
786 if (m
->long_double_built_in
!= END_BUILTINS
)
787 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
788 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
790 = builtin_decl_explicit (m
->complex_long_double_built_in
);
792 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
794 /* Quad-precision function calls are constructed when first
795 needed by builtin_decl_for_precision(), except for those
796 that will be used directly (define by OTHER_BUILTIN). */
797 m
->real16_decl
= quad_decls
[m
->double_built_in
];
799 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
801 /* Same thing for the complex ones. */
802 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
808 /* Create a fndecl for a simple intrinsic library function. */
811 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
814 vec
<tree
, va_gc
> *argtypes
;
816 gfc_actual_arglist
*actual
;
819 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
822 if (ts
->type
== BT_REAL
)
827 pdecl
= &m
->real4_decl
;
830 pdecl
= &m
->real8_decl
;
833 pdecl
= &m
->real10_decl
;
836 pdecl
= &m
->real16_decl
;
842 else if (ts
->type
== BT_COMPLEX
)
844 gcc_assert (m
->complex_available
);
849 pdecl
= &m
->complex4_decl
;
852 pdecl
= &m
->complex8_decl
;
855 pdecl
= &m
->complex10_decl
;
858 pdecl
= &m
->complex16_decl
;
872 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
873 if (gfc_real_kinds
[n
].c_float
)
874 snprintf (name
, sizeof (name
), "%s%s%s",
875 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
876 else if (gfc_real_kinds
[n
].c_double
)
877 snprintf (name
, sizeof (name
), "%s%s",
878 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
879 else if (gfc_real_kinds
[n
].c_long_double
)
880 snprintf (name
, sizeof (name
), "%s%s%s",
881 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
882 else if (gfc_real_kinds
[n
].c_float128
)
883 snprintf (name
, sizeof (name
), "%s%s%s",
884 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
890 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
891 ts
->type
== BT_COMPLEX
? 'c' : 'r',
896 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
898 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
899 vec_safe_push (argtypes
, type
);
901 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
902 fndecl
= build_decl (input_location
,
903 FUNCTION_DECL
, get_identifier (name
), type
);
905 /* Mark the decl as external. */
906 DECL_EXTERNAL (fndecl
) = 1;
907 TREE_PUBLIC (fndecl
) = 1;
909 /* Mark it __attribute__((const)), if possible. */
910 TREE_READONLY (fndecl
) = m
->is_constant
;
912 rest_of_decl_compilation (fndecl
, 1, 0);
919 /* Convert an intrinsic function into an external or builtin call. */
922 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
924 gfc_intrinsic_map_t
*m
;
928 unsigned int num_args
;
931 id
= expr
->value
.function
.isym
->id
;
932 /* Find the entry for this function. */
933 for (m
= gfc_intrinsic_map
;
934 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
940 if (m
->id
== GFC_ISYM_NONE
)
942 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
943 expr
->value
.function
.name
, id
);
946 /* Get the decl and generate the call. */
947 num_args
= gfc_intrinsic_argument_list_length (expr
);
948 args
= XALLOCAVEC (tree
, num_args
);
950 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
951 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
952 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
954 fndecl
= build_addr (fndecl
);
955 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
959 /* If bounds-checking is enabled, create code to verify at runtime that the
960 string lengths for both expressions are the same (needed for e.g. MERGE).
961 If bounds-checking is not enabled, does nothing. */
964 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
965 tree a
, tree b
, stmtblock_t
* target
)
970 /* If bounds-checking is disabled, do nothing. */
971 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
974 /* Compare the two string lengths. */
975 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, a
, b
);
977 /* Output the runtime-check. */
978 name
= gfc_build_cstring_const (intr_name
);
979 name
= gfc_build_addr_expr (pchar_type_node
, name
);
980 gfc_trans_runtime_check (true, false, cond
, target
, where
,
981 "Unequal character lengths (%ld/%ld) in %s",
982 fold_convert (long_integer_type_node
, a
),
983 fold_convert (long_integer_type_node
, b
), name
);
987 /* The EXPONENT(X) intrinsic function is translated into
989 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
990 so that if X is a NaN or infinity, the result is HUGE(0).
994 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
996 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
999 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
1000 expr
->value
.function
.actual
->expr
->ts
.kind
);
1002 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1003 arg
= gfc_evaluate_now (arg
, &se
->pre
);
1005 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
1006 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
1007 cond
= build_call_expr_loc (input_location
,
1008 builtin_decl_explicit (BUILT_IN_ISFINITE
),
1011 res
= gfc_create_var (integer_type_node
, NULL
);
1012 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
1013 gfc_build_addr_expr (NULL_TREE
, res
));
1014 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
1016 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
1019 type
= gfc_typenode_for_spec (&expr
->ts
);
1020 se
->expr
= fold_convert (type
, se
->expr
);
1024 /* Fill in the following structure
1025 struct caf_vector_t {
1026 size_t nvec; // size of the vector
1033 ptrdiff_t lower_bound;
1034 ptrdiff_t upper_bound;
1041 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
1042 tree lower
, tree upper
, tree stride
,
1043 tree vector
, int kind
, tree nvec
)
1045 tree field
, type
, tmp
;
1047 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
1048 type
= TREE_TYPE (desc
);
1050 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1051 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1052 desc
, field
, NULL_TREE
);
1053 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
1056 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1057 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1058 desc
, field
, NULL_TREE
);
1059 type
= TREE_TYPE (desc
);
1061 /* Access the inner struct. */
1062 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
1063 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1064 desc
, field
, NULL_TREE
);
1065 type
= TREE_TYPE (desc
);
1067 if (vector
!= NULL_TREE
)
1069 /* Set vector and kind. */
1070 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1071 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1072 desc
, field
, NULL_TREE
);
1073 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
1074 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1075 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1076 desc
, field
, NULL_TREE
);
1077 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
1081 /* Set dim.lower/upper/stride. */
1082 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1083 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1084 desc
, field
, NULL_TREE
);
1085 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1087 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1088 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1089 desc
, field
, NULL_TREE
);
1090 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1092 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1093 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1094 desc
, field
, NULL_TREE
);
1095 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1101 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1104 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1105 tree lbound
, ubound
, tmp
;
1108 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1110 for (i
= 0; i
< ar
->dimen
; i
++)
1111 switch (ar
->dimen_type
[i
])
1116 gfc_init_se (&argse
, NULL
);
1117 gfc_conv_expr (&argse
, ar
->end
[i
]);
1118 gfc_add_block_to_block (block
, &argse
.pre
);
1119 upper
= gfc_evaluate_now (argse
.expr
, block
);
1122 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1125 gfc_init_se (&argse
, NULL
);
1126 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1127 gfc_add_block_to_block (block
, &argse
.pre
);
1128 stride
= gfc_evaluate_now (argse
.expr
, block
);
1131 stride
= gfc_index_one_node
;
1137 gfc_init_se (&argse
, NULL
);
1138 gfc_conv_expr (&argse
, ar
->start
[i
]);
1139 gfc_add_block_to_block (block
, &argse
.pre
);
1140 lower
= gfc_evaluate_now (argse
.expr
, block
);
1143 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1144 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1147 stride
= gfc_index_one_node
;
1150 nvec
= size_zero_node
;
1151 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1156 gfc_init_se (&argse
, NULL
);
1157 argse
.descriptor_only
= 1;
1158 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1159 gfc_add_block_to_block (block
, &argse
.pre
);
1160 vector
= argse
.expr
;
1161 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1162 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1163 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1164 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1165 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1166 TREE_TYPE (nvec
), nvec
, tmp
);
1167 lower
= gfc_index_zero_node
;
1168 upper
= gfc_index_zero_node
;
1169 stride
= gfc_index_zero_node
;
1170 vector
= gfc_conv_descriptor_data_get (vector
);
1171 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1172 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1177 return gfc_build_addr_expr (NULL_TREE
, var
);
1182 compute_component_offset (tree field
, tree type
)
1185 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1186 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1188 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1189 DECL_FIELD_BIT_OFFSET (field
),
1191 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1194 return DECL_FIELD_OFFSET (field
);
1199 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1201 gfc_ref
*ref
= expr
->ref
, *last_comp_ref
;
1202 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1203 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1204 start
, end
, stride
, vector
, nvec
;
1206 bool ref_static_array
= false;
1207 tree last_component_ref_tree
= NULL_TREE
;
1212 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1213 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
1214 && !expr
->symtree
->n
.sym
->attr
.pointer
;
1217 /* Prevent uninit-warning. */
1218 reference_type
= NULL_TREE
;
1220 /* Skip refs upto the first coarray-ref. */
1221 last_comp_ref
= NULL
;
1222 while (ref
&& (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
== 0))
1224 /* Remember the type of components skipped. */
1225 if (ref
->type
== REF_COMPONENT
)
1226 last_comp_ref
= ref
;
1229 /* When a component was skipped, get the type information of the last
1230 component ref, else get the type from the symbol. */
1233 last_type
= gfc_typenode_for_spec (&last_comp_ref
->u
.c
.component
->ts
);
1234 last_type_n
= last_comp_ref
->u
.c
.component
->ts
.type
;
1238 last_type
= gfc_typenode_for_spec (&expr
->symtree
->n
.sym
->ts
);
1239 last_type_n
= expr
->symtree
->n
.sym
->ts
.type
;
1244 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0
1245 && ref
->u
.ar
.dimen
== 0)
1247 /* Skip pure coindexes. */
1251 tmp
= gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1252 reference_type
= TREE_TYPE (tmp
);
1254 if (caf_ref
== NULL_TREE
)
1257 /* Construct the chain of refs. */
1258 if (prev_caf_ref
!= NULL_TREE
)
1260 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1261 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1262 TREE_TYPE (field
), prev_caf_ref
, field
,
1264 gfc_add_modify (block
, tmp2
, gfc_build_addr_expr (TREE_TYPE (field
),
1272 last_type
= gfc_typenode_for_spec (&ref
->u
.c
.component
->ts
);
1273 last_type_n
= ref
->u
.c
.component
->ts
.type
;
1274 /* Set the type of the ref. */
1275 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1276 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1277 TREE_TYPE (field
), prev_caf_ref
, field
,
1279 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1280 GFC_CAF_REF_COMPONENT
));
1282 /* Ref the c in union u. */
1283 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1284 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1285 TREE_TYPE (field
), prev_caf_ref
, field
,
1287 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 0);
1288 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1289 TREE_TYPE (field
), tmp
, field
,
1292 /* Set the offset. */
1293 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1294 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1295 TREE_TYPE (field
), inner_struct
, field
,
1297 /* Computing the offset is somewhat harder. The bit_offset has to be
1298 taken into account. When the bit_offset in the field_decl is non-
1299 null, divide it by the bitsize_unit and add it to the regular
1301 tmp2
= compute_component_offset (ref
->u
.c
.component
->backend_decl
,
1303 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1305 /* Set caf_token_offset. */
1306 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 1);
1307 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1308 TREE_TYPE (field
), inner_struct
, field
,
1310 if ((ref
->u
.c
.component
->attr
.allocatable
1311 || ref
->u
.c
.component
->attr
.pointer
)
1312 && ref
->u
.c
.component
->attr
.dimension
)
1314 tree arr_desc_token_offset
;
1315 /* Get the token field from the descriptor. */
1316 arr_desc_token_offset
= TREE_OPERAND (
1317 gfc_conv_descriptor_token (ref
->u
.c
.component
->backend_decl
), 1);
1318 arr_desc_token_offset
1319 = compute_component_offset (arr_desc_token_offset
,
1321 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
,
1322 TREE_TYPE (tmp2
), tmp2
,
1323 arr_desc_token_offset
);
1325 else if (ref
->u
.c
.component
->caf_token
)
1326 tmp2
= compute_component_offset (ref
->u
.c
.component
->caf_token
,
1329 tmp2
= integer_zero_node
;
1330 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1332 /* Remember whether this ref was to a non-allocatable/non-pointer
1333 component so the next array ref can be tailored correctly. */
1334 ref_static_array
= !ref
->u
.c
.component
->attr
.allocatable
1335 && !ref
->u
.c
.component
->attr
.pointer
;
1336 last_component_ref_tree
= ref_static_array
1337 ? ref
->u
.c
.component
->backend_decl
: NULL_TREE
;
1340 if (ref_static_array
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
)
1341 ref_static_array
= false;
1342 /* Set the type of the ref. */
1343 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1344 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1345 TREE_TYPE (field
), prev_caf_ref
, field
,
1347 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1349 ? GFC_CAF_REF_STATIC_ARRAY
1350 : GFC_CAF_REF_ARRAY
));
1352 /* Ref the a in union u. */
1353 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1354 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1355 TREE_TYPE (field
), prev_caf_ref
, field
,
1357 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 1);
1358 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1359 TREE_TYPE (field
), tmp
, field
,
1362 /* Set the static_array_type in a for static arrays. */
1363 if (ref_static_array
)
1365 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)),
1367 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1368 TREE_TYPE (field
), inner_struct
, field
,
1370 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (tmp
),
1373 /* Ref the mode in the inner_struct. */
1374 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1375 mode
= fold_build3_loc (input_location
, COMPONENT_REF
,
1376 TREE_TYPE (field
), inner_struct
, field
,
1378 /* Ref the dim in the inner_struct. */
1379 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 2);
1380 dim_array
= fold_build3_loc (input_location
, COMPONENT_REF
,
1381 TREE_TYPE (field
), inner_struct
, field
,
1383 for (i
= 0; i
< ref
->u
.ar
.dimen
; ++i
)
1386 dim
= gfc_build_array_ref (dim_array
, gfc_rank_cst
[i
], NULL_TREE
);
1387 dim_type
= TREE_TYPE (dim
);
1388 mode_rhs
= start
= end
= stride
= NULL_TREE
;
1389 switch (ref
->u
.ar
.dimen_type
[i
])
1392 if (ref
->u
.ar
.end
[i
])
1394 gfc_init_se (&se
, NULL
);
1395 gfc_conv_expr (&se
, ref
->u
.ar
.end
[i
]);
1396 gfc_add_block_to_block (block
, &se
.pre
);
1397 if (ref_static_array
)
1399 /* Make the index zero-based, when reffing a static
1402 gfc_init_se (&se
, NULL
);
1403 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1404 gfc_add_block_to_block (block
, &se
.pre
);
1405 se
.expr
= fold_build2 (MINUS_EXPR
,
1406 gfc_array_index_type
,
1408 gfc_array_index_type
,
1411 end
= gfc_evaluate_now (fold_convert (
1412 gfc_array_index_type
,
1416 else if (ref_static_array
)
1417 end
= fold_build2 (MINUS_EXPR
,
1418 gfc_array_index_type
,
1419 gfc_conv_array_ubound (
1420 last_component_ref_tree
, i
),
1421 gfc_conv_array_lbound (
1422 last_component_ref_tree
, i
));
1426 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1427 GFC_CAF_ARR_REF_OPEN_END
);
1429 if (ref
->u
.ar
.stride
[i
])
1431 gfc_init_se (&se
, NULL
);
1432 gfc_conv_expr (&se
, ref
->u
.ar
.stride
[i
]);
1433 gfc_add_block_to_block (block
, &se
.pre
);
1434 stride
= gfc_evaluate_now (fold_convert (
1435 gfc_array_index_type
,
1438 if (ref_static_array
)
1440 /* Make the index zero-based, when reffing a static
1442 stride
= fold_build2 (MULT_EXPR
,
1443 gfc_array_index_type
,
1444 gfc_conv_array_stride (
1445 last_component_ref_tree
,
1448 gcc_assert (end
!= NULL_TREE
);
1449 /* Multiply with the product of array's stride and
1450 the step of the ref to a virtual upper bound.
1451 We cannot compute the actual upper bound here or
1452 the caflib would compute the extend
1454 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1455 end
, gfc_conv_array_stride (
1456 last_component_ref_tree
,
1458 end
= gfc_evaluate_now (end
, block
);
1459 stride
= gfc_evaluate_now (stride
, block
);
1462 else if (ref_static_array
)
1464 stride
= gfc_conv_array_stride (last_component_ref_tree
,
1466 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1468 end
= gfc_evaluate_now (end
, block
);
1471 /* Always set a ref stride of one to make caflib's
1473 stride
= gfc_index_one_node
;
1477 if (ref
->u
.ar
.start
[i
])
1479 gfc_init_se (&se
, NULL
);
1480 gfc_conv_expr (&se
, ref
->u
.ar
.start
[i
]);
1481 gfc_add_block_to_block (block
, &se
.pre
);
1482 if (ref_static_array
)
1484 /* Make the index zero-based, when reffing a static
1486 start
= fold_convert (gfc_array_index_type
, se
.expr
);
1487 gfc_init_se (&se
, NULL
);
1488 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1489 gfc_add_block_to_block (block
, &se
.pre
);
1490 se
.expr
= fold_build2 (MINUS_EXPR
,
1491 gfc_array_index_type
,
1492 start
, fold_convert (
1493 gfc_array_index_type
,
1495 /* Multiply with the stride. */
1496 se
.expr
= fold_build2 (MULT_EXPR
,
1497 gfc_array_index_type
,
1499 gfc_conv_array_stride (
1500 last_component_ref_tree
,
1503 start
= gfc_evaluate_now (fold_convert (
1504 gfc_array_index_type
,
1507 if (mode_rhs
== NULL_TREE
)
1508 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1509 ref
->u
.ar
.dimen_type
[i
]
1511 ? GFC_CAF_ARR_REF_SINGLE
1512 : GFC_CAF_ARR_REF_RANGE
);
1514 else if (ref_static_array
)
1516 start
= integer_zero_node
;
1517 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1518 ref
->u
.ar
.start
[i
] == NULL
1519 ? GFC_CAF_ARR_REF_FULL
1520 : GFC_CAF_ARR_REF_RANGE
);
1522 else if (end
== NULL_TREE
)
1523 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1524 GFC_CAF_ARR_REF_FULL
);
1526 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1527 GFC_CAF_ARR_REF_OPEN_START
);
1529 /* Ref the s in dim. */
1530 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 0);
1531 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1532 TREE_TYPE (field
), dim
, field
,
1535 /* Set start in s. */
1536 if (start
!= NULL_TREE
)
1538 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1540 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1541 TREE_TYPE (field
), tmp
, field
,
1543 gfc_add_modify (block
, tmp2
,
1544 fold_convert (TREE_TYPE (tmp2
), start
));
1548 if (end
!= NULL_TREE
)
1550 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1552 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1553 TREE_TYPE (field
), tmp
, field
,
1555 gfc_add_modify (block
, tmp2
,
1556 fold_convert (TREE_TYPE (tmp2
), end
));
1560 if (stride
!= NULL_TREE
)
1562 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1564 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1565 TREE_TYPE (field
), tmp
, field
,
1567 gfc_add_modify (block
, tmp2
,
1568 fold_convert (TREE_TYPE (tmp2
), stride
));
1572 /* TODO: In case of static array. */
1573 gcc_assert (!ref_static_array
);
1574 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1575 GFC_CAF_ARR_REF_VECTOR
);
1576 gfc_init_se (&se
, NULL
);
1577 se
.descriptor_only
= 1;
1578 gfc_conv_expr_descriptor (&se
, ref
->u
.ar
.start
[i
]);
1579 gfc_add_block_to_block (block
, &se
.pre
);
1581 tmp
= gfc_conv_descriptor_lbound_get (vector
,
1583 tmp2
= gfc_conv_descriptor_ubound_get (vector
,
1585 nvec
= gfc_conv_array_extent_dim (tmp
, tmp2
, NULL
);
1586 tmp
= gfc_conv_descriptor_stride_get (vector
,
1588 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1589 TREE_TYPE (nvec
), nvec
, tmp
);
1590 vector
= gfc_conv_descriptor_data_get (vector
);
1592 /* Ref the v in dim. */
1593 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 1);
1594 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1595 TREE_TYPE (field
), dim
, field
,
1598 /* Set vector in v. */
1599 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 0);
1600 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1601 TREE_TYPE (field
), tmp
, field
,
1603 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1606 /* Set nvec in v. */
1607 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 1);
1608 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1609 TREE_TYPE (field
), tmp
, field
,
1611 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1614 /* Set kind in v. */
1615 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 2);
1616 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1617 TREE_TYPE (field
), tmp
, field
,
1619 gfc_add_modify (block
, tmp2
, build_int_cst (integer_type_node
,
1620 ref
->u
.ar
.start
[i
]->ts
.kind
));
1625 /* Set the mode for dim i. */
1626 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1627 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
),
1631 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1632 if (i
< GFC_MAX_DIMENSIONS
)
1634 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1635 gfc_add_modify (block
, tmp
,
1636 build_int_cst (unsigned_char_type_node
,
1637 GFC_CAF_ARR_REF_NONE
));
1644 /* Set the size of the current type. */
1645 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 2);
1646 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1647 prev_caf_ref
, field
, NULL_TREE
);
1648 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1649 TYPE_SIZE_UNIT (last_type
)));
1654 if (prev_caf_ref
!= NULL_TREE
)
1656 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1657 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1658 prev_caf_ref
, field
, NULL_TREE
);
1659 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1660 null_pointer_node
));
1662 return caf_ref
!= NULL_TREE
? gfc_build_addr_expr (NULL_TREE
, caf_ref
)
1666 /* Get data from a remote coarray. */
1669 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1670 tree may_require_tmp
, bool may_realloc
,
1671 symbol_attribute
*caf_attr
)
1673 gfc_expr
*array_expr
, *tmp_stat
;
1675 tree caf_decl
, token
, offset
, image_index
, tmp
;
1676 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
1678 symbol_attribute caf_attr_store
;
1680 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1682 if (se
->ss
&& se
->ss
->info
->useflags
)
1684 /* Access the previously obtained result. */
1685 gfc_conv_tmp_array_ref (se
);
1689 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1690 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1691 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1693 if (caf_attr
== NULL
)
1695 caf_attr_store
= gfc_caf_attr (array_expr
);
1696 caf_attr
= &caf_attr_store
;
1702 vec
= null_pointer_node
;
1703 tmp_stat
= gfc_find_stat_co (expr
);
1708 gfc_init_se (&stat_se
, NULL
);
1709 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1710 stat
= stat_se
.expr
;
1711 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1712 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1715 stat
= null_pointer_node
;
1717 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1718 is reallocatable or the right-hand side has allocatable components. */
1719 if (caf_attr
->alloc_comp
|| caf_attr
->pointer_comp
|| may_realloc
)
1721 /* Get using caf_get_by_ref. */
1722 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, array_expr
);
1724 if (caf_reference
!= NULL_TREE
)
1726 if (lhs
== NULL_TREE
)
1728 if (array_expr
->ts
.type
== BT_CHARACTER
)
1729 gfc_init_se (&argse
, NULL
);
1730 if (array_expr
->rank
== 0)
1732 symbol_attribute attr
;
1733 gfc_clear_attr (&attr
);
1734 if (array_expr
->ts
.type
== BT_CHARACTER
)
1736 res_var
= gfc_conv_string_tmp (se
,
1737 build_pointer_type (type
),
1738 array_expr
->ts
.u
.cl
->backend_decl
);
1739 argse
.string_length
= array_expr
->ts
.u
.cl
->backend_decl
;
1742 res_var
= gfc_create_var (type
, "caf_res");
1743 dst_var
= gfc_conv_scalar_to_descriptor (se
, res_var
, attr
);
1744 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1748 /* Create temporary. */
1749 if (array_expr
->ts
.type
== BT_CHARACTER
)
1750 gfc_conv_expr_descriptor (&argse
, array_expr
);
1751 may_realloc
= gfc_trans_create_temp_array (&se
->pre
,
1758 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1759 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1762 tmp
= gfc_conv_descriptor_data_get (res_var
);
1763 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
,
1764 NULL_TREE
, NULL_TREE
,
1767 GFC_CAF_COARRAY_NOCOARRAY
);
1768 gfc_add_expr_to_block (&se
->post
, tmp
);
1773 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1774 if (lhs_kind
== NULL_TREE
)
1777 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1778 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1779 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1780 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1782 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1785 /* No overlap possible as we have generated a temporary. */
1786 if (lhs
== NULL_TREE
)
1787 may_require_tmp
= boolean_false_node
;
1789 /* It guarantees memory consistency within the same segment. */
1790 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1791 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1792 gfc_build_string_const (1, ""), NULL_TREE
,
1793 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1795 ASM_VOLATILE_P (tmp
) = 1;
1796 gfc_add_expr_to_block (&se
->pre
, tmp
);
1798 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1799 10, token
, image_index
, dst_var
,
1800 caf_reference
, lhs_kind
, kind
,
1802 may_realloc
? boolean_true_node
:
1804 stat
, build_int_cst (integer_type_node
,
1805 array_expr
->ts
.type
));
1807 gfc_add_expr_to_block (&se
->pre
, tmp
);
1810 gfc_advance_se_ss_chain (se
);
1813 if (array_expr
->ts
.type
== BT_CHARACTER
)
1814 se
->string_length
= argse
.string_length
;
1820 gfc_init_se (&argse
, NULL
);
1821 if (array_expr
->rank
== 0)
1823 symbol_attribute attr
;
1825 gfc_clear_attr (&attr
);
1826 gfc_conv_expr (&argse
, array_expr
);
1828 if (lhs
== NULL_TREE
)
1830 gfc_clear_attr (&attr
);
1831 if (array_expr
->ts
.type
== BT_CHARACTER
)
1832 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1833 argse
.string_length
);
1835 res_var
= gfc_create_var (type
, "caf_res");
1836 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1837 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1839 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1840 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1844 /* If has_vector, pass descriptor for whole array and the
1845 vector bounds separately. */
1846 gfc_array_ref
*ar
, ar2
;
1847 bool has_vector
= false;
1849 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1852 ar
= gfc_find_array_ref (expr
);
1854 memset (ar
, '\0', sizeof (*ar
));
1858 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1859 gfc_conv_expr_descriptor (&argse
, array_expr
);
1860 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1861 has the wrong type if component references are done. */
1862 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1863 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1868 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1872 if (lhs
== NULL_TREE
)
1874 /* Create temporary. */
1875 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1876 if (se
->loop
->to
[n
] == NULL_TREE
)
1878 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1880 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1883 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1884 NULL_TREE
, false, true, false,
1885 &array_expr
->where
);
1886 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1887 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1889 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1892 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1893 if (lhs_kind
== NULL_TREE
)
1896 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1897 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1899 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1900 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1901 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1902 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1903 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1906 /* No overlap possible as we have generated a temporary. */
1907 if (lhs
== NULL_TREE
)
1908 may_require_tmp
= boolean_false_node
;
1910 /* It guarantees memory consistency within the same segment. */
1911 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1912 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1913 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1914 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1915 ASM_VOLATILE_P (tmp
) = 1;
1916 gfc_add_expr_to_block (&se
->pre
, tmp
);
1918 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1919 token
, offset
, image_index
, argse
.expr
, vec
,
1920 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1922 gfc_add_expr_to_block (&se
->pre
, tmp
);
1925 gfc_advance_se_ss_chain (se
);
1928 if (array_expr
->ts
.type
== BT_CHARACTER
)
1929 se
->string_length
= argse
.string_length
;
1933 /* Send data to a remote coarray. */
1936 conv_caf_send (gfc_code
*code
) {
1937 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
, *tmp_team
;
1938 gfc_se lhs_se
, rhs_se
;
1940 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1941 tree may_require_tmp
, src_stat
, dst_stat
, dst_team
;
1942 tree lhs_type
= NULL_TREE
;
1943 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1944 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1946 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1948 lhs_expr
= code
->ext
.actual
->expr
;
1949 rhs_expr
= code
->ext
.actual
->next
->expr
;
1950 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, true) == 0
1951 ? boolean_false_node
: boolean_true_node
;
1952 gfc_init_block (&block
);
1954 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1955 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1956 src_stat
= dst_stat
= null_pointer_node
;
1957 dst_team
= null_pointer_node
;
1960 gfc_init_se (&lhs_se
, NULL
);
1961 if (lhs_expr
->rank
== 0)
1963 if (lhs_expr
->ts
.type
== BT_CHARACTER
&& lhs_expr
->ts
.deferred
)
1965 lhs_se
.expr
= gfc_get_tree_for_caf_expr (lhs_expr
);
1966 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1970 symbol_attribute attr
;
1971 gfc_clear_attr (&attr
);
1972 gfc_conv_expr (&lhs_se
, lhs_expr
);
1973 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1974 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
,
1976 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1979 else if ((lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
1980 && lhs_caf_attr
.codimension
)
1982 lhs_se
.want_pointer
= 1;
1983 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1984 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1985 has the wrong type if component references are done. */
1986 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1987 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1988 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1989 gfc_get_dtype_rank_type (
1990 gfc_has_vector_subscript (lhs_expr
)
1991 ? gfc_find_array_ref (lhs_expr
)->dimen
1997 bool has_vector
= gfc_has_vector_subscript (lhs_expr
);
1999 if (gfc_is_coindexed (lhs_expr
) || !has_vector
)
2001 /* If has_vector, pass descriptor for whole array and the
2002 vector bounds separately. */
2003 gfc_array_ref
*ar
, ar2
;
2004 bool has_tmp_lhs_array
= false;
2007 has_tmp_lhs_array
= true;
2008 ar
= gfc_find_array_ref (lhs_expr
);
2010 memset (ar
, '\0', sizeof (*ar
));
2014 lhs_se
.want_pointer
= 1;
2015 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
2016 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
2017 that has the wrong type if component references are done. */
2018 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
2019 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
2020 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2021 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2024 if (has_tmp_lhs_array
)
2026 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
2032 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
2033 indexed array expression. This is rewritten to:
2035 tmp_array = arr2[...]
2036 arr1 ([...]) = tmp_array
2038 because using the standard gfc_conv_expr (lhs_expr) did the
2039 assignment with lhs and rhs exchanged. */
2041 gfc_ss
*lss_for_tmparray
, *lss_real
;
2045 tree tmparr_desc
, src
;
2046 tree index
= gfc_index_zero_node
;
2047 tree stride
= gfc_index_zero_node
;
2050 /* Walk both sides of the assignment, once to get the shape of the
2051 temporary array to create right. */
2052 lss_for_tmparray
= gfc_walk_expr (lhs_expr
);
2053 /* And a second time to be able to create an assignment of the
2054 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
2055 the tree in the descriptor with the one for the temporary
2057 lss_real
= gfc_walk_expr (lhs_expr
);
2058 gfc_init_loopinfo (&loop
);
2059 gfc_add_ss_to_loop (&loop
, lss_for_tmparray
);
2060 gfc_add_ss_to_loop (&loop
, lss_real
);
2061 gfc_conv_ss_startstride (&loop
);
2062 gfc_conv_loop_setup (&loop
, &lhs_expr
->where
);
2063 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
2064 gfc_trans_create_temp_array (&lhs_se
.pre
, &lhs_se
.post
,
2065 lss_for_tmparray
, lhs_type
, NULL_TREE
,
2068 tmparr_desc
= lss_for_tmparray
->info
->data
.array
.descriptor
;
2069 gfc_start_scalarized_body (&loop
, &body
);
2070 gfc_init_se (&se
, NULL
);
2071 gfc_copy_loopinfo_to_se (&se
, &loop
);
2073 gfc_conv_expr (&se
, lhs_expr
);
2074 gfc_add_block_to_block (&body
, &se
.pre
);
2076 /* Walk over all indexes of the loop. */
2077 for (n
= loop
.dimen
- 1; n
> 0; --n
)
2079 tmp
= loop
.loopvar
[n
];
2080 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2081 gfc_array_index_type
, tmp
, loop
.from
[n
]);
2082 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2083 gfc_array_index_type
, tmp
, index
);
2085 stride
= fold_build2_loc (input_location
, MINUS_EXPR
,
2086 gfc_array_index_type
,
2087 loop
.to
[n
- 1], loop
.from
[n
- 1]);
2088 stride
= fold_build2_loc (input_location
, PLUS_EXPR
,
2089 gfc_array_index_type
,
2090 stride
, gfc_index_one_node
);
2092 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2093 gfc_array_index_type
, tmp
, stride
);
2096 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2097 gfc_array_index_type
,
2098 index
, loop
.from
[0]);
2100 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2101 gfc_array_index_type
,
2102 loop
.loopvar
[0], index
);
2104 src
= build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc
));
2105 src
= gfc_build_array_ref (src
, index
, NULL
);
2106 /* Now create the assignment of lhs_expr = tmp_array. */
2107 gfc_add_modify (&body
, se
.expr
, src
);
2108 gfc_add_block_to_block (&body
, &se
.post
);
2109 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, tmparr_desc
);
2110 gfc_trans_scalarizing_loops (&loop
, &body
);
2111 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2112 gfc_add_expr_to_block (&lhs_se
.post
, gfc_finish_block (&loop
.pre
));
2113 gfc_free_ss (lss_for_tmparray
);
2114 gfc_free_ss (lss_real
);
2118 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
2120 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2121 temporary and a loop. */
2122 if (!gfc_is_coindexed (lhs_expr
)
2123 && (!lhs_caf_attr
.codimension
2124 || !(lhs_expr
->rank
> 0
2125 && (lhs_caf_attr
.allocatable
|| lhs_caf_attr
.pointer
))))
2127 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
2128 gcc_assert (gfc_is_coindexed (rhs_expr
));
2129 gfc_init_se (&rhs_se
, NULL
);
2130 if (lhs_expr
->rank
== 0 && lhs_caf_attr
.allocatable
)
2133 gfc_init_se (&scal_se
, NULL
);
2134 scal_se
.want_pointer
= 1;
2135 gfc_conv_expr (&scal_se
, lhs_expr
);
2136 /* Ensure scalar on lhs is allocated. */
2137 gfc_add_block_to_block (&block
, &scal_se
.pre
);
2139 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
2141 gfc_typenode_for_spec (&lhs_expr
->ts
)),
2143 tmp
= fold_build2 (EQ_EXPR
, logical_type_node
, scal_se
.expr
,
2145 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2146 tmp
, gfc_finish_block (&scal_se
.pre
),
2147 build_empty_stmt (input_location
));
2148 gfc_add_expr_to_block (&block
, tmp
);
2151 lhs_may_realloc
= lhs_may_realloc
2152 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
2153 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2154 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
2155 may_require_tmp
, lhs_may_realloc
,
2157 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2158 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2159 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2160 return gfc_finish_block (&block
);
2163 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2165 /* Obtain token, offset and image index for the LHS. */
2166 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
2167 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2168 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2169 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
2171 if (lhs_caf_attr
.alloc_comp
)
2172 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
2175 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
2180 gfc_init_se (&rhs_se
, NULL
);
2181 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
2182 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2183 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
2184 if (rhs_expr
->rank
== 0)
2186 symbol_attribute attr
;
2187 gfc_clear_attr (&attr
);
2188 gfc_conv_expr (&rhs_se
, rhs_expr
);
2189 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
2190 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2192 else if ((rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2193 && rhs_caf_attr
.codimension
)
2196 rhs_se
.want_pointer
= 1;
2197 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2198 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2199 has the wrong type if component references are done. */
2200 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2201 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2202 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2203 gfc_get_dtype_rank_type (
2204 gfc_has_vector_subscript (rhs_expr
)
2205 ? gfc_find_array_ref (rhs_expr
)->dimen
2211 /* If has_vector, pass descriptor for whole array and the
2212 vector bounds separately. */
2213 gfc_array_ref
*ar
, ar2
;
2214 bool has_vector
= false;
2217 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2220 ar
= gfc_find_array_ref (rhs_expr
);
2222 memset (ar
, '\0', sizeof (*ar
));
2226 rhs_se
.want_pointer
= 1;
2227 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2228 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2229 has the wrong type if component references are done. */
2230 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2231 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2232 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2233 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2238 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2243 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2245 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2247 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2252 gfc_init_se (&stat_se
, NULL
);
2253 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2254 dst_stat
= stat_se
.expr
;
2255 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2256 gfc_add_block_to_block (&block
, &stat_se
.post
);
2259 tmp_team
= gfc_find_team_co (lhs_expr
);
2264 gfc_init_se (&team_se
, NULL
);
2265 gfc_conv_expr_reference (&team_se
, tmp_team
);
2266 dst_team
= team_se
.expr
;
2267 gfc_add_block_to_block (&block
, &team_se
.pre
);
2268 gfc_add_block_to_block (&block
, &team_se
.post
);
2271 if (!gfc_is_coindexed (rhs_expr
))
2273 if (lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
2275 tree reference
, dst_realloc
;
2276 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2277 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2278 : boolean_false_node
;
2279 tmp
= build_call_expr_loc (input_location
,
2280 gfor_fndecl_caf_send_by_ref
,
2281 10, token
, image_index
, rhs_se
.expr
,
2282 reference
, lhs_kind
, rhs_kind
,
2283 may_require_tmp
, dst_realloc
, src_stat
,
2284 build_int_cst (integer_type_node
,
2285 lhs_expr
->ts
.type
));
2288 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 11,
2289 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2290 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2291 may_require_tmp
, src_stat
, dst_team
);
2295 tree rhs_token
, rhs_offset
, rhs_image_index
;
2297 /* It guarantees memory consistency within the same segment. */
2298 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2299 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2300 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2301 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2302 ASM_VOLATILE_P (tmp
) = 1;
2303 gfc_add_expr_to_block (&block
, tmp
);
2305 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2306 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2307 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2308 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2310 if (rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2312 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2317 gfc_init_se (&stat_se
, NULL
);
2318 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2319 src_stat
= stat_se
.expr
;
2320 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2321 gfc_add_block_to_block (&block
, &stat_se
.post
);
2324 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2326 tree lhs_reference
, rhs_reference
;
2327 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2328 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2329 tmp
= build_call_expr_loc (input_location
,
2330 gfor_fndecl_caf_sendget_by_ref
, 13,
2331 token
, image_index
, lhs_reference
,
2332 rhs_token
, rhs_image_index
, rhs_reference
,
2333 lhs_kind
, rhs_kind
, may_require_tmp
,
2335 build_int_cst (integer_type_node
,
2337 build_int_cst (integer_type_node
,
2338 rhs_expr
->ts
.type
));
2342 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2344 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2345 14, token
, offset
, image_index
,
2346 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2347 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2348 rhs_kind
, may_require_tmp
, src_stat
);
2351 gfc_add_expr_to_block (&block
, tmp
);
2352 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2353 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2355 /* It guarantees memory consistency within the same segment. */
2356 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2357 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2358 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2359 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2360 ASM_VOLATILE_P (tmp
) = 1;
2361 gfc_add_expr_to_block (&block
, tmp
);
2363 return gfc_finish_block (&block
);
2368 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2371 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2372 lbound
, ubound
, extent
, ml
;
2375 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2377 if (expr
->value
.function
.actual
->expr
2378 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2379 distance
= expr
->value
.function
.actual
->expr
;
2381 /* The case -fcoarray=single is handled elsewhere. */
2382 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2384 /* Argument-free version: THIS_IMAGE(). */
2385 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2389 gfc_init_se (&argse
, NULL
);
2390 gfc_conv_expr_val (&argse
, distance
);
2391 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2392 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2393 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2396 tmp
= integer_zero_node
;
2397 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2399 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2404 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2406 type
= gfc_get_int_type (gfc_default_integer_kind
);
2407 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2408 rank
= expr
->value
.function
.actual
->expr
->rank
;
2410 /* Obtain the descriptor of the COARRAY. */
2411 gfc_init_se (&argse
, NULL
);
2412 argse
.want_coarray
= 1;
2413 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2414 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2415 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2420 /* Create an implicit second parameter from the loop variable. */
2421 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2422 gcc_assert (corank
> 0);
2423 gcc_assert (se
->loop
->dimen
== 1);
2424 gcc_assert (se
->ss
->info
->expr
== expr
);
2426 dim_arg
= se
->loop
->loopvar
[0];
2427 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2428 gfc_array_index_type
, dim_arg
,
2429 build_int_cst (TREE_TYPE (dim_arg
), 1));
2430 gfc_advance_se_ss_chain (se
);
2434 /* Use the passed DIM= argument. */
2435 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2436 gfc_init_se (&argse
, NULL
);
2437 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2438 gfc_array_index_type
);
2439 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2440 dim_arg
= argse
.expr
;
2442 if (INTEGER_CST_P (dim_arg
))
2444 if (wi::ltu_p (wi::to_wide (dim_arg
), 1)
2445 || wi::gtu_p (wi::to_wide (dim_arg
),
2446 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2447 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2448 "dimension index", expr
->value
.function
.isym
->name
,
2451 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2453 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2454 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2456 build_int_cst (TREE_TYPE (dim_arg
), 1));
2457 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2458 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2460 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2461 logical_type_node
, cond
, tmp
);
2462 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2467 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2468 one always has a dim_arg argument.
2470 m = this_image() - 1
2473 sub(1) = m + lcobound(corank)
2477 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2480 extent = gfc_extent(i)
2488 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2489 : m + lcobound(corank)
2492 /* this_image () - 1. */
2493 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2495 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2496 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2499 /* sub(1) = m + lcobound(corank). */
2500 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2501 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2503 lbound
= fold_convert (type
, lbound
);
2504 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2510 m
= gfc_create_var (type
, NULL
);
2511 ml
= gfc_create_var (type
, NULL
);
2512 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2513 min_var
= gfc_create_var (integer_type_node
, NULL
);
2515 /* m = this_image () - 1. */
2516 gfc_add_modify (&se
->pre
, m
, tmp
);
2518 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2519 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2520 fold_convert (integer_type_node
, dim_arg
),
2521 build_int_cst (integer_type_node
, rank
- 1));
2522 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2523 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2525 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2528 tmp
= build_int_cst (integer_type_node
, rank
);
2529 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2531 exit_label
= gfc_build_label_decl (NULL_TREE
);
2532 TREE_USED (exit_label
) = 1;
2535 gfc_init_block (&loop
);
2538 gfc_add_modify (&loop
, ml
, m
);
2541 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2542 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2543 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2544 extent
= fold_convert (type
, extent
);
2547 gfc_add_modify (&loop
, m
,
2548 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2551 /* Exit condition: if (i >= min_var) goto exit_label. */
2552 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, loop_var
,
2554 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2555 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2556 build_empty_stmt (input_location
));
2557 gfc_add_expr_to_block (&loop
, tmp
);
2559 /* Increment loop variable: i++. */
2560 gfc_add_modify (&loop
, loop_var
,
2561 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2563 build_int_cst (integer_type_node
, 1)));
2565 /* Making the loop... actually loop! */
2566 tmp
= gfc_finish_block (&loop
);
2567 tmp
= build1_v (LOOP_EXPR
, tmp
);
2568 gfc_add_expr_to_block (&se
->pre
, tmp
);
2570 /* The exit label. */
2571 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2572 gfc_add_expr_to_block (&se
->pre
, tmp
);
2574 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2575 : m + lcobound(corank) */
2577 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, dim_arg
,
2578 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2580 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2581 fold_build2_loc (input_location
, PLUS_EXPR
,
2582 gfc_array_index_type
, dim_arg
,
2583 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2584 lbound
= fold_convert (type
, lbound
);
2586 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2587 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2589 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2591 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2592 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2597 /* Convert a call to image_status. */
2600 conv_intrinsic_image_status (gfc_se
*se
, gfc_expr
*expr
)
2602 unsigned int num_args
;
2605 num_args
= gfc_intrinsic_argument_list_length (expr
);
2606 args
= XALLOCAVEC (tree
, num_args
);
2607 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2608 /* In args[0] the number of the image the status is desired for has to be
2611 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2614 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2615 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2616 fold_convert (integer_type_node
, arg
),
2618 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2619 tmp
, integer_zero_node
,
2620 build_int_cst (integer_type_node
,
2621 GFC_STAT_STOPPED_IMAGE
));
2623 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2624 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_image_status
, 2,
2625 args
[0], build_int_cst (integer_type_node
, -1));
2633 conv_intrinsic_team_number (gfc_se
*se
, gfc_expr
*expr
)
2635 unsigned int num_args
;
2639 num_args
= gfc_intrinsic_argument_list_length (expr
);
2640 args
= XALLOCAVEC (tree
, num_args
);
2641 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2644 GFC_FCOARRAY_SINGLE
&& expr
->value
.function
.actual
->expr
)
2648 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2649 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2650 fold_convert (integer_type_node
, arg
),
2652 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2653 tmp
, integer_zero_node
,
2654 build_int_cst (integer_type_node
,
2655 GFC_STAT_STOPPED_IMAGE
));
2657 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2659 // the value -1 represents that no team has been created yet
2660 tmp
= build_int_cst (integer_type_node
, -1);
2662 else if (flag_coarray
== GFC_FCOARRAY_LIB
&& expr
->value
.function
.actual
->expr
)
2663 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2664 args
[0], build_int_cst (integer_type_node
, -1));
2665 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2666 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2667 integer_zero_node
, build_int_cst (integer_type_node
, -1));
2676 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2678 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2680 gfc_se argse
, subse
;
2681 int rank
, corank
, codim
;
2683 type
= gfc_get_int_type (gfc_default_integer_kind
);
2684 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2685 rank
= expr
->value
.function
.actual
->expr
->rank
;
2687 /* Obtain the descriptor of the COARRAY. */
2688 gfc_init_se (&argse
, NULL
);
2689 argse
.want_coarray
= 1;
2690 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2691 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2692 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2695 /* Obtain a handle to the SUB argument. */
2696 gfc_init_se (&subse
, NULL
);
2697 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2698 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2699 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2700 subdesc
= build_fold_indirect_ref_loc (input_location
,
2701 gfc_conv_descriptor_data_get (subse
.expr
));
2703 /* Fortran 2008 does not require that the values remain in the cobounds,
2704 thus we need explicitly check this - and return 0 if they are exceeded. */
2706 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2707 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2708 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2709 fold_convert (gfc_array_index_type
, tmp
),
2712 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2714 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2715 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2716 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2717 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2718 fold_convert (gfc_array_index_type
, tmp
),
2720 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2721 logical_type_node
, invalid_bound
, cond
);
2722 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2723 fold_convert (gfc_array_index_type
, tmp
),
2725 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2726 logical_type_node
, invalid_bound
, cond
);
2729 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2731 /* See Fortran 2008, C.10 for the following algorithm. */
2733 /* coindex = sub(corank) - lcobound(n). */
2734 coindex
= fold_convert (gfc_array_index_type
,
2735 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2737 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2738 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2739 fold_convert (gfc_array_index_type
, coindex
),
2742 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2744 tree extent
, ubound
;
2746 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2747 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2748 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2749 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2751 /* coindex *= extent. */
2752 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2753 gfc_array_index_type
, coindex
, extent
);
2755 /* coindex += sub(codim). */
2756 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2757 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2758 gfc_array_index_type
, coindex
,
2759 fold_convert (gfc_array_index_type
, tmp
));
2761 /* coindex -= lbound(codim). */
2762 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2763 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2764 gfc_array_index_type
, coindex
, lbound
);
2767 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2768 fold_convert(type
, coindex
),
2769 build_int_cst (type
, 1));
2771 /* Return 0 if "coindex" exceeds num_images(). */
2773 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2774 num_images
= build_int_cst (type
, 1);
2777 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2779 build_int_cst (integer_type_node
, -1));
2780 num_images
= fold_convert (type
, tmp
);
2783 tmp
= gfc_create_var (type
, NULL
);
2784 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2786 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, tmp
,
2788 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
2790 fold_convert (logical_type_node
, invalid_bound
));
2791 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2792 build_int_cst (type
, 0), tmp
);
2796 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2798 tree tmp
, distance
, failed
;
2801 if (expr
->value
.function
.actual
->expr
)
2803 gfc_init_se (&argse
, NULL
);
2804 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2805 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2806 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2807 distance
= fold_convert (integer_type_node
, argse
.expr
);
2810 distance
= integer_zero_node
;
2812 if (expr
->value
.function
.actual
->next
->expr
)
2814 gfc_init_se (&argse
, NULL
);
2815 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2816 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2817 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2818 failed
= fold_convert (integer_type_node
, argse
.expr
);
2821 failed
= build_int_cst (integer_type_node
, -1);
2822 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2824 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2829 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2833 gfc_init_se (&argse
, NULL
);
2834 argse
.data_not_needed
= 1;
2835 argse
.descriptor_only
= 1;
2837 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2838 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2839 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2841 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2842 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2848 gfc_conv_intrinsic_is_contiguous (gfc_se
* se
, gfc_expr
* expr
)
2851 arg
= expr
->value
.function
.actual
->expr
;
2852 gfc_conv_is_contiguous_expr (se
, arg
);
2853 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2856 /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2857 plus it can be called directly. */
2860 gfc_conv_is_contiguous_expr (gfc_se
*se
, gfc_expr
*arg
)
2864 tree desc
, tmp
, stride
, extent
, cond
;
2869 if (arg
->ts
.type
== BT_CLASS
)
2870 gfc_add_class_array_ref (arg
);
2872 ss
= gfc_walk_expr (arg
);
2873 gcc_assert (ss
!= gfc_ss_terminator
);
2874 gfc_init_se (&argse
, NULL
);
2875 argse
.data_not_needed
= 1;
2876 gfc_conv_expr_descriptor (&argse
, arg
);
2878 as
= gfc_get_full_arrayspec_from_expr (arg
);
2880 /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2881 Note in addition that zero-sized arrays don't count as contiguous. */
2883 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2885 /* Build the call to is_contiguous0. */
2886 argse
.want_pointer
= 1;
2887 gfc_conv_expr_descriptor (&argse
, arg
);
2888 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2889 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2890 desc
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2891 fncall0
= build_call_expr_loc (input_location
,
2892 gfor_fndecl_is_contiguous0
, 1, desc
);
2894 se
->expr
= convert (logical_type_node
, se
->expr
);
2898 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2899 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2900 desc
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2902 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[0]);
2903 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2904 stride
, build_int_cst (TREE_TYPE (stride
), 1));
2906 for (i
= 0; i
< arg
->rank
- 1; i
++)
2908 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2909 extent
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2910 extent
= fold_build2_loc (input_location
, MINUS_EXPR
,
2911 gfc_array_index_type
, extent
, tmp
);
2912 extent
= fold_build2_loc (input_location
, PLUS_EXPR
,
2913 gfc_array_index_type
, extent
,
2914 gfc_index_one_node
);
2915 tmp
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[i
]);
2916 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2918 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[i
+1]);
2919 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2921 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2922 boolean_type_node
, cond
, tmp
);
2929 /* Evaluate a single upper or lower bound. */
2930 /* TODO: bound intrinsic generates way too much unnecessary code. */
2933 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2935 gfc_actual_arglist
*arg
;
2936 gfc_actual_arglist
*arg2
;
2941 tree cond
, cond1
, cond3
, cond4
, size
;
2945 gfc_array_spec
* as
;
2946 bool assumed_rank_lb_one
;
2948 arg
= expr
->value
.function
.actual
;
2953 /* Create an implicit second parameter from the loop variable. */
2954 gcc_assert (!arg2
->expr
);
2955 gcc_assert (se
->loop
->dimen
== 1);
2956 gcc_assert (se
->ss
->info
->expr
== expr
);
2957 gfc_advance_se_ss_chain (se
);
2958 bound
= se
->loop
->loopvar
[0];
2959 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2960 gfc_array_index_type
, bound
,
2965 /* use the passed argument. */
2966 gcc_assert (arg2
->expr
);
2967 gfc_init_se (&argse
, NULL
);
2968 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2969 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2971 /* Convert from one based to zero based. */
2972 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2973 gfc_array_index_type
, bound
,
2974 gfc_index_one_node
);
2977 /* TODO: don't re-evaluate the descriptor on each iteration. */
2978 /* Get a descriptor for the first parameter. */
2979 gfc_init_se (&argse
, NULL
);
2980 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2981 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2982 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2986 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2988 if (INTEGER_CST_P (bound
))
2990 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2991 && wi::geu_p (wi::to_wide (bound
),
2992 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2993 || wi::gtu_p (wi::to_wide (bound
), GFC_MAX_DIMENSIONS
))
2994 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2995 "dimension index", upper
? "UBOUND" : "LBOUND",
2999 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
3001 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3003 bound
= gfc_evaluate_now (bound
, &se
->pre
);
3004 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3005 bound
, build_int_cst (TREE_TYPE (bound
), 0));
3006 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3007 tmp
= gfc_conv_descriptor_rank (desc
);
3009 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
3010 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3011 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
3012 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3013 logical_type_node
, cond
, tmp
);
3014 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
3019 /* Take care of the lbound shift for assumed-rank arrays, which are
3020 nonallocatable and nonpointers. Those has a lbound of 1. */
3021 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
3022 && ((arg
->expr
->ts
.type
!= BT_CLASS
3023 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
3024 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
3025 || (arg
->expr
->ts
.type
== BT_CLASS
3026 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
3027 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
3029 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3030 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3032 /* 13.14.53: Result value for LBOUND
3034 Case (i): For an array section or for an array expression other than a
3035 whole array or array structure component, LBOUND(ARRAY, DIM)
3036 has the value 1. For a whole array or array structure
3037 component, LBOUND(ARRAY, DIM) has the value:
3038 (a) equal to the lower bound for subscript DIM of ARRAY if
3039 dimension DIM of ARRAY does not have extent zero
3040 or if ARRAY is an assumed-size array of rank DIM,
3043 13.14.113: Result value for UBOUND
3045 Case (i): For an array section or for an array expression other than a
3046 whole array or array structure component, UBOUND(ARRAY, DIM)
3047 has the value equal to the number of elements in the given
3048 dimension; otherwise, it has a value equal to the upper bound
3049 for subscript DIM of ARRAY if dimension DIM of ARRAY does
3050 not have size zero and has value zero if dimension DIM has
3053 if (!upper
&& assumed_rank_lb_one
)
3054 se
->expr
= gfc_index_one_node
;
3057 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
3059 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3061 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3062 stride
, gfc_index_zero_node
);
3063 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3064 logical_type_node
, cond3
, cond1
);
3065 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3066 stride
, gfc_index_zero_node
);
3071 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3072 logical_type_node
, cond3
, cond4
);
3073 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3074 gfc_index_one_node
, lbound
);
3075 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3076 logical_type_node
, cond4
, cond5
);
3078 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3079 logical_type_node
, cond
, cond5
);
3081 if (assumed_rank_lb_one
)
3083 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3084 gfc_array_index_type
, ubound
, lbound
);
3085 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3086 gfc_array_index_type
, tmp
, gfc_index_one_node
);
3091 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3092 gfc_array_index_type
, cond
,
3093 tmp
, gfc_index_zero_node
);
3097 if (as
->type
== AS_ASSUMED_SIZE
)
3098 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3099 bound
, build_int_cst (TREE_TYPE (bound
),
3100 arg
->expr
->rank
- 1));
3102 cond
= logical_false_node
;
3104 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3105 logical_type_node
, cond3
, cond4
);
3106 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3107 logical_type_node
, cond
, cond1
);
3109 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3110 gfc_array_index_type
, cond
,
3111 lbound
, gfc_index_one_node
);
3118 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
3119 gfc_array_index_type
, ubound
, lbound
);
3120 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
3121 gfc_array_index_type
, size
,
3122 gfc_index_one_node
);
3123 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
3124 gfc_array_index_type
, se
->expr
,
3125 gfc_index_zero_node
);
3128 se
->expr
= gfc_index_one_node
;
3131 /* According to F2018 16.9.172, para 5, an assumed rank object, argument
3132 associated with and assumed size array, has the ubound of the final
3133 dimension set to -1 and UBOUND must return this. */
3134 if (upper
&& as
&& as
->type
== AS_ASSUMED_RANK
)
3136 tree minus_one
= build_int_cst (gfc_array_index_type
, -1);
3137 tree rank
= fold_convert (gfc_array_index_type
,
3138 gfc_conv_descriptor_rank (desc
));
3139 rank
= fold_build2_loc (input_location
, PLUS_EXPR
,
3140 gfc_array_index_type
, rank
, minus_one
);
3141 /* Fix the expression to stop it from becoming even more complicated. */
3142 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3143 cond
= fold_build2_loc (input_location
, NE_EXPR
,
3144 logical_type_node
, bound
, rank
);
3145 cond1
= fold_build2_loc (input_location
, NE_EXPR
,
3146 logical_type_node
, ubound
, minus_one
);
3147 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3148 logical_type_node
, cond
, cond1
);
3149 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3150 gfc_array_index_type
, cond
,
3151 se
->expr
, minus_one
);
3154 type
= gfc_typenode_for_spec (&expr
->ts
);
3155 se
->expr
= convert (type
, se
->expr
);
3160 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
3162 gfc_actual_arglist
*arg
;
3163 gfc_actual_arglist
*arg2
;
3165 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
3169 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
3170 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
3171 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
3173 arg
= expr
->value
.function
.actual
;
3176 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
3177 corank
= gfc_get_corank (arg
->expr
);
3179 gfc_init_se (&argse
, NULL
);
3180 argse
.want_coarray
= 1;
3182 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
3183 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3184 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3189 /* Create an implicit second parameter from the loop variable. */
3190 gcc_assert (!arg2
->expr
);
3191 gcc_assert (corank
> 0);
3192 gcc_assert (se
->loop
->dimen
== 1);
3193 gcc_assert (se
->ss
->info
->expr
== expr
);
3195 bound
= se
->loop
->loopvar
[0];
3196 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3197 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
3198 gfc_advance_se_ss_chain (se
);
3202 /* use the passed argument. */
3203 gcc_assert (arg2
->expr
);
3204 gfc_init_se (&argse
, NULL
);
3205 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
3206 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3209 if (INTEGER_CST_P (bound
))
3211 if (wi::ltu_p (wi::to_wide (bound
), 1)
3212 || wi::gtu_p (wi::to_wide (bound
),
3213 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
3214 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3215 "dimension index", expr
->value
.function
.isym
->name
,
3218 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3220 bound
= gfc_evaluate_now (bound
, &se
->pre
);
3221 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3222 bound
, build_int_cst (TREE_TYPE (bound
), 1));
3223 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
3224 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3226 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3227 logical_type_node
, cond
, tmp
);
3228 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
3233 /* Subtract 1 to get to zero based and add dimensions. */
3234 switch (arg
->expr
->rank
)
3237 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
3238 gfc_array_index_type
, bound
,
3239 gfc_index_one_node
);
3243 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3244 gfc_array_index_type
, bound
,
3245 gfc_rank_cst
[arg
->expr
->rank
- 1]);
3249 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3251 /* Handle UCOBOUND with special handling of the last codimension. */
3252 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
3254 /* Last codimension: For -fcoarray=single just return
3255 the lcobound - otherwise add
3256 ceiling (real (num_images ()) / real (size)) - 1
3257 = (num_images () + size - 1) / size - 1
3258 = (num_images - 1) / size(),
3259 where size is the product of the extent of all but the last
3262 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
3266 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
3267 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3268 2, integer_zero_node
,
3269 build_int_cst (integer_type_node
, -1));
3270 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3271 gfc_array_index_type
,
3272 fold_convert (gfc_array_index_type
, tmp
),
3273 build_int_cst (gfc_array_index_type
, 1));
3274 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
3275 gfc_array_index_type
, tmp
,
3276 fold_convert (gfc_array_index_type
, cosize
));
3277 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3278 gfc_array_index_type
, resbound
, tmp
);
3280 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
3282 /* ubound = lbound + num_images() - 1. */
3283 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3284 2, integer_zero_node
,
3285 build_int_cst (integer_type_node
, -1));
3286 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3287 gfc_array_index_type
,
3288 fold_convert (gfc_array_index_type
, tmp
),
3289 build_int_cst (gfc_array_index_type
, 1));
3290 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3291 gfc_array_index_type
, resbound
, tmp
);
3296 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3298 build_int_cst (TREE_TYPE (bound
),
3299 arg
->expr
->rank
+ corank
- 1));
3301 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3302 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3303 gfc_array_index_type
, cond
,
3304 resbound
, resbound2
);
3307 se
->expr
= resbound
;
3310 se
->expr
= resbound
;
3312 type
= gfc_typenode_for_spec (&expr
->ts
);
3313 se
->expr
= convert (type
, se
->expr
);
3318 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
3320 gfc_actual_arglist
*array_arg
;
3321 gfc_actual_arglist
*dim_arg
;
3325 array_arg
= expr
->value
.function
.actual
;
3326 dim_arg
= array_arg
->next
;
3328 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
3330 gfc_init_se (&argse
, NULL
);
3331 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
3332 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3333 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3336 gcc_assert (dim_arg
->expr
);
3337 gfc_init_se (&argse
, NULL
);
3338 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
3339 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3340 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3341 argse
.expr
, gfc_index_one_node
);
3342 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
3346 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
3350 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3352 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
3356 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
3361 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
3362 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
3371 /* Create a complex value from one or two real components. */
3374 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
3380 unsigned int num_args
;
3382 num_args
= gfc_intrinsic_argument_list_length (expr
);
3383 args
= XALLOCAVEC (tree
, num_args
);
3385 type
= gfc_typenode_for_spec (&expr
->ts
);
3386 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3387 real
= convert (TREE_TYPE (type
), args
[0]);
3389 imag
= convert (TREE_TYPE (type
), args
[1]);
3390 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
3392 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
3393 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
3394 imag
= convert (TREE_TYPE (type
), imag
);
3397 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3399 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3403 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3404 MODULO(A, P) = A - FLOOR (A / P) * P
3406 The obvious algorithms above are numerically instable for large
3407 arguments, hence these intrinsics are instead implemented via calls
3408 to the fmod family of functions. It is the responsibility of the
3409 user to ensure that the second argument is non-zero. */
3412 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3422 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3424 switch (expr
->ts
.type
)
3427 /* Integer case is easy, we've got a builtin op. */
3428 type
= TREE_TYPE (args
[0]);
3431 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3434 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3440 /* Check if we have a builtin fmod. */
3441 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3443 /* The builtin should always be available. */
3444 gcc_assert (fmod
!= NULL_TREE
);
3446 tmp
= build_addr (fmod
);
3447 se
->expr
= build_call_array_loc (input_location
,
3448 TREE_TYPE (TREE_TYPE (fmod
)),
3453 type
= TREE_TYPE (args
[0]);
3455 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3456 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3459 modulo = arg - floor (arg/arg2) * arg2
3461 In order to calculate the result accurately, we use the fmod
3462 function as follows.
3464 res = fmod (arg, arg2);
3467 if ((arg < 0) xor (arg2 < 0))
3471 res = copysign (0., arg2);
3473 => As two nested ternary exprs:
3475 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3476 : copysign (0., arg2);
3480 zero
= gfc_build_const (type
, integer_zero_node
);
3481 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3482 if (!flag_signed_zeros
)
3484 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3486 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3488 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3489 logical_type_node
, test
, test2
);
3490 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3492 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3493 logical_type_node
, test
, test2
);
3494 test
= gfc_evaluate_now (test
, &se
->pre
);
3495 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3496 fold_build2_loc (input_location
,
3498 type
, tmp
, args
[1]),
3503 tree expr1
, copysign
, cscall
;
3504 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3506 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3508 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3510 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3511 logical_type_node
, test
, test2
);
3512 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3513 fold_build2_loc (input_location
,
3515 type
, tmp
, args
[1]),
3517 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3519 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3521 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3531 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3532 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3533 where the right shifts are logical (i.e. 0's are shifted in).
3534 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3535 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3537 DSHIFTL(I,J,BITSIZE) = J
3539 DSHIFTR(I,J,BITSIZE) = I. */
3542 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3544 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3545 tree args
[3], cond
, tmp
;
3548 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3550 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3551 type
= TREE_TYPE (args
[0]);
3552 bitsize
= TYPE_PRECISION (type
);
3553 utype
= unsigned_type_for (type
);
3554 stype
= TREE_TYPE (args
[2]);
3556 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3557 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3558 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3560 /* The generic case. */
3561 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3562 build_int_cst (stype
, bitsize
), shift
);
3563 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3564 arg1
, dshiftl
? shift
: tmp
);
3566 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3567 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3568 right
= fold_convert (type
, right
);
3570 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3572 /* Special cases. */
3573 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3574 build_int_cst (stype
, 0));
3575 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3576 dshiftl
? arg1
: arg2
, res
);
3578 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3579 build_int_cst (stype
, bitsize
));
3580 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3581 dshiftl
? arg2
: arg1
, res
);
3587 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3590 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3598 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3599 type
= TREE_TYPE (args
[0]);
3601 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3602 val
= gfc_evaluate_now (val
, &se
->pre
);
3604 zero
= gfc_build_const (type
, integer_zero_node
);
3605 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, val
, zero
);
3606 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3610 /* SIGN(A, B) is absolute value of A times sign of B.
3611 The real value versions use library functions to ensure the correct
3612 handling of negative zero. Integer case implemented as:
3613 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3617 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3623 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3624 if (expr
->ts
.type
== BT_REAL
)
3628 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3629 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3631 /* We explicitly have to ignore the minus sign. We do so by using
3632 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3634 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3637 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3638 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3640 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3641 TREE_TYPE (args
[0]), cond
,
3642 build_call_expr_loc (input_location
, abs
, 1,
3644 build_call_expr_loc (input_location
, tmp
, 2,
3648 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3653 /* Having excluded floating point types, we know we are now dealing
3654 with signed integer types. */
3655 type
= TREE_TYPE (args
[0]);
3657 /* Args[0] is used multiple times below. */
3658 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3660 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3661 the signs of A and B are the same, and of all ones if they differ. */
3662 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3663 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3664 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3665 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3667 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3668 is all ones (i.e. -1). */
3669 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3670 fold_build2_loc (input_location
, PLUS_EXPR
,
3671 type
, args
[0], tmp
), tmp
);
3675 /* Test for the presence of an optional argument. */
3678 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3682 arg
= expr
->value
.function
.actual
->expr
;
3683 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3684 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3685 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3689 /* Calculate the double precision product of two single precision values. */
3692 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3697 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3699 /* Convert the args to double precision before multiplying. */
3700 type
= gfc_typenode_for_spec (&expr
->ts
);
3701 args
[0] = convert (type
, args
[0]);
3702 args
[1] = convert (type
, args
[1]);
3703 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3708 /* Return a length one character string containing an ascii character. */
3711 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3716 unsigned int num_args
;
3718 num_args
= gfc_intrinsic_argument_list_length (expr
);
3719 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3721 type
= gfc_get_char_type (expr
->ts
.kind
);
3722 var
= gfc_create_var (type
, "char");
3724 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3725 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3726 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3727 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3732 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3740 unsigned int num_args
;
3742 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3743 args
= XALLOCAVEC (tree
, num_args
);
3745 var
= gfc_create_var (pchar_type_node
, "pstr");
3746 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3748 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3749 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3750 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3752 fndecl
= build_addr (gfor_fndecl_ctime
);
3753 tmp
= build_call_array_loc (input_location
,
3754 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3755 fndecl
, num_args
, args
);
3756 gfc_add_expr_to_block (&se
->pre
, tmp
);
3758 /* Free the temporary afterwards, if necessary. */
3759 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3760 len
, build_int_cst (TREE_TYPE (len
), 0));
3761 tmp
= gfc_call_free (var
);
3762 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3763 gfc_add_expr_to_block (&se
->post
, tmp
);
3766 se
->string_length
= len
;
3771 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3779 unsigned int num_args
;
3781 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3782 args
= XALLOCAVEC (tree
, num_args
);
3784 var
= gfc_create_var (pchar_type_node
, "pstr");
3785 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3787 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3788 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3789 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3791 fndecl
= build_addr (gfor_fndecl_fdate
);
3792 tmp
= build_call_array_loc (input_location
,
3793 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3794 fndecl
, num_args
, args
);
3795 gfc_add_expr_to_block (&se
->pre
, tmp
);
3797 /* Free the temporary afterwards, if necessary. */
3798 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3799 len
, build_int_cst (TREE_TYPE (len
), 0));
3800 tmp
= gfc_call_free (var
);
3801 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3802 gfc_add_expr_to_block (&se
->post
, tmp
);
3805 se
->string_length
= len
;
3809 /* Generate a direct call to free() for the FREE subroutine. */
3812 conv_intrinsic_free (gfc_code
*code
)
3818 gfc_init_se (&argse
, NULL
);
3819 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3820 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3822 gfc_init_block (&block
);
3823 call
= build_call_expr_loc (input_location
,
3824 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3825 gfc_add_expr_to_block (&block
, call
);
3826 return gfc_finish_block (&block
);
3830 /* Call the RANDOM_INIT library subroutine with a hidden argument for
3831 handling seeding on coarray images. */
3834 conv_intrinsic_random_init (gfc_code
*code
)
3838 tree arg1
, arg2
, arg3
, tmp
;
3839 tree logical4_type_node
= gfc_get_logical_type (4);
3841 /* Make the function call. */
3842 gfc_init_block (&block
);
3843 gfc_init_se (&se
, NULL
);
3845 /* Convert REPEATABLE to a LOGICAL(4) entity. */
3846 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
3847 gfc_add_block_to_block (&block
, &se
.pre
);
3848 arg1
= fold_convert (logical4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3849 gfc_add_block_to_block (&block
, &se
.post
);
3851 /* Convert IMAGE_DISTINCT to a LOGICAL(4) entity. */
3852 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
3853 gfc_add_block_to_block (&block
, &se
.pre
);
3854 arg2
= fold_convert (logical4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3855 gfc_add_block_to_block (&block
, &se
.post
);
3857 /* Create the hidden argument. For non-coarray codes and -fcoarray=single,
3858 simply set this to 0. For -fcoarray=lib, generate a call to
3859 THIS_IMAGE() without arguments. */
3860 arg3
= build_int_cst (gfc_get_int_type (4), 0);
3861 if (flag_coarray
== GFC_FCOARRAY_LIB
)
3863 arg3
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
,
3865 se
.expr
= fold_convert (gfc_get_int_type (4), arg3
);
3868 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_random_init
, 3,
3870 gfc_add_expr_to_block (&block
, tmp
);
3872 return gfc_finish_block (&block
);
3876 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3880 conv_intrinsic_system_clock (gfc_code
*code
)
3883 gfc_se count_se
, count_rate_se
, count_max_se
;
3884 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3888 gfc_expr
*count
= code
->ext
.actual
->expr
;
3889 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3890 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3892 /* Evaluate our arguments. */
3895 gfc_init_se (&count_se
, NULL
);
3896 gfc_conv_expr (&count_se
, count
);
3901 gfc_init_se (&count_rate_se
, NULL
);
3902 gfc_conv_expr (&count_rate_se
, count_rate
);
3907 gfc_init_se (&count_max_se
, NULL
);
3908 gfc_conv_expr (&count_max_se
, count_max
);
3911 /* Find the smallest kind found of the arguments. */
3913 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3914 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3916 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3919 /* Prepare temporary variables. */
3924 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3925 else if (least
== 4)
3926 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3927 else if (count
->ts
.kind
== 1)
3928 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3931 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3938 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3939 else if (least
== 4)
3940 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3942 arg2
= integer_zero_node
;
3948 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3949 else if (least
== 4)
3950 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3952 arg3
= integer_zero_node
;
3955 /* Make the function call. */
3956 gfc_init_block (&block
);
3962 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3963 : null_pointer_node
;
3964 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3965 : null_pointer_node
;
3966 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3967 : null_pointer_node
;
3972 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3973 : null_pointer_node
;
3974 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3975 : null_pointer_node
;
3976 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3977 : null_pointer_node
;
3984 tmp
= build_call_expr_loc (input_location
,
3985 gfor_fndecl_system_clock4
, 3,
3986 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3987 : null_pointer_node
,
3988 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3989 : null_pointer_node
,
3990 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3991 : null_pointer_node
);
3992 gfc_add_expr_to_block (&block
, tmp
);
3994 /* Handle kind>=8, 10, or 16 arguments */
3997 tmp
= build_call_expr_loc (input_location
,
3998 gfor_fndecl_system_clock8
, 3,
3999 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
4000 : null_pointer_node
,
4001 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
4002 : null_pointer_node
,
4003 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
4004 : null_pointer_node
);
4005 gfc_add_expr_to_block (&block
, tmp
);
4009 /* And store values back if needed. */
4010 if (arg1
&& arg1
!= count_se
.expr
)
4011 gfc_add_modify (&block
, count_se
.expr
,
4012 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
4013 if (arg2
&& arg2
!= count_rate_se
.expr
)
4014 gfc_add_modify (&block
, count_rate_se
.expr
,
4015 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
4016 if (arg3
&& arg3
!= count_max_se
.expr
)
4017 gfc_add_modify (&block
, count_max_se
.expr
,
4018 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
4020 return gfc_finish_block (&block
);
4024 /* Return a character string containing the tty name. */
4027 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
4035 unsigned int num_args
;
4037 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
4038 args
= XALLOCAVEC (tree
, num_args
);
4040 var
= gfc_create_var (pchar_type_node
, "pstr");
4041 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4043 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
4044 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
4045 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
4047 fndecl
= build_addr (gfor_fndecl_ttynam
);
4048 tmp
= build_call_array_loc (input_location
,
4049 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
4050 fndecl
, num_args
, args
);
4051 gfc_add_expr_to_block (&se
->pre
, tmp
);
4053 /* Free the temporary afterwards, if necessary. */
4054 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4055 len
, build_int_cst (TREE_TYPE (len
), 0));
4056 tmp
= gfc_call_free (var
);
4057 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4058 gfc_add_expr_to_block (&se
->post
, tmp
);
4061 se
->string_length
= len
;
4065 /* Get the minimum/maximum value of all the parameters.
4066 minmax (a1, a2, a3, ...)
4069 mvar = COMP (mvar, a2)
4070 mvar = COMP (mvar, a3)
4074 Where COMP is MIN/MAX_EXPR for integral types or when we don't
4075 care about NaNs, or IFN_FMIN/MAX when the target has support for
4076 fast NaN-honouring min/max. When neither holds expand a sequence
4077 of explicit comparisons. */
4079 /* TODO: Mismatching types can occur when specific names are used.
4080 These should be handled during resolution. */
4082 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4090 gfc_actual_arglist
*argexpr
;
4091 unsigned int i
, nargs
;
4093 nargs
= gfc_intrinsic_argument_list_length (expr
);
4094 args
= XALLOCAVEC (tree
, nargs
);
4096 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
4097 type
= gfc_typenode_for_spec (&expr
->ts
);
4099 /* Only evaluate the argument once. */
4100 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
4101 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4103 /* Determine suitable type of temporary, as a GNU extension allows
4104 different argument kinds. */
4105 argtype
= TREE_TYPE (args
[0]);
4106 argexpr
= expr
->value
.function
.actual
;
4107 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++, argexpr
= argexpr
->next
)
4109 tree tmptype
= TREE_TYPE (args
[i
]);
4110 if (TYPE_PRECISION (tmptype
) > TYPE_PRECISION (argtype
))
4113 mvar
= gfc_create_var (argtype
, "M");
4114 gfc_add_modify (&se
->pre
, mvar
, convert (argtype
, args
[0]));
4116 argexpr
= expr
->value
.function
.actual
;
4117 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++, argexpr
= argexpr
->next
)
4119 tree cond
= NULL_TREE
;
4122 /* Handle absent optional arguments by ignoring the comparison. */
4123 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
4124 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
4125 && TREE_CODE (val
) == INDIRECT_REF
)
4127 cond
= fold_build2_loc (input_location
,
4128 NE_EXPR
, logical_type_node
,
4129 TREE_OPERAND (val
, 0),
4130 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
4132 else if (!VAR_P (val
) && !TREE_CONSTANT (val
))
4133 /* Only evaluate the argument once. */
4134 val
= gfc_evaluate_now (val
, &se
->pre
);
4137 /* For floating point types, the question is what MAX(a, NaN) or
4138 MIN(a, NaN) should return (where "a" is a normal number).
4139 There are valid usecase for returning either one, but the
4140 Fortran standard doesn't specify which one should be chosen.
4141 Also, there is no consensus among other tested compilers. In
4142 short, it's a mess. So lets just do whatever is fastest. */
4143 tree_code code
= op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
;
4144 calc
= fold_build2_loc (input_location
, code
, argtype
,
4145 convert (argtype
, val
), mvar
);
4146 tmp
= build2_v (MODIFY_EXPR
, mvar
, calc
);
4148 if (cond
!= NULL_TREE
)
4149 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
4150 build_empty_stmt (input_location
));
4151 gfc_add_expr_to_block (&se
->pre
, tmp
);
4153 if (TREE_CODE (type
) == INTEGER_TYPE
)
4154 se
->expr
= fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, mvar
);
4156 se
->expr
= convert (type
, mvar
);
4160 /* Generate library calls for MIN and MAX intrinsics for character
4163 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
4166 tree var
, len
, fndecl
, tmp
, cond
, function
;
4169 nargs
= gfc_intrinsic_argument_list_length (expr
);
4170 args
= XALLOCAVEC (tree
, nargs
+ 4);
4171 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
4173 /* Create the result variables. */
4174 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4175 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
4176 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
4177 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
4178 args
[2] = build_int_cst (integer_type_node
, op
);
4179 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
4181 if (expr
->ts
.kind
== 1)
4182 function
= gfor_fndecl_string_minmax
;
4183 else if (expr
->ts
.kind
== 4)
4184 function
= gfor_fndecl_string_minmax_char4
;
4188 /* Make the function call. */
4189 fndecl
= build_addr (function
);
4190 tmp
= build_call_array_loc (input_location
,
4191 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4193 gfc_add_expr_to_block (&se
->pre
, tmp
);
4195 /* Free the temporary afterwards, if necessary. */
4196 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4197 len
, build_int_cst (TREE_TYPE (len
), 0));
4198 tmp
= gfc_call_free (var
);
4199 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4200 gfc_add_expr_to_block (&se
->post
, tmp
);
4203 se
->string_length
= len
;
4207 /* Create a symbol node for this intrinsic. The symbol from the frontend
4208 has the generic name. */
4211 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
4215 /* TODO: Add symbols for intrinsic function to the global namespace. */
4216 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
4217 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
4220 sym
->attr
.external
= 1;
4221 sym
->attr
.function
= 1;
4222 sym
->attr
.always_explicit
= 1;
4223 sym
->attr
.proc
= PROC_INTRINSIC
;
4224 sym
->attr
.flavor
= FL_PROCEDURE
;
4228 sym
->attr
.dimension
= 1;
4229 sym
->as
= gfc_get_array_spec ();
4230 sym
->as
->type
= AS_ASSUMED_SHAPE
;
4231 sym
->as
->rank
= expr
->rank
;
4234 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
4235 ignore_optional
? expr
->value
.function
.actual
4241 /* Generate a call to an external intrinsic function. */
4243 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
4246 vec
<tree
, va_gc
> *append_args
;
4248 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
4251 gcc_assert (expr
->rank
> 0);
4253 gcc_assert (expr
->rank
== 0);
4255 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
4257 /* Calls to libgfortran_matmul need to be appended special arguments,
4258 to be able to call the BLAS ?gemm functions if required and possible. */
4260 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
4261 && !expr
->external_blas
4262 && sym
->ts
.type
!= BT_LOGICAL
)
4264 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
4266 if (flag_external_blas
4267 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
4268 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
4272 if (sym
->ts
.type
== BT_REAL
)
4274 if (sym
->ts
.kind
== 4)
4275 gemm_fndecl
= gfor_fndecl_sgemm
;
4277 gemm_fndecl
= gfor_fndecl_dgemm
;
4281 if (sym
->ts
.kind
== 4)
4282 gemm_fndecl
= gfor_fndecl_cgemm
;
4284 gemm_fndecl
= gfor_fndecl_zgemm
;
4287 vec_alloc (append_args
, 3);
4288 append_args
->quick_push (build_int_cst (cint
, 1));
4289 append_args
->quick_push (build_int_cst (cint
,
4290 flag_blas_matmul_limit
));
4291 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
4296 vec_alloc (append_args
, 3);
4297 append_args
->quick_push (build_int_cst (cint
, 0));
4298 append_args
->quick_push (build_int_cst (cint
, 0));
4299 append_args
->quick_push (null_pointer_node
);
4303 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4305 gfc_free_symbol (sym
);
4308 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4328 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4337 gfc_actual_arglist
*actual
;
4344 gfc_conv_intrinsic_funcall (se
, expr
);
4348 actual
= expr
->value
.function
.actual
;
4349 type
= gfc_typenode_for_spec (&expr
->ts
);
4350 /* Initialize the result. */
4351 resvar
= gfc_create_var (type
, "test");
4353 tmp
= convert (type
, boolean_true_node
);
4355 tmp
= convert (type
, boolean_false_node
);
4356 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4358 /* Walk the arguments. */
4359 arrayss
= gfc_walk_expr (actual
->expr
);
4360 gcc_assert (arrayss
!= gfc_ss_terminator
);
4362 /* Initialize the scalarizer. */
4363 gfc_init_loopinfo (&loop
);
4364 exit_label
= gfc_build_label_decl (NULL_TREE
);
4365 TREE_USED (exit_label
) = 1;
4366 gfc_add_ss_to_loop (&loop
, arrayss
);
4368 /* Initialize the loop. */
4369 gfc_conv_ss_startstride (&loop
);
4370 gfc_conv_loop_setup (&loop
, &expr
->where
);
4372 gfc_mark_ss_chain_used (arrayss
, 1);
4373 /* Generate the loop body. */
4374 gfc_start_scalarized_body (&loop
, &body
);
4376 /* If the condition matches then set the return value. */
4377 gfc_start_block (&block
);
4379 tmp
= convert (type
, boolean_false_node
);
4381 tmp
= convert (type
, boolean_true_node
);
4382 gfc_add_modify (&block
, resvar
, tmp
);
4384 /* And break out of the loop. */
4385 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4386 gfc_add_expr_to_block (&block
, tmp
);
4388 found
= gfc_finish_block (&block
);
4390 /* Check this element. */
4391 gfc_init_se (&arrayse
, NULL
);
4392 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4393 arrayse
.ss
= arrayss
;
4394 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4396 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4397 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
, arrayse
.expr
,
4398 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
4399 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
4400 gfc_add_expr_to_block (&body
, tmp
);
4401 gfc_add_block_to_block (&body
, &arrayse
.post
);
4403 gfc_trans_scalarizing_loops (&loop
, &body
);
4405 /* Add the exit label. */
4406 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4407 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4409 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4410 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4411 gfc_cleanup_loop (&loop
);
4417 /* Generate the constant 180 / pi, which is used in the conversion
4418 of acosd(), asind(), atand(), atan2d(). */
4426 gfc_set_model_kind (kind
);
4429 mpfr_set_si (t0
, 180, GFC_RND_MODE
);
4430 mpfr_const_pi (pi
, GFC_RND_MODE
);
4431 mpfr_div (t0
, t0
, pi
, GFC_RND_MODE
);
4432 retval
= gfc_conv_mpfr_to_tree (t0
, kind
, 0);
4439 /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4440 ASIND(x) is translated into ASIN(x) * 180 / pi.
4441 ATAND(x) is translated into ATAN(x) * 180 / pi. */
4444 gfc_conv_intrinsic_atrigd (gfc_se
* se
, gfc_expr
* expr
, gfc_isym_id id
)
4450 type
= gfc_typenode_for_spec (&expr
->ts
);
4452 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4454 if (id
== GFC_ISYM_ACOSD
)
4455 atrigd
= gfc_builtin_decl_for_float_kind (BUILT_IN_ACOS
, expr
->ts
.kind
);
4456 else if (id
== GFC_ISYM_ASIND
)
4457 atrigd
= gfc_builtin_decl_for_float_kind (BUILT_IN_ASIN
, expr
->ts
.kind
);
4458 else if (id
== GFC_ISYM_ATAND
)
4459 atrigd
= gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN
, expr
->ts
.kind
);
4463 atrigd
= build_call_expr_loc (input_location
, atrigd
, 1, arg
);
4465 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, atrigd
,
4466 fold_convert (type
, rad2deg (expr
->ts
.kind
)));
4470 /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4471 COS(X) / SIN(X) for COMPLEX argument. */
4474 gfc_conv_intrinsic_cotan (gfc_se
*se
, gfc_expr
*expr
)
4476 gfc_intrinsic_map_t
*m
;
4480 type
= gfc_typenode_for_spec (&expr
->ts
);
4481 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4483 if (expr
->ts
.type
== BT_REAL
)
4490 gfc_set_model_kind (expr
->ts
.kind
);
4492 mpfr_const_pi (pio2
, GFC_RND_MODE
);
4493 mpfr_div_ui (pio2
, pio2
, 2, GFC_RND_MODE
);
4494 tmp
= gfc_conv_mpfr_to_tree (pio2
, expr
->ts
.kind
, 0);
4497 /* Find tan builtin function. */
4498 m
= gfc_intrinsic_map
;
4499 for (; m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
4500 if (GFC_ISYM_TAN
== m
->id
)
4503 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, arg
, tmp
);
4504 tan
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4505 tan
= build_call_expr_loc (input_location
, tan
, 1, tmp
);
4506 se
->expr
= fold_build1_loc (input_location
, NEGATE_EXPR
, type
, tan
);
4513 /* Find cos builtin function. */
4514 m
= gfc_intrinsic_map
;
4515 for (; m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
4516 if (GFC_ISYM_COS
== m
->id
)
4519 cos
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4520 cos
= build_call_expr_loc (input_location
, cos
, 1, arg
);
4522 /* Find sin builtin function. */
4523 m
= gfc_intrinsic_map
;
4524 for (; m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
4525 if (GFC_ISYM_SIN
== m
->id
)
4528 sin
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4529 sin
= build_call_expr_loc (input_location
, sin
, 1, arg
);
4531 /* Divide cos by sin. */
4532 se
->expr
= fold_build2_loc (input_location
, RDIV_EXPR
, type
, cos
, sin
);
4537 /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4540 gfc_conv_intrinsic_cotand (gfc_se
*se
, gfc_expr
*expr
)
4547 type
= gfc_typenode_for_spec (&expr
->ts
);
4548 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4550 gfc_set_model_kind (expr
->ts
.kind
);
4552 /* Build the tree for x + 90. */
4553 mpfr_init_set_ui (ninety
, 90, GFC_RND_MODE
);
4554 ninety_tree
= gfc_conv_mpfr_to_tree (ninety
, expr
->ts
.kind
, 0);
4555 arg
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, arg
, ninety_tree
);
4556 mpfr_clear (ninety
);
4559 gfc_intrinsic_map_t
*m
= gfc_intrinsic_map
;
4560 for (; m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
4561 if (GFC_ISYM_TAND
== m
->id
)
4564 tree tand
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4565 tand
= build_call_expr_loc (input_location
, tand
, 1, arg
);
4567 se
->expr
= fold_build1_loc (input_location
, NEGATE_EXPR
, type
, tand
);
4571 /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4574 gfc_conv_intrinsic_atan2d (gfc_se
*se
, gfc_expr
*expr
)
4580 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4581 type
= TREE_TYPE (args
[0]);
4583 atan2d
= gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN2
, expr
->ts
.kind
);
4584 atan2d
= build_call_expr_loc (input_location
, atan2d
, 2, args
[0], args
[1]);
4586 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, atan2d
,
4587 rad2deg (expr
->ts
.kind
));
4591 /* COUNT(A) = Number of true elements in A. */
4593 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4600 gfc_actual_arglist
*actual
;
4606 gfc_conv_intrinsic_funcall (se
, expr
);
4610 actual
= expr
->value
.function
.actual
;
4612 type
= gfc_typenode_for_spec (&expr
->ts
);
4613 /* Initialize the result. */
4614 resvar
= gfc_create_var (type
, "count");
4615 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4617 /* Walk the arguments. */
4618 arrayss
= gfc_walk_expr (actual
->expr
);
4619 gcc_assert (arrayss
!= gfc_ss_terminator
);
4621 /* Initialize the scalarizer. */
4622 gfc_init_loopinfo (&loop
);
4623 gfc_add_ss_to_loop (&loop
, arrayss
);
4625 /* Initialize the loop. */
4626 gfc_conv_ss_startstride (&loop
);
4627 gfc_conv_loop_setup (&loop
, &expr
->where
);
4629 gfc_mark_ss_chain_used (arrayss
, 1);
4630 /* Generate the loop body. */
4631 gfc_start_scalarized_body (&loop
, &body
);
4633 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4634 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4635 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4637 gfc_init_se (&arrayse
, NULL
);
4638 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4639 arrayse
.ss
= arrayss
;
4640 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4641 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4642 build_empty_stmt (input_location
));
4644 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4645 gfc_add_expr_to_block (&body
, tmp
);
4646 gfc_add_block_to_block (&body
, &arrayse
.post
);
4648 gfc_trans_scalarizing_loops (&loop
, &body
);
4650 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4651 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4652 gfc_cleanup_loop (&loop
);
4658 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4659 struct and return the corresponding loopinfo. */
4661 static gfc_loopinfo
*
4662 enter_nested_loop (gfc_se
*se
)
4664 se
->ss
= se
->ss
->nested_ss
;
4665 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4667 return se
->ss
->loop
;
4670 /* Build the condition for a mask, which may be optional. */
4673 conv_mask_condition (gfc_se
*maskse
, gfc_expr
*maskexpr
,
4681 type
= TREE_TYPE (maskse
->expr
);
4682 present
= gfc_conv_expr_present (maskexpr
->symtree
->n
.sym
);
4683 present
= convert (type
, present
);
4684 present
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, type
,
4686 return fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4687 type
, present
, maskse
->expr
);
4690 return maskse
->expr
;
4693 /* Inline implementation of the sum and product intrinsics. */
4695 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4699 tree scale
= NULL_TREE
;
4704 gfc_loopinfo loop
, *ploop
;
4705 gfc_actual_arglist
*arg_array
, *arg_mask
;
4706 gfc_ss
*arrayss
= NULL
;
4707 gfc_ss
*maskss
= NULL
;
4711 gfc_expr
*arrayexpr
;
4717 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4723 type
= gfc_typenode_for_spec (&expr
->ts
);
4724 /* Initialize the result. */
4725 resvar
= gfc_create_var (type
, "val");
4730 scale
= gfc_create_var (type
, "scale");
4731 gfc_add_modify (&se
->pre
, scale
,
4732 gfc_build_const (type
, integer_one_node
));
4733 tmp
= gfc_build_const (type
, integer_zero_node
);
4735 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4736 tmp
= gfc_build_const (type
, integer_zero_node
);
4737 else if (op
== NE_EXPR
)
4739 tmp
= convert (type
, boolean_false_node
);
4740 else if (op
== BIT_AND_EXPR
)
4741 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4742 type
, integer_one_node
));
4744 tmp
= gfc_build_const (type
, integer_one_node
);
4746 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4748 arg_array
= expr
->value
.function
.actual
;
4750 arrayexpr
= arg_array
->expr
;
4752 if (op
== NE_EXPR
|| norm2
)
4754 /* PARITY and NORM2. */
4756 optional_mask
= false;
4760 arg_mask
= arg_array
->next
->next
;
4761 gcc_assert (arg_mask
!= NULL
);
4762 maskexpr
= arg_mask
->expr
;
4763 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
4764 && maskexpr
->symtree
->n
.sym
->attr
.dummy
4765 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
4768 if (expr
->rank
== 0)
4770 /* Walk the arguments. */
4771 arrayss
= gfc_walk_expr (arrayexpr
);
4772 gcc_assert (arrayss
!= gfc_ss_terminator
);
4774 if (maskexpr
&& maskexpr
->rank
> 0)
4776 maskss
= gfc_walk_expr (maskexpr
);
4777 gcc_assert (maskss
!= gfc_ss_terminator
);
4782 /* Initialize the scalarizer. */
4783 gfc_init_loopinfo (&loop
);
4785 /* We add the mask first because the number of iterations is
4786 taken from the last ss, and this breaks if an absent
4787 optional argument is used for mask. */
4789 if (maskexpr
&& maskexpr
->rank
> 0)
4790 gfc_add_ss_to_loop (&loop
, maskss
);
4791 gfc_add_ss_to_loop (&loop
, arrayss
);
4793 /* Initialize the loop. */
4794 gfc_conv_ss_startstride (&loop
);
4795 gfc_conv_loop_setup (&loop
, &expr
->where
);
4797 if (maskexpr
&& maskexpr
->rank
> 0)
4798 gfc_mark_ss_chain_used (maskss
, 1);
4799 gfc_mark_ss_chain_used (arrayss
, 1);
4804 /* All the work has been done in the parent loops. */
4805 ploop
= enter_nested_loop (se
);
4809 /* Generate the loop body. */
4810 gfc_start_scalarized_body (ploop
, &body
);
4812 /* If we have a mask, only add this element if the mask is set. */
4813 if (maskexpr
&& maskexpr
->rank
> 0)
4815 gfc_init_se (&maskse
, parent_se
);
4816 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4817 if (expr
->rank
== 0)
4819 gfc_conv_expr_val (&maskse
, maskexpr
);
4820 gfc_add_block_to_block (&body
, &maskse
.pre
);
4822 gfc_start_block (&block
);
4825 gfc_init_block (&block
);
4827 /* Do the actual summation/product. */
4828 gfc_init_se (&arrayse
, parent_se
);
4829 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4830 if (expr
->rank
== 0)
4831 arrayse
.ss
= arrayss
;
4832 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4833 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4837 /* if (x (i) != 0.0)
4843 result = 1.0 + result * val * val;
4849 result += val * val;
4852 tree res1
, res2
, cond
, absX
, val
;
4853 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4855 gfc_init_block (&ifblock1
);
4857 absX
= gfc_create_var (type
, "absX");
4858 gfc_add_modify (&ifblock1
, absX
,
4859 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4861 val
= gfc_create_var (type
, "val");
4862 gfc_add_expr_to_block (&ifblock1
, val
);
4864 gfc_init_block (&ifblock2
);
4865 gfc_add_modify (&ifblock2
, val
,
4866 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4868 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4869 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4870 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4871 gfc_build_const (type
, integer_one_node
));
4872 gfc_add_modify (&ifblock2
, resvar
, res1
);
4873 gfc_add_modify (&ifblock2
, scale
, absX
);
4874 res1
= gfc_finish_block (&ifblock2
);
4876 gfc_init_block (&ifblock3
);
4877 gfc_add_modify (&ifblock3
, val
,
4878 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4880 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4881 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4882 gfc_add_modify (&ifblock3
, resvar
, res2
);
4883 res2
= gfc_finish_block (&ifblock3
);
4885 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4887 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4888 gfc_add_expr_to_block (&ifblock1
, tmp
);
4889 tmp
= gfc_finish_block (&ifblock1
);
4891 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
4893 gfc_build_const (type
, integer_zero_node
));
4895 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4896 gfc_add_expr_to_block (&block
, tmp
);
4900 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4901 gfc_add_modify (&block
, resvar
, tmp
);
4904 gfc_add_block_to_block (&block
, &arrayse
.post
);
4906 if (maskexpr
&& maskexpr
->rank
> 0)
4908 /* We enclose the above in if (mask) {...} . If the mask is an
4909 optional argument, generate
4910 IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4912 tmp
= gfc_finish_block (&block
);
4913 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
4914 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
4915 build_empty_stmt (input_location
));
4918 tmp
= gfc_finish_block (&block
);
4919 gfc_add_expr_to_block (&body
, tmp
);
4921 gfc_trans_scalarizing_loops (ploop
, &body
);
4923 /* For a scalar mask, enclose the loop in an if statement. */
4924 if (maskexpr
&& maskexpr
->rank
== 0)
4926 gfc_init_block (&block
);
4927 gfc_add_block_to_block (&block
, &ploop
->pre
);
4928 gfc_add_block_to_block (&block
, &ploop
->post
);
4929 tmp
= gfc_finish_block (&block
);
4933 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4934 build_empty_stmt (input_location
));
4935 gfc_advance_se_ss_chain (se
);
4941 gcc_assert (expr
->rank
== 0);
4942 gfc_init_se (&maskse
, NULL
);
4943 gfc_conv_expr_val (&maskse
, maskexpr
);
4944 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
4945 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
4946 build_empty_stmt (input_location
));
4949 gfc_add_expr_to_block (&block
, tmp
);
4950 gfc_add_block_to_block (&se
->pre
, &block
);
4951 gcc_assert (se
->post
.head
== NULL
);
4955 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4956 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4959 if (expr
->rank
== 0)
4960 gfc_cleanup_loop (ploop
);
4964 /* result = scale * sqrt(result). */
4966 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4967 resvar
= build_call_expr_loc (input_location
,
4969 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4976 /* Inline implementation of the dot_product intrinsic. This function
4977 is based on gfc_conv_intrinsic_arith (the previous function). */
4979 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4987 gfc_actual_arglist
*actual
;
4988 gfc_ss
*arrayss1
, *arrayss2
;
4989 gfc_se arrayse1
, arrayse2
;
4990 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4992 type
= gfc_typenode_for_spec (&expr
->ts
);
4994 /* Initialize the result. */
4995 resvar
= gfc_create_var (type
, "val");
4996 if (expr
->ts
.type
== BT_LOGICAL
)
4997 tmp
= build_int_cst (type
, 0);
4999 tmp
= gfc_build_const (type
, integer_zero_node
);
5001 gfc_add_modify (&se
->pre
, resvar
, tmp
);
5003 /* Walk argument #1. */
5004 actual
= expr
->value
.function
.actual
;
5005 arrayexpr1
= actual
->expr
;
5006 arrayss1
= gfc_walk_expr (arrayexpr1
);
5007 gcc_assert (arrayss1
!= gfc_ss_terminator
);
5009 /* Walk argument #2. */
5010 actual
= actual
->next
;
5011 arrayexpr2
= actual
->expr
;
5012 arrayss2
= gfc_walk_expr (arrayexpr2
);
5013 gcc_assert (arrayss2
!= gfc_ss_terminator
);
5015 /* Initialize the scalarizer. */
5016 gfc_init_loopinfo (&loop
);
5017 gfc_add_ss_to_loop (&loop
, arrayss1
);
5018 gfc_add_ss_to_loop (&loop
, arrayss2
);
5020 /* Initialize the loop. */
5021 gfc_conv_ss_startstride (&loop
);
5022 gfc_conv_loop_setup (&loop
, &expr
->where
);
5024 gfc_mark_ss_chain_used (arrayss1
, 1);
5025 gfc_mark_ss_chain_used (arrayss2
, 1);
5027 /* Generate the loop body. */
5028 gfc_start_scalarized_body (&loop
, &body
);
5029 gfc_init_block (&block
);
5031 /* Make the tree expression for [conjg(]array1[)]. */
5032 gfc_init_se (&arrayse1
, NULL
);
5033 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
5034 arrayse1
.ss
= arrayss1
;
5035 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
5036 if (expr
->ts
.type
== BT_COMPLEX
)
5037 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
5039 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
5041 /* Make the tree expression for array2. */
5042 gfc_init_se (&arrayse2
, NULL
);
5043 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
5044 arrayse2
.ss
= arrayss2
;
5045 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
5046 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
5048 /* Do the actual product and sum. */
5049 if (expr
->ts
.type
== BT_LOGICAL
)
5051 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
5052 arrayse1
.expr
, arrayse2
.expr
);
5053 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
5057 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
5059 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
5061 gfc_add_modify (&block
, resvar
, tmp
);
5063 /* Finish up the loop block and the loop. */
5064 tmp
= gfc_finish_block (&block
);
5065 gfc_add_expr_to_block (&body
, tmp
);
5067 gfc_trans_scalarizing_loops (&loop
, &body
);
5068 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5069 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5070 gfc_cleanup_loop (&loop
);
5076 /* Emit code for minloc or maxloc intrinsic. There are many different cases
5077 we need to handle. For performance reasons we sometimes create two
5078 loops instead of one, where the second one is much simpler.
5079 Examples for minloc intrinsic:
5080 1) Result is an array, a call is generated
5081 2) Array mask is used and NaNs need to be supported:
5087 if (pos == 0) pos = S + (1 - from);
5088 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5095 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5099 3) NaNs need to be supported, but it is known at compile time or cheaply
5100 at runtime whether array is nonempty or not:
5105 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5108 if (from <= to) pos = 1;
5112 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5116 4) NaNs aren't supported, array mask is used:
5117 limit = infinities_supported ? Infinity : huge (limit);
5121 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5127 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5131 5) Same without array mask:
5132 limit = infinities_supported ? Infinity : huge (limit);
5133 pos = (from <= to) ? 1 : 0;
5136 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5139 For 3) and 5), if mask is scalar, this all goes into a conditional,
5140 setting pos = 0; in the else branch.
5142 Since we now also support the BACK argument, instead of using
5143 if (a[S] < limit), we now use
5146 cond = a[S] <= limit;
5148 cond = a[S] < limit;
5152 The optimizer is smart enough to move the condition out of the loop.
5153 The are now marked as unlikely to for further speedup. */
5156 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5160 stmtblock_t ifblock
;
5161 stmtblock_t elseblock
;
5173 gfc_actual_arglist
*actual
;
5178 gfc_expr
*arrayexpr
;
5186 actual
= expr
->value
.function
.actual
;
5188 /* The last argument, BACK, is passed by value. Ensure that
5189 by setting its name to %VAL. */
5190 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
5192 if (a
->next
== NULL
)
5198 gfc_conv_intrinsic_funcall (se
, expr
);
5202 arrayexpr
= actual
->expr
;
5204 /* Special case for character maxloc. Remove unneeded actual
5205 arguments, then call a library function. */
5207 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5209 gfc_actual_arglist
*a
, *b
;
5214 if (b
->expr
== NULL
|| strcmp (b
->name
, "dim") == 0)
5218 gfc_free_actual_arglist (b
);
5223 gfc_conv_intrinsic_funcall (se
, expr
);
5227 /* Initialize the result. */
5228 pos
= gfc_create_var (gfc_array_index_type
, "pos");
5229 offset
= gfc_create_var (gfc_array_index_type
, "offset");
5230 type
= gfc_typenode_for_spec (&expr
->ts
);
5232 /* Walk the arguments. */
5233 arrayss
= gfc_walk_expr (arrayexpr
);
5234 gcc_assert (arrayss
!= gfc_ss_terminator
);
5236 actual
= actual
->next
->next
;
5237 gcc_assert (actual
);
5238 maskexpr
= actual
->expr
;
5239 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5240 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5241 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5242 backexpr
= actual
->next
->next
->expr
;
5244 if (maskexpr
&& maskexpr
->rank
!= 0)
5246 maskss
= gfc_walk_expr (maskexpr
);
5247 gcc_assert (maskss
!= gfc_ss_terminator
);
5252 if (gfc_array_size (arrayexpr
, &asize
))
5254 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5256 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5257 logical_type_node
, nonempty
,
5258 gfc_index_zero_node
);
5263 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
5264 switch (arrayexpr
->ts
.type
)
5267 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
5271 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
5272 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
5273 arrayexpr
->ts
.kind
);
5280 /* We start with the most negative possible value for MAXLOC, and the most
5281 positive possible value for MINLOC. The most negative possible value is
5282 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5283 possible value is HUGE in both cases. */
5285 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5286 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
5287 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
5288 build_int_cst (TREE_TYPE (tmp
), 1));
5290 gfc_add_modify (&se
->pre
, limit
, tmp
);
5292 /* Initialize the scalarizer. */
5293 gfc_init_loopinfo (&loop
);
5295 /* We add the mask first because the number of iterations is taken
5296 from the last ss, and this breaks if an absent optional argument
5297 is used for mask. */
5300 gfc_add_ss_to_loop (&loop
, maskss
);
5302 gfc_add_ss_to_loop (&loop
, arrayss
);
5304 /* Initialize the loop. */
5305 gfc_conv_ss_startstride (&loop
);
5307 /* The code generated can have more than one loop in sequence (see the
5308 comment at the function header). This doesn't work well with the
5309 scalarizer, which changes arrays' offset when the scalarization loops
5310 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
5311 are currently inlined in the scalar case only (for which loop is of rank
5312 one). As there is no dependency to care about in that case, there is no
5313 temporary, so that we can use the scalarizer temporary code to handle
5314 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
5315 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
5317 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
5318 should eventually go away. We could either create two loops properly,
5319 or find another way to save/restore the array offsets between the two
5320 loops (without conflicting with temporary management), or use a single
5321 loop minmaxloc implementation. See PR 31067. */
5322 loop
.temp_dim
= loop
.dimen
;
5323 gfc_conv_loop_setup (&loop
, &expr
->where
);
5325 gcc_assert (loop
.dimen
== 1);
5326 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
5327 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5328 loop
.from
[0], loop
.to
[0]);
5332 /* Initialize the position to zero, following Fortran 2003. We are free
5333 to do this because Fortran 95 allows the result of an entirely false
5334 mask to be processor dependent. If we know at compile time the array
5335 is non-empty and no MASK is used, we can initialize to 1 to simplify
5337 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
5338 gfc_add_modify (&loop
.pre
, pos
,
5339 fold_build3_loc (input_location
, COND_EXPR
,
5340 gfc_array_index_type
,
5341 nonempty
, gfc_index_one_node
,
5342 gfc_index_zero_node
));
5345 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
5346 lab1
= gfc_build_label_decl (NULL_TREE
);
5347 TREE_USED (lab1
) = 1;
5348 lab2
= gfc_build_label_decl (NULL_TREE
);
5349 TREE_USED (lab2
) = 1;
5352 /* An offset must be added to the loop
5353 counter to obtain the required position. */
5354 gcc_assert (loop
.from
[0]);
5356 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5357 gfc_index_one_node
, loop
.from
[0]);
5358 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5360 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
5362 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
5363 /* Generate the loop body. */
5364 gfc_start_scalarized_body (&loop
, &body
);
5366 /* If we have a mask, only check this element if the mask is set. */
5369 gfc_init_se (&maskse
, NULL
);
5370 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5372 gfc_conv_expr_val (&maskse
, maskexpr
);
5373 gfc_add_block_to_block (&body
, &maskse
.pre
);
5375 gfc_start_block (&block
);
5378 gfc_init_block (&block
);
5380 /* Compare with the current limit. */
5381 gfc_init_se (&arrayse
, NULL
);
5382 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5383 arrayse
.ss
= arrayss
;
5384 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5385 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5387 gfc_init_se (&backse
, NULL
);
5388 gfc_conv_expr_val (&backse
, backexpr
);
5389 gfc_add_block_to_block (&block
, &backse
.pre
);
5391 /* We do the following if this is a more extreme value. */
5392 gfc_start_block (&ifblock
);
5394 /* Assign the value to the limit... */
5395 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5397 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
5399 stmtblock_t ifblock2
;
5402 gfc_start_block (&ifblock2
);
5403 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5404 loop
.loopvar
[0], offset
);
5405 gfc_add_modify (&ifblock2
, pos
, tmp
);
5406 ifbody2
= gfc_finish_block (&ifblock2
);
5407 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pos
,
5408 gfc_index_zero_node
);
5409 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
5410 build_empty_stmt (input_location
));
5411 gfc_add_expr_to_block (&block
, tmp
);
5414 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5415 loop
.loopvar
[0], offset
);
5416 gfc_add_modify (&ifblock
, pos
, tmp
);
5419 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
5421 ifbody
= gfc_finish_block (&ifblock
);
5423 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
5426 cond
= fold_build2_loc (input_location
,
5427 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5428 logical_type_node
, arrayse
.expr
, limit
);
5431 tree ifbody2
, elsebody2
;
5433 /* We switch to > or >= depending on the value of the BACK argument. */
5434 cond
= gfc_create_var (logical_type_node
, "cond");
5436 gfc_start_block (&ifblock
);
5437 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5438 logical_type_node
, arrayse
.expr
, limit
);
5440 gfc_add_modify (&ifblock
, cond
, b_if
);
5441 ifbody2
= gfc_finish_block (&ifblock
);
5443 gfc_start_block (&elseblock
);
5444 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5445 arrayse
.expr
, limit
);
5447 gfc_add_modify (&elseblock
, cond
, b_else
);
5448 elsebody2
= gfc_finish_block (&elseblock
);
5450 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5451 backse
.expr
, ifbody2
, elsebody2
);
5453 gfc_add_expr_to_block (&block
, tmp
);
5456 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5457 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
5458 build_empty_stmt (input_location
));
5460 gfc_add_expr_to_block (&block
, ifbody
);
5464 /* We enclose the above in if (mask) {...}. If the mask is an
5465 optional argument, generate IF (.NOT. PRESENT(MASK)
5469 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5470 tmp
= gfc_finish_block (&block
);
5471 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5472 build_empty_stmt (input_location
));
5475 tmp
= gfc_finish_block (&block
);
5476 gfc_add_expr_to_block (&body
, tmp
);
5480 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5482 if (HONOR_NANS (DECL_MODE (limit
)))
5484 if (nonempty
!= NULL
)
5486 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
5487 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
5488 build_empty_stmt (input_location
));
5489 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
5493 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
5494 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
5496 /* If we have a mask, only check this element if the mask is set. */
5499 gfc_init_se (&maskse
, NULL
);
5500 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5502 gfc_conv_expr_val (&maskse
, maskexpr
);
5503 gfc_add_block_to_block (&body
, &maskse
.pre
);
5505 gfc_start_block (&block
);
5508 gfc_init_block (&block
);
5510 /* Compare with the current limit. */
5511 gfc_init_se (&arrayse
, NULL
);
5512 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5513 arrayse
.ss
= arrayss
;
5514 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5515 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5517 /* We do the following if this is a more extreme value. */
5518 gfc_start_block (&ifblock
);
5520 /* Assign the value to the limit... */
5521 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5523 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5524 loop
.loopvar
[0], offset
);
5525 gfc_add_modify (&ifblock
, pos
, tmp
);
5527 ifbody
= gfc_finish_block (&ifblock
);
5529 /* We switch to > or >= depending on the value of the BACK argument. */
5531 tree ifbody2
, elsebody2
;
5533 cond
= gfc_create_var (logical_type_node
, "cond");
5535 gfc_start_block (&ifblock
);
5536 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5537 logical_type_node
, arrayse
.expr
, limit
);
5539 gfc_add_modify (&ifblock
, cond
, b_if
);
5540 ifbody2
= gfc_finish_block (&ifblock
);
5542 gfc_start_block (&elseblock
);
5543 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5544 arrayse
.expr
, limit
);
5546 gfc_add_modify (&elseblock
, cond
, b_else
);
5547 elsebody2
= gfc_finish_block (&elseblock
);
5549 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5550 backse
.expr
, ifbody2
, elsebody2
);
5553 gfc_add_expr_to_block (&block
, tmp
);
5554 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5555 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
5556 build_empty_stmt (input_location
));
5558 gfc_add_expr_to_block (&block
, tmp
);
5562 /* We enclose the above in if (mask) {...}. If the mask is
5563 an optional argument, generate IF (.NOT. PRESENT(MASK)
5567 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5568 tmp
= gfc_finish_block (&block
);
5569 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5570 build_empty_stmt (input_location
));
5573 tmp
= gfc_finish_block (&block
);
5574 gfc_add_expr_to_block (&body
, tmp
);
5575 /* Avoid initializing loopvar[0] again, it should be left where
5576 it finished by the first loop. */
5577 loop
.from
[0] = loop
.loopvar
[0];
5580 gfc_trans_scalarizing_loops (&loop
, &body
);
5583 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
5585 /* For a scalar mask, enclose the loop in an if statement. */
5586 if (maskexpr
&& maskss
== NULL
)
5590 gfc_init_se (&maskse
, NULL
);
5591 gfc_conv_expr_val (&maskse
, maskexpr
);
5592 gfc_init_block (&block
);
5593 gfc_add_block_to_block (&block
, &loop
.pre
);
5594 gfc_add_block_to_block (&block
, &loop
.post
);
5595 tmp
= gfc_finish_block (&block
);
5597 /* For the else part of the scalar mask, just initialize
5598 the pos variable the same way as above. */
5600 gfc_init_block (&elseblock
);
5601 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
5602 elsetmp
= gfc_finish_block (&elseblock
);
5603 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5604 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
, elsetmp
);
5605 gfc_add_expr_to_block (&block
, tmp
);
5606 gfc_add_block_to_block (&se
->pre
, &block
);
5610 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5611 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5613 gfc_cleanup_loop (&loop
);
5615 se
->expr
= convert (type
, pos
);
5618 /* Emit code for findloc. */
5621 gfc_conv_intrinsic_findloc (gfc_se
*se
, gfc_expr
*expr
)
5623 gfc_actual_arglist
*array_arg
, *value_arg
, *dim_arg
, *mask_arg
,
5624 *kind_arg
, *back_arg
;
5625 gfc_expr
*value_expr
;
5630 stmtblock_t loopblock
;
5634 tree forward_branch
= NULL_TREE
;
5649 array_arg
= expr
->value
.function
.actual
;
5650 value_arg
= array_arg
->next
;
5651 dim_arg
= value_arg
->next
;
5652 mask_arg
= dim_arg
->next
;
5653 kind_arg
= mask_arg
->next
;
5654 back_arg
= kind_arg
->next
;
5656 /* Remove kind and set ikind. */
5659 ikind
= mpz_get_si (kind_arg
->expr
->value
.integer
);
5660 gfc_free_expr (kind_arg
->expr
);
5661 kind_arg
->expr
= NULL
;
5664 ikind
= gfc_default_integer_kind
;
5666 value_expr
= value_arg
->expr
;
5668 /* Unless it's a string, pass VALUE by value. */
5669 if (value_expr
->ts
.type
!= BT_CHARACTER
)
5670 value_arg
->name
= "%VAL";
5672 /* Pass BACK argument by value. */
5673 back_arg
->name
= "%VAL";
5675 /* Call the library if we have a character function or if
5677 if (se
->ss
|| array_arg
->expr
->ts
.type
== BT_CHARACTER
)
5679 se
->ignore_optional
= 1;
5680 if (expr
->rank
== 0)
5682 /* Remove dim argument. */
5683 gfc_free_expr (dim_arg
->expr
);
5684 dim_arg
->expr
= NULL
;
5686 gfc_conv_intrinsic_funcall (se
, expr
);
5690 type
= gfc_get_int_type (ikind
);
5692 /* Initialize the result. */
5693 resvar
= gfc_create_var (gfc_array_index_type
, "pos");
5694 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (gfc_array_index_type
, 0));
5695 offset
= gfc_create_var (gfc_array_index_type
, "offset");
5697 maskexpr
= mask_arg
->expr
;
5698 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5699 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5700 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5702 /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5704 for (i
= 0 ; i
< 2; i
++)
5706 /* Walk the arguments. */
5707 arrayss
= gfc_walk_expr (array_arg
->expr
);
5708 gcc_assert (arrayss
!= gfc_ss_terminator
);
5710 if (maskexpr
&& maskexpr
->rank
!= 0)
5712 maskss
= gfc_walk_expr (maskexpr
);
5713 gcc_assert (maskss
!= gfc_ss_terminator
);
5718 /* Initialize the scalarizer. */
5719 gfc_init_loopinfo (&loop
);
5720 exit_label
= gfc_build_label_decl (NULL_TREE
);
5721 TREE_USED (exit_label
) = 1;
5723 /* We add the mask first because the number of iterations is
5724 taken from the last ss, and this breaks if an absent
5725 optional argument is used for mask. */
5728 gfc_add_ss_to_loop (&loop
, maskss
);
5729 gfc_add_ss_to_loop (&loop
, arrayss
);
5731 /* Initialize the loop. */
5732 gfc_conv_ss_startstride (&loop
);
5733 gfc_conv_loop_setup (&loop
, &expr
->where
);
5735 /* Calculate the offset. */
5736 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5737 gfc_index_one_node
, loop
.from
[0]);
5738 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5740 gfc_mark_ss_chain_used (arrayss
, 1);
5742 gfc_mark_ss_chain_used (maskss
, 1);
5744 /* The first loop is for BACK=.true. */
5746 loop
.reverse
[0] = GFC_REVERSE_SET
;
5748 /* Generate the loop body. */
5749 gfc_start_scalarized_body (&loop
, &body
);
5751 /* If we have an array mask, only add the element if it is
5755 gfc_init_se (&maskse
, NULL
);
5756 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5758 gfc_conv_expr_val (&maskse
, maskexpr
);
5759 gfc_add_block_to_block (&body
, &maskse
.pre
);
5762 /* If the condition matches then set the return value. */
5763 gfc_start_block (&block
);
5765 /* Add the offset. */
5766 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5768 loop
.loopvar
[0], offset
);
5769 gfc_add_modify (&block
, resvar
, tmp
);
5770 /* And break out of the loop. */
5771 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5772 gfc_add_expr_to_block (&block
, tmp
);
5774 found
= gfc_finish_block (&block
);
5776 /* Check this element. */
5777 gfc_init_se (&arrayse
, NULL
);
5778 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5779 arrayse
.ss
= arrayss
;
5780 gfc_conv_expr_val (&arrayse
, array_arg
->expr
);
5781 gfc_add_block_to_block (&body
, &arrayse
.pre
);
5783 gfc_init_se (&valuese
, NULL
);
5784 gfc_conv_expr_val (&valuese
, value_arg
->expr
);
5785 gfc_add_block_to_block (&body
, &valuese
.pre
);
5787 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5788 arrayse
.expr
, valuese
.expr
);
5790 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
5793 /* We enclose the above in if (mask) {...}. If the mask is
5794 an optional argument, generate IF (.NOT. PRESENT(MASK)
5798 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5799 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5800 build_empty_stmt (input_location
));
5803 gfc_add_expr_to_block (&body
, tmp
);
5804 gfc_add_block_to_block (&body
, &arrayse
.post
);
5806 gfc_trans_scalarizing_loops (&loop
, &body
);
5808 /* Add the exit label. */
5809 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5810 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5811 gfc_start_block (&loopblock
);
5812 gfc_add_block_to_block (&loopblock
, &loop
.pre
);
5813 gfc_add_block_to_block (&loopblock
, &loop
.post
);
5815 forward_branch
= gfc_finish_block (&loopblock
);
5817 back_branch
= gfc_finish_block (&loopblock
);
5819 gfc_cleanup_loop (&loop
);
5822 /* Enclose the two loops in an IF statement. */
5824 gfc_init_se (&backse
, NULL
);
5825 gfc_conv_expr_val (&backse
, back_arg
->expr
);
5826 gfc_add_block_to_block (&se
->pre
, &backse
.pre
);
5827 tmp
= build3_v (COND_EXPR
, backse
.expr
, forward_branch
, back_branch
);
5829 /* For a scalar mask, enclose the loop in an if statement. */
5830 if (maskexpr
&& maskss
== NULL
)
5835 gfc_init_se (&maskse
, NULL
);
5836 gfc_conv_expr_val (&maskse
, maskexpr
);
5837 gfc_init_block (&block
);
5838 gfc_add_expr_to_block (&block
, maskse
.expr
);
5839 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5840 if_stmt
= build3_v (COND_EXPR
, ifmask
, tmp
,
5841 build_empty_stmt (input_location
));
5842 gfc_add_expr_to_block (&block
, if_stmt
);
5843 tmp
= gfc_finish_block (&block
);
5846 gfc_add_expr_to_block (&se
->pre
, tmp
);
5847 se
->expr
= convert (type
, resvar
);
5851 /* Emit code for minval or maxval intrinsic. There are many different cases
5852 we need to handle. For performance reasons we sometimes create two
5853 loops instead of one, where the second one is much simpler.
5854 Examples for minval intrinsic:
5855 1) Result is an array, a call is generated
5856 2) Array mask is used and NaNs need to be supported, rank 1:
5861 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
5864 limit = nonempty ? NaN : huge (limit);
5866 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
5867 3) NaNs need to be supported, but it is known at compile time or cheaply
5868 at runtime whether array is nonempty or not, rank 1:
5871 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
5872 limit = (from <= to) ? NaN : huge (limit);
5874 while (S <= to) { limit = min (a[S], limit); S++; }
5875 4) Array mask is used and NaNs need to be supported, rank > 1:
5884 if (fast) limit = min (a[S1][S2], limit);
5887 if (a[S1][S2] <= limit) {
5898 limit = nonempty ? NaN : huge (limit);
5899 5) NaNs need to be supported, but it is known at compile time or cheaply
5900 at runtime whether array is nonempty or not, rank > 1:
5907 if (fast) limit = min (a[S1][S2], limit);
5909 if (a[S1][S2] <= limit) {
5919 limit = (nonempty_array) ? NaN : huge (limit);
5920 6) NaNs aren't supported, but infinities are. Array mask is used:
5925 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
5928 limit = nonempty ? limit : huge (limit);
5929 7) Same without array mask:
5932 while (S <= to) { limit = min (a[S], limit); S++; }
5933 limit = (from <= to) ? limit : huge (limit);
5934 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
5935 limit = huge (limit);
5937 while (S <= to) { limit = min (a[S], limit); S++); }
5939 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
5940 with array mask instead).
5941 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
5942 setting limit = huge (limit); in the else branch. */
5945 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5955 tree huge_cst
= NULL
, nan_cst
= NULL
;
5957 stmtblock_t block
, block2
;
5959 gfc_actual_arglist
*actual
;
5964 gfc_expr
*arrayexpr
;
5971 gfc_conv_intrinsic_funcall (se
, expr
);
5975 actual
= expr
->value
.function
.actual
;
5976 arrayexpr
= actual
->expr
;
5978 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5980 gfc_actual_arglist
*a2
, *a3
;
5981 a2
= actual
->next
; /* dim */
5982 a3
= a2
->next
; /* mask */
5983 if (a2
->expr
== NULL
|| expr
->rank
== 0)
5985 if (a3
->expr
== NULL
)
5986 actual
->next
= NULL
;
5992 gfc_free_actual_arglist (a2
);
5995 if (a3
->expr
== NULL
)
5998 gfc_free_actual_arglist (a3
);
6000 gfc_conv_intrinsic_funcall (se
, expr
);
6003 type
= gfc_typenode_for_spec (&expr
->ts
);
6004 /* Initialize the result. */
6005 limit
= gfc_create_var (type
, "limit");
6006 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
6007 switch (expr
->ts
.type
)
6010 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
6012 if (HONOR_INFINITIES (DECL_MODE (limit
)))
6014 REAL_VALUE_TYPE real
;
6016 tmp
= build_real (type
, real
);
6020 if (HONOR_NANS (DECL_MODE (limit
)))
6021 nan_cst
= gfc_build_nan (type
, "");
6025 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
6032 /* We start with the most negative possible value for MAXVAL, and the most
6033 positive possible value for MINVAL. The most negative possible value is
6034 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6035 possible value is HUGE in both cases. */
6038 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
6040 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
6041 TREE_TYPE (huge_cst
), huge_cst
);
6044 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
6045 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6046 tmp
, build_int_cst (type
, 1));
6048 gfc_add_modify (&se
->pre
, limit
, tmp
);
6050 /* Walk the arguments. */
6051 arrayss
= gfc_walk_expr (arrayexpr
);
6052 gcc_assert (arrayss
!= gfc_ss_terminator
);
6054 actual
= actual
->next
->next
;
6055 gcc_assert (actual
);
6056 maskexpr
= actual
->expr
;
6057 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
6058 && maskexpr
->symtree
->n
.sym
->attr
.dummy
6059 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
6061 if (maskexpr
&& maskexpr
->rank
!= 0)
6063 maskss
= gfc_walk_expr (maskexpr
);
6064 gcc_assert (maskss
!= gfc_ss_terminator
);
6069 if (gfc_array_size (arrayexpr
, &asize
))
6071 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
6073 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
6074 logical_type_node
, nonempty
,
6075 gfc_index_zero_node
);
6080 /* Initialize the scalarizer. */
6081 gfc_init_loopinfo (&loop
);
6083 /* We add the mask first because the number of iterations is taken
6084 from the last ss, and this breaks if an absent optional argument
6085 is used for mask. */
6088 gfc_add_ss_to_loop (&loop
, maskss
);
6089 gfc_add_ss_to_loop (&loop
, arrayss
);
6091 /* Initialize the loop. */
6092 gfc_conv_ss_startstride (&loop
);
6094 /* The code generated can have more than one loop in sequence (see the
6095 comment at the function header). This doesn't work well with the
6096 scalarizer, which changes arrays' offset when the scalarization loops
6097 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6098 are currently inlined in the scalar case only. As there is no dependency
6099 to care about in that case, there is no temporary, so that we can use the
6100 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6101 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6102 gfc_trans_scalarized_loop_boundary even later to restore offset.
6103 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6104 should eventually go away. We could either create two loops properly,
6105 or find another way to save/restore the array offsets between the two
6106 loops (without conflicting with temporary management), or use a single
6107 loop minmaxval implementation. See PR 31067. */
6108 loop
.temp_dim
= loop
.dimen
;
6109 gfc_conv_loop_setup (&loop
, &expr
->where
);
6111 if (nonempty
== NULL
&& maskss
== NULL
6112 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
6113 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
6114 loop
.from
[0], loop
.to
[0]);
6115 nonempty_var
= NULL
;
6116 if (nonempty
== NULL
6117 && (HONOR_INFINITIES (DECL_MODE (limit
))
6118 || HONOR_NANS (DECL_MODE (limit
))))
6120 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
6121 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
6122 nonempty
= nonempty_var
;
6126 if (HONOR_NANS (DECL_MODE (limit
)))
6128 if (loop
.dimen
== 1)
6130 lab
= gfc_build_label_decl (NULL_TREE
);
6131 TREE_USED (lab
) = 1;
6135 fast
= gfc_create_var (logical_type_node
, "fast");
6136 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
6140 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
6142 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
6143 /* Generate the loop body. */
6144 gfc_start_scalarized_body (&loop
, &body
);
6146 /* If we have a mask, only add this element if the mask is set. */
6149 gfc_init_se (&maskse
, NULL
);
6150 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
6152 gfc_conv_expr_val (&maskse
, maskexpr
);
6153 gfc_add_block_to_block (&body
, &maskse
.pre
);
6155 gfc_start_block (&block
);
6158 gfc_init_block (&block
);
6160 /* Compare with the current limit. */
6161 gfc_init_se (&arrayse
, NULL
);
6162 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
6163 arrayse
.ss
= arrayss
;
6164 gfc_conv_expr_val (&arrayse
, arrayexpr
);
6165 gfc_add_block_to_block (&block
, &arrayse
.pre
);
6167 gfc_init_block (&block2
);
6170 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
6172 if (HONOR_NANS (DECL_MODE (limit
)))
6174 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
6175 logical_type_node
, arrayse
.expr
, limit
);
6177 ifbody
= build1_v (GOTO_EXPR
, lab
);
6180 stmtblock_t ifblock
;
6182 gfc_init_block (&ifblock
);
6183 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
6184 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
6185 ifbody
= gfc_finish_block (&ifblock
);
6187 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
6188 build_empty_stmt (input_location
));
6189 gfc_add_expr_to_block (&block2
, tmp
);
6193 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6195 tmp
= fold_build2_loc (input_location
,
6196 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6197 type
, arrayse
.expr
, limit
);
6198 gfc_add_modify (&block2
, limit
, tmp
);
6203 tree elsebody
= gfc_finish_block (&block2
);
6205 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6207 if (HONOR_NANS (DECL_MODE (limit
)))
6209 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
6210 arrayse
.expr
, limit
);
6211 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
6212 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
6213 build_empty_stmt (input_location
));
6217 tmp
= fold_build2_loc (input_location
,
6218 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6219 type
, arrayse
.expr
, limit
);
6220 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
6222 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
6223 gfc_add_expr_to_block (&block
, tmp
);
6226 gfc_add_block_to_block (&block
, &block2
);
6228 gfc_add_block_to_block (&block
, &arrayse
.post
);
6230 tmp
= gfc_finish_block (&block
);
6233 /* We enclose the above in if (mask) {...}. If the mask is an
6234 optional argument, generate IF (.NOT. PRESENT(MASK)
6237 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6238 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6239 build_empty_stmt (input_location
));
6241 gfc_add_expr_to_block (&body
, tmp
);
6245 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
6247 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
6249 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
6250 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
6252 /* If we have a mask, only add this element if the mask is set. */
6255 gfc_init_se (&maskse
, NULL
);
6256 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
6258 gfc_conv_expr_val (&maskse
, maskexpr
);
6259 gfc_add_block_to_block (&body
, &maskse
.pre
);
6261 gfc_start_block (&block
);
6264 gfc_init_block (&block
);
6266 /* Compare with the current limit. */
6267 gfc_init_se (&arrayse
, NULL
);
6268 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
6269 arrayse
.ss
= arrayss
;
6270 gfc_conv_expr_val (&arrayse
, arrayexpr
);
6271 gfc_add_block_to_block (&block
, &arrayse
.pre
);
6273 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6275 if (HONOR_NANS (DECL_MODE (limit
)))
6277 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
6278 arrayse
.expr
, limit
);
6279 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
6280 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
6281 build_empty_stmt (input_location
));
6282 gfc_add_expr_to_block (&block
, tmp
);
6286 tmp
= fold_build2_loc (input_location
,
6287 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6288 type
, arrayse
.expr
, limit
);
6289 gfc_add_modify (&block
, limit
, tmp
);
6292 gfc_add_block_to_block (&block
, &arrayse
.post
);
6294 tmp
= gfc_finish_block (&block
);
6296 /* We enclose the above in if (mask) {...}. */
6299 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6300 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6301 build_empty_stmt (input_location
));
6304 gfc_add_expr_to_block (&body
, tmp
);
6305 /* Avoid initializing loopvar[0] again, it should be left where
6306 it finished by the first loop. */
6307 loop
.from
[0] = loop
.loopvar
[0];
6309 gfc_trans_scalarizing_loops (&loop
, &body
);
6313 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
6315 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
6316 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
6318 gfc_add_expr_to_block (&loop
.pre
, tmp
);
6320 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
6322 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
6324 gfc_add_modify (&loop
.pre
, limit
, tmp
);
6327 /* For a scalar mask, enclose the loop in an if statement. */
6328 if (maskexpr
&& maskss
== NULL
)
6333 gfc_init_se (&maskse
, NULL
);
6334 gfc_conv_expr_val (&maskse
, maskexpr
);
6335 gfc_init_block (&block
);
6336 gfc_add_block_to_block (&block
, &loop
.pre
);
6337 gfc_add_block_to_block (&block
, &loop
.post
);
6338 tmp
= gfc_finish_block (&block
);
6340 if (HONOR_INFINITIES (DECL_MODE (limit
)))
6341 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
6343 else_stmt
= build_empty_stmt (input_location
);
6345 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6346 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
, else_stmt
);
6347 gfc_add_expr_to_block (&block
, tmp
);
6348 gfc_add_block_to_block (&se
->pre
, &block
);
6352 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6353 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
6356 gfc_cleanup_loop (&loop
);
6361 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6363 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
6369 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6370 type
= TREE_TYPE (args
[0]);
6372 /* Optionally generate code for runtime argument check. */
6373 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6375 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6376 logical_type_node
, args
[1],
6377 build_int_cst (TREE_TYPE (args
[1]), 0));
6378 tree nbits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6379 tree above
= fold_build2_loc (input_location
, GE_EXPR
,
6380 logical_type_node
, args
[1], nbits
);
6381 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6382 logical_type_node
, below
, above
);
6383 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6384 "POS argument (%ld) out of range 0:%ld "
6385 "in intrinsic BTEST",
6386 fold_convert (long_integer_type_node
, args
[1]),
6387 fold_convert (long_integer_type_node
, nbits
));
6390 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
6391 build_int_cst (type
, 1), args
[1]);
6392 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
6393 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
6394 build_int_cst (type
, 0));
6395 type
= gfc_typenode_for_spec (&expr
->ts
);
6396 se
->expr
= convert (type
, tmp
);
6400 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6402 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6406 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6408 /* Convert both arguments to the unsigned type of the same size. */
6409 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
6410 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
6412 /* If they have unequal type size, convert to the larger one. */
6413 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
6414 > TYPE_PRECISION (TREE_TYPE (args
[1])))
6415 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
6416 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
6417 > TYPE_PRECISION (TREE_TYPE (args
[0])))
6418 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
6420 /* Now, we compare them. */
6421 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
6426 /* Generate code to perform the specified operation. */
6428 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6432 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6433 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
6439 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
6443 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6444 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6445 TREE_TYPE (arg
), arg
);
6448 /* Set or clear a single bit. */
6450 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
6457 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6458 type
= TREE_TYPE (args
[0]);
6460 /* Optionally generate code for runtime argument check. */
6461 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6463 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6464 logical_type_node
, args
[1],
6465 build_int_cst (TREE_TYPE (args
[1]), 0));
6466 tree nbits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6467 tree above
= fold_build2_loc (input_location
, GE_EXPR
,
6468 logical_type_node
, args
[1], nbits
);
6469 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6470 logical_type_node
, below
, above
);
6471 size_t len_name
= strlen (expr
->value
.function
.isym
->name
);
6472 char *name
= XALLOCAVEC (char, len_name
+ 1);
6473 for (size_t i
= 0; i
< len_name
; i
++)
6474 name
[i
] = TOUPPER (expr
->value
.function
.isym
->name
[i
]);
6475 name
[len_name
] = '\0';
6476 tree iname
= gfc_build_addr_expr (pchar_type_node
,
6477 gfc_build_cstring_const (name
));
6478 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6479 "POS argument (%ld) out of range 0:%ld "
6481 fold_convert (long_integer_type_node
, args
[1]),
6482 fold_convert (long_integer_type_node
, nbits
),
6486 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
6487 build_int_cst (type
, 1), args
[1]);
6493 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
6495 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
6498 /* Extract a sequence of bits.
6499 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6501 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
6508 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6509 type
= TREE_TYPE (args
[0]);
6511 /* Optionally generate code for runtime argument check. */
6512 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6514 tree tmp1
= fold_convert (long_integer_type_node
, args
[1]);
6515 tree tmp2
= fold_convert (long_integer_type_node
, args
[2]);
6516 tree nbits
= build_int_cst (long_integer_type_node
,
6517 TYPE_PRECISION (type
));
6518 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6519 logical_type_node
, args
[1],
6520 build_int_cst (TREE_TYPE (args
[1]), 0));
6521 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6522 logical_type_node
, tmp1
, nbits
);
6523 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6524 logical_type_node
, below
, above
);
6525 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6526 "POS argument (%ld) out of range 0:%ld "
6527 "in intrinsic IBITS", tmp1
, nbits
);
6528 below
= fold_build2_loc (input_location
, LT_EXPR
,
6529 logical_type_node
, args
[2],
6530 build_int_cst (TREE_TYPE (args
[2]), 0));
6531 above
= fold_build2_loc (input_location
, GT_EXPR
,
6532 logical_type_node
, tmp2
, nbits
);
6533 scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6534 logical_type_node
, below
, above
);
6535 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6536 "LEN argument (%ld) out of range 0:%ld "
6537 "in intrinsic IBITS", tmp2
, nbits
);
6538 above
= fold_build2_loc (input_location
, PLUS_EXPR
,
6539 long_integer_type_node
, tmp1
, tmp2
);
6540 scond
= fold_build2_loc (input_location
, GT_EXPR
,
6541 logical_type_node
, above
, nbits
);
6542 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6543 "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6544 "in intrinsic IBITS", tmp1
, tmp2
, nbits
);
6547 mask
= build_int_cst (type
, -1);
6548 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
6549 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
6551 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
6553 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
6557 gfc_conv_intrinsic_shape (gfc_se
*se
, gfc_expr
*expr
)
6559 gfc_actual_arglist
*s
, *k
;
6564 /* Remove the KIND argument, if present. */
6565 s
= expr
->value
.function
.actual
;
6571 gfc_conv_intrinsic_funcall (se
, expr
);
6573 as
= gfc_get_full_arrayspec_from_expr (s
->expr
);;
6574 ss
= gfc_walk_expr (s
->expr
);
6576 /* According to F2018 16.9.172, para 5, an assumed rank entity, argument
6577 associated with an assumed size array, has the ubound of the final
6578 dimension set to -1 and SHAPE must return this. */
6579 if (as
&& as
->type
== AS_ASSUMED_RANK
6580 && se
->expr
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
))
6581 && ss
&& ss
->info
->type
== GFC_SS_SECTION
)
6583 tree desc
, rank
, minus_one
, cond
, ubound
, tmp
;
6587 minus_one
= build_int_cst (gfc_array_index_type
, -1);
6589 /* Recover the descriptor for the array. */
6590 gfc_init_se (&ase
, NULL
);
6591 ase
.descriptor_only
= 1;
6592 gfc_conv_expr_lhs (&ase
, ss
->info
->expr
);
6594 /* Obtain rank-1 so that we can address both descriptors. */
6595 rank
= gfc_conv_descriptor_rank (ase
.expr
);
6596 rank
= fold_convert (gfc_array_index_type
, rank
);
6597 rank
= fold_build2_loc (input_location
, PLUS_EXPR
,
6598 gfc_array_index_type
,
6600 rank
= gfc_evaluate_now (rank
, &se
->pre
);
6602 /* The ubound for the final dimension will be tested for being -1. */
6603 ubound
= gfc_conv_descriptor_ubound_get (ase
.expr
, rank
);
6604 ubound
= gfc_evaluate_now (ubound
, &se
->pre
);
6605 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6609 /* Obtain the last element of the result from the library shape
6610 intrinsic and set it to -1 if that is the value of ubound. */
6612 tmp
= gfc_conv_array_data (desc
);
6613 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6614 tmp
= gfc_build_array_ref (tmp
, rank
, NULL
, NULL
);
6616 gfc_init_block (&block
);
6617 gfc_add_modify (&block
, tmp
, build_int_cst (TREE_TYPE (tmp
), -1));
6619 cond
= build3_v (COND_EXPR
, cond
,
6620 gfc_finish_block (&block
),
6621 build_empty_stmt (input_location
));
6622 gfc_add_expr_to_block (&se
->pre
, cond
);
6628 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
6631 tree args
[2], type
, num_bits
, cond
;
6634 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6636 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6637 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6638 type
= TREE_TYPE (args
[0]);
6641 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
6643 gcc_assert (right_shift
);
6645 se
->expr
= fold_build2_loc (input_location
,
6646 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
6647 TREE_TYPE (args
[0]), args
[0], args
[1]);
6650 se
->expr
= fold_convert (type
, se
->expr
);
6653 bigshift
= build_int_cst (type
, 0);
6656 tree nonneg
= fold_build2_loc (input_location
, GE_EXPR
,
6657 logical_type_node
, args
[0],
6658 build_int_cst (TREE_TYPE (args
[0]), 0));
6659 bigshift
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonneg
,
6660 build_int_cst (type
, 0),
6661 build_int_cst (type
, -1));
6664 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6665 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6667 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6669 /* Optionally generate code for runtime argument check. */
6670 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6672 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6673 logical_type_node
, args
[1],
6674 build_int_cst (TREE_TYPE (args
[1]), 0));
6675 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6676 logical_type_node
, args
[1], num_bits
);
6677 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6678 logical_type_node
, below
, above
);
6679 size_t len_name
= strlen (expr
->value
.function
.isym
->name
);
6680 char *name
= XALLOCAVEC (char, len_name
+ 1);
6681 for (size_t i
= 0; i
< len_name
; i
++)
6682 name
[i
] = TOUPPER (expr
->value
.function
.isym
->name
[i
]);
6683 name
[len_name
] = '\0';
6684 tree iname
= gfc_build_addr_expr (pchar_type_node
,
6685 gfc_build_cstring_const (name
));
6686 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6687 "SHIFT argument (%ld) out of range 0:%ld "
6689 fold_convert (long_integer_type_node
, args
[1]),
6690 fold_convert (long_integer_type_node
, num_bits
),
6694 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6697 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6698 bigshift
, se
->expr
);
6701 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
6703 : ((shift >= 0) ? i << shift : i >> -shift)
6704 where all shifts are logical shifts. */
6706 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
6718 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6720 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6721 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6723 type
= TREE_TYPE (args
[0]);
6724 utype
= unsigned_type_for (type
);
6726 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
6729 /* Left shift if positive. */
6730 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
6732 /* Right shift if negative.
6733 We convert to an unsigned type because we want a logical shift.
6734 The standard doesn't define the case of shifting negative
6735 numbers, and we try to be compatible with other compilers, most
6736 notably g77, here. */
6737 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
6738 utype
, convert (utype
, args
[0]), width
));
6740 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
6741 build_int_cst (TREE_TYPE (args
[1]), 0));
6742 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
6744 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6745 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6747 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6749 /* Optionally generate code for runtime argument check. */
6750 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6752 tree outside
= fold_build2_loc (input_location
, GT_EXPR
,
6753 logical_type_node
, width
, num_bits
);
6754 gfc_trans_runtime_check (true, false, outside
, &se
->pre
, &expr
->where
,
6755 "SHIFT argument (%ld) out of range -%ld:%ld "
6756 "in intrinsic ISHFT",
6757 fold_convert (long_integer_type_node
, args
[1]),
6758 fold_convert (long_integer_type_node
, num_bits
),
6759 fold_convert (long_integer_type_node
, num_bits
));
6762 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
6764 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6765 build_int_cst (type
, 0), tmp
);
6769 /* Circular shift. AKA rotate or barrel shift. */
6772 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
6781 unsigned int num_args
;
6783 num_args
= gfc_intrinsic_argument_list_length (expr
);
6784 args
= XALLOCAVEC (tree
, num_args
);
6786 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6788 type
= TREE_TYPE (args
[0]);
6789 nbits
= build_int_cst (long_integer_type_node
, TYPE_PRECISION (type
));
6793 /* Use a library function for the 3 parameter version. */
6794 tree int4type
= gfc_get_int_type (4);
6796 /* We convert the first argument to at least 4 bytes, and
6797 convert back afterwards. This removes the need for library
6798 functions for all argument sizes, and function will be
6799 aligned to at least 32 bits, so there's no loss. */
6800 if (expr
->ts
.kind
< 4)
6801 args
[0] = convert (int4type
, args
[0]);
6803 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
6804 need loads of library functions. They cannot have values >
6805 BIT_SIZE (I) so the conversion is safe. */
6806 args
[1] = convert (int4type
, args
[1]);
6807 args
[2] = convert (int4type
, args
[2]);
6809 /* Optionally generate code for runtime argument check. */
6810 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6812 tree size
= fold_convert (long_integer_type_node
, args
[2]);
6813 tree below
= fold_build2_loc (input_location
, LE_EXPR
,
6814 logical_type_node
, size
,
6815 build_int_cst (TREE_TYPE (args
[1]), 0));
6816 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6817 logical_type_node
, size
, nbits
);
6818 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6819 logical_type_node
, below
, above
);
6820 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6821 "SIZE argument (%ld) out of range 1:%ld "
6822 "in intrinsic ISHFTC", size
, nbits
);
6823 tree width
= fold_convert (long_integer_type_node
, args
[1]);
6824 width
= fold_build1_loc (input_location
, ABS_EXPR
,
6825 long_integer_type_node
, width
);
6826 scond
= fold_build2_loc (input_location
, GT_EXPR
,
6827 logical_type_node
, width
, size
);
6828 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6829 "SHIFT argument (%ld) out of range -%ld:%ld "
6830 "in intrinsic ISHFTC",
6831 fold_convert (long_integer_type_node
, args
[1]),
6835 switch (expr
->ts
.kind
)
6840 tmp
= gfor_fndecl_math_ishftc4
;
6843 tmp
= gfor_fndecl_math_ishftc8
;
6846 tmp
= gfor_fndecl_math_ishftc16
;
6851 se
->expr
= build_call_expr_loc (input_location
,
6852 tmp
, 3, args
[0], args
[1], args
[2]);
6853 /* Convert the result back to the original type, if we extended
6854 the first argument's width above. */
6855 if (expr
->ts
.kind
< 4)
6856 se
->expr
= convert (type
, se
->expr
);
6861 /* Evaluate arguments only once. */
6862 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6863 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6865 /* Optionally generate code for runtime argument check. */
6866 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6868 tree width
= fold_convert (long_integer_type_node
, args
[1]);
6869 width
= fold_build1_loc (input_location
, ABS_EXPR
,
6870 long_integer_type_node
, width
);
6871 tree outside
= fold_build2_loc (input_location
, GT_EXPR
,
6872 logical_type_node
, width
, nbits
);
6873 gfc_trans_runtime_check (true, false, outside
, &se
->pre
, &expr
->where
,
6874 "SHIFT argument (%ld) out of range -%ld:%ld "
6875 "in intrinsic ISHFTC",
6876 fold_convert (long_integer_type_node
, args
[1]),
6880 /* Rotate left if positive. */
6881 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
6883 /* Rotate right if negative. */
6884 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
6886 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
6888 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
6889 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
6891 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
6893 /* Do nothing if shift == 0. */
6894 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
6896 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
6901 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
6902 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
6904 The conditional expression is necessary because the result of LEADZ(0)
6905 is defined, but the result of __builtin_clz(0) is undefined for most
6908 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
6909 difference in bit size between the argument of LEADZ and the C int. */
6912 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
6924 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6925 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6927 /* Which variant of __builtin_clz* should we call? */
6928 if (argsize
<= INT_TYPE_SIZE
)
6930 arg_type
= unsigned_type_node
;
6931 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
6933 else if (argsize
<= LONG_TYPE_SIZE
)
6935 arg_type
= long_unsigned_type_node
;
6936 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
6938 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6940 arg_type
= long_long_unsigned_type_node
;
6941 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6945 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6946 arg_type
= gfc_build_uint_type (argsize
);
6950 /* Convert the actual argument twice: first, to the unsigned type of the
6951 same size; then, to the proper argument type for the built-in
6952 function. But the return type is of the default INTEGER kind. */
6953 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6954 arg
= fold_convert (arg_type
, arg
);
6955 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6956 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6958 /* Compute LEADZ for the case i .ne. 0. */
6961 s
= TYPE_PRECISION (arg_type
) - argsize
;
6962 tmp
= fold_convert (result_type
,
6963 build_call_expr_loc (input_location
, func
,
6965 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
6966 tmp
, build_int_cst (result_type
, s
));
6970 /* We end up here if the argument type is larger than 'long long'.
6971 We generate this code:
6973 if (x & (ULL_MAX << ULL_SIZE) != 0)
6974 return clzll ((unsigned long long) (x >> ULLSIZE));
6976 return ULL_SIZE + clzll ((unsigned long long) x);
6977 where ULL_MAX is the largest value that a ULL_MAX can hold
6978 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6979 is the bit-size of the long long type (64 in this example). */
6980 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
6982 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
6983 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6984 long_long_unsigned_type_node
,
6985 build_int_cst (long_long_unsigned_type_node
,
6988 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
6989 fold_convert (arg_type
, ullmax
), ullsize
);
6990 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
6992 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6993 cond
, build_int_cst (arg_type
, 0));
6995 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
6997 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
6998 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6999 tmp1
= fold_convert (result_type
,
7000 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
7002 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
7003 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
7004 tmp2
= fold_convert (result_type
,
7005 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
7006 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7009 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
7013 /* Build BIT_SIZE. */
7014 bit_size
= build_int_cst (result_type
, argsize
);
7016 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7017 arg
, build_int_cst (arg_type
, 0));
7018 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
7023 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7025 The conditional expression is necessary because the result of TRAILZ(0)
7026 is defined, but the result of __builtin_ctz(0) is undefined for most
7030 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
7041 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7042 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
7044 /* Which variant of __builtin_ctz* should we call? */
7045 if (argsize
<= INT_TYPE_SIZE
)
7047 arg_type
= unsigned_type_node
;
7048 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
7050 else if (argsize
<= LONG_TYPE_SIZE
)
7052 arg_type
= long_unsigned_type_node
;
7053 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
7055 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
7057 arg_type
= long_long_unsigned_type_node
;
7058 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7062 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
7063 arg_type
= gfc_build_uint_type (argsize
);
7067 /* Convert the actual argument twice: first, to the unsigned type of the
7068 same size; then, to the proper argument type for the built-in
7069 function. But the return type is of the default INTEGER kind. */
7070 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7071 arg
= fold_convert (arg_type
, arg
);
7072 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7073 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7075 /* Compute TRAILZ for the case i .ne. 0. */
7077 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
7081 /* We end up here if the argument type is larger than 'long long'.
7082 We generate this code:
7084 if ((x & ULL_MAX) == 0)
7085 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7087 return ctzll ((unsigned long long) x);
7089 where ULL_MAX is the largest value that a ULL_MAX can hold
7090 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7091 is the bit-size of the long long type (64 in this example). */
7092 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
7094 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
7095 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7096 long_long_unsigned_type_node
,
7097 build_int_cst (long_long_unsigned_type_node
, 0));
7099 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
7100 fold_convert (arg_type
, ullmax
));
7101 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
7102 build_int_cst (arg_type
, 0));
7104 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
7106 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
7107 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7108 tmp1
= fold_convert (result_type
,
7109 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
7110 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7113 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
7114 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7115 tmp2
= fold_convert (result_type
,
7116 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
7118 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
7122 /* Build BIT_SIZE. */
7123 bit_size
= build_int_cst (result_type
, argsize
);
7125 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7126 arg
, build_int_cst (arg_type
, 0));
7127 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
7131 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7132 for types larger than "long long", we call the long long built-in for
7133 the lower and higher bits and combine the result. */
7136 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
7144 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7145 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
7146 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7148 /* Which variant of the builtin should we call? */
7149 if (argsize
<= INT_TYPE_SIZE
)
7151 arg_type
= unsigned_type_node
;
7152 func
= builtin_decl_explicit (parity
7154 : BUILT_IN_POPCOUNT
);
7156 else if (argsize
<= LONG_TYPE_SIZE
)
7158 arg_type
= long_unsigned_type_node
;
7159 func
= builtin_decl_explicit (parity
7161 : BUILT_IN_POPCOUNTL
);
7163 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
7165 arg_type
= long_long_unsigned_type_node
;
7166 func
= builtin_decl_explicit (parity
7168 : BUILT_IN_POPCOUNTLL
);
7172 /* Our argument type is larger than 'long long', which mean none
7173 of the POPCOUNT builtins covers it. We thus call the 'long long'
7174 variant multiple times, and add the results. */
7175 tree utype
, arg2
, call1
, call2
;
7177 /* For now, we only cover the case where argsize is twice as large
7179 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
7181 func
= builtin_decl_explicit (parity
7183 : BUILT_IN_POPCOUNTLL
);
7185 /* Convert it to an integer, and store into a variable. */
7186 utype
= gfc_build_uint_type (argsize
);
7187 arg
= fold_convert (utype
, arg
);
7188 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7190 /* Call the builtin twice. */
7191 call1
= build_call_expr_loc (input_location
, func
, 1,
7192 fold_convert (long_long_unsigned_type_node
,
7195 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
7196 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
7197 call2
= build_call_expr_loc (input_location
, func
, 1,
7198 fold_convert (long_long_unsigned_type_node
,
7201 /* Combine the results. */
7203 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
7206 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7212 /* Convert the actual argument twice: first, to the unsigned type of the
7213 same size; then, to the proper argument type for the built-in
7215 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7216 arg
= fold_convert (arg_type
, arg
);
7218 se
->expr
= fold_convert (result_type
,
7219 build_call_expr_loc (input_location
, func
, 1, arg
));
7223 /* Process an intrinsic with unspecified argument-types that has an optional
7224 argument (which could be of type character), e.g. EOSHIFT. For those, we
7225 need to append the string length of the optional argument if it is not
7226 present and the type is really character.
7227 primary specifies the position (starting at 1) of the non-optional argument
7228 specifying the type and optional gives the position of the optional
7229 argument in the arglist. */
7232 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
7233 unsigned primary
, unsigned optional
)
7235 gfc_actual_arglist
* prim_arg
;
7236 gfc_actual_arglist
* opt_arg
;
7238 gfc_actual_arglist
* arg
;
7240 vec
<tree
, va_gc
> *append_args
;
7242 /* Find the two arguments given as position. */
7246 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
7250 if (cur_pos
== primary
)
7252 if (cur_pos
== optional
)
7255 if (cur_pos
>= primary
&& cur_pos
>= optional
)
7258 gcc_assert (prim_arg
);
7259 gcc_assert (prim_arg
->expr
);
7260 gcc_assert (opt_arg
);
7262 /* If we do have type CHARACTER and the optional argument is really absent,
7263 append a dummy 0 as string length. */
7265 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
7269 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
7270 vec_alloc (append_args
, 1);
7271 append_args
->quick_push (dummy
);
7274 /* Build the call itself. */
7275 gcc_assert (!se
->ignore_optional
);
7276 sym
= gfc_get_symbol_for_expr (expr
, false);
7277 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
7279 gfc_free_symbol (sym
);
7282 /* The length of a character string. */
7284 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
7293 gcc_assert (!se
->ss
);
7295 arg
= expr
->value
.function
.actual
->expr
;
7297 type
= gfc_typenode_for_spec (&expr
->ts
);
7298 switch (arg
->expr_type
)
7301 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
7305 /* Obtain the string length from the function used by
7306 trans-array.c(gfc_trans_array_constructor). */
7308 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
7312 if (arg
->ref
== NULL
7313 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
7315 /* This doesn't catch all cases.
7316 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7317 and the surrounding thread. */
7318 sym
= arg
->symtree
->n
.sym
;
7319 decl
= gfc_get_symbol_decl (sym
);
7320 if (decl
== current_function_decl
&& sym
->attr
.function
7321 && (sym
->result
== sym
))
7322 decl
= gfc_get_fake_result_decl (sym
, 0);
7324 len
= sym
->ts
.u
.cl
->backend_decl
;
7332 gfc_init_se (&argse
, se
);
7334 gfc_conv_expr (&argse
, arg
);
7336 gfc_conv_expr_descriptor (&argse
, arg
);
7337 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7338 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7339 len
= argse
.string_length
;
7342 se
->expr
= convert (type
, len
);
7345 /* The length of a character string not including trailing blanks. */
7347 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
7349 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7350 tree args
[2], type
, fndecl
;
7352 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7353 type
= gfc_typenode_for_spec (&expr
->ts
);
7356 fndecl
= gfor_fndecl_string_len_trim
;
7358 fndecl
= gfor_fndecl_string_len_trim_char4
;
7362 se
->expr
= build_call_expr_loc (input_location
,
7363 fndecl
, 2, args
[0], args
[1]);
7364 se
->expr
= convert (type
, se
->expr
);
7368 /* Returns the starting position of a substring within a string. */
7371 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
7374 tree logical4_type_node
= gfc_get_logical_type (4);
7378 unsigned int num_args
;
7380 args
= XALLOCAVEC (tree
, 5);
7382 /* Get number of arguments; characters count double due to the
7383 string length argument. Kind= is not passed to the library
7384 and thus ignored. */
7385 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
7390 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
7391 type
= gfc_typenode_for_spec (&expr
->ts
);
7394 args
[4] = build_int_cst (logical4_type_node
, 0);
7396 args
[4] = convert (logical4_type_node
, args
[4]);
7398 fndecl
= build_addr (function
);
7399 se
->expr
= build_call_array_loc (input_location
,
7400 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7402 se
->expr
= convert (type
, se
->expr
);
7406 /* The ascii value for a single character. */
7408 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
7410 tree args
[3], type
, pchartype
;
7413 nargs
= gfc_intrinsic_argument_list_length (expr
);
7414 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
7415 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
7416 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
7417 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
7418 type
= gfc_typenode_for_spec (&expr
->ts
);
7420 se
->expr
= build_fold_indirect_ref_loc (input_location
,
7422 se
->expr
= convert (type
, se
->expr
);
7426 /* Intrinsic ISNAN calls __builtin_isnan. */
7429 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
7433 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7434 se
->expr
= build_call_expr_loc (input_location
,
7435 builtin_decl_explicit (BUILT_IN_ISNAN
),
7437 STRIP_TYPE_NOPS (se
->expr
);
7438 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7442 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7443 their argument against a constant integer value. */
7446 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
7450 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7451 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
7452 gfc_typenode_for_spec (&expr
->ts
),
7453 arg
, build_int_cst (TREE_TYPE (arg
), value
));
7458 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7461 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
7469 unsigned int num_args
;
7471 num_args
= gfc_intrinsic_argument_list_length (expr
);
7472 args
= XALLOCAVEC (tree
, num_args
);
7474 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
7475 if (expr
->ts
.type
!= BT_CHARACTER
)
7483 /* We do the same as in the non-character case, but the argument
7484 list is different because of the string length arguments. We
7485 also have to set the string length for the result. */
7492 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
7494 se
->string_length
= len
;
7496 type
= TREE_TYPE (tsource
);
7497 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
7498 fold_convert (type
, fsource
));
7502 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7505 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
7507 tree args
[3], mask
, type
;
7509 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7510 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
7512 type
= TREE_TYPE (args
[0]);
7513 gcc_assert (TREE_TYPE (args
[1]) == type
);
7514 gcc_assert (TREE_TYPE (mask
) == type
);
7516 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
7517 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
7518 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7520 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
7525 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7526 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7529 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
7531 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
7534 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7535 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7537 type
= gfc_get_int_type (expr
->ts
.kind
);
7538 utype
= unsigned_type_for (type
);
7540 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
7541 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
7543 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
7544 build_int_cst (utype
, 0));
7548 /* Left-justified mask. */
7549 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
7551 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
7552 fold_convert (utype
, res
));
7554 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7555 smaller than type width. */
7556 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
7557 build_int_cst (TREE_TYPE (arg
), 0));
7558 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
7559 build_int_cst (utype
, 0), res
);
7563 /* Right-justified mask. */
7564 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
7565 fold_convert (utype
, arg
));
7566 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
7568 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7569 strictly smaller than type width. */
7570 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7572 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
7573 cond
, allones
, res
);
7576 se
->expr
= fold_convert (type
, res
);
7580 /* FRACTION (s) is translated into:
7581 isfinite (s) ? frexp (s, &dummy_int) : NaN */
7583 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
7585 tree arg
, type
, tmp
, res
, frexp
, cond
;
7587 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7589 type
= gfc_typenode_for_spec (&expr
->ts
);
7590 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7591 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7593 cond
= build_call_expr_loc (input_location
,
7594 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7597 tmp
= gfc_create_var (integer_type_node
, NULL
);
7598 res
= build_call_expr_loc (input_location
, frexp
, 2,
7599 fold_convert (type
, arg
),
7600 gfc_build_addr_expr (NULL_TREE
, tmp
));
7601 res
= fold_convert (type
, res
);
7603 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
7604 cond
, res
, gfc_build_nan (type
, ""));
7608 /* NEAREST (s, dir) is translated into
7609 tmp = copysign (HUGE_VAL, dir);
7610 return nextafter (s, tmp);
7613 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
7615 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
7617 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
7618 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
7620 type
= gfc_typenode_for_spec (&expr
->ts
);
7621 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7623 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
7624 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
7625 fold_convert (type
, args
[1]));
7626 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
7627 fold_convert (type
, args
[0]), tmp
);
7628 se
->expr
= fold_convert (type
, se
->expr
);
7632 /* SPACING (s) is translated into
7642 e = MAX_EXPR (e, emin);
7643 res = scalbn (1., e);
7647 where prec is the precision of s, gfc_real_kinds[k].digits,
7648 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7649 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7652 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
7654 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
7655 tree cond
, nan
, tmp
, frexp
, scalbn
;
7659 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7660 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
7661 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
7662 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
7664 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7665 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7667 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7668 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7670 type
= gfc_typenode_for_spec (&expr
->ts
);
7671 e
= gfc_create_var (integer_type_node
, NULL
);
7672 res
= gfc_create_var (type
, NULL
);
7675 /* Build the block for s /= 0. */
7676 gfc_start_block (&block
);
7677 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7678 gfc_build_addr_expr (NULL_TREE
, e
));
7679 gfc_add_expr_to_block (&block
, tmp
);
7681 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
7683 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
7684 integer_type_node
, tmp
, emin
));
7686 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
7687 build_real_from_int_cst (type
, integer_one_node
), e
);
7688 gfc_add_modify (&block
, res
, tmp
);
7690 /* Finish by building the IF statement for value zero. */
7691 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
7692 build_real_from_int_cst (type
, integer_zero_node
));
7693 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
7694 gfc_finish_block (&block
));
7696 /* And deal with infinities and NaNs. */
7697 cond
= build_call_expr_loc (input_location
,
7698 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7700 nan
= gfc_build_nan (type
, "");
7701 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
7703 gfc_add_expr_to_block (&se
->pre
, tmp
);
7708 /* RRSPACING (s) is translated into
7717 x = scalbn (x, precision - e);
7724 where precision is gfc_real_kinds[k].digits. */
7727 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
7729 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
7733 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7734 prec
= gfc_real_kinds
[k
].digits
;
7736 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7737 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7738 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
7740 type
= gfc_typenode_for_spec (&expr
->ts
);
7741 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7742 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7744 e
= gfc_create_var (integer_type_node
, NULL
);
7745 x
= gfc_create_var (type
, NULL
);
7746 gfc_add_modify (&se
->pre
, x
,
7747 build_call_expr_loc (input_location
, fabs
, 1, arg
));
7750 gfc_start_block (&block
);
7751 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7752 gfc_build_addr_expr (NULL_TREE
, e
));
7753 gfc_add_expr_to_block (&block
, tmp
);
7755 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
7756 build_int_cst (integer_type_node
, prec
), e
);
7757 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
7758 gfc_add_modify (&block
, x
, tmp
);
7759 stmt
= gfc_finish_block (&block
);
7762 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
7763 build_real_from_int_cst (type
, integer_zero_node
));
7764 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
7766 /* And deal with infinities and NaNs. */
7767 cond
= build_call_expr_loc (input_location
,
7768 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7770 nan
= gfc_build_nan (type
, "");
7771 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
7773 gfc_add_expr_to_block (&se
->pre
, tmp
);
7774 se
->expr
= fold_convert (type
, x
);
7778 /* SCALE (s, i) is translated into scalbn (s, i). */
7780 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
7782 tree args
[2], type
, scalbn
;
7784 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7786 type
= gfc_typenode_for_spec (&expr
->ts
);
7787 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7788 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
7789 fold_convert (type
, args
[0]),
7790 fold_convert (integer_type_node
, args
[1]));
7791 se
->expr
= fold_convert (type
, se
->expr
);
7795 /* SET_EXPONENT (s, i) is translated into
7796 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
7798 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
7800 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
7802 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7803 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7805 type
= gfc_typenode_for_spec (&expr
->ts
);
7806 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7807 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
7809 tmp
= gfc_create_var (integer_type_node
, NULL
);
7810 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
7811 fold_convert (type
, args
[0]),
7812 gfc_build_addr_expr (NULL_TREE
, tmp
));
7813 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
7814 fold_convert (integer_type_node
, args
[1]));
7815 res
= fold_convert (type
, res
);
7817 /* Call to isfinite */
7818 cond
= build_call_expr_loc (input_location
,
7819 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7821 nan
= gfc_build_nan (type
, "");
7823 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
7829 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
7831 gfc_actual_arglist
*actual
;
7838 gfc_symbol
*sym
= NULL
;
7840 gfc_init_se (&argse
, NULL
);
7841 actual
= expr
->value
.function
.actual
;
7843 if (actual
->expr
->ts
.type
== BT_CLASS
)
7844 gfc_add_class_array_ref (actual
->expr
);
7848 /* These are emerging from the interface mapping, when a class valued
7849 function appears as the rhs in a realloc on assign statement, where
7850 the size of the result is that of one of the actual arguments. */
7851 if (e
->expr_type
== EXPR_VARIABLE
7852 && e
->symtree
->n
.sym
->ns
== NULL
/* This is distinctive! */
7853 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7854 && e
->ref
&& e
->ref
->type
== REF_COMPONENT
7855 && strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0)
7856 sym
= e
->symtree
->n
.sym
;
7858 argse
.data_not_needed
= 1;
7859 if (gfc_is_class_array_function (e
))
7861 /* For functions that return a class array conv_expr_descriptor is not
7862 able to get the descriptor right. Therefore this special case. */
7863 gfc_conv_expr_reference (&argse
, e
);
7864 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
7865 gfc_class_data_get (argse
.expr
));
7867 else if (sym
&& sym
->backend_decl
)
7869 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
7870 argse
.expr
= sym
->backend_decl
;
7871 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
7872 gfc_class_data_get (argse
.expr
));
7876 argse
.want_pointer
= 1;
7877 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
7879 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7880 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7881 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
7883 /* Build the call to size0. */
7884 fncall0
= build_call_expr_loc (input_location
,
7885 gfor_fndecl_size0
, 1, arg1
);
7887 actual
= actual
->next
;
7891 gfc_init_se (&argse
, NULL
);
7892 gfc_conv_expr_type (&argse
, actual
->expr
,
7893 gfc_array_index_type
);
7894 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7896 /* Unusually, for an intrinsic, size does not exclude
7897 an optional arg2, so we must test for it. */
7898 if (actual
->expr
->expr_type
== EXPR_VARIABLE
7899 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
7900 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
7903 /* Build the call to size1. */
7904 fncall1
= build_call_expr_loc (input_location
,
7905 gfor_fndecl_size1
, 2,
7908 gfc_init_se (&argse
, NULL
);
7909 argse
.want_pointer
= 1;
7910 argse
.data_not_needed
= 1;
7911 gfc_conv_expr (&argse
, actual
->expr
);
7912 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7913 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7914 argse
.expr
, null_pointer_node
);
7915 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
7916 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
7917 pvoid_type_node
, tmp
, fncall1
, fncall0
);
7921 se
->expr
= NULL_TREE
;
7922 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
7923 gfc_array_index_type
,
7924 argse
.expr
, gfc_index_one_node
);
7927 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
7929 argse
.expr
= gfc_index_zero_node
;
7930 se
->expr
= NULL_TREE
;
7935 if (se
->expr
== NULL_TREE
)
7937 tree ubound
, lbound
;
7939 arg1
= build_fold_indirect_ref_loc (input_location
,
7941 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
7942 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
7943 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
7944 gfc_array_index_type
, ubound
, lbound
);
7945 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
7946 gfc_array_index_type
,
7947 se
->expr
, gfc_index_one_node
);
7948 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7949 gfc_array_index_type
, se
->expr
,
7950 gfc_index_zero_node
);
7953 type
= gfc_typenode_for_spec (&expr
->ts
);
7954 se
->expr
= convert (type
, se
->expr
);
7958 /* Helper function to compute the size of a character variable,
7959 excluding the terminating null characters. The result has
7960 gfc_array_index_type type. */
7963 size_of_string_in_bytes (int kind
, tree string_length
)
7966 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
7968 bytesize
= build_int_cst (gfc_array_index_type
,
7969 gfc_character_kinds
[i
].bit_size
/ 8);
7971 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7973 fold_convert (gfc_array_index_type
, string_length
));
7978 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
7990 gfc_init_se (&argse
, NULL
);
7991 arg
= expr
->value
.function
.actual
->expr
;
7993 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
7994 gfc_conv_expr_descriptor (&argse
, arg
);
7996 gfc_conv_expr_reference (&argse
, arg
);
7998 if (arg
->ts
.type
== BT_ASSUMED
)
8000 /* This only works if an array descriptor has been passed; thus, extract
8001 the size from the descriptor. */
8002 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
8003 == TYPE_PRECISION (size_type_node
));
8004 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
8005 tmp
= DECL_LANG_SPECIFIC (tmp
)
8006 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
8007 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
8008 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
8009 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8011 tmp
= gfc_conv_descriptor_dtype (tmp
);
8012 field
= gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8013 GFC_DTYPE_ELEM_LEN
);
8014 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
8015 tmp
, field
, NULL_TREE
);
8017 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
8019 else if (arg
->ts
.type
== BT_CLASS
)
8021 /* Conv_expr_descriptor returns a component_ref to _data component of the
8022 class object. The class object may be a non-pointer object, e.g.
8023 located on the stack, or a memory location pointed to, e.g. a
8024 parameter, i.e., an indirect_ref. */
8026 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
8027 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
8028 && GFC_DECL_CLASS (TREE_OPERAND (
8029 TREE_OPERAND (argse
.expr
, 0), 0)))
8030 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
8031 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
8032 else if (arg
->rank
> 0
8034 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
8035 /* The scalarizer added an additional temp. To get the class' vptr
8036 one has to look at the original backend_decl. */
8037 byte_size
= gfc_class_vtab_size_get (
8038 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
8040 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
8044 if (arg
->ts
.type
== BT_CHARACTER
)
8045 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
8049 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8052 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8053 byte_size
= fold_convert (gfc_array_index_type
,
8054 size_in_bytes (byte_size
));
8059 se
->expr
= byte_size
;
8062 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
8063 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
8065 if (arg
->rank
== -1)
8067 tree cond
, loop_var
, exit_label
;
8070 tmp
= fold_convert (gfc_array_index_type
,
8071 gfc_conv_descriptor_rank (argse
.expr
));
8072 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
8073 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
8074 exit_label
= gfc_build_label_decl (NULL_TREE
);
8081 source_bytes = source_bytes * array.dim[i].extent;
8085 gfc_start_block (&body
);
8086 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
8088 tmp
= build1_v (GOTO_EXPR
, exit_label
);
8089 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
8090 cond
, tmp
, build_empty_stmt (input_location
));
8091 gfc_add_expr_to_block (&body
, tmp
);
8093 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
8094 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
8095 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
8096 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8097 gfc_array_index_type
, tmp
, source_bytes
);
8098 gfc_add_modify (&body
, source_bytes
, tmp
);
8100 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8101 gfc_array_index_type
, loop_var
,
8102 gfc_index_one_node
);
8103 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
8105 tmp
= gfc_finish_block (&body
);
8107 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
8109 gfc_add_expr_to_block (&argse
.pre
, tmp
);
8111 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8112 gfc_add_expr_to_block (&argse
.pre
, tmp
);
8116 /* Obtain the size of the array in bytes. */
8117 for (n
= 0; n
< arg
->rank
; n
++)
8120 idx
= gfc_rank_cst
[n
];
8121 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
8122 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
8123 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
8124 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8125 gfc_array_index_type
, tmp
, source_bytes
);
8126 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8129 se
->expr
= source_bytes
;
8132 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8137 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
8141 tree type
, result_type
, tmp
;
8143 arg
= expr
->value
.function
.actual
->expr
;
8145 gfc_init_se (&argse
, NULL
);
8146 result_type
= gfc_get_int_type (expr
->ts
.kind
);
8150 if (arg
->ts
.type
== BT_CLASS
)
8152 gfc_add_vptr_component (arg
);
8153 gfc_add_size_component (arg
);
8154 gfc_conv_expr (&argse
, arg
);
8155 tmp
= fold_convert (result_type
, argse
.expr
);
8159 gfc_conv_expr_reference (&argse
, arg
);
8160 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8165 argse
.want_pointer
= 0;
8166 gfc_conv_expr_descriptor (&argse
, arg
);
8167 if (arg
->ts
.type
== BT_CLASS
)
8170 tmp
= gfc_class_vtab_size_get (
8171 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
8173 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
8174 tmp
= fold_convert (result_type
, tmp
);
8177 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8180 /* Obtain the argument's word length. */
8181 if (arg
->ts
.type
== BT_CHARACTER
)
8182 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
8184 tmp
= size_in_bytes (type
);
8185 tmp
= fold_convert (result_type
, tmp
);
8188 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
8189 build_int_cst (result_type
, BITS_PER_UNIT
));
8190 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8194 /* Intrinsic string comparison functions. */
8197 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
8201 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
8204 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
8205 expr
->value
.function
.actual
->expr
->ts
.kind
,
8207 se
->expr
= fold_build2_loc (input_location
, op
,
8208 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
8209 build_int_cst (TREE_TYPE (se
->expr
), 0));
8212 /* Generate a call to the adjustl/adjustr library function. */
8214 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
8222 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
8225 type
= TREE_TYPE (args
[2]);
8226 var
= gfc_conv_string_tmp (se
, type
, len
);
8229 tmp
= build_call_expr_loc (input_location
,
8230 fndecl
, 3, args
[0], args
[1], args
[2]);
8231 gfc_add_expr_to_block (&se
->pre
, tmp
);
8233 se
->string_length
= len
;
8237 /* Generate code for the TRANSFER intrinsic:
8239 DEST = TRANSFER (SOURCE, MOLD)
8241 typeof<DEST> = typeof<MOLD>
8246 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8248 typeof<DEST> = typeof<MOLD>
8250 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8251 sizeof (DEST(0) * SIZE). */
8253 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
8269 tree class_ref
= NULL_TREE
;
8270 gfc_actual_arglist
*arg
;
8272 gfc_array_info
*info
;
8276 gfc_expr
*source_expr
, *mold_expr
, *class_expr
;
8280 info
= &se
->ss
->info
->data
.array
;
8282 /* Convert SOURCE. The output from this stage is:-
8283 source_bytes = length of the source in bytes
8284 source = pointer to the source data. */
8285 arg
= expr
->value
.function
.actual
;
8286 source_expr
= arg
->expr
;
8288 /* Ensure double transfer through LOGICAL preserves all
8290 if (arg
->expr
->expr_type
== EXPR_FUNCTION
8291 && arg
->expr
->value
.function
.esym
== NULL
8292 && arg
->expr
->value
.function
.isym
!= NULL
8293 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
8294 && arg
->expr
->ts
.type
== BT_LOGICAL
8295 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
8296 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
8298 gfc_init_se (&argse
, NULL
);
8300 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
8302 /* Obtain the pointer to source and the length of source in bytes. */
8303 if (arg
->expr
->rank
== 0)
8305 gfc_conv_expr_reference (&argse
, arg
->expr
);
8306 if (arg
->expr
->ts
.type
== BT_CLASS
)
8308 tmp
= build_fold_indirect_ref_loc (input_location
, argse
.expr
);
8309 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
8310 source
= gfc_class_data_get (tmp
);
8313 /* Array elements are evaluated as a reference to the data.
8314 To obtain the vptr for the element size, the argument
8315 expression must be stripped to the class reference and
8316 re-evaluated. The pre and post blocks are not needed. */
8317 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
8318 source
= argse
.expr
;
8319 class_expr
= gfc_find_and_cut_at_last_class_ref (arg
->expr
);
8320 gfc_init_se (&argse
, NULL
);
8321 gfc_conv_expr (&argse
, class_expr
);
8322 class_ref
= argse
.expr
;
8326 source
= argse
.expr
;
8328 /* Obtain the source word length. */
8329 switch (arg
->expr
->ts
.type
)
8332 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
8333 argse
.string_length
);
8336 if (class_ref
!= NULL_TREE
)
8337 tmp
= gfc_class_vtab_size_get (class_ref
);
8339 tmp
= gfc_class_vtab_size_get (argse
.expr
);
8342 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8344 tmp
= fold_convert (gfc_array_index_type
,
8345 size_in_bytes (source_type
));
8351 argse
.want_pointer
= 0;
8352 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
8353 source
= gfc_conv_descriptor_data_get (argse
.expr
);
8354 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8356 /* Repack the source if not simply contiguous. */
8357 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
8359 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
8361 if (warn_array_temporaries
)
8362 gfc_warning (OPT_Warray_temporaries
,
8363 "Creating array temporary at %L", &expr
->where
);
8365 source
= build_call_expr_loc (input_location
,
8366 gfor_fndecl_in_pack
, 1, tmp
);
8367 source
= gfc_evaluate_now (source
, &argse
.pre
);
8369 /* Free the temporary. */
8370 gfc_start_block (&block
);
8371 tmp
= gfc_call_free (source
);
8372 gfc_add_expr_to_block (&block
, tmp
);
8373 stmt
= gfc_finish_block (&block
);
8375 /* Clean up if it was repacked. */
8376 gfc_init_block (&block
);
8377 tmp
= gfc_conv_array_data (argse
.expr
);
8378 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8380 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
8381 build_empty_stmt (input_location
));
8382 gfc_add_expr_to_block (&block
, tmp
);
8383 gfc_add_block_to_block (&block
, &se
->post
);
8384 gfc_init_block (&se
->post
);
8385 gfc_add_block_to_block (&se
->post
, &block
);
8388 /* Obtain the source word length. */
8389 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
8390 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
8391 argse
.string_length
);
8393 tmp
= fold_convert (gfc_array_index_type
,
8394 size_in_bytes (source_type
));
8396 /* Obtain the size of the array in bytes. */
8397 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
8398 for (n
= 0; n
< arg
->expr
->rank
; n
++)
8401 idx
= gfc_rank_cst
[n
];
8402 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8403 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
8404 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
8405 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8406 gfc_array_index_type
, upper
, lower
);
8407 gfc_add_modify (&argse
.pre
, extent
, tmp
);
8408 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8409 gfc_array_index_type
, extent
,
8410 gfc_index_one_node
);
8411 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8412 gfc_array_index_type
, tmp
, source_bytes
);
8416 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8417 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8418 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8420 /* Now convert MOLD. The outputs are:
8421 mold_type = the TREE type of MOLD
8422 dest_word_len = destination word length in bytes. */
8424 mold_expr
= arg
->expr
;
8426 gfc_init_se (&argse
, NULL
);
8428 scalar_mold
= arg
->expr
->rank
== 0;
8430 if (arg
->expr
->rank
== 0)
8432 gfc_conv_expr_reference (&argse
, arg
->expr
);
8433 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8438 gfc_init_se (&argse
, NULL
);
8439 argse
.want_pointer
= 0;
8440 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
8441 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8444 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8445 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8447 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
8449 /* If this TRANSFER is nested in another TRANSFER, use a type
8450 that preserves all bits. */
8451 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
8452 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
8455 /* Obtain the destination word length. */
8456 switch (arg
->expr
->ts
.type
)
8459 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
8460 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
8463 tmp
= gfc_class_vtab_size_get (argse
.expr
);
8466 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
8469 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
8470 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
8472 /* Finally convert SIZE, if it is present. */
8474 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
8478 gfc_init_se (&argse
, NULL
);
8479 gfc_conv_expr_reference (&argse
, arg
->expr
);
8480 tmp
= convert (gfc_array_index_type
,
8481 build_fold_indirect_ref_loc (input_location
,
8483 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8484 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8489 /* Separate array and scalar results. */
8490 if (scalar_mold
&& tmp
== NULL_TREE
)
8491 goto scalar_transfer
;
8493 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
8494 if (tmp
!= NULL_TREE
)
8495 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8496 tmp
, dest_word_len
);
8500 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
8501 gfc_add_modify (&se
->pre
, size_words
,
8502 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
8503 gfc_array_index_type
,
8504 size_bytes
, dest_word_len
));
8506 /* Evaluate the bounds of the result. If the loop range exists, we have
8507 to check if it is too large. If so, we modify loop->to be consistent
8508 with min(size, size(source)). Otherwise, size is made consistent with
8509 the loop range, so that the right number of bytes is transferred.*/
8510 n
= se
->loop
->order
[0];
8511 if (se
->loop
->to
[n
] != NULL_TREE
)
8513 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8514 se
->loop
->to
[n
], se
->loop
->from
[n
]);
8515 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8516 tmp
, gfc_index_one_node
);
8517 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
8519 gfc_add_modify (&se
->pre
, size_words
, tmp
);
8520 gfc_add_modify (&se
->pre
, size_bytes
,
8521 fold_build2_loc (input_location
, MULT_EXPR
,
8522 gfc_array_index_type
,
8523 size_words
, dest_word_len
));
8524 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8525 size_words
, se
->loop
->from
[n
]);
8526 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8527 upper
, gfc_index_one_node
);
8531 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8532 size_words
, gfc_index_one_node
);
8533 se
->loop
->from
[n
] = gfc_index_zero_node
;
8536 se
->loop
->to
[n
] = upper
;
8538 /* Build a destination descriptor, using the pointer, source, as the
8540 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
8541 NULL_TREE
, false, true, false, &expr
->where
);
8543 /* Cast the pointer to the result. */
8544 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
8545 tmp
= fold_convert (pvoid_type_node
, tmp
);
8547 /* Use memcpy to do the transfer. */
8549 = build_call_expr_loc (input_location
,
8550 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
8551 fold_convert (pvoid_type_node
, source
),
8552 fold_convert (size_type_node
,
8553 fold_build2_loc (input_location
,
8555 gfc_array_index_type
,
8558 gfc_add_expr_to_block (&se
->pre
, tmp
);
8560 se
->expr
= info
->descriptor
;
8561 if (expr
->ts
.type
== BT_CHARACTER
)
8562 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
8566 /* Deal with scalar results. */
8568 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
8569 dest_word_len
, source_bytes
);
8570 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
8571 extent
, gfc_index_zero_node
);
8573 if (expr
->ts
.type
== BT_CHARACTER
)
8575 tree direct
, indirect
, free
;
8577 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
8578 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
8581 /* If source is longer than the destination, use a pointer to
8582 the source directly. */
8583 gfc_init_block (&block
);
8584 gfc_add_modify (&block
, tmpdecl
, ptr
);
8585 direct
= gfc_finish_block (&block
);
8587 /* Otherwise, allocate a string with the length of the destination
8588 and copy the source into it. */
8589 gfc_init_block (&block
);
8590 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
8591 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
8592 gfc_add_modify (&block
, tmpdecl
,
8593 fold_convert (TREE_TYPE (ptr
), tmp
));
8594 tmp
= build_call_expr_loc (input_location
,
8595 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
8596 fold_convert (pvoid_type_node
, tmpdecl
),
8597 fold_convert (pvoid_type_node
, ptr
),
8598 fold_convert (size_type_node
, extent
));
8599 gfc_add_expr_to_block (&block
, tmp
);
8600 indirect
= gfc_finish_block (&block
);
8602 /* Wrap it up with the condition. */
8603 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
8604 dest_word_len
, source_bytes
);
8605 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
8606 gfc_add_expr_to_block (&se
->pre
, tmp
);
8608 /* Free the temporary string, if necessary. */
8609 free
= gfc_call_free (tmpdecl
);
8610 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8611 dest_word_len
, source_bytes
);
8612 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
8613 gfc_add_expr_to_block (&se
->post
, tmp
);
8616 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
8620 tmpdecl
= gfc_create_var (mold_type
, "transfer");
8622 ptr
= convert (build_pointer_type (mold_type
), source
);
8624 /* For CLASS results, allocate the needed memory first. */
8625 if (mold_expr
->ts
.type
== BT_CLASS
)
8628 cdata
= gfc_class_data_get (tmpdecl
);
8629 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
8630 gfc_add_modify (&se
->pre
, cdata
, tmp
);
8633 /* Use memcpy to do the transfer. */
8634 if (mold_expr
->ts
.type
== BT_CLASS
)
8635 tmp
= gfc_class_data_get (tmpdecl
);
8637 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
8639 tmp
= build_call_expr_loc (input_location
,
8640 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
8641 fold_convert (pvoid_type_node
, tmp
),
8642 fold_convert (pvoid_type_node
, ptr
),
8643 fold_convert (size_type_node
, extent
));
8644 gfc_add_expr_to_block (&se
->pre
, tmp
);
8646 /* For CLASS results, set the _vptr. */
8647 if (mold_expr
->ts
.type
== BT_CLASS
)
8651 vptr
= gfc_class_vptr_get (tmpdecl
);
8652 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
8654 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
8655 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
8663 /* Generate a call to caf_is_present. */
8666 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
8668 tree caf_reference
, caf_decl
, token
, image_index
;
8670 /* Compile the reference chain. */
8671 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
8672 gcc_assert (caf_reference
!= NULL_TREE
);
8674 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
8675 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8676 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8677 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
8678 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
8681 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
8682 3, token
, image_index
, caf_reference
);
8686 /* Test whether this ref-chain refs this image only. */
8689 caf_this_image_ref (gfc_ref
*ref
)
8691 for ( ; ref
; ref
= ref
->next
)
8692 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
8693 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
8699 /* Generate code for the ALLOCATED intrinsic.
8700 Generate inline code that directly check the address of the argument. */
8703 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
8705 gfc_actual_arglist
*arg1
;
8708 symbol_attribute caf_attr
;
8710 gfc_init_se (&arg1se
, NULL
);
8711 arg1
= expr
->value
.function
.actual
;
8713 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8715 /* Make sure that class array expressions have both a _data
8716 component reference and an array reference.... */
8717 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
8718 gfc_add_class_array_ref (arg1
->expr
);
8719 /* .... whilst scalars only need the _data component. */
8721 gfc_add_data_component (arg1
->expr
);
8724 /* When arg1 references an allocatable component in a coarray, then call
8725 the caf-library function caf_is_present (). */
8726 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
8727 && arg1
->expr
->value
.function
.isym
8728 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8729 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
8731 gfc_clear_attr (&caf_attr
);
8732 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
8733 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
8734 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
8737 if (arg1
->expr
->rank
== 0)
8739 /* Allocatable scalar. */
8740 arg1se
.want_pointer
= 1;
8741 gfc_conv_expr (&arg1se
, arg1
->expr
);
8746 /* Allocatable array. */
8747 arg1se
.descriptor_only
= 1;
8748 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8749 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8752 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
8753 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
8756 /* Components of pointer array references sometimes come back with a pre block. */
8757 if (arg1se
.pre
.head
)
8758 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8760 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
8764 /* Generate code for the ASSOCIATED intrinsic.
8765 If both POINTER and TARGET are arrays, generate a call to library function
8766 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
8767 In other cases, generate inline code that directly compare the address of
8768 POINTER with the address of TARGET. */
8771 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
8773 gfc_actual_arglist
*arg1
;
8774 gfc_actual_arglist
*arg2
;
8779 tree nonzero_arraylen
;
8783 gfc_init_se (&arg1se
, NULL
);
8784 gfc_init_se (&arg2se
, NULL
);
8785 arg1
= expr
->value
.function
.actual
;
8788 /* Check whether the expression is a scalar or not; we cannot use
8789 arg1->expr->rank as it can be nonzero for proc pointers. */
8790 ss
= gfc_walk_expr (arg1
->expr
);
8791 scalar
= ss
== gfc_ss_terminator
;
8793 gfc_free_ss_chain (ss
);
8797 /* No optional target. */
8800 /* A pointer to a scalar. */
8801 arg1se
.want_pointer
= 1;
8802 gfc_conv_expr (&arg1se
, arg1
->expr
);
8803 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8804 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
8805 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
8807 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8809 tmp2
= gfc_class_data_get (arg1se
.expr
);
8810 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
8811 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
8818 /* A pointer to an array. */
8819 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8820 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8822 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8823 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8824 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
8825 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
8830 /* An optional target. */
8831 if (arg2
->expr
->ts
.type
== BT_CLASS
)
8832 gfc_add_data_component (arg2
->expr
);
8836 /* A pointer to a scalar. */
8837 arg1se
.want_pointer
= 1;
8838 gfc_conv_expr (&arg1se
, arg1
->expr
);
8839 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8840 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
8841 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
8843 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8844 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
8846 arg2se
.want_pointer
= 1;
8847 gfc_conv_expr (&arg2se
, arg2
->expr
);
8848 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8849 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
8850 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
8852 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8853 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8854 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8855 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8856 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8857 arg1se
.expr
, arg2se
.expr
);
8858 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8859 arg1se
.expr
, null_pointer_node
);
8860 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8861 logical_type_node
, tmp
, tmp2
);
8865 /* An array pointer of zero length is not associated if target is
8867 arg1se
.descriptor_only
= 1;
8868 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
8869 if (arg1
->expr
->rank
== -1)
8871 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
8872 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8873 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
8876 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
8877 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
8878 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
8879 logical_type_node
, tmp
,
8880 build_int_cst (TREE_TYPE (tmp
), 0));
8882 /* A pointer to an array, call library function _gfor_associated. */
8883 arg1se
.want_pointer
= 1;
8884 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8885 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8886 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8888 arg2se
.want_pointer
= 1;
8889 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
8890 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8891 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8892 se
->expr
= build_call_expr_loc (input_location
,
8893 gfor_fndecl_associated
, 2,
8894 arg1se
.expr
, arg2se
.expr
);
8895 se
->expr
= convert (logical_type_node
, se
->expr
);
8896 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8897 logical_type_node
, se
->expr
,
8901 /* If target is present zero character length pointers cannot
8903 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
8905 tmp
= arg1se
.string_length
;
8906 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8907 logical_type_node
, tmp
,
8908 build_zero_cst (TREE_TYPE (tmp
)));
8909 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8910 logical_type_node
, se
->expr
, tmp
);
8914 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8918 /* Generate code for the SAME_TYPE_AS intrinsic.
8919 Generate inline code that directly checks the vindices. */
8922 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
8927 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
8929 gfc_init_se (&se1
, NULL
);
8930 gfc_init_se (&se2
, NULL
);
8932 a
= expr
->value
.function
.actual
->expr
;
8933 b
= expr
->value
.function
.actual
->next
->expr
;
8935 if (UNLIMITED_POLY (a
))
8937 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
8938 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8939 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
8942 if (UNLIMITED_POLY (b
))
8944 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
8945 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8946 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
8949 if (a
->ts
.type
== BT_CLASS
)
8951 gfc_add_vptr_component (a
);
8952 gfc_add_hash_component (a
);
8954 else if (a
->ts
.type
== BT_DERIVED
)
8955 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8956 a
->ts
.u
.derived
->hash_value
);
8958 if (b
->ts
.type
== BT_CLASS
)
8960 gfc_add_vptr_component (b
);
8961 gfc_add_hash_component (b
);
8963 else if (b
->ts
.type
== BT_DERIVED
)
8964 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8965 b
->ts
.u
.derived
->hash_value
);
8967 gfc_conv_expr (&se1
, a
);
8968 gfc_conv_expr (&se2
, b
);
8970 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
8971 logical_type_node
, se1
.expr
,
8972 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
8975 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
8976 logical_type_node
, conda
, tmp
);
8979 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
8980 logical_type_node
, condb
, tmp
);
8982 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
8986 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
8989 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
8993 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
8994 se
->expr
= build_call_expr_loc (input_location
,
8995 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
8996 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9000 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9003 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
9007 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
9009 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9010 type
= gfc_get_int_type (4);
9011 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
9013 /* Convert it to the required type. */
9014 type
= gfc_typenode_for_spec (&expr
->ts
);
9015 se
->expr
= build_call_expr_loc (input_location
,
9016 gfor_fndecl_si_kind
, 1, arg
);
9017 se
->expr
= fold_convert (type
, se
->expr
);
9021 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9024 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
9026 gfc_actual_arglist
*actual
;
9029 vec
<tree
, va_gc
> *args
= NULL
;
9031 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
9033 gfc_init_se (&argse
, se
);
9035 /* Pass a NULL pointer for an absent arg. */
9036 if (actual
->expr
== NULL
)
9037 argse
.expr
= null_pointer_node
;
9043 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
9045 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9046 ts
.type
= BT_INTEGER
;
9047 ts
.kind
= gfc_c_int_kind
;
9048 gfc_convert_type (actual
->expr
, &ts
, 2);
9050 gfc_conv_expr_reference (&argse
, actual
->expr
);
9053 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
9054 gfc_add_block_to_block (&se
->post
, &argse
.post
);
9055 vec_safe_push (args
, argse
.expr
);
9058 /* Convert it to the required type. */
9059 type
= gfc_typenode_for_spec (&expr
->ts
);
9060 se
->expr
= build_call_expr_loc_vec (input_location
,
9061 gfor_fndecl_sr_kind
, args
);
9062 se
->expr
= fold_convert (type
, se
->expr
);
9066 /* Generate code for TRIM (A) intrinsic function. */
9069 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
9079 unsigned int num_args
;
9081 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
9082 args
= XALLOCAVEC (tree
, num_args
);
9084 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
9085 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
9086 len
= gfc_create_var (gfc_charlen_type_node
, "len");
9088 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
9089 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
9092 if (expr
->ts
.kind
== 1)
9093 function
= gfor_fndecl_string_trim
;
9094 else if (expr
->ts
.kind
== 4)
9095 function
= gfor_fndecl_string_trim_char4
;
9099 fndecl
= build_addr (function
);
9100 tmp
= build_call_array_loc (input_location
,
9101 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
9103 gfc_add_expr_to_block (&se
->pre
, tmp
);
9105 /* Free the temporary afterwards, if necessary. */
9106 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
9107 len
, build_int_cst (TREE_TYPE (len
), 0));
9108 tmp
= gfc_call_free (var
);
9109 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
9110 gfc_add_expr_to_block (&se
->post
, tmp
);
9113 se
->string_length
= len
;
9117 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9120 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
9122 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
9123 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
9125 stmtblock_t block
, body
;
9128 /* We store in charsize the size of a character. */
9129 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
9130 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
9132 /* Get the arguments. */
9133 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
9134 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
9136 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
9137 ncopies_type
= TREE_TYPE (ncopies
);
9139 /* Check that NCOPIES is not negative. */
9140 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
9141 build_int_cst (ncopies_type
, 0));
9142 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
9143 "Argument NCOPIES of REPEAT intrinsic is negative "
9144 "(its value is %ld)",
9145 fold_convert (long_integer_type_node
, ncopies
));
9147 /* If the source length is zero, any non negative value of NCOPIES
9148 is valid, and nothing happens. */
9149 n
= gfc_create_var (ncopies_type
, "ncopies");
9150 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
9152 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
9153 build_int_cst (ncopies_type
, 0), ncopies
);
9154 gfc_add_modify (&se
->pre
, n
, tmp
);
9157 /* Check that ncopies is not too large: ncopies should be less than
9158 (or equal to) MAX / slen, where MAX is the maximal integer of
9159 the gfc_charlen_type_node type. If slen == 0, we need a special
9160 case to avoid the division by zero. */
9161 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
9162 fold_convert (sizetype
,
9163 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
9165 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
9166 ? sizetype
: ncopies_type
;
9167 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
9168 fold_convert (largest
, ncopies
),
9169 fold_convert (largest
, max
));
9170 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
9172 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
9173 logical_false_node
, cond
);
9174 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
9175 "Argument NCOPIES of REPEAT intrinsic is too large");
9177 /* Compute the destination length. */
9178 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
9179 fold_convert (gfc_charlen_type_node
, slen
),
9180 fold_convert (gfc_charlen_type_node
, ncopies
));
9181 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
9182 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
9184 /* Generate the code to do the repeat operation:
9185 for (i = 0; i < ncopies; i++)
9186 memmove (dest + (i * slen * size), src, slen*size); */
9187 gfc_start_block (&block
);
9188 count
= gfc_create_var (sizetype
, "count");
9189 gfc_add_modify (&block
, count
, size_zero_node
);
9190 exit_label
= gfc_build_label_decl (NULL_TREE
);
9192 /* Start the loop body. */
9193 gfc_start_block (&body
);
9195 /* Exit the loop if count >= ncopies. */
9196 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
9197 fold_convert (sizetype
, ncopies
));
9198 tmp
= build1_v (GOTO_EXPR
, exit_label
);
9199 TREE_USED (exit_label
) = 1;
9200 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
9201 build_empty_stmt (input_location
));
9202 gfc_add_expr_to_block (&body
, tmp
);
9204 /* Call memmove (dest + (i*slen*size), src, slen*size). */
9205 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
9207 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
9209 tmp
= fold_build_pointer_plus_loc (input_location
,
9210 fold_convert (pvoid_type_node
, dest
), tmp
);
9211 tmp
= build_call_expr_loc (input_location
,
9212 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
9214 fold_build2_loc (input_location
, MULT_EXPR
,
9215 size_type_node
, slen
, size
));
9216 gfc_add_expr_to_block (&body
, tmp
);
9218 /* Increment count. */
9219 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
9220 count
, size_one_node
);
9221 gfc_add_modify (&body
, count
, tmp
);
9223 /* Build the loop. */
9224 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
9225 gfc_add_expr_to_block (&block
, tmp
);
9227 /* Add the exit label. */
9228 tmp
= build1_v (LABEL_EXPR
, exit_label
);
9229 gfc_add_expr_to_block (&block
, tmp
);
9231 /* Finish the block. */
9232 tmp
= gfc_finish_block (&block
);
9233 gfc_add_expr_to_block (&se
->pre
, tmp
);
9235 /* Set the result value. */
9237 se
->string_length
= dlen
;
9241 /* Generate code for the IARGC intrinsic. */
9244 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
9250 /* Call the library function. This always returns an INTEGER(4). */
9251 fndecl
= gfor_fndecl_iargc
;
9252 tmp
= build_call_expr_loc (input_location
,
9255 /* Convert it to the required type. */
9256 type
= gfc_typenode_for_spec (&expr
->ts
);
9257 tmp
= fold_convert (type
, tmp
);
9263 /* Generate code for the KILL intrinsic. */
9266 conv_intrinsic_kill (gfc_se
*se
, gfc_expr
*expr
)
9269 tree int4_type_node
= gfc_get_int_type (4);
9273 unsigned int num_args
;
9275 num_args
= gfc_intrinsic_argument_list_length (expr
);
9276 args
= XALLOCAVEC (tree
, num_args
);
9277 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
9279 /* Convert PID to a INTEGER(4) entity. */
9280 pid
= convert (int4_type_node
, args
[0]);
9282 /* Convert SIG to a INTEGER(4) entity. */
9283 sig
= convert (int4_type_node
, args
[1]);
9285 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill
, 2, pid
, sig
);
9287 se
->expr
= fold_convert (TREE_TYPE (args
[0]), tmp
);
9292 conv_intrinsic_kill_sub (gfc_code
*code
)
9296 tree int4_type_node
= gfc_get_int_type (4);
9302 /* Make the function call. */
9303 gfc_init_block (&block
);
9304 gfc_init_se (&se
, NULL
);
9306 /* Convert PID to a INTEGER(4) entity. */
9307 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
9308 gfc_add_block_to_block (&block
, &se
.pre
);
9309 pid
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
9310 gfc_add_block_to_block (&block
, &se
.post
);
9312 /* Convert SIG to a INTEGER(4) entity. */
9313 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
9314 gfc_add_block_to_block (&block
, &se
.pre
);
9315 sig
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
9316 gfc_add_block_to_block (&block
, &se
.post
);
9318 /* Deal with an optional STATUS. */
9319 if (code
->ext
.actual
->next
->next
->expr
)
9321 gfc_init_se (&se_stat
, NULL
);
9322 gfc_conv_expr (&se_stat
, code
->ext
.actual
->next
->next
->expr
);
9323 statp
= gfc_create_var (gfc_get_int_type (4), "_statp");
9328 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill_sub
, 3, pid
, sig
,
9329 statp
? gfc_build_addr_expr (NULL_TREE
, statp
) : null_pointer_node
);
9331 gfc_add_expr_to_block (&block
, tmp
);
9333 if (statp
&& statp
!= se_stat
.expr
)
9334 gfc_add_modify (&block
, se_stat
.expr
,
9335 fold_convert (TREE_TYPE (se_stat
.expr
), statp
));
9337 return gfc_finish_block (&block
);
9342 /* The loc intrinsic returns the address of its argument as
9343 gfc_index_integer_kind integer. */
9346 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
9351 gcc_assert (!se
->ss
);
9353 arg_expr
= expr
->value
.function
.actual
->expr
;
9354 if (arg_expr
->rank
== 0)
9356 if (arg_expr
->ts
.type
== BT_CLASS
)
9357 gfc_add_data_component (arg_expr
);
9358 gfc_conv_expr_reference (se
, arg_expr
);
9361 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
9362 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
9364 /* Create a temporary variable for loc return value. Without this,
9365 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
9366 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
9367 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
9368 se
->expr
= temp_var
;
9372 /* The following routine generates code for the intrinsic
9373 functions from the ISO_C_BINDING module:
9379 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
9381 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
9383 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
9385 if (arg
->expr
->rank
== 0)
9386 gfc_conv_expr_reference (se
, arg
->expr
);
9387 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
9388 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
9391 gfc_conv_expr_descriptor (se
, arg
->expr
);
9392 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
9395 /* TODO -- the following two lines shouldn't be necessary, but if
9396 they're removed, a bug is exposed later in the code path.
9397 This workaround was thus introduced, but will have to be
9398 removed; please see PR 35150 for details about the issue. */
9399 se
->expr
= convert (pvoid_type_node
, se
->expr
);
9400 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
9402 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
9403 gfc_conv_expr_reference (se
, arg
->expr
);
9404 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
9409 /* Build the addr_expr for the first argument. The argument is
9410 already an *address* so we don't need to set want_pointer in
9412 gfc_init_se (&arg1se
, NULL
);
9413 gfc_conv_expr (&arg1se
, arg
->expr
);
9414 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
9415 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
9417 /* See if we were given two arguments. */
9418 if (arg
->next
->expr
== NULL
)
9419 /* Only given one arg so generate a null and do a
9420 not-equal comparison against the first arg. */
9421 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9423 fold_convert (TREE_TYPE (arg1se
.expr
),
9424 null_pointer_node
));
9430 /* Given two arguments so build the arg2se from second arg. */
9431 gfc_init_se (&arg2se
, NULL
);
9432 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
9433 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
9434 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
9436 /* Generate test to compare that the two args are equal. */
9437 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9438 arg1se
.expr
, arg2se
.expr
);
9439 /* Generate test to ensure that the first arg is not null. */
9440 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
9442 arg1se
.expr
, null_pointer_node
);
9444 /* Finally, the generated test must check that both arg1 is not
9445 NULL and that it is equal to the second arg. */
9446 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9448 not_null_expr
, eq_expr
);
9456 /* The following routine generates code for the intrinsic
9457 subroutines from the ISO_C_BINDING module:
9459 * C_F_PROCPOINTER. */
9462 conv_isocbinding_subroutine (gfc_code
*code
)
9469 tree desc
, dim
, tmp
, stride
, offset
;
9470 stmtblock_t body
, block
;
9472 gfc_actual_arglist
*arg
= code
->ext
.actual
;
9474 gfc_init_se (&se
, NULL
);
9475 gfc_init_se (&cptrse
, NULL
);
9476 gfc_conv_expr (&cptrse
, arg
->expr
);
9477 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
9478 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
9480 gfc_init_se (&fptrse
, NULL
);
9481 if (arg
->next
->expr
->rank
== 0)
9483 fptrse
.want_pointer
= 1;
9484 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
9485 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
9486 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
9487 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
9488 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
9489 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
9491 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9492 TREE_TYPE (fptrse
.expr
),
9494 fold_convert (TREE_TYPE (fptrse
.expr
),
9496 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
9497 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9498 return gfc_finish_block (&se
.pre
);
9501 gfc_start_block (&block
);
9503 /* Get the descriptor of the Fortran pointer. */
9504 fptrse
.descriptor_only
= 1;
9505 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
9506 gfc_add_block_to_block (&block
, &fptrse
.pre
);
9509 /* Set the span field. */
9510 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
9511 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9512 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
9514 /* Set data value, dtype, and offset. */
9515 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
9516 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
9517 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
9518 gfc_get_dtype (TREE_TYPE (desc
)));
9520 /* Start scalarization of the bounds, using the shape argument. */
9522 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
9523 gcc_assert (shape_ss
!= gfc_ss_terminator
);
9524 gfc_init_se (&shapese
, NULL
);
9526 gfc_init_loopinfo (&loop
);
9527 gfc_add_ss_to_loop (&loop
, shape_ss
);
9528 gfc_conv_ss_startstride (&loop
);
9529 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
9530 gfc_mark_ss_chain_used (shape_ss
, 1);
9532 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
9533 shapese
.ss
= shape_ss
;
9535 stride
= gfc_create_var (gfc_array_index_type
, "stride");
9536 offset
= gfc_create_var (gfc_array_index_type
, "offset");
9537 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
9538 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
9541 gfc_start_scalarized_body (&loop
, &body
);
9543 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
9544 loop
.loopvar
[0], loop
.from
[0]);
9546 /* Set bounds and stride. */
9547 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
9548 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
9550 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
9551 gfc_add_block_to_block (&body
, &shapese
.pre
);
9552 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
9553 gfc_add_block_to_block (&body
, &shapese
.post
);
9555 /* Calculate offset. */
9556 gfc_add_modify (&body
, offset
,
9557 fold_build2_loc (input_location
, PLUS_EXPR
,
9558 gfc_array_index_type
, offset
, stride
));
9559 /* Update stride. */
9560 gfc_add_modify (&body
, stride
,
9561 fold_build2_loc (input_location
, MULT_EXPR
,
9562 gfc_array_index_type
, stride
,
9563 fold_convert (gfc_array_index_type
,
9565 /* Finish scalarization loop. */
9566 gfc_trans_scalarizing_loops (&loop
, &body
);
9567 gfc_add_block_to_block (&block
, &loop
.pre
);
9568 gfc_add_block_to_block (&block
, &loop
.post
);
9569 gfc_add_block_to_block (&block
, &fptrse
.post
);
9570 gfc_cleanup_loop (&loop
);
9572 gfc_add_modify (&block
, offset
,
9573 fold_build1_loc (input_location
, NEGATE_EXPR
,
9574 gfc_array_index_type
, offset
));
9575 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
9577 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
9578 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9579 return gfc_finish_block (&se
.pre
);
9583 /* Save and restore floating-point state. */
9586 gfc_save_fp_state (stmtblock_t
*block
)
9588 tree type
, fpstate
, tmp
;
9590 type
= build_array_type (char_type_node
,
9591 build_range_type (size_type_node
, size_zero_node
,
9592 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
9593 fpstate
= gfc_create_var (type
, "fpstate");
9594 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
9596 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
9598 gfc_add_expr_to_block (block
, tmp
);
9605 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
9609 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
9611 gfc_add_expr_to_block (block
, tmp
);
9615 /* Generate code for arguments of IEEE functions. */
9618 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
9621 gfc_actual_arglist
*actual
;
9626 actual
= expr
->value
.function
.actual
;
9627 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
9629 gcc_assert (actual
);
9632 gfc_init_se (&argse
, se
);
9633 gfc_conv_expr_val (&argse
, e
);
9635 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
9636 gfc_add_block_to_block (&se
->post
, &argse
.post
);
9637 argarray
[arg
] = argse
.expr
;
9642 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
9643 and IEEE_UNORDERED, which translate directly to GCC type-generic
9647 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
9648 enum built_in_function code
, int nargs
)
9651 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
9653 conv_ieee_function_args (se
, expr
, args
, nargs
);
9654 se
->expr
= build_call_expr_loc_array (input_location
,
9655 builtin_decl_explicit (code
),
9657 STRIP_TYPE_NOPS (se
->expr
);
9658 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9662 /* Generate code for IEEE_IS_NORMAL intrinsic:
9663 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
9666 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
9668 tree arg
, isnormal
, iszero
;
9670 /* Convert arg, evaluate it only once. */
9671 conv_ieee_function_args (se
, expr
, &arg
, 1);
9672 arg
= gfc_evaluate_now (arg
, &se
->pre
);
9674 isnormal
= build_call_expr_loc (input_location
,
9675 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
9677 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
9678 build_real_from_int_cst (TREE_TYPE (arg
),
9679 integer_zero_node
));
9680 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9681 logical_type_node
, isnormal
, iszero
);
9682 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9686 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
9687 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
9690 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
9692 tree arg
, signbit
, isnan
;
9694 /* Convert arg, evaluate it only once. */
9695 conv_ieee_function_args (se
, expr
, &arg
, 1);
9696 arg
= gfc_evaluate_now (arg
, &se
->pre
);
9698 isnan
= build_call_expr_loc (input_location
,
9699 builtin_decl_explicit (BUILT_IN_ISNAN
),
9701 STRIP_TYPE_NOPS (isnan
);
9703 signbit
= build_call_expr_loc (input_location
,
9704 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
9706 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9707 signbit
, integer_zero_node
);
9709 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9710 logical_type_node
, signbit
,
9711 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
9712 TREE_TYPE(isnan
), isnan
));
9714 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9718 /* Generate code for IEEE_LOGB and IEEE_RINT. */
9721 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
9722 enum built_in_function code
)
9724 tree arg
, decl
, call
, fpstate
;
9727 conv_ieee_function_args (se
, expr
, &arg
, 1);
9728 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
9729 decl
= builtin_decl_for_precision (code
, argprec
);
9731 /* Save floating-point state. */
9732 fpstate
= gfc_save_fp_state (&se
->pre
);
9734 /* Make the function call. */
9735 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
9736 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
9738 /* Restore floating-point state. */
9739 gfc_restore_fp_state (&se
->post
, fpstate
);
9743 /* Generate code for IEEE_REM. */
9746 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
9748 tree args
[2], decl
, call
, fpstate
;
9751 conv_ieee_function_args (se
, expr
, args
, 2);
9753 /* If arguments have unequal size, convert them to the larger. */
9754 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
9755 > TYPE_PRECISION (TREE_TYPE (args
[1])))
9756 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
9757 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
9758 > TYPE_PRECISION (TREE_TYPE (args
[0])))
9759 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
9761 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9762 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
9764 /* Save floating-point state. */
9765 fpstate
= gfc_save_fp_state (&se
->pre
);
9767 /* Make the function call. */
9768 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9769 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9771 /* Restore floating-point state. */
9772 gfc_restore_fp_state (&se
->post
, fpstate
);
9776 /* Generate code for IEEE_NEXT_AFTER. */
9779 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
9781 tree args
[2], decl
, call
, fpstate
;
9784 conv_ieee_function_args (se
, expr
, args
, 2);
9786 /* Result has the characteristics of first argument. */
9787 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
9788 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9789 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
9791 /* Save floating-point state. */
9792 fpstate
= gfc_save_fp_state (&se
->pre
);
9794 /* Make the function call. */
9795 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9796 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9798 /* Restore floating-point state. */
9799 gfc_restore_fp_state (&se
->post
, fpstate
);
9803 /* Generate code for IEEE_SCALB. */
9806 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
9808 tree args
[2], decl
, call
, huge
, type
;
9811 conv_ieee_function_args (se
, expr
, args
, 2);
9813 /* Result has the characteristics of first argument. */
9814 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9815 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
9817 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
9819 /* We need to fold the integer into the range of a C int. */
9820 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
9821 type
= TREE_TYPE (args
[1]);
9823 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
9824 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
9826 huge
= fold_convert (type
, huge
);
9827 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
9829 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
9830 fold_build1_loc (input_location
, NEGATE_EXPR
,
9834 args
[1] = fold_convert (integer_type_node
, args
[1]);
9836 /* Make the function call. */
9837 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9838 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9842 /* Generate code for IEEE_COPY_SIGN. */
9845 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
9847 tree args
[2], decl
, sign
;
9850 conv_ieee_function_args (se
, expr
, args
, 2);
9852 /* Get the sign of the second argument. */
9853 sign
= build_call_expr_loc (input_location
,
9854 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
9856 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9857 sign
, integer_zero_node
);
9859 /* Create a value of one, with the right sign. */
9860 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
9862 fold_build1_loc (input_location
, NEGATE_EXPR
,
9866 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
9868 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9869 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
9871 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9875 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
9879 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
9881 const char *name
= expr
->value
.function
.name
;
9883 if (gfc_str_startswith (name
, "_gfortran_ieee_is_nan"))
9884 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
9885 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_finite"))
9886 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
9887 else if (gfc_str_startswith (name
, "_gfortran_ieee_unordered"))
9888 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
9889 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_normal"))
9890 conv_intrinsic_ieee_is_normal (se
, expr
);
9891 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_negative"))
9892 conv_intrinsic_ieee_is_negative (se
, expr
);
9893 else if (gfc_str_startswith (name
, "_gfortran_ieee_copy_sign"))
9894 conv_intrinsic_ieee_copy_sign (se
, expr
);
9895 else if (gfc_str_startswith (name
, "_gfortran_ieee_scalb"))
9896 conv_intrinsic_ieee_scalb (se
, expr
);
9897 else if (gfc_str_startswith (name
, "_gfortran_ieee_next_after"))
9898 conv_intrinsic_ieee_next_after (se
, expr
);
9899 else if (gfc_str_startswith (name
, "_gfortran_ieee_rem"))
9900 conv_intrinsic_ieee_rem (se
, expr
);
9901 else if (gfc_str_startswith (name
, "_gfortran_ieee_logb"))
9902 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
9903 else if (gfc_str_startswith (name
, "_gfortran_ieee_rint"))
9904 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
9906 /* It is not among the functions we translate directly. We return
9907 false, so a library function call is emitted. */
9914 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
9917 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
9919 tree arg
, res
, restype
;
9921 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
9922 arg
= fold_convert (size_type_node
, arg
);
9923 res
= build_call_expr_loc (input_location
,
9924 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
9925 restype
= gfc_typenode_for_spec (&expr
->ts
);
9926 se
->expr
= fold_convert (restype
, res
);
9930 /* Generate code for an intrinsic function. Some map directly to library
9931 calls, others get special handling. In some cases the name of the function
9932 used depends on the type specifiers. */
9935 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
9941 name
= &expr
->value
.function
.name
[2];
9945 lib
= gfc_is_intrinsic_libcall (expr
);
9949 se
->ignore_optional
= 1;
9951 switch (expr
->value
.function
.isym
->id
)
9953 case GFC_ISYM_EOSHIFT
:
9955 case GFC_ISYM_RESHAPE
:
9956 /* For all of those the first argument specifies the type and the
9957 third is optional. */
9958 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
9961 case GFC_ISYM_FINDLOC
:
9962 gfc_conv_intrinsic_findloc (se
, expr
);
9965 case GFC_ISYM_MINLOC
:
9966 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9969 case GFC_ISYM_MAXLOC
:
9970 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9973 case GFC_ISYM_SHAPE
:
9974 gfc_conv_intrinsic_shape (se
, expr
);
9978 gfc_conv_intrinsic_funcall (se
, expr
);
9986 switch (expr
->value
.function
.isym
->id
)
9991 case GFC_ISYM_REPEAT
:
9992 gfc_conv_intrinsic_repeat (se
, expr
);
9996 gfc_conv_intrinsic_trim (se
, expr
);
9999 case GFC_ISYM_SC_KIND
:
10000 gfc_conv_intrinsic_sc_kind (se
, expr
);
10003 case GFC_ISYM_SI_KIND
:
10004 gfc_conv_intrinsic_si_kind (se
, expr
);
10007 case GFC_ISYM_SR_KIND
:
10008 gfc_conv_intrinsic_sr_kind (se
, expr
);
10011 case GFC_ISYM_EXPONENT
:
10012 gfc_conv_intrinsic_exponent (se
, expr
);
10015 case GFC_ISYM_SCAN
:
10016 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10018 fndecl
= gfor_fndecl_string_scan
;
10019 else if (kind
== 4)
10020 fndecl
= gfor_fndecl_string_scan_char4
;
10022 gcc_unreachable ();
10024 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10027 case GFC_ISYM_VERIFY
:
10028 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10030 fndecl
= gfor_fndecl_string_verify
;
10031 else if (kind
== 4)
10032 fndecl
= gfor_fndecl_string_verify_char4
;
10034 gcc_unreachable ();
10036 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10039 case GFC_ISYM_ALLOCATED
:
10040 gfc_conv_allocated (se
, expr
);
10043 case GFC_ISYM_ASSOCIATED
:
10044 gfc_conv_associated(se
, expr
);
10047 case GFC_ISYM_SAME_TYPE_AS
:
10048 gfc_conv_same_type_as (se
, expr
);
10052 gfc_conv_intrinsic_abs (se
, expr
);
10055 case GFC_ISYM_ADJUSTL
:
10056 if (expr
->ts
.kind
== 1)
10057 fndecl
= gfor_fndecl_adjustl
;
10058 else if (expr
->ts
.kind
== 4)
10059 fndecl
= gfor_fndecl_adjustl_char4
;
10061 gcc_unreachable ();
10063 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
10066 case GFC_ISYM_ADJUSTR
:
10067 if (expr
->ts
.kind
== 1)
10068 fndecl
= gfor_fndecl_adjustr
;
10069 else if (expr
->ts
.kind
== 4)
10070 fndecl
= gfor_fndecl_adjustr_char4
;
10072 gcc_unreachable ();
10074 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
10077 case GFC_ISYM_AIMAG
:
10078 gfc_conv_intrinsic_imagpart (se
, expr
);
10081 case GFC_ISYM_AINT
:
10082 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
10086 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
10089 case GFC_ISYM_ANINT
:
10090 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
10094 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
10098 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
10101 case GFC_ISYM_ACOSD
:
10102 case GFC_ISYM_ASIND
:
10103 case GFC_ISYM_ATAND
:
10104 gfc_conv_intrinsic_atrigd (se
, expr
, expr
->value
.function
.isym
->id
);
10107 case GFC_ISYM_COTAN
:
10108 gfc_conv_intrinsic_cotan (se
, expr
);
10111 case GFC_ISYM_COTAND
:
10112 gfc_conv_intrinsic_cotand (se
, expr
);
10115 case GFC_ISYM_ATAN2D
:
10116 gfc_conv_intrinsic_atan2d (se
, expr
);
10119 case GFC_ISYM_BTEST
:
10120 gfc_conv_intrinsic_btest (se
, expr
);
10124 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
10128 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
10132 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
10136 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
10139 case GFC_ISYM_C_ASSOCIATED
:
10140 case GFC_ISYM_C_FUNLOC
:
10141 case GFC_ISYM_C_LOC
:
10142 conv_isocbinding_function (se
, expr
);
10145 case GFC_ISYM_ACHAR
:
10146 case GFC_ISYM_CHAR
:
10147 gfc_conv_intrinsic_char (se
, expr
);
10150 case GFC_ISYM_CONVERSION
:
10151 case GFC_ISYM_DBLE
:
10152 case GFC_ISYM_DFLOAT
:
10153 case GFC_ISYM_FLOAT
:
10154 case GFC_ISYM_LOGICAL
:
10155 case GFC_ISYM_REAL
:
10156 case GFC_ISYM_REALPART
:
10157 case GFC_ISYM_SNGL
:
10158 gfc_conv_intrinsic_conversion (se
, expr
);
10161 /* Integer conversions are handled separately to make sure we get the
10162 correct rounding mode. */
10164 case GFC_ISYM_INT2
:
10165 case GFC_ISYM_INT8
:
10166 case GFC_ISYM_LONG
:
10167 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
10170 case GFC_ISYM_NINT
:
10171 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
10174 case GFC_ISYM_CEILING
:
10175 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
10178 case GFC_ISYM_FLOOR
:
10179 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
10183 gfc_conv_intrinsic_mod (se
, expr
, 0);
10186 case GFC_ISYM_MODULO
:
10187 gfc_conv_intrinsic_mod (se
, expr
, 1);
10190 case GFC_ISYM_CAF_GET
:
10191 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10195 case GFC_ISYM_CMPLX
:
10196 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
10199 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
10200 gfc_conv_intrinsic_iargc (se
, expr
);
10203 case GFC_ISYM_COMPLEX
:
10204 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
10207 case GFC_ISYM_CONJG
:
10208 gfc_conv_intrinsic_conjg (se
, expr
);
10211 case GFC_ISYM_COUNT
:
10212 gfc_conv_intrinsic_count (se
, expr
);
10215 case GFC_ISYM_CTIME
:
10216 gfc_conv_intrinsic_ctime (se
, expr
);
10220 gfc_conv_intrinsic_dim (se
, expr
);
10223 case GFC_ISYM_DOT_PRODUCT
:
10224 gfc_conv_intrinsic_dot_product (se
, expr
);
10227 case GFC_ISYM_DPROD
:
10228 gfc_conv_intrinsic_dprod (se
, expr
);
10231 case GFC_ISYM_DSHIFTL
:
10232 gfc_conv_intrinsic_dshift (se
, expr
, true);
10235 case GFC_ISYM_DSHIFTR
:
10236 gfc_conv_intrinsic_dshift (se
, expr
, false);
10239 case GFC_ISYM_FDATE
:
10240 gfc_conv_intrinsic_fdate (se
, expr
);
10243 case GFC_ISYM_FRACTION
:
10244 gfc_conv_intrinsic_fraction (se
, expr
);
10247 case GFC_ISYM_IALL
:
10248 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
10251 case GFC_ISYM_IAND
:
10252 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
10255 case GFC_ISYM_IANY
:
10256 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
10259 case GFC_ISYM_IBCLR
:
10260 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
10263 case GFC_ISYM_IBITS
:
10264 gfc_conv_intrinsic_ibits (se
, expr
);
10267 case GFC_ISYM_IBSET
:
10268 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
10271 case GFC_ISYM_IACHAR
:
10272 case GFC_ISYM_ICHAR
:
10273 /* We assume ASCII character sequence. */
10274 gfc_conv_intrinsic_ichar (se
, expr
);
10277 case GFC_ISYM_IARGC
:
10278 gfc_conv_intrinsic_iargc (se
, expr
);
10281 case GFC_ISYM_IEOR
:
10282 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
10285 case GFC_ISYM_INDEX
:
10286 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10288 fndecl
= gfor_fndecl_string_index
;
10289 else if (kind
== 4)
10290 fndecl
= gfor_fndecl_string_index_char4
;
10292 gcc_unreachable ();
10294 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10298 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
10301 case GFC_ISYM_IPARITY
:
10302 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
10305 case GFC_ISYM_IS_IOSTAT_END
:
10306 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
10309 case GFC_ISYM_IS_IOSTAT_EOR
:
10310 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
10313 case GFC_ISYM_IS_CONTIGUOUS
:
10314 gfc_conv_intrinsic_is_contiguous (se
, expr
);
10317 case GFC_ISYM_ISNAN
:
10318 gfc_conv_intrinsic_isnan (se
, expr
);
10321 case GFC_ISYM_KILL
:
10322 conv_intrinsic_kill (se
, expr
);
10325 case GFC_ISYM_LSHIFT
:
10326 gfc_conv_intrinsic_shift (se
, expr
, false, false);
10329 case GFC_ISYM_RSHIFT
:
10330 gfc_conv_intrinsic_shift (se
, expr
, true, true);
10333 case GFC_ISYM_SHIFTA
:
10334 gfc_conv_intrinsic_shift (se
, expr
, true, true);
10337 case GFC_ISYM_SHIFTL
:
10338 gfc_conv_intrinsic_shift (se
, expr
, false, false);
10341 case GFC_ISYM_SHIFTR
:
10342 gfc_conv_intrinsic_shift (se
, expr
, true, false);
10345 case GFC_ISYM_ISHFT
:
10346 gfc_conv_intrinsic_ishft (se
, expr
);
10349 case GFC_ISYM_ISHFTC
:
10350 gfc_conv_intrinsic_ishftc (se
, expr
);
10353 case GFC_ISYM_LEADZ
:
10354 gfc_conv_intrinsic_leadz (se
, expr
);
10357 case GFC_ISYM_TRAILZ
:
10358 gfc_conv_intrinsic_trailz (se
, expr
);
10361 case GFC_ISYM_POPCNT
:
10362 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
10365 case GFC_ISYM_POPPAR
:
10366 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
10369 case GFC_ISYM_LBOUND
:
10370 gfc_conv_intrinsic_bound (se
, expr
, 0);
10373 case GFC_ISYM_LCOBOUND
:
10374 conv_intrinsic_cobound (se
, expr
);
10377 case GFC_ISYM_TRANSPOSE
:
10378 /* The scalarizer has already been set up for reversed dimension access
10379 order ; now we just get the argument value normally. */
10380 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
10384 gfc_conv_intrinsic_len (se
, expr
);
10387 case GFC_ISYM_LEN_TRIM
:
10388 gfc_conv_intrinsic_len_trim (se
, expr
);
10392 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
10396 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
10400 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
10404 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
10407 case GFC_ISYM_MALLOC
:
10408 gfc_conv_intrinsic_malloc (se
, expr
);
10411 case GFC_ISYM_MASKL
:
10412 gfc_conv_intrinsic_mask (se
, expr
, 1);
10415 case GFC_ISYM_MASKR
:
10416 gfc_conv_intrinsic_mask (se
, expr
, 0);
10420 if (expr
->ts
.type
== BT_CHARACTER
)
10421 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
10423 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
10426 case GFC_ISYM_MAXLOC
:
10427 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
10430 case GFC_ISYM_FINDLOC
:
10431 gfc_conv_intrinsic_findloc (se
, expr
);
10434 case GFC_ISYM_MAXVAL
:
10435 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
10438 case GFC_ISYM_MERGE
:
10439 gfc_conv_intrinsic_merge (se
, expr
);
10442 case GFC_ISYM_MERGE_BITS
:
10443 gfc_conv_intrinsic_merge_bits (se
, expr
);
10447 if (expr
->ts
.type
== BT_CHARACTER
)
10448 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
10450 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
10453 case GFC_ISYM_MINLOC
:
10454 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
10457 case GFC_ISYM_MINVAL
:
10458 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
10461 case GFC_ISYM_NEAREST
:
10462 gfc_conv_intrinsic_nearest (se
, expr
);
10465 case GFC_ISYM_NORM2
:
10466 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
10470 gfc_conv_intrinsic_not (se
, expr
);
10474 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
10477 case GFC_ISYM_PARITY
:
10478 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
10481 case GFC_ISYM_PRESENT
:
10482 gfc_conv_intrinsic_present (se
, expr
);
10485 case GFC_ISYM_PRODUCT
:
10486 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
10489 case GFC_ISYM_RANK
:
10490 gfc_conv_intrinsic_rank (se
, expr
);
10493 case GFC_ISYM_RRSPACING
:
10494 gfc_conv_intrinsic_rrspacing (se
, expr
);
10497 case GFC_ISYM_SET_EXPONENT
:
10498 gfc_conv_intrinsic_set_exponent (se
, expr
);
10501 case GFC_ISYM_SCALE
:
10502 gfc_conv_intrinsic_scale (se
, expr
);
10505 case GFC_ISYM_SIGN
:
10506 gfc_conv_intrinsic_sign (se
, expr
);
10509 case GFC_ISYM_SIZE
:
10510 gfc_conv_intrinsic_size (se
, expr
);
10513 case GFC_ISYM_SIZEOF
:
10514 case GFC_ISYM_C_SIZEOF
:
10515 gfc_conv_intrinsic_sizeof (se
, expr
);
10518 case GFC_ISYM_STORAGE_SIZE
:
10519 gfc_conv_intrinsic_storage_size (se
, expr
);
10522 case GFC_ISYM_SPACING
:
10523 gfc_conv_intrinsic_spacing (se
, expr
);
10526 case GFC_ISYM_STRIDE
:
10527 conv_intrinsic_stride (se
, expr
);
10531 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
10534 case GFC_ISYM_TEAM_NUMBER
:
10535 conv_intrinsic_team_number (se
, expr
);
10538 case GFC_ISYM_TRANSFER
:
10539 if (se
->ss
&& se
->ss
->info
->useflags
)
10540 /* Access the previously obtained result. */
10541 gfc_conv_tmp_array_ref (se
);
10543 gfc_conv_intrinsic_transfer (se
, expr
);
10546 case GFC_ISYM_TTYNAM
:
10547 gfc_conv_intrinsic_ttynam (se
, expr
);
10550 case GFC_ISYM_UBOUND
:
10551 gfc_conv_intrinsic_bound (se
, expr
, 1);
10554 case GFC_ISYM_UCOBOUND
:
10555 conv_intrinsic_cobound (se
, expr
);
10559 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
10563 gfc_conv_intrinsic_loc (se
, expr
);
10566 case GFC_ISYM_THIS_IMAGE
:
10567 /* For num_images() == 1, handle as LCOBOUND. */
10568 if (expr
->value
.function
.actual
->expr
10569 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
10570 conv_intrinsic_cobound (se
, expr
);
10572 trans_this_image (se
, expr
);
10575 case GFC_ISYM_IMAGE_INDEX
:
10576 trans_image_index (se
, expr
);
10579 case GFC_ISYM_IMAGE_STATUS
:
10580 conv_intrinsic_image_status (se
, expr
);
10583 case GFC_ISYM_NUM_IMAGES
:
10584 trans_num_images (se
, expr
);
10587 case GFC_ISYM_ACCESS
:
10588 case GFC_ISYM_CHDIR
:
10589 case GFC_ISYM_CHMOD
:
10590 case GFC_ISYM_DTIME
:
10591 case GFC_ISYM_ETIME
:
10592 case GFC_ISYM_EXTENDS_TYPE_OF
:
10593 case GFC_ISYM_FGET
:
10594 case GFC_ISYM_FGETC
:
10595 case GFC_ISYM_FNUM
:
10596 case GFC_ISYM_FPUT
:
10597 case GFC_ISYM_FPUTC
:
10598 case GFC_ISYM_FSTAT
:
10599 case GFC_ISYM_FTELL
:
10600 case GFC_ISYM_GETCWD
:
10601 case GFC_ISYM_GETGID
:
10602 case GFC_ISYM_GETPID
:
10603 case GFC_ISYM_GETUID
:
10604 case GFC_ISYM_HOSTNM
:
10605 case GFC_ISYM_IERRNO
:
10606 case GFC_ISYM_IRAND
:
10607 case GFC_ISYM_ISATTY
:
10609 case GFC_ISYM_LINK
:
10610 case GFC_ISYM_LSTAT
:
10611 case GFC_ISYM_MATMUL
:
10612 case GFC_ISYM_MCLOCK
:
10613 case GFC_ISYM_MCLOCK8
:
10614 case GFC_ISYM_RAND
:
10615 case GFC_ISYM_RENAME
:
10616 case GFC_ISYM_SECOND
:
10617 case GFC_ISYM_SECNDS
:
10618 case GFC_ISYM_SIGNAL
:
10619 case GFC_ISYM_STAT
:
10620 case GFC_ISYM_SYMLNK
:
10621 case GFC_ISYM_SYSTEM
:
10622 case GFC_ISYM_TIME
:
10623 case GFC_ISYM_TIME8
:
10624 case GFC_ISYM_UMASK
:
10625 case GFC_ISYM_UNLINK
:
10627 gfc_conv_intrinsic_funcall (se
, expr
);
10630 case GFC_ISYM_EOSHIFT
:
10631 case GFC_ISYM_PACK
:
10632 case GFC_ISYM_RESHAPE
:
10633 /* For those, expr->rank should always be >0 and thus the if above the
10634 switch should have matched. */
10635 gcc_unreachable ();
10639 gfc_conv_intrinsic_lib_function (se
, expr
);
10646 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
10648 gfc_ss
*arg_ss
, *tmp_ss
;
10649 gfc_actual_arglist
*arg
;
10651 arg
= expr
->value
.function
.actual
;
10653 gcc_assert (arg
->expr
);
10655 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
10656 gcc_assert (arg_ss
!= gfc_ss_terminator
);
10658 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
10660 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
10661 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
10663 gcc_assert (tmp_ss
->dimen
== 2);
10665 /* We just invert dimensions. */
10666 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
10669 /* Stop when tmp_ss points to the last valid element of the chain... */
10670 if (tmp_ss
->next
== gfc_ss_terminator
)
10674 /* ... so that we can attach the rest of the chain to it. */
10681 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
10682 This has the side effect of reversing the nested list, so there is no
10683 need to call gfc_reverse_ss on it (the given list is assumed not to be
10687 nest_loop_dimension (gfc_ss
*ss
, int dim
)
10690 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
10691 gfc_loopinfo
*new_loop
;
10693 gcc_assert (ss
!= gfc_ss_terminator
);
10695 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
10697 new_ss
= gfc_get_ss ();
10698 new_ss
->next
= prev_ss
;
10699 new_ss
->parent
= ss
;
10700 new_ss
->info
= ss
->info
;
10701 new_ss
->info
->refcount
++;
10702 if (ss
->dimen
!= 0)
10704 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
10705 && ss
->info
->type
!= GFC_SS_REFERENCE
);
10708 new_ss
->dim
[0] = ss
->dim
[dim
];
10710 gcc_assert (dim
< ss
->dimen
);
10712 ss_dim
= --ss
->dimen
;
10713 for (i
= dim
; i
< ss_dim
; i
++)
10714 ss
->dim
[i
] = ss
->dim
[i
+ 1];
10716 ss
->dim
[ss_dim
] = 0;
10722 ss
->nested_ss
->parent
= new_ss
;
10723 new_ss
->nested_ss
= ss
->nested_ss
;
10725 ss
->nested_ss
= new_ss
;
10728 new_loop
= gfc_get_loopinfo ();
10729 gfc_init_loopinfo (new_loop
);
10731 gcc_assert (prev_ss
!= NULL
);
10732 gcc_assert (prev_ss
!= gfc_ss_terminator
);
10733 gfc_add_ss_to_loop (new_loop
, prev_ss
);
10734 return new_ss
->parent
;
10738 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
10739 is to be inlined. */
10742 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
10744 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
10745 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
10747 bool scalar_mask
= false;
10749 /* The rank of the result will be determined later. */
10750 arg1
= expr
->value
.function
.actual
;
10753 gcc_assert (arg3
!= NULL
);
10755 if (expr
->rank
== 0)
10758 tmp_ss
= gfc_ss_terminator
;
10764 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
10765 if (mask_ss
== tmp_ss
)
10771 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
10772 gcc_assert (array_ss
!= tmp_ss
);
10774 /* Odd thing: If the mask is scalar, it is used by the frontend after
10775 the array (to make an if around the nested loop). Thus it shall
10776 be after array_ss once the gfc_ss list is reversed. */
10778 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
10782 /* "Hide" the dimension on which we will sum in the first arg's scalarization
10784 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
10785 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
10793 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
10796 switch (expr
->value
.function
.isym
->id
)
10798 case GFC_ISYM_PRODUCT
:
10800 return walk_inline_intrinsic_arith (ss
, expr
);
10802 case GFC_ISYM_TRANSPOSE
:
10803 return walk_inline_intrinsic_transpose (ss
, expr
);
10806 gcc_unreachable ();
10808 gcc_unreachable ();
10812 /* This generates code to execute before entering the scalarization loop.
10813 Currently does nothing. */
10816 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
10818 switch (ss
->info
->expr
->value
.function
.isym
->id
)
10820 case GFC_ISYM_UBOUND
:
10821 case GFC_ISYM_LBOUND
:
10822 case GFC_ISYM_UCOBOUND
:
10823 case GFC_ISYM_LCOBOUND
:
10824 case GFC_ISYM_THIS_IMAGE
:
10828 gcc_unreachable ();
10833 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
10834 are expanded into code inside the scalarization loop. */
10837 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
10839 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
10840 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
10842 /* The two argument version returns a scalar. */
10843 if (expr
->value
.function
.actual
->next
->expr
)
10846 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
10850 /* Walk an intrinsic array libcall. */
10853 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
10855 gcc_assert (expr
->rank
> 0);
10856 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10860 /* Return whether the function call expression EXPR will be expanded
10861 inline by gfc_conv_intrinsic_function. */
10864 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
10866 gfc_actual_arglist
*args
, *dim_arg
, *mask_arg
;
10867 gfc_expr
*maskexpr
;
10869 if (!expr
->value
.function
.isym
)
10872 switch (expr
->value
.function
.isym
->id
)
10874 case GFC_ISYM_PRODUCT
:
10876 /* Disable inline expansion if code size matters. */
10880 args
= expr
->value
.function
.actual
;
10881 dim_arg
= args
->next
;
10883 /* We need to be able to subset the SUM argument at compile-time. */
10884 if (dim_arg
->expr
&& dim_arg
->expr
->expr_type
!= EXPR_CONSTANT
)
10887 /* FIXME: If MASK is optional for a more than two-dimensional
10888 argument, the scalarizer gets confused if the mask is
10889 absent. See PR 82995. For now, fall back to the library
10892 mask_arg
= dim_arg
->next
;
10893 maskexpr
= mask_arg
->expr
;
10895 if (expr
->rank
> 0 && maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
10896 && maskexpr
->symtree
->n
.sym
->attr
.dummy
10897 && maskexpr
->symtree
->n
.sym
->attr
.optional
)
10902 case GFC_ISYM_TRANSPOSE
:
10911 /* Returns nonzero if the specified intrinsic function call maps directly to
10912 an external library call. Should only be used for functions that return
10916 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
10918 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
10919 gcc_assert (expr
->rank
> 0);
10921 if (gfc_inline_intrinsic_function_p (expr
))
10924 switch (expr
->value
.function
.isym
->id
)
10928 case GFC_ISYM_COUNT
:
10929 case GFC_ISYM_FINDLOC
:
10931 case GFC_ISYM_IANY
:
10932 case GFC_ISYM_IALL
:
10933 case GFC_ISYM_IPARITY
:
10934 case GFC_ISYM_MATMUL
:
10935 case GFC_ISYM_MAXLOC
:
10936 case GFC_ISYM_MAXVAL
:
10937 case GFC_ISYM_MINLOC
:
10938 case GFC_ISYM_MINVAL
:
10939 case GFC_ISYM_NORM2
:
10940 case GFC_ISYM_PARITY
:
10941 case GFC_ISYM_PRODUCT
:
10943 case GFC_ISYM_SHAPE
:
10944 case GFC_ISYM_SPREAD
:
10946 /* Ignore absent optional parameters. */
10949 case GFC_ISYM_CSHIFT
:
10950 case GFC_ISYM_EOSHIFT
:
10951 case GFC_ISYM_GET_TEAM
:
10952 case GFC_ISYM_FAILED_IMAGES
:
10953 case GFC_ISYM_STOPPED_IMAGES
:
10954 case GFC_ISYM_PACK
:
10955 case GFC_ISYM_RESHAPE
:
10956 case GFC_ISYM_UNPACK
:
10957 /* Pass absent optional parameters. */
10965 /* Walk an intrinsic function. */
10967 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
10968 gfc_intrinsic_sym
* isym
)
10972 if (isym
->elemental
)
10973 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
10974 NULL
, GFC_SS_SCALAR
);
10976 if (expr
->rank
== 0)
10979 if (gfc_inline_intrinsic_function_p (expr
))
10980 return walk_inline_intrinsic_function (ss
, expr
);
10982 if (gfc_is_intrinsic_libcall (expr
))
10983 return gfc_walk_intrinsic_libfunc (ss
, expr
);
10985 /* Special cases. */
10988 case GFC_ISYM_LBOUND
:
10989 case GFC_ISYM_LCOBOUND
:
10990 case GFC_ISYM_UBOUND
:
10991 case GFC_ISYM_UCOBOUND
:
10992 case GFC_ISYM_THIS_IMAGE
:
10993 return gfc_walk_intrinsic_bound (ss
, expr
);
10995 case GFC_ISYM_TRANSFER
:
10996 case GFC_ISYM_CAF_GET
:
10997 return gfc_walk_intrinsic_libfunc (ss
, expr
);
11000 /* This probably meant someone forgot to add an intrinsic to the above
11001 list(s) when they implemented it, or something's gone horribly
11003 gcc_unreachable ();
11008 conv_co_collective (gfc_code
*code
)
11011 stmtblock_t block
, post_block
;
11012 tree fndecl
, array
= NULL_TREE
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
11013 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
11015 gfc_start_block (&block
);
11016 gfc_init_block (&post_block
);
11018 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
11020 opr_expr
= code
->ext
.actual
->next
->expr
;
11021 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
11022 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11023 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
11028 image_idx_expr
= code
->ext
.actual
->next
->expr
;
11029 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
11030 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11036 gfc_init_se (&argse
, NULL
);
11037 gfc_conv_expr (&argse
, stat_expr
);
11038 gfc_add_block_to_block (&block
, &argse
.pre
);
11039 gfc_add_block_to_block (&post_block
, &argse
.post
);
11041 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
11042 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
11044 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
11047 stat
= null_pointer_node
;
11049 /* Early exit for GFC_FCOARRAY_SINGLE. */
11050 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
11052 if (stat
!= NULL_TREE
)
11053 gfc_add_modify (&block
, stat
,
11054 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
11055 return gfc_finish_block (&block
);
11058 /* Handle the array. */
11059 gfc_init_se (&argse
, NULL
);
11060 if (code
->ext
.actual
->expr
->rank
== 0)
11062 symbol_attribute attr
;
11063 gfc_clear_attr (&attr
);
11064 gfc_init_se (&argse
, NULL
);
11065 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
11066 gfc_add_block_to_block (&block
, &argse
.pre
);
11067 gfc_add_block_to_block (&post_block
, &argse
.post
);
11068 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
11069 array
= gfc_build_addr_expr (NULL_TREE
, array
);
11073 argse
.want_pointer
= 1;
11074 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
11075 array
= argse
.expr
;
11078 gfc_add_block_to_block (&block
, &argse
.pre
);
11079 gfc_add_block_to_block (&post_block
, &argse
.post
);
11081 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
11082 strlen
= argse
.string_length
;
11084 strlen
= integer_zero_node
;
11087 if (image_idx_expr
)
11089 gfc_init_se (&argse
, NULL
);
11090 gfc_conv_expr (&argse
, image_idx_expr
);
11091 gfc_add_block_to_block (&block
, &argse
.pre
);
11092 gfc_add_block_to_block (&post_block
, &argse
.post
);
11093 image_index
= fold_convert (integer_type_node
, argse
.expr
);
11096 image_index
= integer_zero_node
;
11101 gfc_init_se (&argse
, NULL
);
11102 gfc_conv_expr (&argse
, errmsg_expr
);
11103 gfc_add_block_to_block (&block
, &argse
.pre
);
11104 gfc_add_block_to_block (&post_block
, &argse
.post
);
11105 errmsg
= argse
.expr
;
11106 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
11110 errmsg
= null_pointer_node
;
11111 errmsg_len
= build_zero_cst (size_type_node
);
11114 /* Generate the function call. */
11115 switch (code
->resolved_isym
->id
)
11117 case GFC_ISYM_CO_BROADCAST
:
11118 fndecl
= gfor_fndecl_co_broadcast
;
11120 case GFC_ISYM_CO_MAX
:
11121 fndecl
= gfor_fndecl_co_max
;
11123 case GFC_ISYM_CO_MIN
:
11124 fndecl
= gfor_fndecl_co_min
;
11126 case GFC_ISYM_CO_REDUCE
:
11127 fndecl
= gfor_fndecl_co_reduce
;
11129 case GFC_ISYM_CO_SUM
:
11130 fndecl
= gfor_fndecl_co_sum
;
11133 gcc_unreachable ();
11136 gfc_symbol
*derived
= code
->ext
.actual
->expr
->ts
.type
== BT_DERIVED
11137 ? code
->ext
.actual
->expr
->ts
.u
.derived
: NULL
;
11139 if (derived
&& derived
->attr
.alloc_comp
11140 && code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
11141 /* The derived type has the attribute 'alloc_comp'. */
11143 tree tmp
= gfc_bcast_alloc_comp (derived
, code
->ext
.actual
->expr
,
11144 code
->ext
.actual
->expr
->rank
,
11145 image_index
, stat
, errmsg
, errmsg_len
);
11146 gfc_add_expr_to_block (&block
, tmp
);
11150 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
11151 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
11152 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
11153 image_index
, stat
, errmsg
, errmsg_len
);
11154 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
11155 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
,
11156 image_index
, stat
, errmsg
,
11157 strlen
, errmsg_len
);
11160 tree opr
, opr_flags
;
11162 // FIXME: Handle TS29113's bind(C) strings with descriptor.
11164 if (gfc_is_proc_ptr_comp (opr_expr
))
11166 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
11167 opr_flag_int
= sym
->attr
.dimension
11168 || (sym
->ts
.type
== BT_CHARACTER
11169 && !sym
->attr
.is_bind_c
)
11170 ? GFC_CAF_BYREF
: 0;
11171 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
11172 && !sym
->attr
.is_bind_c
11173 ? GFC_CAF_HIDDENLEN
: 0;
11174 opr_flag_int
|= sym
->formal
->sym
->attr
.value
11175 ? GFC_CAF_ARG_VALUE
: 0;
11179 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
11180 ? GFC_CAF_BYREF
: 0;
11181 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
11182 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
11183 ? GFC_CAF_HIDDENLEN
: 0;
11184 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
11185 ? GFC_CAF_ARG_VALUE
: 0;
11187 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
11188 gfc_conv_expr (&argse
, opr_expr
);
11190 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
,
11191 opr_flags
, image_index
, stat
, errmsg
,
11192 strlen
, errmsg_len
);
11196 gfc_add_expr_to_block (&block
, fndecl
);
11197 gfc_add_block_to_block (&block
, &post_block
);
11199 return gfc_finish_block (&block
);
11204 conv_intrinsic_atomic_op (gfc_code
*code
)
11207 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
11208 stmtblock_t block
, post_block
;
11209 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
11210 gfc_expr
*stat_expr
;
11211 built_in_function fn
;
11213 if (atom_expr
->expr_type
== EXPR_FUNCTION
11214 && atom_expr
->value
.function
.isym
11215 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11216 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11218 gfc_start_block (&block
);
11219 gfc_init_block (&post_block
);
11221 gfc_init_se (&argse
, NULL
);
11222 argse
.want_pointer
= 1;
11223 gfc_conv_expr (&argse
, atom_expr
);
11224 gfc_add_block_to_block (&block
, &argse
.pre
);
11225 gfc_add_block_to_block (&post_block
, &argse
.post
);
11228 gfc_init_se (&argse
, NULL
);
11229 if (flag_coarray
== GFC_FCOARRAY_LIB
11230 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
11231 argse
.want_pointer
= 1;
11232 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
11233 gfc_add_block_to_block (&block
, &argse
.pre
);
11234 gfc_add_block_to_block (&post_block
, &argse
.post
);
11235 value
= argse
.expr
;
11237 switch (code
->resolved_isym
->id
)
11239 case GFC_ISYM_ATOMIC_ADD
:
11240 case GFC_ISYM_ATOMIC_AND
:
11241 case GFC_ISYM_ATOMIC_DEF
:
11242 case GFC_ISYM_ATOMIC_OR
:
11243 case GFC_ISYM_ATOMIC_XOR
:
11244 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
11245 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11246 old
= null_pointer_node
;
11249 gfc_init_se (&argse
, NULL
);
11250 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11251 argse
.want_pointer
= 1;
11252 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
11253 gfc_add_block_to_block (&block
, &argse
.pre
);
11254 gfc_add_block_to_block (&post_block
, &argse
.post
);
11256 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11260 if (stat_expr
!= NULL
)
11262 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
11263 gfc_init_se (&argse
, NULL
);
11264 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11265 argse
.want_pointer
= 1;
11266 gfc_conv_expr_val (&argse
, stat_expr
);
11267 gfc_add_block_to_block (&block
, &argse
.pre
);
11268 gfc_add_block_to_block (&post_block
, &argse
.post
);
11271 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11272 stat
= null_pointer_node
;
11274 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11276 tree image_index
, caf_decl
, offset
, token
;
11279 switch (code
->resolved_isym
->id
)
11281 case GFC_ISYM_ATOMIC_ADD
:
11282 case GFC_ISYM_ATOMIC_FETCH_ADD
:
11283 op
= (int) GFC_CAF_ATOMIC_ADD
;
11285 case GFC_ISYM_ATOMIC_AND
:
11286 case GFC_ISYM_ATOMIC_FETCH_AND
:
11287 op
= (int) GFC_CAF_ATOMIC_AND
;
11289 case GFC_ISYM_ATOMIC_OR
:
11290 case GFC_ISYM_ATOMIC_FETCH_OR
:
11291 op
= (int) GFC_CAF_ATOMIC_OR
;
11293 case GFC_ISYM_ATOMIC_XOR
:
11294 case GFC_ISYM_ATOMIC_FETCH_XOR
:
11295 op
= (int) GFC_CAF_ATOMIC_XOR
;
11297 case GFC_ISYM_ATOMIC_DEF
:
11298 op
= 0; /* Unused. */
11301 gcc_unreachable ();
11304 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
11305 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
11306 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
11308 if (gfc_is_coindexed (atom_expr
))
11309 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
11311 image_index
= integer_zero_node
;
11313 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
11315 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
11316 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
11317 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11320 gfc_init_se (&argse
, NULL
);
11321 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
11324 gfc_add_block_to_block (&block
, &argse
.pre
);
11325 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
11326 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
11327 token
, offset
, image_index
, value
, stat
,
11328 build_int_cst (integer_type_node
,
11329 (int) atom_expr
->ts
.type
),
11330 build_int_cst (integer_type_node
,
11331 (int) atom_expr
->ts
.kind
));
11333 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
11334 build_int_cst (integer_type_node
, op
),
11335 token
, offset
, image_index
, value
, old
, stat
,
11336 build_int_cst (integer_type_node
,
11337 (int) atom_expr
->ts
.type
),
11338 build_int_cst (integer_type_node
,
11339 (int) atom_expr
->ts
.kind
));
11341 gfc_add_expr_to_block (&block
, tmp
);
11342 gfc_add_block_to_block (&block
, &argse
.post
);
11343 gfc_add_block_to_block (&block
, &post_block
);
11344 return gfc_finish_block (&block
);
11348 switch (code
->resolved_isym
->id
)
11350 case GFC_ISYM_ATOMIC_ADD
:
11351 case GFC_ISYM_ATOMIC_FETCH_ADD
:
11352 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
11354 case GFC_ISYM_ATOMIC_AND
:
11355 case GFC_ISYM_ATOMIC_FETCH_AND
:
11356 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
11358 case GFC_ISYM_ATOMIC_DEF
:
11359 fn
= BUILT_IN_ATOMIC_STORE_N
;
11361 case GFC_ISYM_ATOMIC_OR
:
11362 case GFC_ISYM_ATOMIC_FETCH_OR
:
11363 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
11365 case GFC_ISYM_ATOMIC_XOR
:
11366 case GFC_ISYM_ATOMIC_FETCH_XOR
:
11367 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
11370 gcc_unreachable ();
11373 tmp
= TREE_TYPE (TREE_TYPE (atom
));
11374 fn
= (built_in_function
) ((int) fn
11375 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
11377 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
11378 tmp
= builtin_decl_explicit (fn
);
11380 switch (code
->resolved_isym
->id
)
11382 case GFC_ISYM_ATOMIC_ADD
:
11383 case GFC_ISYM_ATOMIC_AND
:
11384 case GFC_ISYM_ATOMIC_DEF
:
11385 case GFC_ISYM_ATOMIC_OR
:
11386 case GFC_ISYM_ATOMIC_XOR
:
11387 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
11388 fold_convert (itype
, value
),
11389 build_int_cst (NULL
, MEMMODEL_RELAXED
));
11390 gfc_add_expr_to_block (&block
, tmp
);
11393 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
11394 fold_convert (itype
, value
),
11395 build_int_cst (NULL
, MEMMODEL_RELAXED
));
11396 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
11400 if (stat
!= NULL_TREE
)
11401 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11402 gfc_add_block_to_block (&block
, &post_block
);
11403 return gfc_finish_block (&block
);
11408 conv_intrinsic_atomic_ref (gfc_code
*code
)
11411 tree tmp
, atom
, value
, stat
= NULL_TREE
;
11412 stmtblock_t block
, post_block
;
11413 built_in_function fn
;
11414 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
11416 if (atom_expr
->expr_type
== EXPR_FUNCTION
11417 && atom_expr
->value
.function
.isym
11418 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11419 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11421 gfc_start_block (&block
);
11422 gfc_init_block (&post_block
);
11423 gfc_init_se (&argse
, NULL
);
11424 argse
.want_pointer
= 1;
11425 gfc_conv_expr (&argse
, atom_expr
);
11426 gfc_add_block_to_block (&block
, &argse
.pre
);
11427 gfc_add_block_to_block (&post_block
, &argse
.post
);
11430 gfc_init_se (&argse
, NULL
);
11431 if (flag_coarray
== GFC_FCOARRAY_LIB
11432 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
11433 argse
.want_pointer
= 1;
11434 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
11435 gfc_add_block_to_block (&block
, &argse
.pre
);
11436 gfc_add_block_to_block (&post_block
, &argse
.post
);
11437 value
= argse
.expr
;
11440 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
11442 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
11444 gfc_init_se (&argse
, NULL
);
11445 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11446 argse
.want_pointer
= 1;
11447 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
11448 gfc_add_block_to_block (&block
, &argse
.pre
);
11449 gfc_add_block_to_block (&post_block
, &argse
.post
);
11452 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11453 stat
= null_pointer_node
;
11455 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11457 tree image_index
, caf_decl
, offset
, token
;
11458 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
11460 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
11461 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
11462 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
11464 if (gfc_is_coindexed (atom_expr
))
11465 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
11467 image_index
= integer_zero_node
;
11469 gfc_init_se (&argse
, NULL
);
11470 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
11472 gfc_add_block_to_block (&block
, &argse
.pre
);
11474 /* Different type, need type conversion. */
11475 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
11477 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
11478 orig_value
= value
;
11479 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
11482 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
11483 token
, offset
, image_index
, value
, stat
,
11484 build_int_cst (integer_type_node
,
11485 (int) atom_expr
->ts
.type
),
11486 build_int_cst (integer_type_node
,
11487 (int) atom_expr
->ts
.kind
));
11488 gfc_add_expr_to_block (&block
, tmp
);
11489 if (vardecl
!= NULL_TREE
)
11490 gfc_add_modify (&block
, orig_value
,
11491 fold_convert (TREE_TYPE (orig_value
), vardecl
));
11492 gfc_add_block_to_block (&block
, &argse
.post
);
11493 gfc_add_block_to_block (&block
, &post_block
);
11494 return gfc_finish_block (&block
);
11497 tmp
= TREE_TYPE (TREE_TYPE (atom
));
11498 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
11499 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
11501 tmp
= builtin_decl_explicit (fn
);
11502 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
11503 build_int_cst (integer_type_node
,
11504 MEMMODEL_RELAXED
));
11505 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
11507 if (stat
!= NULL_TREE
)
11508 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11509 gfc_add_block_to_block (&block
, &post_block
);
11510 return gfc_finish_block (&block
);
11515 conv_intrinsic_atomic_cas (gfc_code
*code
)
11518 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
11519 stmtblock_t block
, post_block
;
11520 built_in_function fn
;
11521 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
11523 if (atom_expr
->expr_type
== EXPR_FUNCTION
11524 && atom_expr
->value
.function
.isym
11525 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11526 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11528 gfc_init_block (&block
);
11529 gfc_init_block (&post_block
);
11530 gfc_init_se (&argse
, NULL
);
11531 argse
.want_pointer
= 1;
11532 gfc_conv_expr (&argse
, atom_expr
);
11535 gfc_init_se (&argse
, NULL
);
11536 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11537 argse
.want_pointer
= 1;
11538 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
11539 gfc_add_block_to_block (&block
, &argse
.pre
);
11540 gfc_add_block_to_block (&post_block
, &argse
.post
);
11543 gfc_init_se (&argse
, NULL
);
11544 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11545 argse
.want_pointer
= 1;
11546 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
11547 gfc_add_block_to_block (&block
, &argse
.pre
);
11548 gfc_add_block_to_block (&post_block
, &argse
.post
);
11551 gfc_init_se (&argse
, NULL
);
11552 if (flag_coarray
== GFC_FCOARRAY_LIB
11553 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
11554 == atom_expr
->ts
.kind
)
11555 argse
.want_pointer
= 1;
11556 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
11557 gfc_add_block_to_block (&block
, &argse
.pre
);
11558 gfc_add_block_to_block (&post_block
, &argse
.post
);
11559 new_val
= argse
.expr
;
11562 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
11564 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
11566 gfc_init_se (&argse
, NULL
);
11567 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11568 argse
.want_pointer
= 1;
11569 gfc_conv_expr_val (&argse
,
11570 code
->ext
.actual
->next
->next
->next
->next
->expr
);
11571 gfc_add_block_to_block (&block
, &argse
.pre
);
11572 gfc_add_block_to_block (&post_block
, &argse
.post
);
11575 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11576 stat
= null_pointer_node
;
11578 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11580 tree image_index
, caf_decl
, offset
, token
;
11582 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
11583 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
11584 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
11586 if (gfc_is_coindexed (atom_expr
))
11587 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
11589 image_index
= integer_zero_node
;
11591 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
11593 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
11594 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
11595 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11598 /* Convert a constant to a pointer. */
11599 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
11601 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
11602 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
11603 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11606 gfc_init_se (&argse
, NULL
);
11607 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
11609 gfc_add_block_to_block (&block
, &argse
.pre
);
11611 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
11612 token
, offset
, image_index
, old
, comp
, new_val
,
11613 stat
, build_int_cst (integer_type_node
,
11614 (int) atom_expr
->ts
.type
),
11615 build_int_cst (integer_type_node
,
11616 (int) atom_expr
->ts
.kind
));
11617 gfc_add_expr_to_block (&block
, tmp
);
11618 gfc_add_block_to_block (&block
, &argse
.post
);
11619 gfc_add_block_to_block (&block
, &post_block
);
11620 return gfc_finish_block (&block
);
11623 tmp
= TREE_TYPE (TREE_TYPE (atom
));
11624 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
11625 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
11627 tmp
= builtin_decl_explicit (fn
);
11629 gfc_add_modify (&block
, old
, comp
);
11630 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
11631 gfc_build_addr_expr (NULL
, old
),
11632 fold_convert (TREE_TYPE (old
), new_val
),
11633 boolean_false_node
,
11634 build_int_cst (NULL
, MEMMODEL_RELAXED
),
11635 build_int_cst (NULL
, MEMMODEL_RELAXED
));
11636 gfc_add_expr_to_block (&block
, tmp
);
11638 if (stat
!= NULL_TREE
)
11639 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11640 gfc_add_block_to_block (&block
, &post_block
);
11641 return gfc_finish_block (&block
);
11645 conv_intrinsic_event_query (gfc_code
*code
)
11648 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
11649 tree count
= NULL_TREE
, count2
= NULL_TREE
;
11651 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
11653 if (code
->ext
.actual
->next
->next
->expr
)
11655 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
11657 gfc_init_se (&argse
, NULL
);
11658 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
11661 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11662 stat
= null_pointer_node
;
11664 if (code
->ext
.actual
->next
->expr
)
11666 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
11667 gfc_init_se (&argse
, NULL
);
11668 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
11669 count
= argse
.expr
;
11672 gfc_start_block (&se
.pre
);
11673 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11675 tree tmp
, token
, image_index
;
11676 tree index
= build_zero_cst (gfc_array_index_type
);
11678 if (event_expr
->expr_type
== EXPR_FUNCTION
11679 && event_expr
->value
.function
.isym
11680 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11681 event_expr
= event_expr
->value
.function
.actual
->expr
;
11683 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
11685 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
11686 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
11687 != INTMOD_ISO_FORTRAN_ENV
11688 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
11689 != ISOFORTRAN_EVENT_TYPE
)
11691 gfc_error ("Sorry, the event component of derived type at %L is not "
11692 "yet supported", &event_expr
->where
);
11696 if (gfc_is_coindexed (event_expr
))
11698 gfc_error ("The event variable at %L shall not be coindexed",
11699 &event_expr
->where
);
11703 image_index
= integer_zero_node
;
11705 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
11708 /* For arrays, obtain the array index. */
11709 if (gfc_expr_attr (event_expr
).dimension
)
11711 tree desc
, tmp
, extent
, lbound
, ubound
;
11712 gfc_array_ref
*ar
, ar2
;
11715 /* TODO: Extend this, once DT components are supported. */
11716 ar
= &event_expr
->ref
->u
.ar
;
11718 memset (ar
, '\0', sizeof (*ar
));
11720 ar
->type
= AR_FULL
;
11722 gfc_init_se (&argse
, NULL
);
11723 argse
.descriptor_only
= 1;
11724 gfc_conv_expr_descriptor (&argse
, event_expr
);
11725 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
11729 extent
= build_one_cst (gfc_array_index_type
);
11730 for (i
= 0; i
< ar
->dimen
; i
++)
11732 gfc_init_se (&argse
, NULL
);
11733 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
11734 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
11735 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
11736 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
11737 TREE_TYPE (lbound
), argse
.expr
, lbound
);
11738 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
11739 TREE_TYPE (tmp
), extent
, tmp
);
11740 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
11741 TREE_TYPE (tmp
), index
, tmp
);
11742 if (i
< ar
->dimen
- 1)
11744 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
11745 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
11746 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
11747 TREE_TYPE (tmp
), extent
, tmp
);
11752 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
11755 count
= gfc_create_var (integer_type_node
, "count");
11758 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
11761 stat
= gfc_create_var (integer_type_node
, "stat");
11764 index
= fold_convert (size_type_node
, index
);
11765 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
11766 token
, index
, image_index
, count
11767 ? gfc_build_addr_expr (NULL
, count
) : count
,
11768 stat
!= null_pointer_node
11769 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
11770 gfc_add_expr_to_block (&se
.pre
, tmp
);
11772 if (count2
!= NULL_TREE
)
11773 gfc_add_modify (&se
.pre
, count2
,
11774 fold_convert (TREE_TYPE (count2
), count
));
11776 if (stat2
!= NULL_TREE
)
11777 gfc_add_modify (&se
.pre
, stat2
,
11778 fold_convert (TREE_TYPE (stat2
), stat
));
11780 return gfc_finish_block (&se
.pre
);
11783 gfc_init_se (&argse
, NULL
);
11784 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
11785 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
11787 if (stat
!= NULL_TREE
)
11788 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11790 return gfc_finish_block (&se
.pre
);
11794 conv_intrinsic_move_alloc (gfc_code
*code
)
11797 gfc_expr
*from_expr
, *to_expr
;
11798 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
11799 gfc_se from_se
, to_se
;
11803 gfc_start_block (&block
);
11805 from_expr
= code
->ext
.actual
->expr
;
11806 to_expr
= code
->ext
.actual
->next
->expr
;
11808 gfc_init_se (&from_se
, NULL
);
11809 gfc_init_se (&to_se
, NULL
);
11811 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
11812 || to_expr
->ts
.type
== BT_CLASS
);
11813 coarray
= gfc_get_corank (from_expr
) != 0;
11815 if (from_expr
->rank
== 0 && !coarray
)
11817 if (from_expr
->ts
.type
!= BT_CLASS
)
11818 from_expr2
= from_expr
;
11821 from_expr2
= gfc_copy_expr (from_expr
);
11822 gfc_add_data_component (from_expr2
);
11825 if (to_expr
->ts
.type
!= BT_CLASS
)
11826 to_expr2
= to_expr
;
11829 to_expr2
= gfc_copy_expr (to_expr
);
11830 gfc_add_data_component (to_expr2
);
11833 from_se
.want_pointer
= 1;
11834 to_se
.want_pointer
= 1;
11835 gfc_conv_expr (&from_se
, from_expr2
);
11836 gfc_conv_expr (&to_se
, to_expr2
);
11837 gfc_add_block_to_block (&block
, &from_se
.pre
);
11838 gfc_add_block_to_block (&block
, &to_se
.pre
);
11840 /* Deallocate "to". */
11841 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
11842 true, to_expr
, to_expr
->ts
);
11843 gfc_add_expr_to_block (&block
, tmp
);
11845 /* Assign (_data) pointers. */
11846 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11847 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
11849 /* Set "from" to NULL. */
11850 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11851 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
11853 gfc_add_block_to_block (&block
, &from_se
.post
);
11854 gfc_add_block_to_block (&block
, &to_se
.post
);
11857 if (to_expr
->ts
.type
== BT_CLASS
)
11861 gfc_free_expr (to_expr2
);
11862 gfc_init_se (&to_se
, NULL
);
11863 to_se
.want_pointer
= 1;
11864 gfc_add_vptr_component (to_expr
);
11865 gfc_conv_expr (&to_se
, to_expr
);
11867 if (from_expr
->ts
.type
== BT_CLASS
)
11869 if (UNLIMITED_POLY (from_expr
))
11873 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
11877 gfc_free_expr (from_expr2
);
11878 gfc_init_se (&from_se
, NULL
);
11879 from_se
.want_pointer
= 1;
11880 gfc_add_vptr_component (from_expr
);
11881 gfc_conv_expr (&from_se
, from_expr
);
11882 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11883 fold_convert (TREE_TYPE (to_se
.expr
),
11886 /* Reset _vptr component to declared type. */
11888 /* Unlimited polymorphic. */
11889 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11890 fold_convert (TREE_TYPE (from_se
.expr
),
11891 null_pointer_node
));
11894 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11895 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11896 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
11901 vtab
= gfc_find_vtab (&from_expr
->ts
);
11903 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11904 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11905 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
11909 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
11911 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
11912 fold_convert (TREE_TYPE (to_se
.string_length
),
11913 from_se
.string_length
));
11914 if (from_expr
->ts
.deferred
)
11915 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
11916 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
11919 return gfc_finish_block (&block
);
11922 /* Update _vptr component. */
11923 if (to_expr
->ts
.type
== BT_CLASS
)
11927 to_se
.want_pointer
= 1;
11928 to_expr2
= gfc_copy_expr (to_expr
);
11929 gfc_add_vptr_component (to_expr2
);
11930 gfc_conv_expr (&to_se
, to_expr2
);
11932 if (from_expr
->ts
.type
== BT_CLASS
)
11934 if (UNLIMITED_POLY (from_expr
))
11938 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
11942 from_se
.want_pointer
= 1;
11943 from_expr2
= gfc_copy_expr (from_expr
);
11944 gfc_add_vptr_component (from_expr2
);
11945 gfc_conv_expr (&from_se
, from_expr2
);
11946 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11947 fold_convert (TREE_TYPE (to_se
.expr
),
11950 /* Reset _vptr component to declared type. */
11952 /* Unlimited polymorphic. */
11953 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11954 fold_convert (TREE_TYPE (from_se
.expr
),
11955 null_pointer_node
));
11958 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11959 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11960 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
11965 vtab
= gfc_find_vtab (&from_expr
->ts
);
11967 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11968 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11969 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
11972 gfc_free_expr (to_expr2
);
11973 gfc_init_se (&to_se
, NULL
);
11975 if (from_expr
->ts
.type
== BT_CLASS
)
11977 gfc_free_expr (from_expr2
);
11978 gfc_init_se (&from_se
, NULL
);
11983 /* Deallocate "to". */
11984 if (from_expr
->rank
== 0)
11986 to_se
.want_coarray
= 1;
11987 from_se
.want_coarray
= 1;
11989 gfc_conv_expr_descriptor (&to_se
, to_expr
);
11990 gfc_conv_expr_descriptor (&from_se
, from_expr
);
11992 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
11993 is an image control "statement", cf. IR F08/0040 in 12-006A. */
11994 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
11998 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
11999 NULL_TREE
, NULL_TREE
, true, to_expr
,
12000 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
12001 gfc_add_expr_to_block (&block
, tmp
);
12003 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
12004 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
12005 logical_type_node
, tmp
,
12006 fold_convert (TREE_TYPE (tmp
),
12007 null_pointer_node
));
12008 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
12009 3, null_pointer_node
, null_pointer_node
,
12010 build_int_cst (integer_type_node
, 0));
12012 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
12013 tmp
, build_empty_stmt (input_location
));
12014 gfc_add_expr_to_block (&block
, tmp
);
12018 if (to_expr
->ts
.type
== BT_DERIVED
12019 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
12021 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
12022 to_se
.expr
, to_expr
->rank
);
12023 gfc_add_expr_to_block (&block
, tmp
);
12026 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
12027 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
12028 NULL_TREE
, true, to_expr
,
12029 GFC_CAF_COARRAY_NOCOARRAY
);
12030 gfc_add_expr_to_block (&block
, tmp
);
12033 /* Move the pointer and update the array descriptor data. */
12034 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
12036 /* Set "from" to NULL. */
12037 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
12038 gfc_add_modify_loc (input_location
, &block
, tmp
,
12039 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
12042 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
12044 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
12045 fold_convert (TREE_TYPE (to_se
.string_length
),
12046 from_se
.string_length
));
12047 if (from_expr
->ts
.deferred
)
12048 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
12049 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
12052 return gfc_finish_block (&block
);
12057 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
12061 gcc_assert (code
->resolved_isym
);
12063 switch (code
->resolved_isym
->id
)
12065 case GFC_ISYM_MOVE_ALLOC
:
12066 res
= conv_intrinsic_move_alloc (code
);
12069 case GFC_ISYM_ATOMIC_CAS
:
12070 res
= conv_intrinsic_atomic_cas (code
);
12073 case GFC_ISYM_ATOMIC_ADD
:
12074 case GFC_ISYM_ATOMIC_AND
:
12075 case GFC_ISYM_ATOMIC_DEF
:
12076 case GFC_ISYM_ATOMIC_OR
:
12077 case GFC_ISYM_ATOMIC_XOR
:
12078 case GFC_ISYM_ATOMIC_FETCH_ADD
:
12079 case GFC_ISYM_ATOMIC_FETCH_AND
:
12080 case GFC_ISYM_ATOMIC_FETCH_OR
:
12081 case GFC_ISYM_ATOMIC_FETCH_XOR
:
12082 res
= conv_intrinsic_atomic_op (code
);
12085 case GFC_ISYM_ATOMIC_REF
:
12086 res
= conv_intrinsic_atomic_ref (code
);
12089 case GFC_ISYM_EVENT_QUERY
:
12090 res
= conv_intrinsic_event_query (code
);
12093 case GFC_ISYM_C_F_POINTER
:
12094 case GFC_ISYM_C_F_PROCPOINTER
:
12095 res
= conv_isocbinding_subroutine (code
);
12098 case GFC_ISYM_CAF_SEND
:
12099 res
= conv_caf_send (code
);
12102 case GFC_ISYM_CO_BROADCAST
:
12103 case GFC_ISYM_CO_MIN
:
12104 case GFC_ISYM_CO_MAX
:
12105 case GFC_ISYM_CO_REDUCE
:
12106 case GFC_ISYM_CO_SUM
:
12107 res
= conv_co_collective (code
);
12110 case GFC_ISYM_FREE
:
12111 res
= conv_intrinsic_free (code
);
12114 case GFC_ISYM_RANDOM_INIT
:
12115 res
= conv_intrinsic_random_init (code
);
12118 case GFC_ISYM_KILL
:
12119 res
= conv_intrinsic_kill_sub (code
);
12122 case GFC_ISYM_SYSTEM_CLOCK
:
12123 res
= conv_intrinsic_system_clock (code
);
12134 #include "gt-fortran-trans-intrinsic.h"