1 /* Intrinsic translation
2 Copyright (C) 2002-2021 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "internal-fn.h"
35 #include "tree-nested.h"
36 #include "stor-layout.h"
37 #include "toplev.h" /* For rest_of_decl_compilation. */
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 #include "dependency.h" /* For CAF array alias analysis. */
45 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
47 /* This maps Fortran intrinsic math functions to external library or GCC
49 typedef struct GTY(()) gfc_intrinsic_map_t
{
50 /* The explicit enum is required to work around inadequacies in the
51 garbage collection/gengtype parsing mechanism. */
54 /* Enum value from the "language-independent", aka C-centric, part
55 of gcc, or END_BUILTINS of no such value set. */
56 enum built_in_function float_built_in
;
57 enum built_in_function double_built_in
;
58 enum built_in_function long_double_built_in
;
59 enum built_in_function complex_float_built_in
;
60 enum built_in_function complex_double_built_in
;
61 enum built_in_function complex_long_double_built_in
;
63 /* True if the naming pattern is to prepend "c" for complex and
64 append "f" for kind=4. False if the naming pattern is to
65 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
68 /* True if a complex version of the function exists. */
69 bool complex_available
;
71 /* True if the function should be marked const. */
74 /* The base library name of this function. */
77 /* Cache decls created for the various operand types. */
89 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
90 defines complex variants of all of the entries in mathbuiltins.def
92 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
93 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
94 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
95 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
96 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
98 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
99 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
100 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
101 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
102 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
104 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
105 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
106 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
108 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
110 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
111 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
112 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
113 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
114 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
116 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
118 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
119 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
120 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
121 #include "mathbuiltins.def"
123 /* Functions in libgfortran. */
124 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
125 LIB_FUNCTION (SIND
, "sind", false),
126 LIB_FUNCTION (COSD
, "cosd", false),
127 LIB_FUNCTION (TAND
, "tand", false),
130 LIB_FUNCTION (NONE
, NULL
, false)
135 #undef DEFINE_MATH_BUILTIN
136 #undef DEFINE_MATH_BUILTIN_C
139 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
142 /* Find the correct variant of a given builtin from its argument. */
144 builtin_decl_for_precision (enum built_in_function base_built_in
,
147 enum built_in_function i
= END_BUILTINS
;
149 gfc_intrinsic_map_t
*m
;
150 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
153 if (precision
== TYPE_PRECISION (float_type_node
))
154 i
= m
->float_built_in
;
155 else if (precision
== TYPE_PRECISION (double_type_node
))
156 i
= m
->double_built_in
;
157 else if (precision
== TYPE_PRECISION (long_double_type_node
))
158 i
= m
->long_double_built_in
;
159 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
161 /* Special treatment, because it is not exactly a built-in, but
162 a library function. */
163 return m
->real16_decl
;
166 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
171 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
174 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
176 if (gfc_real_kinds
[i
].c_float128
)
178 /* For __float128, the story is a bit different, because we return
179 a decl to a library function rather than a built-in. */
180 gfc_intrinsic_map_t
*m
;
181 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
184 return m
->real16_decl
;
187 return builtin_decl_for_precision (double_built_in
,
188 gfc_real_kinds
[i
].mode_precision
);
192 /* Evaluate the arguments to an intrinsic function. The value
193 of NARGS may be less than the actual number of arguments in EXPR
194 to allow optional "KIND" arguments that are not included in the
195 generated code to be ignored. */
198 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
199 tree
*argarray
, int nargs
)
201 gfc_actual_arglist
*actual
;
203 gfc_intrinsic_arg
*formal
;
207 formal
= expr
->value
.function
.isym
->formal
;
208 actual
= expr
->value
.function
.actual
;
210 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
211 actual
= actual
->next
,
212 formal
= formal
? formal
->next
: NULL
)
216 /* Skip omitted optional arguments. */
223 /* Evaluate the parameter. This will substitute scalarized
224 references automatically. */
225 gfc_init_se (&argse
, se
);
227 if (e
->ts
.type
== BT_CHARACTER
)
229 gfc_conv_expr (&argse
, e
);
230 gfc_conv_string_parameter (&argse
);
231 argarray
[curr_arg
++] = argse
.string_length
;
232 gcc_assert (curr_arg
< nargs
);
235 gfc_conv_expr_val (&argse
, e
);
237 /* If an optional argument is itself an optional dummy argument,
238 check its presence and substitute a null if absent. */
239 if (e
->expr_type
== EXPR_VARIABLE
240 && e
->symtree
->n
.sym
->attr
.optional
243 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
245 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
246 gfc_add_block_to_block (&se
->post
, &argse
.post
);
247 argarray
[curr_arg
] = argse
.expr
;
251 /* Count the number of actual arguments to the intrinsic function EXPR
252 including any "hidden" string length arguments. */
255 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
258 gfc_actual_arglist
*actual
;
260 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
265 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
275 /* Conversions between different types are output by the frontend as
276 intrinsic functions. We implement these directly with inline code. */
279 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
285 nargs
= gfc_intrinsic_argument_list_length (expr
);
286 args
= XALLOCAVEC (tree
, nargs
);
288 /* Evaluate all the arguments passed. Whilst we're only interested in the
289 first one here, there are other parts of the front-end that assume this
290 and will trigger an ICE if it's not the case. */
291 type
= gfc_typenode_for_spec (&expr
->ts
);
292 gcc_assert (expr
->value
.function
.actual
->expr
);
293 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
295 /* Conversion between character kinds involves a call to a library
297 if (expr
->ts
.type
== BT_CHARACTER
)
299 tree fndecl
, var
, addr
, tmp
;
301 if (expr
->ts
.kind
== 1
302 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
303 fndecl
= gfor_fndecl_convert_char4_to_char1
;
304 else if (expr
->ts
.kind
== 4
305 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
306 fndecl
= gfor_fndecl_convert_char1_to_char4
;
310 /* Create the variable storing the converted value. */
311 type
= gfc_get_pchar_type (expr
->ts
.kind
);
312 var
= gfc_create_var (type
, "str");
313 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
315 /* Call the library function that will perform the conversion. */
316 gcc_assert (nargs
>= 2);
317 tmp
= build_call_expr_loc (input_location
,
318 fndecl
, 3, addr
, args
[0], args
[1]);
319 gfc_add_expr_to_block (&se
->pre
, tmp
);
321 /* Free the temporary afterwards. */
322 tmp
= gfc_call_free (var
);
323 gfc_add_expr_to_block (&se
->post
, tmp
);
326 se
->string_length
= args
[0];
331 /* Conversion from complex to non-complex involves taking the real
332 component of the value. */
333 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
334 && expr
->ts
.type
!= BT_COMPLEX
)
338 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
339 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
343 se
->expr
= convert (type
, args
[0]);
346 /* This is needed because the gcc backend only implements
347 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
348 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
349 Similarly for CEILING. */
352 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
359 argtype
= TREE_TYPE (arg
);
360 arg
= gfc_evaluate_now (arg
, pblock
);
362 intval
= convert (type
, arg
);
363 intval
= gfc_evaluate_now (intval
, pblock
);
365 tmp
= convert (argtype
, intval
);
366 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
367 logical_type_node
, tmp
, arg
);
369 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
370 intval
, build_int_cst (type
, 1));
371 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
376 /* Round to nearest integer, away from zero. */
379 build_round_expr (tree arg
, tree restype
)
383 int argprec
, resprec
;
385 argtype
= TREE_TYPE (arg
);
386 argprec
= TYPE_PRECISION (argtype
);
387 resprec
= TYPE_PRECISION (restype
);
389 /* Depending on the type of the result, choose the int intrinsic
390 (iround, available only as a builtin, therefore cannot use it for
391 __float128), long int intrinsic (lround family) or long long
392 intrinsic (llround). We might also need to convert the result
394 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
395 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
396 else if (resprec
<= LONG_TYPE_SIZE
)
397 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
398 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
399 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
400 else if (resprec
>= argprec
&& resprec
== 128)
402 /* Search for a real kind suitable as temporary for conversion. */
404 for (int i
= 0; kind
< 0 && gfc_real_kinds
[i
].kind
!= 0; i
++)
405 if (gfc_real_kinds
[i
].mode_precision
>= resprec
)
406 kind
= gfc_real_kinds
[i
].kind
;
408 gfc_internal_error ("Could not find real kind with at least %d bits",
410 arg
= fold_convert (gfc_float128_type_node
, arg
);
411 fn
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
416 return convert (restype
, build_call_expr_loc (input_location
,
421 /* Convert a real to an integer using a specific rounding mode.
422 Ideally we would just build the corresponding GENERIC node,
423 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
426 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
427 enum rounding_mode op
)
432 return build_fixbound_expr (pblock
, arg
, type
, 0);
435 return build_fixbound_expr (pblock
, arg
, type
, 1);
438 return build_round_expr (arg
, type
);
441 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
449 /* Round a real value using the specified rounding mode.
450 We use a temporary integer of that same kind size as the result.
451 Values larger than those that can be represented by this kind are
452 unchanged, as they will not be accurate enough to represent the
454 huge = HUGE (KIND (a))
455 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
459 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
471 kind
= expr
->ts
.kind
;
472 nargs
= gfc_intrinsic_argument_list_length (expr
);
475 /* We have builtin functions for some cases. */
479 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
483 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
490 /* Evaluate the argument. */
491 gcc_assert (expr
->value
.function
.actual
->expr
);
492 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
494 /* Use a builtin function if one exists. */
495 if (decl
!= NULL_TREE
)
497 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
501 /* This code is probably redundant, but we'll keep it lying around just
503 type
= gfc_typenode_for_spec (&expr
->ts
);
504 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
506 /* Test if the value is too large to handle sensibly. */
507 gfc_set_model_kind (kind
);
509 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
510 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
511 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
512 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, arg
[0],
515 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
516 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
517 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, arg
[0],
519 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, logical_type_node
,
521 itype
= gfc_get_int_type (kind
);
523 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
524 tmp
= convert (type
, tmp
);
525 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
531 /* Convert to an integer using the specified rounding mode. */
534 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
540 nargs
= gfc_intrinsic_argument_list_length (expr
);
541 args
= XALLOCAVEC (tree
, nargs
);
543 /* Evaluate the argument, we process all arguments even though we only
544 use the first one for code generation purposes. */
545 type
= gfc_typenode_for_spec (&expr
->ts
);
546 gcc_assert (expr
->value
.function
.actual
->expr
);
547 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
549 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
551 /* Conversion to a different integer kind. */
552 se
->expr
= convert (type
, args
[0]);
556 /* Conversion from complex to non-complex involves taking the real
557 component of the value. */
558 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
559 && expr
->ts
.type
!= BT_COMPLEX
)
563 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
564 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
568 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
573 /* Get the imaginary component of a value. */
576 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
580 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
581 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
582 TREE_TYPE (TREE_TYPE (arg
)), arg
);
586 /* Get the complex conjugate of a value. */
589 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
593 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
594 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
600 define_quad_builtin (const char *name
, tree type
, bool is_const
)
603 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
606 /* Mark the decl as external. */
607 DECL_EXTERNAL (fndecl
) = 1;
608 TREE_PUBLIC (fndecl
) = 1;
610 /* Mark it __attribute__((const)). */
611 TREE_READONLY (fndecl
) = is_const
;
613 rest_of_decl_compilation (fndecl
, 1, 0);
618 /* Add SIMD attribute for FNDECL built-in if the built-in
619 name is in VECTORIZED_BUILTINS. */
622 add_simd_flag_for_built_in (tree fndecl
)
624 if (gfc_vectorized_builtins
== NULL
625 || fndecl
== NULL_TREE
)
628 const char *name
= IDENTIFIER_POINTER (DECL_NAME (fndecl
));
629 int *clauses
= gfc_vectorized_builtins
->get (name
);
632 for (unsigned i
= 0; i
< 3; i
++)
633 if (*clauses
& (1 << i
))
635 gfc_simd_clause simd_type
= (gfc_simd_clause
)*clauses
;
636 tree omp_clause
= NULL_TREE
;
637 if (simd_type
== SIMD_NONE
)
638 ; /* No SIMD clause. */
642 = (simd_type
== SIMD_INBRANCH
643 ? OMP_CLAUSE_INBRANCH
: OMP_CLAUSE_NOTINBRANCH
);
644 omp_clause
= build_omp_clause (UNKNOWN_LOCATION
, code
);
645 omp_clause
= build_tree_list (NULL_TREE
, omp_clause
);
648 DECL_ATTRIBUTES (fndecl
)
649 = tree_cons (get_identifier ("omp declare simd"), omp_clause
,
650 DECL_ATTRIBUTES (fndecl
));
655 /* Set SIMD attribute to all built-in functions that are mentioned
656 in gfc_vectorized_builtins vector. */
659 gfc_adjust_builtins (void)
661 gfc_intrinsic_map_t
*m
;
662 for (m
= gfc_intrinsic_map
;
663 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
665 add_simd_flag_for_built_in (m
->real4_decl
);
666 add_simd_flag_for_built_in (m
->complex4_decl
);
667 add_simd_flag_for_built_in (m
->real8_decl
);
668 add_simd_flag_for_built_in (m
->complex8_decl
);
669 add_simd_flag_for_built_in (m
->real10_decl
);
670 add_simd_flag_for_built_in (m
->complex10_decl
);
671 add_simd_flag_for_built_in (m
->real16_decl
);
672 add_simd_flag_for_built_in (m
->complex16_decl
);
673 add_simd_flag_for_built_in (m
->real16_decl
);
674 add_simd_flag_for_built_in (m
->complex16_decl
);
677 /* Release all strings. */
678 if (gfc_vectorized_builtins
!= NULL
)
680 for (hash_map
<nofree_string_hash
, int>::iterator it
681 = gfc_vectorized_builtins
->begin ();
682 it
!= gfc_vectorized_builtins
->end (); ++it
)
683 free (CONST_CAST (char *, (*it
).first
));
685 delete gfc_vectorized_builtins
;
686 gfc_vectorized_builtins
= NULL
;
690 /* Initialize function decls for library functions. The external functions
691 are created as required. Builtin functions are added here. */
694 gfc_build_intrinsic_lib_fndecls (void)
696 gfc_intrinsic_map_t
*m
;
697 tree quad_decls
[END_BUILTINS
+ 1];
699 if (gfc_real16_is_float128
)
701 /* If we have soft-float types, we create the decls for their
702 C99-like library functions. For now, we only handle __float128
703 q-suffixed functions. */
705 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
706 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
708 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
710 type
= gfc_float128_type_node
;
711 complex_type
= gfc_complex_float128_type_node
;
712 /* type (*) (type) */
713 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
715 func_iround
= build_function_type_list (integer_type_node
,
717 /* long (*) (type) */
718 func_lround
= build_function_type_list (long_integer_type_node
,
720 /* long long (*) (type) */
721 func_llround
= build_function_type_list (long_long_integer_type_node
,
723 /* type (*) (type, type) */
724 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
725 /* type (*) (type, &int) */
727 = build_function_type_list (type
,
729 build_pointer_type (integer_type_node
),
731 /* type (*) (type, int) */
732 func_scalbn
= build_function_type_list (type
,
733 type
, integer_type_node
, NULL_TREE
);
734 /* type (*) (complex type) */
735 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
736 /* complex type (*) (complex type, complex type) */
738 = build_function_type_list (complex_type
,
739 complex_type
, complex_type
, NULL_TREE
);
741 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
742 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
743 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
745 /* Only these built-ins are actually needed here. These are used directly
746 from the code, when calling builtin_decl_for_precision() or
747 builtin_decl_for_float_type(). The others are all constructed by
748 gfc_get_intrinsic_lib_fndecl(). */
749 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
750 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
752 #include "mathbuiltins.def"
756 #undef DEFINE_MATH_BUILTIN
757 #undef DEFINE_MATH_BUILTIN_C
759 /* There is one built-in we defined manually, because it gets called
760 with builtin_decl_for_precision() or builtin_decl_for_float_type()
761 even though it is not an OTHER_BUILTIN: it is SQRT. */
762 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
766 /* Add GCC builtin functions. */
767 for (m
= gfc_intrinsic_map
;
768 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
770 if (m
->float_built_in
!= END_BUILTINS
)
771 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
772 if (m
->complex_float_built_in
!= END_BUILTINS
)
773 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
774 if (m
->double_built_in
!= END_BUILTINS
)
775 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
776 if (m
->complex_double_built_in
!= END_BUILTINS
)
777 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
779 /* If real(kind=10) exists, it is always long double. */
780 if (m
->long_double_built_in
!= END_BUILTINS
)
781 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
782 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
784 = builtin_decl_explicit (m
->complex_long_double_built_in
);
786 if (!gfc_real16_is_float128
)
788 if (m
->long_double_built_in
!= END_BUILTINS
)
789 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
790 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
792 = builtin_decl_explicit (m
->complex_long_double_built_in
);
794 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
796 /* Quad-precision function calls are constructed when first
797 needed by builtin_decl_for_precision(), except for those
798 that will be used directly (define by OTHER_BUILTIN). */
799 m
->real16_decl
= quad_decls
[m
->double_built_in
];
801 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
803 /* Same thing for the complex ones. */
804 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
810 /* Create a fndecl for a simple intrinsic library function. */
813 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
816 vec
<tree
, va_gc
> *argtypes
;
818 gfc_actual_arglist
*actual
;
821 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
824 if (ts
->type
== BT_REAL
)
829 pdecl
= &m
->real4_decl
;
832 pdecl
= &m
->real8_decl
;
835 pdecl
= &m
->real10_decl
;
838 pdecl
= &m
->real16_decl
;
844 else if (ts
->type
== BT_COMPLEX
)
846 gcc_assert (m
->complex_available
);
851 pdecl
= &m
->complex4_decl
;
854 pdecl
= &m
->complex8_decl
;
857 pdecl
= &m
->complex10_decl
;
860 pdecl
= &m
->complex16_decl
;
874 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
875 if (gfc_real_kinds
[n
].c_float
)
876 snprintf (name
, sizeof (name
), "%s%s%s",
877 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
878 else if (gfc_real_kinds
[n
].c_double
)
879 snprintf (name
, sizeof (name
), "%s%s",
880 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
881 else if (gfc_real_kinds
[n
].c_long_double
)
882 snprintf (name
, sizeof (name
), "%s%s%s",
883 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
884 else if (gfc_real_kinds
[n
].c_float128
)
885 snprintf (name
, sizeof (name
), "%s%s%s",
886 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
892 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
893 ts
->type
== BT_COMPLEX
? 'c' : 'r',
898 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
900 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
901 vec_safe_push (argtypes
, type
);
903 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
904 fndecl
= build_decl (input_location
,
905 FUNCTION_DECL
, get_identifier (name
), type
);
907 /* Mark the decl as external. */
908 DECL_EXTERNAL (fndecl
) = 1;
909 TREE_PUBLIC (fndecl
) = 1;
911 /* Mark it __attribute__((const)), if possible. */
912 TREE_READONLY (fndecl
) = m
->is_constant
;
914 rest_of_decl_compilation (fndecl
, 1, 0);
921 /* Convert an intrinsic function into an external or builtin call. */
924 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
926 gfc_intrinsic_map_t
*m
;
930 unsigned int num_args
;
933 id
= expr
->value
.function
.isym
->id
;
934 /* Find the entry for this function. */
935 for (m
= gfc_intrinsic_map
;
936 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
942 if (m
->id
== GFC_ISYM_NONE
)
944 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
945 expr
->value
.function
.name
, id
);
948 /* Get the decl and generate the call. */
949 num_args
= gfc_intrinsic_argument_list_length (expr
);
950 args
= XALLOCAVEC (tree
, num_args
);
952 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
953 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
954 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
956 fndecl
= build_addr (fndecl
);
957 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
961 /* If bounds-checking is enabled, create code to verify at runtime that the
962 string lengths for both expressions are the same (needed for e.g. MERGE).
963 If bounds-checking is not enabled, does nothing. */
966 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
967 tree a
, tree b
, stmtblock_t
* target
)
972 /* If bounds-checking is disabled, do nothing. */
973 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
976 /* Compare the two string lengths. */
977 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, a
, b
);
979 /* Output the runtime-check. */
980 name
= gfc_build_cstring_const (intr_name
);
981 name
= gfc_build_addr_expr (pchar_type_node
, name
);
982 gfc_trans_runtime_check (true, false, cond
, target
, where
,
983 "Unequal character lengths (%ld/%ld) in %s",
984 fold_convert (long_integer_type_node
, a
),
985 fold_convert (long_integer_type_node
, b
), name
);
989 /* The EXPONENT(X) intrinsic function is translated into
991 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
992 so that if X is a NaN or infinity, the result is HUGE(0).
996 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
998 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
1001 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
1002 expr
->value
.function
.actual
->expr
->ts
.kind
);
1004 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1005 arg
= gfc_evaluate_now (arg
, &se
->pre
);
1007 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
1008 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
1009 cond
= build_call_expr_loc (input_location
,
1010 builtin_decl_explicit (BUILT_IN_ISFINITE
),
1013 res
= gfc_create_var (integer_type_node
, NULL
);
1014 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
1015 gfc_build_addr_expr (NULL_TREE
, res
));
1016 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
1018 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
1021 type
= gfc_typenode_for_spec (&expr
->ts
);
1022 se
->expr
= fold_convert (type
, se
->expr
);
1026 /* Fill in the following structure
1027 struct caf_vector_t {
1028 size_t nvec; // size of the vector
1035 ptrdiff_t lower_bound;
1036 ptrdiff_t upper_bound;
1043 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
1044 tree lower
, tree upper
, tree stride
,
1045 tree vector
, int kind
, tree nvec
)
1047 tree field
, type
, tmp
;
1049 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
1050 type
= TREE_TYPE (desc
);
1052 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1053 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1054 desc
, field
, NULL_TREE
);
1055 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
1058 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1059 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1060 desc
, field
, NULL_TREE
);
1061 type
= TREE_TYPE (desc
);
1063 /* Access the inner struct. */
1064 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
1065 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1066 desc
, field
, NULL_TREE
);
1067 type
= TREE_TYPE (desc
);
1069 if (vector
!= NULL_TREE
)
1071 /* Set vector and kind. */
1072 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1073 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1074 desc
, field
, NULL_TREE
);
1075 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
1076 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1077 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1078 desc
, field
, NULL_TREE
);
1079 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
1083 /* Set dim.lower/upper/stride. */
1084 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1085 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1086 desc
, field
, NULL_TREE
);
1087 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1089 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1090 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1091 desc
, field
, NULL_TREE
);
1092 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1094 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1095 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1096 desc
, field
, NULL_TREE
);
1097 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1103 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1106 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1107 tree lbound
, ubound
, tmp
;
1110 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1112 for (i
= 0; i
< ar
->dimen
; i
++)
1113 switch (ar
->dimen_type
[i
])
1118 gfc_init_se (&argse
, NULL
);
1119 gfc_conv_expr (&argse
, ar
->end
[i
]);
1120 gfc_add_block_to_block (block
, &argse
.pre
);
1121 upper
= gfc_evaluate_now (argse
.expr
, block
);
1124 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1127 gfc_init_se (&argse
, NULL
);
1128 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1129 gfc_add_block_to_block (block
, &argse
.pre
);
1130 stride
= gfc_evaluate_now (argse
.expr
, block
);
1133 stride
= gfc_index_one_node
;
1139 gfc_init_se (&argse
, NULL
);
1140 gfc_conv_expr (&argse
, ar
->start
[i
]);
1141 gfc_add_block_to_block (block
, &argse
.pre
);
1142 lower
= gfc_evaluate_now (argse
.expr
, block
);
1145 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1146 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1149 stride
= gfc_index_one_node
;
1152 nvec
= size_zero_node
;
1153 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1158 gfc_init_se (&argse
, NULL
);
1159 argse
.descriptor_only
= 1;
1160 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1161 gfc_add_block_to_block (block
, &argse
.pre
);
1162 vector
= argse
.expr
;
1163 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1164 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1165 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1166 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1167 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1168 TREE_TYPE (nvec
), nvec
, tmp
);
1169 lower
= gfc_index_zero_node
;
1170 upper
= gfc_index_zero_node
;
1171 stride
= gfc_index_zero_node
;
1172 vector
= gfc_conv_descriptor_data_get (vector
);
1173 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1174 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1179 return gfc_build_addr_expr (NULL_TREE
, var
);
1184 compute_component_offset (tree field
, tree type
)
1187 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1188 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1190 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1191 DECL_FIELD_BIT_OFFSET (field
),
1193 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1196 return DECL_FIELD_OFFSET (field
);
1201 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1203 gfc_ref
*ref
= expr
->ref
, *last_comp_ref
;
1204 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1205 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1206 start
, end
, stride
, vector
, nvec
;
1208 bool ref_static_array
= false;
1209 tree last_component_ref_tree
= NULL_TREE
;
1214 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1215 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
1216 && !expr
->symtree
->n
.sym
->attr
.pointer
;
1219 /* Prevent uninit-warning. */
1220 reference_type
= NULL_TREE
;
1222 /* Skip refs upto the first coarray-ref. */
1223 last_comp_ref
= NULL
;
1224 while (ref
&& (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
== 0))
1226 /* Remember the type of components skipped. */
1227 if (ref
->type
== REF_COMPONENT
)
1228 last_comp_ref
= ref
;
1231 /* When a component was skipped, get the type information of the last
1232 component ref, else get the type from the symbol. */
1235 last_type
= gfc_typenode_for_spec (&last_comp_ref
->u
.c
.component
->ts
);
1236 last_type_n
= last_comp_ref
->u
.c
.component
->ts
.type
;
1240 last_type
= gfc_typenode_for_spec (&expr
->symtree
->n
.sym
->ts
);
1241 last_type_n
= expr
->symtree
->n
.sym
->ts
.type
;
1246 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0
1247 && ref
->u
.ar
.dimen
== 0)
1249 /* Skip pure coindexes. */
1253 tmp
= gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1254 reference_type
= TREE_TYPE (tmp
);
1256 if (caf_ref
== NULL_TREE
)
1259 /* Construct the chain of refs. */
1260 if (prev_caf_ref
!= NULL_TREE
)
1262 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1263 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1264 TREE_TYPE (field
), prev_caf_ref
, field
,
1266 gfc_add_modify (block
, tmp2
, gfc_build_addr_expr (TREE_TYPE (field
),
1274 last_type
= gfc_typenode_for_spec (&ref
->u
.c
.component
->ts
);
1275 last_type_n
= ref
->u
.c
.component
->ts
.type
;
1276 /* Set the type of the ref. */
1277 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1278 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1279 TREE_TYPE (field
), prev_caf_ref
, field
,
1281 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1282 GFC_CAF_REF_COMPONENT
));
1284 /* Ref the c in union u. */
1285 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1286 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1287 TREE_TYPE (field
), prev_caf_ref
, field
,
1289 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 0);
1290 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1291 TREE_TYPE (field
), tmp
, field
,
1294 /* Set the offset. */
1295 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1296 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1297 TREE_TYPE (field
), inner_struct
, field
,
1299 /* Computing the offset is somewhat harder. The bit_offset has to be
1300 taken into account. When the bit_offset in the field_decl is non-
1301 null, divide it by the bitsize_unit and add it to the regular
1303 tmp2
= compute_component_offset (ref
->u
.c
.component
->backend_decl
,
1305 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1307 /* Set caf_token_offset. */
1308 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 1);
1309 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1310 TREE_TYPE (field
), inner_struct
, field
,
1312 if ((ref
->u
.c
.component
->attr
.allocatable
1313 || ref
->u
.c
.component
->attr
.pointer
)
1314 && ref
->u
.c
.component
->attr
.dimension
)
1316 tree arr_desc_token_offset
;
1317 /* Get the token field from the descriptor. */
1318 arr_desc_token_offset
= TREE_OPERAND (
1319 gfc_conv_descriptor_token (ref
->u
.c
.component
->backend_decl
), 1);
1320 arr_desc_token_offset
1321 = compute_component_offset (arr_desc_token_offset
,
1323 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
,
1324 TREE_TYPE (tmp2
), tmp2
,
1325 arr_desc_token_offset
);
1327 else if (ref
->u
.c
.component
->caf_token
)
1328 tmp2
= compute_component_offset (ref
->u
.c
.component
->caf_token
,
1331 tmp2
= integer_zero_node
;
1332 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1334 /* Remember whether this ref was to a non-allocatable/non-pointer
1335 component so the next array ref can be tailored correctly. */
1336 ref_static_array
= !ref
->u
.c
.component
->attr
.allocatable
1337 && !ref
->u
.c
.component
->attr
.pointer
;
1338 last_component_ref_tree
= ref_static_array
1339 ? ref
->u
.c
.component
->backend_decl
: NULL_TREE
;
1342 if (ref_static_array
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
)
1343 ref_static_array
= false;
1344 /* Set the type of the ref. */
1345 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1346 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1347 TREE_TYPE (field
), prev_caf_ref
, field
,
1349 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1351 ? GFC_CAF_REF_STATIC_ARRAY
1352 : GFC_CAF_REF_ARRAY
));
1354 /* Ref the a in union u. */
1355 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1356 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1357 TREE_TYPE (field
), prev_caf_ref
, field
,
1359 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 1);
1360 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1361 TREE_TYPE (field
), tmp
, field
,
1364 /* Set the static_array_type in a for static arrays. */
1365 if (ref_static_array
)
1367 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)),
1369 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1370 TREE_TYPE (field
), inner_struct
, field
,
1372 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (tmp
),
1375 /* Ref the mode in the inner_struct. */
1376 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1377 mode
= fold_build3_loc (input_location
, COMPONENT_REF
,
1378 TREE_TYPE (field
), inner_struct
, field
,
1380 /* Ref the dim in the inner_struct. */
1381 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 2);
1382 dim_array
= fold_build3_loc (input_location
, COMPONENT_REF
,
1383 TREE_TYPE (field
), inner_struct
, field
,
1385 for (i
= 0; i
< ref
->u
.ar
.dimen
; ++i
)
1388 dim
= gfc_build_array_ref (dim_array
, gfc_rank_cst
[i
], NULL_TREE
);
1389 dim_type
= TREE_TYPE (dim
);
1390 mode_rhs
= start
= end
= stride
= NULL_TREE
;
1391 switch (ref
->u
.ar
.dimen_type
[i
])
1394 if (ref
->u
.ar
.end
[i
])
1396 gfc_init_se (&se
, NULL
);
1397 gfc_conv_expr (&se
, ref
->u
.ar
.end
[i
]);
1398 gfc_add_block_to_block (block
, &se
.pre
);
1399 if (ref_static_array
)
1401 /* Make the index zero-based, when reffing a static
1404 gfc_init_se (&se
, NULL
);
1405 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1406 gfc_add_block_to_block (block
, &se
.pre
);
1407 se
.expr
= fold_build2 (MINUS_EXPR
,
1408 gfc_array_index_type
,
1410 gfc_array_index_type
,
1413 end
= gfc_evaluate_now (fold_convert (
1414 gfc_array_index_type
,
1418 else if (ref_static_array
)
1419 end
= fold_build2 (MINUS_EXPR
,
1420 gfc_array_index_type
,
1421 gfc_conv_array_ubound (
1422 last_component_ref_tree
, i
),
1423 gfc_conv_array_lbound (
1424 last_component_ref_tree
, i
));
1428 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1429 GFC_CAF_ARR_REF_OPEN_END
);
1431 if (ref
->u
.ar
.stride
[i
])
1433 gfc_init_se (&se
, NULL
);
1434 gfc_conv_expr (&se
, ref
->u
.ar
.stride
[i
]);
1435 gfc_add_block_to_block (block
, &se
.pre
);
1436 stride
= gfc_evaluate_now (fold_convert (
1437 gfc_array_index_type
,
1440 if (ref_static_array
)
1442 /* Make the index zero-based, when reffing a static
1444 stride
= fold_build2 (MULT_EXPR
,
1445 gfc_array_index_type
,
1446 gfc_conv_array_stride (
1447 last_component_ref_tree
,
1450 gcc_assert (end
!= NULL_TREE
);
1451 /* Multiply with the product of array's stride and
1452 the step of the ref to a virtual upper bound.
1453 We cannot compute the actual upper bound here or
1454 the caflib would compute the extend
1456 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1457 end
, gfc_conv_array_stride (
1458 last_component_ref_tree
,
1460 end
= gfc_evaluate_now (end
, block
);
1461 stride
= gfc_evaluate_now (stride
, block
);
1464 else if (ref_static_array
)
1466 stride
= gfc_conv_array_stride (last_component_ref_tree
,
1468 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1470 end
= gfc_evaluate_now (end
, block
);
1473 /* Always set a ref stride of one to make caflib's
1475 stride
= gfc_index_one_node
;
1479 if (ref
->u
.ar
.start
[i
])
1481 gfc_init_se (&se
, NULL
);
1482 gfc_conv_expr (&se
, ref
->u
.ar
.start
[i
]);
1483 gfc_add_block_to_block (block
, &se
.pre
);
1484 if (ref_static_array
)
1486 /* Make the index zero-based, when reffing a static
1488 start
= fold_convert (gfc_array_index_type
, se
.expr
);
1489 gfc_init_se (&se
, NULL
);
1490 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1491 gfc_add_block_to_block (block
, &se
.pre
);
1492 se
.expr
= fold_build2 (MINUS_EXPR
,
1493 gfc_array_index_type
,
1494 start
, fold_convert (
1495 gfc_array_index_type
,
1497 /* Multiply with the stride. */
1498 se
.expr
= fold_build2 (MULT_EXPR
,
1499 gfc_array_index_type
,
1501 gfc_conv_array_stride (
1502 last_component_ref_tree
,
1505 start
= gfc_evaluate_now (fold_convert (
1506 gfc_array_index_type
,
1509 if (mode_rhs
== NULL_TREE
)
1510 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1511 ref
->u
.ar
.dimen_type
[i
]
1513 ? GFC_CAF_ARR_REF_SINGLE
1514 : GFC_CAF_ARR_REF_RANGE
);
1516 else if (ref_static_array
)
1518 start
= integer_zero_node
;
1519 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1520 ref
->u
.ar
.start
[i
] == NULL
1521 ? GFC_CAF_ARR_REF_FULL
1522 : GFC_CAF_ARR_REF_RANGE
);
1524 else if (end
== NULL_TREE
)
1525 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1526 GFC_CAF_ARR_REF_FULL
);
1528 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1529 GFC_CAF_ARR_REF_OPEN_START
);
1531 /* Ref the s in dim. */
1532 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 0);
1533 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1534 TREE_TYPE (field
), dim
, field
,
1537 /* Set start in s. */
1538 if (start
!= NULL_TREE
)
1540 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1542 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1543 TREE_TYPE (field
), tmp
, field
,
1545 gfc_add_modify (block
, tmp2
,
1546 fold_convert (TREE_TYPE (tmp2
), start
));
1550 if (end
!= NULL_TREE
)
1552 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1554 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1555 TREE_TYPE (field
), tmp
, field
,
1557 gfc_add_modify (block
, tmp2
,
1558 fold_convert (TREE_TYPE (tmp2
), end
));
1562 if (stride
!= NULL_TREE
)
1564 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1566 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1567 TREE_TYPE (field
), tmp
, field
,
1569 gfc_add_modify (block
, tmp2
,
1570 fold_convert (TREE_TYPE (tmp2
), stride
));
1574 /* TODO: In case of static array. */
1575 gcc_assert (!ref_static_array
);
1576 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1577 GFC_CAF_ARR_REF_VECTOR
);
1578 gfc_init_se (&se
, NULL
);
1579 se
.descriptor_only
= 1;
1580 gfc_conv_expr_descriptor (&se
, ref
->u
.ar
.start
[i
]);
1581 gfc_add_block_to_block (block
, &se
.pre
);
1583 tmp
= gfc_conv_descriptor_lbound_get (vector
,
1585 tmp2
= gfc_conv_descriptor_ubound_get (vector
,
1587 nvec
= gfc_conv_array_extent_dim (tmp
, tmp2
, NULL
);
1588 tmp
= gfc_conv_descriptor_stride_get (vector
,
1590 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1591 TREE_TYPE (nvec
), nvec
, tmp
);
1592 vector
= gfc_conv_descriptor_data_get (vector
);
1594 /* Ref the v in dim. */
1595 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 1);
1596 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1597 TREE_TYPE (field
), dim
, field
,
1600 /* Set vector in v. */
1601 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 0);
1602 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1603 TREE_TYPE (field
), tmp
, field
,
1605 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1608 /* Set nvec in v. */
1609 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 1);
1610 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1611 TREE_TYPE (field
), tmp
, field
,
1613 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1616 /* Set kind in v. */
1617 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 2);
1618 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1619 TREE_TYPE (field
), tmp
, field
,
1621 gfc_add_modify (block
, tmp2
, build_int_cst (integer_type_node
,
1622 ref
->u
.ar
.start
[i
]->ts
.kind
));
1627 /* Set the mode for dim i. */
1628 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1629 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
),
1633 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1634 if (i
< GFC_MAX_DIMENSIONS
)
1636 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1637 gfc_add_modify (block
, tmp
,
1638 build_int_cst (unsigned_char_type_node
,
1639 GFC_CAF_ARR_REF_NONE
));
1646 /* Set the size of the current type. */
1647 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 2);
1648 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1649 prev_caf_ref
, field
, NULL_TREE
);
1650 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1651 TYPE_SIZE_UNIT (last_type
)));
1656 if (prev_caf_ref
!= NULL_TREE
)
1658 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1659 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1660 prev_caf_ref
, field
, NULL_TREE
);
1661 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1662 null_pointer_node
));
1664 return caf_ref
!= NULL_TREE
? gfc_build_addr_expr (NULL_TREE
, caf_ref
)
1668 /* Get data from a remote coarray. */
1671 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1672 tree may_require_tmp
, bool may_realloc
,
1673 symbol_attribute
*caf_attr
)
1675 gfc_expr
*array_expr
, *tmp_stat
;
1677 tree caf_decl
, token
, offset
, image_index
, tmp
;
1678 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
1680 symbol_attribute caf_attr_store
;
1682 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1684 if (se
->ss
&& se
->ss
->info
->useflags
)
1686 /* Access the previously obtained result. */
1687 gfc_conv_tmp_array_ref (se
);
1691 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1692 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1693 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1695 if (caf_attr
== NULL
)
1697 caf_attr_store
= gfc_caf_attr (array_expr
);
1698 caf_attr
= &caf_attr_store
;
1704 vec
= null_pointer_node
;
1705 tmp_stat
= gfc_find_stat_co (expr
);
1710 gfc_init_se (&stat_se
, NULL
);
1711 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1712 stat
= stat_se
.expr
;
1713 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1714 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1717 stat
= null_pointer_node
;
1719 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1720 is reallocatable or the right-hand side has allocatable components. */
1721 if (caf_attr
->alloc_comp
|| caf_attr
->pointer_comp
|| may_realloc
)
1723 /* Get using caf_get_by_ref. */
1724 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, array_expr
);
1726 if (caf_reference
!= NULL_TREE
)
1728 if (lhs
== NULL_TREE
)
1730 if (array_expr
->ts
.type
== BT_CHARACTER
)
1731 gfc_init_se (&argse
, NULL
);
1732 if (array_expr
->rank
== 0)
1734 symbol_attribute attr
;
1735 gfc_clear_attr (&attr
);
1736 if (array_expr
->ts
.type
== BT_CHARACTER
)
1738 res_var
= gfc_conv_string_tmp (se
,
1739 build_pointer_type (type
),
1740 array_expr
->ts
.u
.cl
->backend_decl
);
1741 argse
.string_length
= array_expr
->ts
.u
.cl
->backend_decl
;
1744 res_var
= gfc_create_var (type
, "caf_res");
1745 dst_var
= gfc_conv_scalar_to_descriptor (se
, res_var
, attr
);
1746 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1750 /* Create temporary. */
1751 if (array_expr
->ts
.type
== BT_CHARACTER
)
1752 gfc_conv_expr_descriptor (&argse
, array_expr
);
1753 may_realloc
= gfc_trans_create_temp_array (&se
->pre
,
1760 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1761 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1764 tmp
= gfc_conv_descriptor_data_get (res_var
);
1765 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
,
1766 NULL_TREE
, NULL_TREE
,
1769 GFC_CAF_COARRAY_NOCOARRAY
);
1770 gfc_add_expr_to_block (&se
->post
, tmp
);
1775 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1776 if (lhs_kind
== NULL_TREE
)
1779 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1780 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1781 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1782 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1784 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1787 /* No overlap possible as we have generated a temporary. */
1788 if (lhs
== NULL_TREE
)
1789 may_require_tmp
= boolean_false_node
;
1791 /* It guarantees memory consistency within the same segment. */
1792 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1793 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1794 gfc_build_string_const (1, ""), NULL_TREE
,
1795 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1797 ASM_VOLATILE_P (tmp
) = 1;
1798 gfc_add_expr_to_block (&se
->pre
, tmp
);
1800 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1801 10, token
, image_index
, dst_var
,
1802 caf_reference
, lhs_kind
, kind
,
1804 may_realloc
? boolean_true_node
:
1806 stat
, build_int_cst (integer_type_node
,
1807 array_expr
->ts
.type
));
1809 gfc_add_expr_to_block (&se
->pre
, tmp
);
1812 gfc_advance_se_ss_chain (se
);
1815 if (array_expr
->ts
.type
== BT_CHARACTER
)
1816 se
->string_length
= argse
.string_length
;
1822 gfc_init_se (&argse
, NULL
);
1823 if (array_expr
->rank
== 0)
1825 symbol_attribute attr
;
1827 gfc_clear_attr (&attr
);
1828 gfc_conv_expr (&argse
, array_expr
);
1830 if (lhs
== NULL_TREE
)
1832 gfc_clear_attr (&attr
);
1833 if (array_expr
->ts
.type
== BT_CHARACTER
)
1834 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1835 argse
.string_length
);
1837 res_var
= gfc_create_var (type
, "caf_res");
1838 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1839 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1841 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1842 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1846 /* If has_vector, pass descriptor for whole array and the
1847 vector bounds separately. */
1848 gfc_array_ref
*ar
, ar2
;
1849 bool has_vector
= false;
1851 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1854 ar
= gfc_find_array_ref (expr
);
1856 memset (ar
, '\0', sizeof (*ar
));
1860 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1861 gfc_conv_expr_descriptor (&argse
, array_expr
);
1862 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1863 has the wrong type if component references are done. */
1864 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1865 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1870 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1874 if (lhs
== NULL_TREE
)
1876 /* Create temporary. */
1877 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1878 if (se
->loop
->to
[n
] == NULL_TREE
)
1880 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1882 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1885 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1886 NULL_TREE
, false, true, false,
1887 &array_expr
->where
);
1888 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1889 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1891 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1894 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1895 if (lhs_kind
== NULL_TREE
)
1898 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1899 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1901 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1902 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1903 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1904 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1905 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1908 /* No overlap possible as we have generated a temporary. */
1909 if (lhs
== NULL_TREE
)
1910 may_require_tmp
= boolean_false_node
;
1912 /* It guarantees memory consistency within the same segment. */
1913 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1914 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1915 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1916 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1917 ASM_VOLATILE_P (tmp
) = 1;
1918 gfc_add_expr_to_block (&se
->pre
, tmp
);
1920 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1921 token
, offset
, image_index
, argse
.expr
, vec
,
1922 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1924 gfc_add_expr_to_block (&se
->pre
, tmp
);
1927 gfc_advance_se_ss_chain (se
);
1930 if (array_expr
->ts
.type
== BT_CHARACTER
)
1931 se
->string_length
= argse
.string_length
;
1935 /* Send data to a remote coarray. */
1938 conv_caf_send (gfc_code
*code
) {
1939 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
, *tmp_team
;
1940 gfc_se lhs_se
, rhs_se
;
1942 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1943 tree may_require_tmp
, src_stat
, dst_stat
, dst_team
;
1944 tree lhs_type
= NULL_TREE
;
1945 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1946 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1948 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1950 lhs_expr
= code
->ext
.actual
->expr
;
1951 rhs_expr
= code
->ext
.actual
->next
->expr
;
1952 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, true) == 0
1953 ? boolean_false_node
: boolean_true_node
;
1954 gfc_init_block (&block
);
1956 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1957 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1958 src_stat
= dst_stat
= null_pointer_node
;
1959 dst_team
= null_pointer_node
;
1962 gfc_init_se (&lhs_se
, NULL
);
1963 if (lhs_expr
->rank
== 0)
1965 if (lhs_expr
->ts
.type
== BT_CHARACTER
&& lhs_expr
->ts
.deferred
)
1967 lhs_se
.expr
= gfc_get_tree_for_caf_expr (lhs_expr
);
1968 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1972 symbol_attribute attr
;
1973 gfc_clear_attr (&attr
);
1974 gfc_conv_expr (&lhs_se
, lhs_expr
);
1975 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1976 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
,
1978 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1981 else if ((lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
1982 && lhs_caf_attr
.codimension
)
1984 lhs_se
.want_pointer
= 1;
1985 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1986 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1987 has the wrong type if component references are done. */
1988 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1989 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1990 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1991 gfc_get_dtype_rank_type (
1992 gfc_has_vector_subscript (lhs_expr
)
1993 ? gfc_find_array_ref (lhs_expr
)->dimen
1999 bool has_vector
= gfc_has_vector_subscript (lhs_expr
);
2001 if (gfc_is_coindexed (lhs_expr
) || !has_vector
)
2003 /* If has_vector, pass descriptor for whole array and the
2004 vector bounds separately. */
2005 gfc_array_ref
*ar
, ar2
;
2006 bool has_tmp_lhs_array
= false;
2009 has_tmp_lhs_array
= true;
2010 ar
= gfc_find_array_ref (lhs_expr
);
2012 memset (ar
, '\0', sizeof (*ar
));
2016 lhs_se
.want_pointer
= 1;
2017 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
2018 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
2019 that has the wrong type if component references are done. */
2020 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
2021 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
2022 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2023 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2026 if (has_tmp_lhs_array
)
2028 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
2034 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
2035 indexed array expression. This is rewritten to:
2037 tmp_array = arr2[...]
2038 arr1 ([...]) = tmp_array
2040 because using the standard gfc_conv_expr (lhs_expr) did the
2041 assignment with lhs and rhs exchanged. */
2043 gfc_ss
*lss_for_tmparray
, *lss_real
;
2047 tree tmparr_desc
, src
;
2048 tree index
= gfc_index_zero_node
;
2049 tree stride
= gfc_index_zero_node
;
2052 /* Walk both sides of the assignment, once to get the shape of the
2053 temporary array to create right. */
2054 lss_for_tmparray
= gfc_walk_expr (lhs_expr
);
2055 /* And a second time to be able to create an assignment of the
2056 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
2057 the tree in the descriptor with the one for the temporary
2059 lss_real
= gfc_walk_expr (lhs_expr
);
2060 gfc_init_loopinfo (&loop
);
2061 gfc_add_ss_to_loop (&loop
, lss_for_tmparray
);
2062 gfc_add_ss_to_loop (&loop
, lss_real
);
2063 gfc_conv_ss_startstride (&loop
);
2064 gfc_conv_loop_setup (&loop
, &lhs_expr
->where
);
2065 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
2066 gfc_trans_create_temp_array (&lhs_se
.pre
, &lhs_se
.post
,
2067 lss_for_tmparray
, lhs_type
, NULL_TREE
,
2070 tmparr_desc
= lss_for_tmparray
->info
->data
.array
.descriptor
;
2071 gfc_start_scalarized_body (&loop
, &body
);
2072 gfc_init_se (&se
, NULL
);
2073 gfc_copy_loopinfo_to_se (&se
, &loop
);
2075 gfc_conv_expr (&se
, lhs_expr
);
2076 gfc_add_block_to_block (&body
, &se
.pre
);
2078 /* Walk over all indexes of the loop. */
2079 for (n
= loop
.dimen
- 1; n
> 0; --n
)
2081 tmp
= loop
.loopvar
[n
];
2082 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2083 gfc_array_index_type
, tmp
, loop
.from
[n
]);
2084 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2085 gfc_array_index_type
, tmp
, index
);
2087 stride
= fold_build2_loc (input_location
, MINUS_EXPR
,
2088 gfc_array_index_type
,
2089 loop
.to
[n
- 1], loop
.from
[n
- 1]);
2090 stride
= fold_build2_loc (input_location
, PLUS_EXPR
,
2091 gfc_array_index_type
,
2092 stride
, gfc_index_one_node
);
2094 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2095 gfc_array_index_type
, tmp
, stride
);
2098 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2099 gfc_array_index_type
,
2100 index
, loop
.from
[0]);
2102 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2103 gfc_array_index_type
,
2104 loop
.loopvar
[0], index
);
2106 src
= build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc
));
2107 src
= gfc_build_array_ref (src
, index
, NULL
);
2108 /* Now create the assignment of lhs_expr = tmp_array. */
2109 gfc_add_modify (&body
, se
.expr
, src
);
2110 gfc_add_block_to_block (&body
, &se
.post
);
2111 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, tmparr_desc
);
2112 gfc_trans_scalarizing_loops (&loop
, &body
);
2113 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2114 gfc_add_expr_to_block (&lhs_se
.post
, gfc_finish_block (&loop
.pre
));
2115 gfc_free_ss (lss_for_tmparray
);
2116 gfc_free_ss (lss_real
);
2120 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
2122 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2123 temporary and a loop. */
2124 if (!gfc_is_coindexed (lhs_expr
)
2125 && (!lhs_caf_attr
.codimension
2126 || !(lhs_expr
->rank
> 0
2127 && (lhs_caf_attr
.allocatable
|| lhs_caf_attr
.pointer
))))
2129 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
2130 gcc_assert (gfc_is_coindexed (rhs_expr
));
2131 gfc_init_se (&rhs_se
, NULL
);
2132 if (lhs_expr
->rank
== 0 && lhs_caf_attr
.allocatable
)
2135 gfc_init_se (&scal_se
, NULL
);
2136 scal_se
.want_pointer
= 1;
2137 gfc_conv_expr (&scal_se
, lhs_expr
);
2138 /* Ensure scalar on lhs is allocated. */
2139 gfc_add_block_to_block (&block
, &scal_se
.pre
);
2141 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
2143 gfc_typenode_for_spec (&lhs_expr
->ts
)),
2145 tmp
= fold_build2 (EQ_EXPR
, logical_type_node
, scal_se
.expr
,
2147 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2148 tmp
, gfc_finish_block (&scal_se
.pre
),
2149 build_empty_stmt (input_location
));
2150 gfc_add_expr_to_block (&block
, tmp
);
2153 lhs_may_realloc
= lhs_may_realloc
2154 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
2155 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2156 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
2157 may_require_tmp
, lhs_may_realloc
,
2159 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2160 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2161 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2162 return gfc_finish_block (&block
);
2165 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2167 /* Obtain token, offset and image index for the LHS. */
2168 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
2169 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2170 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2171 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
2173 if (lhs_caf_attr
.alloc_comp
)
2174 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
2177 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
2182 gfc_init_se (&rhs_se
, NULL
);
2183 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
2184 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2185 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
2186 if (rhs_expr
->rank
== 0)
2188 symbol_attribute attr
;
2189 gfc_clear_attr (&attr
);
2190 gfc_conv_expr (&rhs_se
, rhs_expr
);
2191 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
2192 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2194 else if ((rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2195 && rhs_caf_attr
.codimension
)
2198 rhs_se
.want_pointer
= 1;
2199 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2200 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2201 has the wrong type if component references are done. */
2202 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2203 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2204 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2205 gfc_get_dtype_rank_type (
2206 gfc_has_vector_subscript (rhs_expr
)
2207 ? gfc_find_array_ref (rhs_expr
)->dimen
2213 /* If has_vector, pass descriptor for whole array and the
2214 vector bounds separately. */
2215 gfc_array_ref
*ar
, ar2
;
2216 bool has_vector
= false;
2219 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2222 ar
= gfc_find_array_ref (rhs_expr
);
2224 memset (ar
, '\0', sizeof (*ar
));
2228 rhs_se
.want_pointer
= 1;
2229 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2230 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2231 has the wrong type if component references are done. */
2232 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2233 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2234 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2235 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2240 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2245 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2247 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2249 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2254 gfc_init_se (&stat_se
, NULL
);
2255 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2256 dst_stat
= stat_se
.expr
;
2257 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2258 gfc_add_block_to_block (&block
, &stat_se
.post
);
2261 tmp_team
= gfc_find_team_co (lhs_expr
);
2266 gfc_init_se (&team_se
, NULL
);
2267 gfc_conv_expr_reference (&team_se
, tmp_team
);
2268 dst_team
= team_se
.expr
;
2269 gfc_add_block_to_block (&block
, &team_se
.pre
);
2270 gfc_add_block_to_block (&block
, &team_se
.post
);
2273 if (!gfc_is_coindexed (rhs_expr
))
2275 if (lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
2277 tree reference
, dst_realloc
;
2278 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2279 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2280 : boolean_false_node
;
2281 tmp
= build_call_expr_loc (input_location
,
2282 gfor_fndecl_caf_send_by_ref
,
2283 10, token
, image_index
, rhs_se
.expr
,
2284 reference
, lhs_kind
, rhs_kind
,
2285 may_require_tmp
, dst_realloc
, src_stat
,
2286 build_int_cst (integer_type_node
,
2287 lhs_expr
->ts
.type
));
2290 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 11,
2291 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2292 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2293 may_require_tmp
, src_stat
, dst_team
);
2297 tree rhs_token
, rhs_offset
, rhs_image_index
;
2299 /* It guarantees memory consistency within the same segment. */
2300 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2301 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2302 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2303 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2304 ASM_VOLATILE_P (tmp
) = 1;
2305 gfc_add_expr_to_block (&block
, tmp
);
2307 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2308 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2309 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2310 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2312 if (rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2314 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2319 gfc_init_se (&stat_se
, NULL
);
2320 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2321 src_stat
= stat_se
.expr
;
2322 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2323 gfc_add_block_to_block (&block
, &stat_se
.post
);
2326 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2328 tree lhs_reference
, rhs_reference
;
2329 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2330 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2331 tmp
= build_call_expr_loc (input_location
,
2332 gfor_fndecl_caf_sendget_by_ref
, 13,
2333 token
, image_index
, lhs_reference
,
2334 rhs_token
, rhs_image_index
, rhs_reference
,
2335 lhs_kind
, rhs_kind
, may_require_tmp
,
2337 build_int_cst (integer_type_node
,
2339 build_int_cst (integer_type_node
,
2340 rhs_expr
->ts
.type
));
2344 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2346 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2347 14, token
, offset
, image_index
,
2348 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2349 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2350 rhs_kind
, may_require_tmp
, src_stat
);
2353 gfc_add_expr_to_block (&block
, tmp
);
2354 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2355 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2357 /* It guarantees memory consistency within the same segment. */
2358 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2359 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2360 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2361 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2362 ASM_VOLATILE_P (tmp
) = 1;
2363 gfc_add_expr_to_block (&block
, tmp
);
2365 return gfc_finish_block (&block
);
2370 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2373 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2374 lbound
, ubound
, extent
, ml
;
2377 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2379 if (expr
->value
.function
.actual
->expr
2380 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2381 distance
= expr
->value
.function
.actual
->expr
;
2383 /* The case -fcoarray=single is handled elsewhere. */
2384 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2386 /* Argument-free version: THIS_IMAGE(). */
2387 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2391 gfc_init_se (&argse
, NULL
);
2392 gfc_conv_expr_val (&argse
, distance
);
2393 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2394 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2395 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2398 tmp
= integer_zero_node
;
2399 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2401 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2406 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2408 type
= gfc_get_int_type (gfc_default_integer_kind
);
2409 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2410 rank
= expr
->value
.function
.actual
->expr
->rank
;
2412 /* Obtain the descriptor of the COARRAY. */
2413 gfc_init_se (&argse
, NULL
);
2414 argse
.want_coarray
= 1;
2415 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2416 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2417 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2422 /* Create an implicit second parameter from the loop variable. */
2423 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2424 gcc_assert (corank
> 0);
2425 gcc_assert (se
->loop
->dimen
== 1);
2426 gcc_assert (se
->ss
->info
->expr
== expr
);
2428 dim_arg
= se
->loop
->loopvar
[0];
2429 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2430 gfc_array_index_type
, dim_arg
,
2431 build_int_cst (TREE_TYPE (dim_arg
), 1));
2432 gfc_advance_se_ss_chain (se
);
2436 /* Use the passed DIM= argument. */
2437 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2438 gfc_init_se (&argse
, NULL
);
2439 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2440 gfc_array_index_type
);
2441 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2442 dim_arg
= argse
.expr
;
2444 if (INTEGER_CST_P (dim_arg
))
2446 if (wi::ltu_p (wi::to_wide (dim_arg
), 1)
2447 || wi::gtu_p (wi::to_wide (dim_arg
),
2448 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2449 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2450 "dimension index", expr
->value
.function
.isym
->name
,
2453 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2455 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2456 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2458 build_int_cst (TREE_TYPE (dim_arg
), 1));
2459 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2460 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2462 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2463 logical_type_node
, cond
, tmp
);
2464 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2469 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2470 one always has a dim_arg argument.
2472 m = this_image() - 1
2475 sub(1) = m + lcobound(corank)
2479 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2482 extent = gfc_extent(i)
2490 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2491 : m + lcobound(corank)
2494 /* this_image () - 1. */
2495 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2497 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2498 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2501 /* sub(1) = m + lcobound(corank). */
2502 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2503 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2505 lbound
= fold_convert (type
, lbound
);
2506 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2512 m
= gfc_create_var (type
, NULL
);
2513 ml
= gfc_create_var (type
, NULL
);
2514 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2515 min_var
= gfc_create_var (integer_type_node
, NULL
);
2517 /* m = this_image () - 1. */
2518 gfc_add_modify (&se
->pre
, m
, tmp
);
2520 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2521 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2522 fold_convert (integer_type_node
, dim_arg
),
2523 build_int_cst (integer_type_node
, rank
- 1));
2524 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2525 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2527 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2530 tmp
= build_int_cst (integer_type_node
, rank
);
2531 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2533 exit_label
= gfc_build_label_decl (NULL_TREE
);
2534 TREE_USED (exit_label
) = 1;
2537 gfc_init_block (&loop
);
2540 gfc_add_modify (&loop
, ml
, m
);
2543 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2544 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2545 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2546 extent
= fold_convert (type
, extent
);
2549 gfc_add_modify (&loop
, m
,
2550 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2553 /* Exit condition: if (i >= min_var) goto exit_label. */
2554 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, loop_var
,
2556 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2557 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2558 build_empty_stmt (input_location
));
2559 gfc_add_expr_to_block (&loop
, tmp
);
2561 /* Increment loop variable: i++. */
2562 gfc_add_modify (&loop
, loop_var
,
2563 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2565 build_int_cst (integer_type_node
, 1)));
2567 /* Making the loop... actually loop! */
2568 tmp
= gfc_finish_block (&loop
);
2569 tmp
= build1_v (LOOP_EXPR
, tmp
);
2570 gfc_add_expr_to_block (&se
->pre
, tmp
);
2572 /* The exit label. */
2573 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2574 gfc_add_expr_to_block (&se
->pre
, tmp
);
2576 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2577 : m + lcobound(corank) */
2579 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, dim_arg
,
2580 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2582 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2583 fold_build2_loc (input_location
, PLUS_EXPR
,
2584 gfc_array_index_type
, dim_arg
,
2585 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2586 lbound
= fold_convert (type
, lbound
);
2588 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2589 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2591 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2593 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2594 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2599 /* Convert a call to image_status. */
2602 conv_intrinsic_image_status (gfc_se
*se
, gfc_expr
*expr
)
2604 unsigned int num_args
;
2607 num_args
= gfc_intrinsic_argument_list_length (expr
);
2608 args
= XALLOCAVEC (tree
, num_args
);
2609 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2610 /* In args[0] the number of the image the status is desired for has to be
2613 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2616 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2617 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2618 fold_convert (integer_type_node
, arg
),
2620 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2621 tmp
, integer_zero_node
,
2622 build_int_cst (integer_type_node
,
2623 GFC_STAT_STOPPED_IMAGE
));
2625 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2626 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_image_status
, 2,
2627 args
[0], build_int_cst (integer_type_node
, -1));
2635 conv_intrinsic_team_number (gfc_se
*se
, gfc_expr
*expr
)
2637 unsigned int num_args
;
2641 num_args
= gfc_intrinsic_argument_list_length (expr
);
2642 args
= XALLOCAVEC (tree
, num_args
);
2643 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2646 GFC_FCOARRAY_SINGLE
&& expr
->value
.function
.actual
->expr
)
2650 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2651 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2652 fold_convert (integer_type_node
, arg
),
2654 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2655 tmp
, integer_zero_node
,
2656 build_int_cst (integer_type_node
,
2657 GFC_STAT_STOPPED_IMAGE
));
2659 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2661 // the value -1 represents that no team has been created yet
2662 tmp
= build_int_cst (integer_type_node
, -1);
2664 else if (flag_coarray
== GFC_FCOARRAY_LIB
&& expr
->value
.function
.actual
->expr
)
2665 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2666 args
[0], build_int_cst (integer_type_node
, -1));
2667 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2668 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2669 integer_zero_node
, build_int_cst (integer_type_node
, -1));
2678 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2680 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2682 gfc_se argse
, subse
;
2683 int rank
, corank
, codim
;
2685 type
= gfc_get_int_type (gfc_default_integer_kind
);
2686 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2687 rank
= expr
->value
.function
.actual
->expr
->rank
;
2689 /* Obtain the descriptor of the COARRAY. */
2690 gfc_init_se (&argse
, NULL
);
2691 argse
.want_coarray
= 1;
2692 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2693 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2694 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2697 /* Obtain a handle to the SUB argument. */
2698 gfc_init_se (&subse
, NULL
);
2699 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2700 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2701 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2702 subdesc
= build_fold_indirect_ref_loc (input_location
,
2703 gfc_conv_descriptor_data_get (subse
.expr
));
2705 /* Fortran 2008 does not require that the values remain in the cobounds,
2706 thus we need explicitly check this - and return 0 if they are exceeded. */
2708 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2709 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2710 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2711 fold_convert (gfc_array_index_type
, tmp
),
2714 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2716 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2717 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2718 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2719 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2720 fold_convert (gfc_array_index_type
, tmp
),
2722 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2723 logical_type_node
, invalid_bound
, cond
);
2724 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2725 fold_convert (gfc_array_index_type
, tmp
),
2727 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2728 logical_type_node
, invalid_bound
, cond
);
2731 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2733 /* See Fortran 2008, C.10 for the following algorithm. */
2735 /* coindex = sub(corank) - lcobound(n). */
2736 coindex
= fold_convert (gfc_array_index_type
,
2737 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2739 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2740 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2741 fold_convert (gfc_array_index_type
, coindex
),
2744 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2746 tree extent
, ubound
;
2748 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2749 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2750 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2751 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2753 /* coindex *= extent. */
2754 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2755 gfc_array_index_type
, coindex
, extent
);
2757 /* coindex += sub(codim). */
2758 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2759 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2760 gfc_array_index_type
, coindex
,
2761 fold_convert (gfc_array_index_type
, tmp
));
2763 /* coindex -= lbound(codim). */
2764 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2765 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2766 gfc_array_index_type
, coindex
, lbound
);
2769 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2770 fold_convert(type
, coindex
),
2771 build_int_cst (type
, 1));
2773 /* Return 0 if "coindex" exceeds num_images(). */
2775 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2776 num_images
= build_int_cst (type
, 1);
2779 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2781 build_int_cst (integer_type_node
, -1));
2782 num_images
= fold_convert (type
, tmp
);
2785 tmp
= gfc_create_var (type
, NULL
);
2786 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2788 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, tmp
,
2790 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
2792 fold_convert (logical_type_node
, invalid_bound
));
2793 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2794 build_int_cst (type
, 0), tmp
);
2798 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2800 tree tmp
, distance
, failed
;
2803 if (expr
->value
.function
.actual
->expr
)
2805 gfc_init_se (&argse
, NULL
);
2806 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2807 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2808 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2809 distance
= fold_convert (integer_type_node
, argse
.expr
);
2812 distance
= integer_zero_node
;
2814 if (expr
->value
.function
.actual
->next
->expr
)
2816 gfc_init_se (&argse
, NULL
);
2817 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2818 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2819 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2820 failed
= fold_convert (integer_type_node
, argse
.expr
);
2823 failed
= build_int_cst (integer_type_node
, -1);
2824 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2826 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2831 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2835 gfc_init_se (&argse
, NULL
);
2836 argse
.data_not_needed
= 1;
2837 argse
.descriptor_only
= 1;
2839 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2840 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2841 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2843 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2844 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2850 gfc_conv_intrinsic_is_contiguous (gfc_se
* se
, gfc_expr
* expr
)
2853 arg
= expr
->value
.function
.actual
->expr
;
2854 gfc_conv_is_contiguous_expr (se
, arg
);
2855 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2858 /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2859 plus it can be called directly. */
2862 gfc_conv_is_contiguous_expr (gfc_se
*se
, gfc_expr
*arg
)
2866 tree desc
, tmp
, stride
, extent
, cond
;
2871 if (arg
->ts
.type
== BT_CLASS
)
2872 gfc_add_class_array_ref (arg
);
2874 ss
= gfc_walk_expr (arg
);
2875 gcc_assert (ss
!= gfc_ss_terminator
);
2876 gfc_init_se (&argse
, NULL
);
2877 argse
.data_not_needed
= 1;
2878 gfc_conv_expr_descriptor (&argse
, arg
);
2880 as
= gfc_get_full_arrayspec_from_expr (arg
);
2882 /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2883 Note in addition that zero-sized arrays don't count as contiguous. */
2885 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2887 /* Build the call to is_contiguous0. */
2888 argse
.want_pointer
= 1;
2889 gfc_conv_expr_descriptor (&argse
, arg
);
2890 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2891 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2892 desc
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2893 fncall0
= build_call_expr_loc (input_location
,
2894 gfor_fndecl_is_contiguous0
, 1, desc
);
2896 se
->expr
= convert (logical_type_node
, se
->expr
);
2900 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2901 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2902 desc
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
2904 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[0]);
2905 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2906 stride
, build_int_cst (TREE_TYPE (stride
), 1));
2908 for (i
= 0; i
< arg
->rank
- 1; i
++)
2910 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2911 extent
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2912 extent
= fold_build2_loc (input_location
, MINUS_EXPR
,
2913 gfc_array_index_type
, extent
, tmp
);
2914 extent
= fold_build2_loc (input_location
, PLUS_EXPR
,
2915 gfc_array_index_type
, extent
,
2916 gfc_index_one_node
);
2917 tmp
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[i
]);
2918 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2920 stride
= gfc_conv_descriptor_stride_get (desc
, gfc_rank_cst
[i
+1]);
2921 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2923 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2924 boolean_type_node
, cond
, tmp
);
2931 /* Evaluate a single upper or lower bound. */
2932 /* TODO: bound intrinsic generates way too much unnecessary code. */
2935 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2937 gfc_actual_arglist
*arg
;
2938 gfc_actual_arglist
*arg2
;
2943 tree cond
, cond1
, cond3
, cond4
, size
;
2947 gfc_array_spec
* as
;
2948 bool assumed_rank_lb_one
;
2950 arg
= expr
->value
.function
.actual
;
2955 /* Create an implicit second parameter from the loop variable. */
2956 gcc_assert (!arg2
->expr
);
2957 gcc_assert (se
->loop
->dimen
== 1);
2958 gcc_assert (se
->ss
->info
->expr
== expr
);
2959 gfc_advance_se_ss_chain (se
);
2960 bound
= se
->loop
->loopvar
[0];
2961 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2962 gfc_array_index_type
, bound
,
2967 /* use the passed argument. */
2968 gcc_assert (arg2
->expr
);
2969 gfc_init_se (&argse
, NULL
);
2970 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2971 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2973 /* Convert from one based to zero based. */
2974 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2975 gfc_array_index_type
, bound
,
2976 gfc_index_one_node
);
2979 /* TODO: don't re-evaluate the descriptor on each iteration. */
2980 /* Get a descriptor for the first parameter. */
2981 gfc_init_se (&argse
, NULL
);
2982 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2983 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2984 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2988 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2990 if (INTEGER_CST_P (bound
))
2992 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2993 && wi::geu_p (wi::to_wide (bound
),
2994 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2995 || wi::gtu_p (wi::to_wide (bound
), GFC_MAX_DIMENSIONS
))
2996 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2997 "dimension index", upper
? "UBOUND" : "LBOUND",
3001 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
3003 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3005 bound
= gfc_evaluate_now (bound
, &se
->pre
);
3006 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3007 bound
, build_int_cst (TREE_TYPE (bound
), 0));
3008 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3009 tmp
= gfc_conv_descriptor_rank (desc
);
3011 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
3012 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3013 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
3014 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3015 logical_type_node
, cond
, tmp
);
3016 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
3021 /* Take care of the lbound shift for assumed-rank arrays, which are
3022 nonallocatable and nonpointers. Those has a lbound of 1. */
3023 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
3024 && ((arg
->expr
->ts
.type
!= BT_CLASS
3025 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
3026 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
3027 || (arg
->expr
->ts
.type
== BT_CLASS
3028 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
3029 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
3031 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3032 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3034 /* 13.14.53: Result value for LBOUND
3036 Case (i): For an array section or for an array expression other than a
3037 whole array or array structure component, LBOUND(ARRAY, DIM)
3038 has the value 1. For a whole array or array structure
3039 component, LBOUND(ARRAY, DIM) has the value:
3040 (a) equal to the lower bound for subscript DIM of ARRAY if
3041 dimension DIM of ARRAY does not have extent zero
3042 or if ARRAY is an assumed-size array of rank DIM,
3045 13.14.113: Result value for UBOUND
3047 Case (i): For an array section or for an array expression other than a
3048 whole array or array structure component, UBOUND(ARRAY, DIM)
3049 has the value equal to the number of elements in the given
3050 dimension; otherwise, it has a value equal to the upper bound
3051 for subscript DIM of ARRAY if dimension DIM of ARRAY does
3052 not have size zero and has value zero if dimension DIM has
3055 if (!upper
&& assumed_rank_lb_one
)
3056 se
->expr
= gfc_index_one_node
;
3059 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
3061 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3063 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3064 stride
, gfc_index_zero_node
);
3065 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3066 logical_type_node
, cond3
, cond1
);
3067 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3068 stride
, gfc_index_zero_node
);
3073 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3074 logical_type_node
, cond3
, cond4
);
3075 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3076 gfc_index_one_node
, lbound
);
3077 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3078 logical_type_node
, cond4
, cond5
);
3080 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3081 logical_type_node
, cond
, cond5
);
3083 if (assumed_rank_lb_one
)
3085 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3086 gfc_array_index_type
, ubound
, lbound
);
3087 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3088 gfc_array_index_type
, tmp
, gfc_index_one_node
);
3093 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3094 gfc_array_index_type
, cond
,
3095 tmp
, gfc_index_zero_node
);
3099 if (as
->type
== AS_ASSUMED_SIZE
)
3100 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3101 bound
, build_int_cst (TREE_TYPE (bound
),
3102 arg
->expr
->rank
- 1));
3104 cond
= logical_false_node
;
3106 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3107 logical_type_node
, cond3
, cond4
);
3108 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3109 logical_type_node
, cond
, cond1
);
3111 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3112 gfc_array_index_type
, cond
,
3113 lbound
, gfc_index_one_node
);
3120 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
3121 gfc_array_index_type
, ubound
, lbound
);
3122 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
3123 gfc_array_index_type
, size
,
3124 gfc_index_one_node
);
3125 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
3126 gfc_array_index_type
, se
->expr
,
3127 gfc_index_zero_node
);
3130 se
->expr
= gfc_index_one_node
;
3133 /* According to F2018 16.9.172, para 5, an assumed rank object, argument
3134 associated with and assumed size array, has the ubound of the final
3135 dimension set to -1 and UBOUND must return this. */
3136 if (upper
&& as
&& as
->type
== AS_ASSUMED_RANK
)
3138 tree minus_one
= build_int_cst (gfc_array_index_type
, -1);
3139 tree rank
= fold_convert (gfc_array_index_type
,
3140 gfc_conv_descriptor_rank (desc
));
3141 rank
= fold_build2_loc (input_location
, PLUS_EXPR
,
3142 gfc_array_index_type
, rank
, minus_one
);
3143 /* Fix the expression to stop it from becoming even more complicated. */
3144 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3145 cond
= fold_build2_loc (input_location
, NE_EXPR
,
3146 logical_type_node
, bound
, rank
);
3147 cond1
= fold_build2_loc (input_location
, NE_EXPR
,
3148 logical_type_node
, ubound
, minus_one
);
3149 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3150 logical_type_node
, cond
, cond1
);
3151 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3152 gfc_array_index_type
, cond
,
3153 se
->expr
, minus_one
);
3156 type
= gfc_typenode_for_spec (&expr
->ts
);
3157 se
->expr
= convert (type
, se
->expr
);
3162 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
3164 gfc_actual_arglist
*arg
;
3165 gfc_actual_arglist
*arg2
;
3167 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
3171 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
3172 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
3173 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
3175 arg
= expr
->value
.function
.actual
;
3178 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
3179 corank
= gfc_get_corank (arg
->expr
);
3181 gfc_init_se (&argse
, NULL
);
3182 argse
.want_coarray
= 1;
3184 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
3185 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3186 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3191 /* Create an implicit second parameter from the loop variable. */
3192 gcc_assert (!arg2
->expr
);
3193 gcc_assert (corank
> 0);
3194 gcc_assert (se
->loop
->dimen
== 1);
3195 gcc_assert (se
->ss
->info
->expr
== expr
);
3197 bound
= se
->loop
->loopvar
[0];
3198 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3199 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
3200 gfc_advance_se_ss_chain (se
);
3204 /* use the passed argument. */
3205 gcc_assert (arg2
->expr
);
3206 gfc_init_se (&argse
, NULL
);
3207 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
3208 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3211 if (INTEGER_CST_P (bound
))
3213 if (wi::ltu_p (wi::to_wide (bound
), 1)
3214 || wi::gtu_p (wi::to_wide (bound
),
3215 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
3216 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3217 "dimension index", expr
->value
.function
.isym
->name
,
3220 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3222 bound
= gfc_evaluate_now (bound
, &se
->pre
);
3223 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3224 bound
, build_int_cst (TREE_TYPE (bound
), 1));
3225 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
3226 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3228 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3229 logical_type_node
, cond
, tmp
);
3230 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
3235 /* Subtract 1 to get to zero based and add dimensions. */
3236 switch (arg
->expr
->rank
)
3239 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
3240 gfc_array_index_type
, bound
,
3241 gfc_index_one_node
);
3245 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3246 gfc_array_index_type
, bound
,
3247 gfc_rank_cst
[arg
->expr
->rank
- 1]);
3251 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3253 /* Handle UCOBOUND with special handling of the last codimension. */
3254 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
3256 /* Last codimension: For -fcoarray=single just return
3257 the lcobound - otherwise add
3258 ceiling (real (num_images ()) / real (size)) - 1
3259 = (num_images () + size - 1) / size - 1
3260 = (num_images - 1) / size(),
3261 where size is the product of the extent of all but the last
3264 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
3268 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
3269 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3270 2, integer_zero_node
,
3271 build_int_cst (integer_type_node
, -1));
3272 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3273 gfc_array_index_type
,
3274 fold_convert (gfc_array_index_type
, tmp
),
3275 build_int_cst (gfc_array_index_type
, 1));
3276 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
3277 gfc_array_index_type
, tmp
,
3278 fold_convert (gfc_array_index_type
, cosize
));
3279 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3280 gfc_array_index_type
, resbound
, tmp
);
3282 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
3284 /* ubound = lbound + num_images() - 1. */
3285 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3286 2, integer_zero_node
,
3287 build_int_cst (integer_type_node
, -1));
3288 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3289 gfc_array_index_type
,
3290 fold_convert (gfc_array_index_type
, tmp
),
3291 build_int_cst (gfc_array_index_type
, 1));
3292 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3293 gfc_array_index_type
, resbound
, tmp
);
3298 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3300 build_int_cst (TREE_TYPE (bound
),
3301 arg
->expr
->rank
+ corank
- 1));
3303 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3304 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3305 gfc_array_index_type
, cond
,
3306 resbound
, resbound2
);
3309 se
->expr
= resbound
;
3312 se
->expr
= resbound
;
3314 type
= gfc_typenode_for_spec (&expr
->ts
);
3315 se
->expr
= convert (type
, se
->expr
);
3320 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
3322 gfc_actual_arglist
*array_arg
;
3323 gfc_actual_arglist
*dim_arg
;
3327 array_arg
= expr
->value
.function
.actual
;
3328 dim_arg
= array_arg
->next
;
3330 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
3332 gfc_init_se (&argse
, NULL
);
3333 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
3334 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3335 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3338 gcc_assert (dim_arg
->expr
);
3339 gfc_init_se (&argse
, NULL
);
3340 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
3341 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3342 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3343 argse
.expr
, gfc_index_one_node
);
3344 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
3348 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
3352 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3354 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
3358 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
3363 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
3364 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
3373 /* Create a complex value from one or two real components. */
3376 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
3382 unsigned int num_args
;
3384 num_args
= gfc_intrinsic_argument_list_length (expr
);
3385 args
= XALLOCAVEC (tree
, num_args
);
3387 type
= gfc_typenode_for_spec (&expr
->ts
);
3388 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3389 real
= convert (TREE_TYPE (type
), args
[0]);
3391 imag
= convert (TREE_TYPE (type
), args
[1]);
3392 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
3394 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
3395 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
3396 imag
= convert (TREE_TYPE (type
), imag
);
3399 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3401 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3405 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3406 MODULO(A, P) = A - FLOOR (A / P) * P
3408 The obvious algorithms above are numerically instable for large
3409 arguments, hence these intrinsics are instead implemented via calls
3410 to the fmod family of functions. It is the responsibility of the
3411 user to ensure that the second argument is non-zero. */
3414 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3424 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3426 switch (expr
->ts
.type
)
3429 /* Integer case is easy, we've got a builtin op. */
3430 type
= TREE_TYPE (args
[0]);
3433 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3436 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3442 /* Check if we have a builtin fmod. */
3443 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3445 /* The builtin should always be available. */
3446 gcc_assert (fmod
!= NULL_TREE
);
3448 tmp
= build_addr (fmod
);
3449 se
->expr
= build_call_array_loc (input_location
,
3450 TREE_TYPE (TREE_TYPE (fmod
)),
3455 type
= TREE_TYPE (args
[0]);
3457 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3458 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3461 modulo = arg - floor (arg/arg2) * arg2
3463 In order to calculate the result accurately, we use the fmod
3464 function as follows.
3466 res = fmod (arg, arg2);
3469 if ((arg < 0) xor (arg2 < 0))
3473 res = copysign (0., arg2);
3475 => As two nested ternary exprs:
3477 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3478 : copysign (0., arg2);
3482 zero
= gfc_build_const (type
, integer_zero_node
);
3483 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3484 if (!flag_signed_zeros
)
3486 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3488 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3490 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3491 logical_type_node
, test
, test2
);
3492 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3494 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3495 logical_type_node
, test
, test2
);
3496 test
= gfc_evaluate_now (test
, &se
->pre
);
3497 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3498 fold_build2_loc (input_location
,
3500 type
, tmp
, args
[1]),
3505 tree expr1
, copysign
, cscall
;
3506 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3508 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3510 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3512 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3513 logical_type_node
, test
, test2
);
3514 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3515 fold_build2_loc (input_location
,
3517 type
, tmp
, args
[1]),
3519 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3521 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3523 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3533 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3534 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3535 where the right shifts are logical (i.e. 0's are shifted in).
3536 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3537 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3539 DSHIFTL(I,J,BITSIZE) = J
3541 DSHIFTR(I,J,BITSIZE) = I. */
3544 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3546 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3547 tree args
[3], cond
, tmp
;
3550 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3552 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3553 type
= TREE_TYPE (args
[0]);
3554 bitsize
= TYPE_PRECISION (type
);
3555 utype
= unsigned_type_for (type
);
3556 stype
= TREE_TYPE (args
[2]);
3558 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3559 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3560 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3562 /* The generic case. */
3563 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3564 build_int_cst (stype
, bitsize
), shift
);
3565 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3566 arg1
, dshiftl
? shift
: tmp
);
3568 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3569 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3570 right
= fold_convert (type
, right
);
3572 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3574 /* Special cases. */
3575 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3576 build_int_cst (stype
, 0));
3577 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3578 dshiftl
? arg1
: arg2
, res
);
3580 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3581 build_int_cst (stype
, bitsize
));
3582 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3583 dshiftl
? arg2
: arg1
, res
);
3589 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3592 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3600 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3601 type
= TREE_TYPE (args
[0]);
3603 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3604 val
= gfc_evaluate_now (val
, &se
->pre
);
3606 zero
= gfc_build_const (type
, integer_zero_node
);
3607 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, val
, zero
);
3608 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3612 /* SIGN(A, B) is absolute value of A times sign of B.
3613 The real value versions use library functions to ensure the correct
3614 handling of negative zero. Integer case implemented as:
3615 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3619 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3625 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3626 if (expr
->ts
.type
== BT_REAL
)
3630 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3631 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3633 /* We explicitly have to ignore the minus sign. We do so by using
3634 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3636 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3639 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3640 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3642 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3643 TREE_TYPE (args
[0]), cond
,
3644 build_call_expr_loc (input_location
, abs
, 1,
3646 build_call_expr_loc (input_location
, tmp
, 2,
3650 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3655 /* Having excluded floating point types, we know we are now dealing
3656 with signed integer types. */
3657 type
= TREE_TYPE (args
[0]);
3659 /* Args[0] is used multiple times below. */
3660 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3662 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3663 the signs of A and B are the same, and of all ones if they differ. */
3664 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3665 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3666 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3667 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3669 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3670 is all ones (i.e. -1). */
3671 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3672 fold_build2_loc (input_location
, PLUS_EXPR
,
3673 type
, args
[0], tmp
), tmp
);
3677 /* Test for the presence of an optional argument. */
3680 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3684 arg
= expr
->value
.function
.actual
->expr
;
3685 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3686 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3687 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3691 /* Calculate the double precision product of two single precision values. */
3694 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3699 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3701 /* Convert the args to double precision before multiplying. */
3702 type
= gfc_typenode_for_spec (&expr
->ts
);
3703 args
[0] = convert (type
, args
[0]);
3704 args
[1] = convert (type
, args
[1]);
3705 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3710 /* Return a length one character string containing an ascii character. */
3713 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3718 unsigned int num_args
;
3720 num_args
= gfc_intrinsic_argument_list_length (expr
);
3721 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3723 type
= gfc_get_char_type (expr
->ts
.kind
);
3724 var
= gfc_create_var (type
, "char");
3726 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3727 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3728 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3729 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3734 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3742 unsigned int num_args
;
3744 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3745 args
= XALLOCAVEC (tree
, num_args
);
3747 var
= gfc_create_var (pchar_type_node
, "pstr");
3748 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3750 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3751 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3752 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3754 fndecl
= build_addr (gfor_fndecl_ctime
);
3755 tmp
= build_call_array_loc (input_location
,
3756 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3757 fndecl
, num_args
, args
);
3758 gfc_add_expr_to_block (&se
->pre
, tmp
);
3760 /* Free the temporary afterwards, if necessary. */
3761 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3762 len
, build_int_cst (TREE_TYPE (len
), 0));
3763 tmp
= gfc_call_free (var
);
3764 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3765 gfc_add_expr_to_block (&se
->post
, tmp
);
3768 se
->string_length
= len
;
3773 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3781 unsigned int num_args
;
3783 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3784 args
= XALLOCAVEC (tree
, num_args
);
3786 var
= gfc_create_var (pchar_type_node
, "pstr");
3787 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3789 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3790 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3791 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3793 fndecl
= build_addr (gfor_fndecl_fdate
);
3794 tmp
= build_call_array_loc (input_location
,
3795 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3796 fndecl
, num_args
, args
);
3797 gfc_add_expr_to_block (&se
->pre
, tmp
);
3799 /* Free the temporary afterwards, if necessary. */
3800 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3801 len
, build_int_cst (TREE_TYPE (len
), 0));
3802 tmp
= gfc_call_free (var
);
3803 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3804 gfc_add_expr_to_block (&se
->post
, tmp
);
3807 se
->string_length
= len
;
3811 /* Generate a direct call to free() for the FREE subroutine. */
3814 conv_intrinsic_free (gfc_code
*code
)
3820 gfc_init_se (&argse
, NULL
);
3821 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3822 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3824 gfc_init_block (&block
);
3825 call
= build_call_expr_loc (input_location
,
3826 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3827 gfc_add_expr_to_block (&block
, call
);
3828 return gfc_finish_block (&block
);
3832 /* Call the RANDOM_INIT library subroutine with a hidden argument for
3833 handling seeding on coarray images. */
3836 conv_intrinsic_random_init (gfc_code
*code
)
3840 tree arg1
, arg2
, arg3
, tmp
;
3841 tree logical4_type_node
= gfc_get_logical_type (4);
3843 /* Make the function call. */
3844 gfc_init_block (&block
);
3845 gfc_init_se (&se
, NULL
);
3847 /* Convert REPEATABLE to a LOGICAL(4) entity. */
3848 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
3849 gfc_add_block_to_block (&block
, &se
.pre
);
3850 arg1
= fold_convert (logical4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3851 gfc_add_block_to_block (&block
, &se
.post
);
3853 /* Convert IMAGE_DISTINCT to a LOGICAL(4) entity. */
3854 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
3855 gfc_add_block_to_block (&block
, &se
.pre
);
3856 arg2
= fold_convert (logical4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3857 gfc_add_block_to_block (&block
, &se
.post
);
3859 /* Create the hidden argument. For non-coarray codes and -fcoarray=single,
3860 simply set this to 0. For -fcoarray=lib, generate a call to
3861 THIS_IMAGE() without arguments. */
3862 arg3
= build_int_cst (gfc_get_int_type (4), 0);
3863 if (flag_coarray
== GFC_FCOARRAY_LIB
)
3865 arg3
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
,
3867 se
.expr
= fold_convert (gfc_get_int_type (4), arg3
);
3870 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_random_init
, 3,
3872 gfc_add_expr_to_block (&block
, tmp
);
3874 return gfc_finish_block (&block
);
3878 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3882 conv_intrinsic_system_clock (gfc_code
*code
)
3885 gfc_se count_se
, count_rate_se
, count_max_se
;
3886 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3890 gfc_expr
*count
= code
->ext
.actual
->expr
;
3891 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3892 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3894 /* Evaluate our arguments. */
3897 gfc_init_se (&count_se
, NULL
);
3898 gfc_conv_expr (&count_se
, count
);
3903 gfc_init_se (&count_rate_se
, NULL
);
3904 gfc_conv_expr (&count_rate_se
, count_rate
);
3909 gfc_init_se (&count_max_se
, NULL
);
3910 gfc_conv_expr (&count_max_se
, count_max
);
3913 /* Find the smallest kind found of the arguments. */
3915 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3916 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3918 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3921 /* Prepare temporary variables. */
3926 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3927 else if (least
== 4)
3928 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3929 else if (count
->ts
.kind
== 1)
3930 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3933 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3940 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3941 else if (least
== 4)
3942 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3944 arg2
= integer_zero_node
;
3950 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3951 else if (least
== 4)
3952 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3954 arg3
= integer_zero_node
;
3957 /* Make the function call. */
3958 gfc_init_block (&block
);
3964 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3965 : null_pointer_node
;
3966 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3967 : null_pointer_node
;
3968 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3969 : null_pointer_node
;
3974 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3975 : null_pointer_node
;
3976 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3977 : null_pointer_node
;
3978 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3979 : null_pointer_node
;
3986 tmp
= build_call_expr_loc (input_location
,
3987 gfor_fndecl_system_clock4
, 3,
3988 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3989 : null_pointer_node
,
3990 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3991 : null_pointer_node
,
3992 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3993 : null_pointer_node
);
3994 gfc_add_expr_to_block (&block
, tmp
);
3996 /* Handle kind>=8, 10, or 16 arguments */
3999 tmp
= build_call_expr_loc (input_location
,
4000 gfor_fndecl_system_clock8
, 3,
4001 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
4002 : null_pointer_node
,
4003 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
4004 : null_pointer_node
,
4005 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
4006 : null_pointer_node
);
4007 gfc_add_expr_to_block (&block
, tmp
);
4011 /* And store values back if needed. */
4012 if (arg1
&& arg1
!= count_se
.expr
)
4013 gfc_add_modify (&block
, count_se
.expr
,
4014 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
4015 if (arg2
&& arg2
!= count_rate_se
.expr
)
4016 gfc_add_modify (&block
, count_rate_se
.expr
,
4017 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
4018 if (arg3
&& arg3
!= count_max_se
.expr
)
4019 gfc_add_modify (&block
, count_max_se
.expr
,
4020 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
4022 return gfc_finish_block (&block
);
4026 /* Return a character string containing the tty name. */
4029 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
4037 unsigned int num_args
;
4039 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
4040 args
= XALLOCAVEC (tree
, num_args
);
4042 var
= gfc_create_var (pchar_type_node
, "pstr");
4043 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4045 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
4046 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
4047 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
4049 fndecl
= build_addr (gfor_fndecl_ttynam
);
4050 tmp
= build_call_array_loc (input_location
,
4051 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
4052 fndecl
, num_args
, args
);
4053 gfc_add_expr_to_block (&se
->pre
, tmp
);
4055 /* Free the temporary afterwards, if necessary. */
4056 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4057 len
, build_int_cst (TREE_TYPE (len
), 0));
4058 tmp
= gfc_call_free (var
);
4059 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4060 gfc_add_expr_to_block (&se
->post
, tmp
);
4063 se
->string_length
= len
;
4067 /* Get the minimum/maximum value of all the parameters.
4068 minmax (a1, a2, a3, ...)
4071 mvar = COMP (mvar, a2)
4072 mvar = COMP (mvar, a3)
4076 Where COMP is MIN/MAX_EXPR for integral types or when we don't
4077 care about NaNs, or IFN_FMIN/MAX when the target has support for
4078 fast NaN-honouring min/max. When neither holds expand a sequence
4079 of explicit comparisons. */
4081 /* TODO: Mismatching types can occur when specific names are used.
4082 These should be handled during resolution. */
4084 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4092 gfc_actual_arglist
*argexpr
;
4093 unsigned int i
, nargs
;
4095 nargs
= gfc_intrinsic_argument_list_length (expr
);
4096 args
= XALLOCAVEC (tree
, nargs
);
4098 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
4099 type
= gfc_typenode_for_spec (&expr
->ts
);
4101 /* Only evaluate the argument once. */
4102 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
4103 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4105 /* Determine suitable type of temporary, as a GNU extension allows
4106 different argument kinds. */
4107 argtype
= TREE_TYPE (args
[0]);
4108 argexpr
= expr
->value
.function
.actual
;
4109 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++, argexpr
= argexpr
->next
)
4111 tree tmptype
= TREE_TYPE (args
[i
]);
4112 if (TYPE_PRECISION (tmptype
) > TYPE_PRECISION (argtype
))
4115 mvar
= gfc_create_var (argtype
, "M");
4116 gfc_add_modify (&se
->pre
, mvar
, convert (argtype
, args
[0]));
4118 argexpr
= expr
->value
.function
.actual
;
4119 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++, argexpr
= argexpr
->next
)
4121 tree cond
= NULL_TREE
;
4124 /* Handle absent optional arguments by ignoring the comparison. */
4125 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
4126 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
4127 && TREE_CODE (val
) == INDIRECT_REF
)
4129 cond
= fold_build2_loc (input_location
,
4130 NE_EXPR
, logical_type_node
,
4131 TREE_OPERAND (val
, 0),
4132 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
4134 else if (!VAR_P (val
) && !TREE_CONSTANT (val
))
4135 /* Only evaluate the argument once. */
4136 val
= gfc_evaluate_now (val
, &se
->pre
);
4139 /* For floating point types, the question is what MAX(a, NaN) or
4140 MIN(a, NaN) should return (where "a" is a normal number).
4141 There are valid usecase for returning either one, but the
4142 Fortran standard doesn't specify which one should be chosen.
4143 Also, there is no consensus among other tested compilers. In
4144 short, it's a mess. So lets just do whatever is fastest. */
4145 tree_code code
= op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
;
4146 calc
= fold_build2_loc (input_location
, code
, argtype
,
4147 convert (argtype
, val
), mvar
);
4148 tmp
= build2_v (MODIFY_EXPR
, mvar
, calc
);
4150 if (cond
!= NULL_TREE
)
4151 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
4152 build_empty_stmt (input_location
));
4153 gfc_add_expr_to_block (&se
->pre
, tmp
);
4155 if (TREE_CODE (type
) == INTEGER_TYPE
)
4156 se
->expr
= fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, mvar
);
4158 se
->expr
= convert (type
, mvar
);
4162 /* Generate library calls for MIN and MAX intrinsics for character
4165 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
4168 tree var
, len
, fndecl
, tmp
, cond
, function
;
4171 nargs
= gfc_intrinsic_argument_list_length (expr
);
4172 args
= XALLOCAVEC (tree
, nargs
+ 4);
4173 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
4175 /* Create the result variables. */
4176 len
= gfc_create_var (gfc_charlen_type_node
, "len");
4177 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
4178 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
4179 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
4180 args
[2] = build_int_cst (integer_type_node
, op
);
4181 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
4183 if (expr
->ts
.kind
== 1)
4184 function
= gfor_fndecl_string_minmax
;
4185 else if (expr
->ts
.kind
== 4)
4186 function
= gfor_fndecl_string_minmax_char4
;
4190 /* Make the function call. */
4191 fndecl
= build_addr (function
);
4192 tmp
= build_call_array_loc (input_location
,
4193 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4195 gfc_add_expr_to_block (&se
->pre
, tmp
);
4197 /* Free the temporary afterwards, if necessary. */
4198 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4199 len
, build_int_cst (TREE_TYPE (len
), 0));
4200 tmp
= gfc_call_free (var
);
4201 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4202 gfc_add_expr_to_block (&se
->post
, tmp
);
4205 se
->string_length
= len
;
4209 /* Create a symbol node for this intrinsic. The symbol from the frontend
4210 has the generic name. */
4213 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
4217 /* TODO: Add symbols for intrinsic function to the global namespace. */
4218 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
4219 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
4222 sym
->attr
.external
= 1;
4223 sym
->attr
.function
= 1;
4224 sym
->attr
.always_explicit
= 1;
4225 sym
->attr
.proc
= PROC_INTRINSIC
;
4226 sym
->attr
.flavor
= FL_PROCEDURE
;
4230 sym
->attr
.dimension
= 1;
4231 sym
->as
= gfc_get_array_spec ();
4232 sym
->as
->type
= AS_ASSUMED_SHAPE
;
4233 sym
->as
->rank
= expr
->rank
;
4236 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
4237 ignore_optional
? expr
->value
.function
.actual
4243 /* Remove empty actual arguments. */
4246 remove_empty_actual_arguments (gfc_actual_arglist
**ap
)
4250 if ((*ap
)->expr
== NULL
)
4252 gfc_actual_arglist
*r
= *ap
;
4255 gfc_free_actual_arglist (r
);
4258 ap
= &((*ap
)->next
);
4262 #define MAX_SPEC_ARG 12
4264 /* Make up an fn spec that's right for intrinsic functions that we
4268 intrinsic_fnspec (gfc_expr
*expr
)
4270 static char fnspec_buf
[MAX_SPEC_ARG
*2+1];
4275 #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
4277 /* Set the fndecl. */
4279 /* Function return value. FIXME: Check if the second letter could
4280 be something other than a space, for further optimization. */
4282 if (expr
->rank
== 0)
4284 if (expr
->ts
.type
== BT_CHARACTER
)
4286 ADD_CHAR ('w'); /* Address of character. */
4287 ADD_CHAR ('.'); /* Length of character. */
4291 ADD_CHAR ('w'); /* Return value is a descriptor. */
4294 for (gfc_actual_arglist
*a
= expr
->value
.function
.actual
; a
; a
= a
->next
)
4296 if (a
->expr
== NULL
)
4299 if (a
->name
&& strcmp (a
->name
,"%VAL") == 0)
4303 if (a
->expr
->rank
> 0)
4308 num_char_args
+= a
->expr
->ts
.type
== BT_CHARACTER
;
4309 gcc_assert (fp
- fnspec_buf
+ num_char_args
<= MAX_SPEC_ARG
*2);
4312 for (i
= 0; i
< num_char_args
; i
++)
4322 /* Generate the right symbol for the specific intrinsic function and
4323 modify the expr accordingly. This assumes that absent optional
4324 arguments should be removed. */
4327 specific_intrinsic_symbol (gfc_expr
*expr
)
4331 sym
= gfc_find_intrinsic_symbol (expr
);
4334 sym
= gfc_get_intrinsic_function_symbol (expr
);
4336 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
)
4337 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, NULL
);
4339 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
4340 expr
->value
.function
.actual
, true);
4342 = gfc_get_extern_function_decl (sym
, expr
->value
.function
.actual
,
4343 intrinsic_fnspec (expr
));
4346 remove_empty_actual_arguments (&(expr
->value
.function
.actual
));
4351 /* Generate a call to an external intrinsic function. FIXME: So far,
4352 this only works for functions which are called with well-defined
4353 types; CSHIFT and friends will come later. */
4356 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
4359 vec
<tree
, va_gc
> *append_args
;
4360 bool specific_symbol
;
4362 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
4365 gcc_assert (expr
->rank
> 0);
4367 gcc_assert (expr
->rank
== 0);
4369 switch (expr
->value
.function
.isym
->id
)
4373 case GFC_ISYM_FINDLOC
:
4374 case GFC_ISYM_MAXLOC
:
4375 case GFC_ISYM_MINLOC
:
4376 case GFC_ISYM_MAXVAL
:
4377 case GFC_ISYM_MINVAL
:
4378 case GFC_ISYM_NORM2
:
4379 case GFC_ISYM_PRODUCT
:
4381 specific_symbol
= true;
4384 specific_symbol
= false;
4387 if (specific_symbol
)
4389 /* Need to copy here because specific_intrinsic_symbol modifies
4390 expr to omit the absent optional arguments. */
4391 expr
= gfc_copy_expr (expr
);
4392 sym
= specific_intrinsic_symbol (expr
);
4395 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
4397 /* Calls to libgfortran_matmul need to be appended special arguments,
4398 to be able to call the BLAS ?gemm functions if required and possible. */
4400 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
4401 && !expr
->external_blas
4402 && sym
->ts
.type
!= BT_LOGICAL
)
4404 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
4406 if (flag_external_blas
4407 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
4408 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
4412 if (sym
->ts
.type
== BT_REAL
)
4414 if (sym
->ts
.kind
== 4)
4415 gemm_fndecl
= gfor_fndecl_sgemm
;
4417 gemm_fndecl
= gfor_fndecl_dgemm
;
4421 if (sym
->ts
.kind
== 4)
4422 gemm_fndecl
= gfor_fndecl_cgemm
;
4424 gemm_fndecl
= gfor_fndecl_zgemm
;
4427 vec_alloc (append_args
, 3);
4428 append_args
->quick_push (build_int_cst (cint
, 1));
4429 append_args
->quick_push (build_int_cst (cint
,
4430 flag_blas_matmul_limit
));
4431 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
4436 vec_alloc (append_args
, 3);
4437 append_args
->quick_push (build_int_cst (cint
, 0));
4438 append_args
->quick_push (build_int_cst (cint
, 0));
4439 append_args
->quick_push (null_pointer_node
);
4443 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4446 if (specific_symbol
)
4447 gfc_free_expr (expr
);
4449 gfc_free_symbol (sym
);
4452 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4472 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4481 gfc_actual_arglist
*actual
;
4488 gfc_conv_intrinsic_funcall (se
, expr
);
4492 actual
= expr
->value
.function
.actual
;
4493 type
= gfc_typenode_for_spec (&expr
->ts
);
4494 /* Initialize the result. */
4495 resvar
= gfc_create_var (type
, "test");
4497 tmp
= convert (type
, boolean_true_node
);
4499 tmp
= convert (type
, boolean_false_node
);
4500 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4502 /* Walk the arguments. */
4503 arrayss
= gfc_walk_expr (actual
->expr
);
4504 gcc_assert (arrayss
!= gfc_ss_terminator
);
4506 /* Initialize the scalarizer. */
4507 gfc_init_loopinfo (&loop
);
4508 exit_label
= gfc_build_label_decl (NULL_TREE
);
4509 TREE_USED (exit_label
) = 1;
4510 gfc_add_ss_to_loop (&loop
, arrayss
);
4512 /* Initialize the loop. */
4513 gfc_conv_ss_startstride (&loop
);
4514 gfc_conv_loop_setup (&loop
, &expr
->where
);
4516 gfc_mark_ss_chain_used (arrayss
, 1);
4517 /* Generate the loop body. */
4518 gfc_start_scalarized_body (&loop
, &body
);
4520 /* If the condition matches then set the return value. */
4521 gfc_start_block (&block
);
4523 tmp
= convert (type
, boolean_false_node
);
4525 tmp
= convert (type
, boolean_true_node
);
4526 gfc_add_modify (&block
, resvar
, tmp
);
4528 /* And break out of the loop. */
4529 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4530 gfc_add_expr_to_block (&block
, tmp
);
4532 found
= gfc_finish_block (&block
);
4534 /* Check this element. */
4535 gfc_init_se (&arrayse
, NULL
);
4536 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4537 arrayse
.ss
= arrayss
;
4538 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4540 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4541 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
, arrayse
.expr
,
4542 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
4543 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
4544 gfc_add_expr_to_block (&body
, tmp
);
4545 gfc_add_block_to_block (&body
, &arrayse
.post
);
4547 gfc_trans_scalarizing_loops (&loop
, &body
);
4549 /* Add the exit label. */
4550 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4551 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4553 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4554 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4555 gfc_cleanup_loop (&loop
);
4561 /* Generate the constant 180 / pi, which is used in the conversion
4562 of acosd(), asind(), atand(), atan2d(). */
4570 gfc_set_model_kind (kind
);
4573 mpfr_set_si (t0
, 180, GFC_RND_MODE
);
4574 mpfr_const_pi (pi
, GFC_RND_MODE
);
4575 mpfr_div (t0
, t0
, pi
, GFC_RND_MODE
);
4576 retval
= gfc_conv_mpfr_to_tree (t0
, kind
, 0);
4583 /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4584 ASIND(x) is translated into ASIN(x) * 180 / pi.
4585 ATAND(x) is translated into ATAN(x) * 180 / pi. */
4588 gfc_conv_intrinsic_atrigd (gfc_se
* se
, gfc_expr
* expr
, gfc_isym_id id
)
4594 type
= gfc_typenode_for_spec (&expr
->ts
);
4596 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4598 if (id
== GFC_ISYM_ACOSD
)
4599 atrigd
= gfc_builtin_decl_for_float_kind (BUILT_IN_ACOS
, expr
->ts
.kind
);
4600 else if (id
== GFC_ISYM_ASIND
)
4601 atrigd
= gfc_builtin_decl_for_float_kind (BUILT_IN_ASIN
, expr
->ts
.kind
);
4602 else if (id
== GFC_ISYM_ATAND
)
4603 atrigd
= gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN
, expr
->ts
.kind
);
4607 atrigd
= build_call_expr_loc (input_location
, atrigd
, 1, arg
);
4609 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, atrigd
,
4610 fold_convert (type
, rad2deg (expr
->ts
.kind
)));
4614 /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4615 COS(X) / SIN(X) for COMPLEX argument. */
4618 gfc_conv_intrinsic_cotan (gfc_se
*se
, gfc_expr
*expr
)
4620 gfc_intrinsic_map_t
*m
;
4624 type
= gfc_typenode_for_spec (&expr
->ts
);
4625 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4627 if (expr
->ts
.type
== BT_REAL
)
4634 gfc_set_model_kind (expr
->ts
.kind
);
4636 mpfr_const_pi (pio2
, GFC_RND_MODE
);
4637 mpfr_div_ui (pio2
, pio2
, 2, GFC_RND_MODE
);
4638 tmp
= gfc_conv_mpfr_to_tree (pio2
, expr
->ts
.kind
, 0);
4641 /* Find tan builtin function. */
4642 m
= gfc_intrinsic_map
;
4643 for (; m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
4644 if (GFC_ISYM_TAN
== m
->id
)
4647 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, arg
, tmp
);
4648 tan
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4649 tan
= build_call_expr_loc (input_location
, tan
, 1, tmp
);
4650 se
->expr
= fold_build1_loc (input_location
, NEGATE_EXPR
, type
, tan
);
4657 /* Find cos builtin function. */
4658 m
= gfc_intrinsic_map
;
4659 for (; m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
4660 if (GFC_ISYM_COS
== m
->id
)
4663 cos
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4664 cos
= build_call_expr_loc (input_location
, cos
, 1, arg
);
4666 /* Find sin builtin function. */
4667 m
= gfc_intrinsic_map
;
4668 for (; m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
4669 if (GFC_ISYM_SIN
== m
->id
)
4672 sin
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4673 sin
= build_call_expr_loc (input_location
, sin
, 1, arg
);
4675 /* Divide cos by sin. */
4676 se
->expr
= fold_build2_loc (input_location
, RDIV_EXPR
, type
, cos
, sin
);
4681 /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4684 gfc_conv_intrinsic_cotand (gfc_se
*se
, gfc_expr
*expr
)
4691 type
= gfc_typenode_for_spec (&expr
->ts
);
4692 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4694 gfc_set_model_kind (expr
->ts
.kind
);
4696 /* Build the tree for x + 90. */
4697 mpfr_init_set_ui (ninety
, 90, GFC_RND_MODE
);
4698 ninety_tree
= gfc_conv_mpfr_to_tree (ninety
, expr
->ts
.kind
, 0);
4699 arg
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, arg
, ninety_tree
);
4700 mpfr_clear (ninety
);
4703 gfc_intrinsic_map_t
*m
= gfc_intrinsic_map
;
4704 for (; m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
4705 if (GFC_ISYM_TAND
== m
->id
)
4708 tree tand
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
4709 tand
= build_call_expr_loc (input_location
, tand
, 1, arg
);
4711 se
->expr
= fold_build1_loc (input_location
, NEGATE_EXPR
, type
, tand
);
4715 /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4718 gfc_conv_intrinsic_atan2d (gfc_se
*se
, gfc_expr
*expr
)
4724 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4725 type
= TREE_TYPE (args
[0]);
4727 atan2d
= gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN2
, expr
->ts
.kind
);
4728 atan2d
= build_call_expr_loc (input_location
, atan2d
, 2, args
[0], args
[1]);
4730 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, atan2d
,
4731 rad2deg (expr
->ts
.kind
));
4735 /* COUNT(A) = Number of true elements in A. */
4737 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4744 gfc_actual_arglist
*actual
;
4750 gfc_conv_intrinsic_funcall (se
, expr
);
4754 actual
= expr
->value
.function
.actual
;
4756 type
= gfc_typenode_for_spec (&expr
->ts
);
4757 /* Initialize the result. */
4758 resvar
= gfc_create_var (type
, "count");
4759 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4761 /* Walk the arguments. */
4762 arrayss
= gfc_walk_expr (actual
->expr
);
4763 gcc_assert (arrayss
!= gfc_ss_terminator
);
4765 /* Initialize the scalarizer. */
4766 gfc_init_loopinfo (&loop
);
4767 gfc_add_ss_to_loop (&loop
, arrayss
);
4769 /* Initialize the loop. */
4770 gfc_conv_ss_startstride (&loop
);
4771 gfc_conv_loop_setup (&loop
, &expr
->where
);
4773 gfc_mark_ss_chain_used (arrayss
, 1);
4774 /* Generate the loop body. */
4775 gfc_start_scalarized_body (&loop
, &body
);
4777 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4778 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4779 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4781 gfc_init_se (&arrayse
, NULL
);
4782 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4783 arrayse
.ss
= arrayss
;
4784 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4785 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4786 build_empty_stmt (input_location
));
4788 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4789 gfc_add_expr_to_block (&body
, tmp
);
4790 gfc_add_block_to_block (&body
, &arrayse
.post
);
4792 gfc_trans_scalarizing_loops (&loop
, &body
);
4794 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4795 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4796 gfc_cleanup_loop (&loop
);
4802 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4803 struct and return the corresponding loopinfo. */
4805 static gfc_loopinfo
*
4806 enter_nested_loop (gfc_se
*se
)
4808 se
->ss
= se
->ss
->nested_ss
;
4809 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4811 return se
->ss
->loop
;
4814 /* Build the condition for a mask, which may be optional. */
4817 conv_mask_condition (gfc_se
*maskse
, gfc_expr
*maskexpr
,
4825 type
= TREE_TYPE (maskse
->expr
);
4826 present
= gfc_conv_expr_present (maskexpr
->symtree
->n
.sym
);
4827 present
= convert (type
, present
);
4828 present
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, type
,
4830 return fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4831 type
, present
, maskse
->expr
);
4834 return maskse
->expr
;
4837 /* Inline implementation of the sum and product intrinsics. */
4839 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4843 tree scale
= NULL_TREE
;
4848 gfc_loopinfo loop
, *ploop
;
4849 gfc_actual_arglist
*arg_array
, *arg_mask
;
4850 gfc_ss
*arrayss
= NULL
;
4851 gfc_ss
*maskss
= NULL
;
4855 gfc_expr
*arrayexpr
;
4861 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4867 type
= gfc_typenode_for_spec (&expr
->ts
);
4868 /* Initialize the result. */
4869 resvar
= gfc_create_var (type
, "val");
4874 scale
= gfc_create_var (type
, "scale");
4875 gfc_add_modify (&se
->pre
, scale
,
4876 gfc_build_const (type
, integer_one_node
));
4877 tmp
= gfc_build_const (type
, integer_zero_node
);
4879 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4880 tmp
= gfc_build_const (type
, integer_zero_node
);
4881 else if (op
== NE_EXPR
)
4883 tmp
= convert (type
, boolean_false_node
);
4884 else if (op
== BIT_AND_EXPR
)
4885 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4886 type
, integer_one_node
));
4888 tmp
= gfc_build_const (type
, integer_one_node
);
4890 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4892 arg_array
= expr
->value
.function
.actual
;
4894 arrayexpr
= arg_array
->expr
;
4896 if (op
== NE_EXPR
|| norm2
)
4898 /* PARITY and NORM2. */
4900 optional_mask
= false;
4904 arg_mask
= arg_array
->next
->next
;
4905 gcc_assert (arg_mask
!= NULL
);
4906 maskexpr
= arg_mask
->expr
;
4907 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
4908 && maskexpr
->symtree
->n
.sym
->attr
.dummy
4909 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
4912 if (expr
->rank
== 0)
4914 /* Walk the arguments. */
4915 arrayss
= gfc_walk_expr (arrayexpr
);
4916 gcc_assert (arrayss
!= gfc_ss_terminator
);
4918 if (maskexpr
&& maskexpr
->rank
> 0)
4920 maskss
= gfc_walk_expr (maskexpr
);
4921 gcc_assert (maskss
!= gfc_ss_terminator
);
4926 /* Initialize the scalarizer. */
4927 gfc_init_loopinfo (&loop
);
4929 /* We add the mask first because the number of iterations is
4930 taken from the last ss, and this breaks if an absent
4931 optional argument is used for mask. */
4933 if (maskexpr
&& maskexpr
->rank
> 0)
4934 gfc_add_ss_to_loop (&loop
, maskss
);
4935 gfc_add_ss_to_loop (&loop
, arrayss
);
4937 /* Initialize the loop. */
4938 gfc_conv_ss_startstride (&loop
);
4939 gfc_conv_loop_setup (&loop
, &expr
->where
);
4941 if (maskexpr
&& maskexpr
->rank
> 0)
4942 gfc_mark_ss_chain_used (maskss
, 1);
4943 gfc_mark_ss_chain_used (arrayss
, 1);
4948 /* All the work has been done in the parent loops. */
4949 ploop
= enter_nested_loop (se
);
4953 /* Generate the loop body. */
4954 gfc_start_scalarized_body (ploop
, &body
);
4956 /* If we have a mask, only add this element if the mask is set. */
4957 if (maskexpr
&& maskexpr
->rank
> 0)
4959 gfc_init_se (&maskse
, parent_se
);
4960 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4961 if (expr
->rank
== 0)
4963 gfc_conv_expr_val (&maskse
, maskexpr
);
4964 gfc_add_block_to_block (&body
, &maskse
.pre
);
4966 gfc_start_block (&block
);
4969 gfc_init_block (&block
);
4971 /* Do the actual summation/product. */
4972 gfc_init_se (&arrayse
, parent_se
);
4973 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4974 if (expr
->rank
== 0)
4975 arrayse
.ss
= arrayss
;
4976 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4977 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4981 /* if (x (i) != 0.0)
4987 result = 1.0 + result * val * val;
4993 result += val * val;
4996 tree res1
, res2
, cond
, absX
, val
;
4997 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4999 gfc_init_block (&ifblock1
);
5001 absX
= gfc_create_var (type
, "absX");
5002 gfc_add_modify (&ifblock1
, absX
,
5003 fold_build1_loc (input_location
, ABS_EXPR
, type
,
5005 val
= gfc_create_var (type
, "val");
5006 gfc_add_expr_to_block (&ifblock1
, val
);
5008 gfc_init_block (&ifblock2
);
5009 gfc_add_modify (&ifblock2
, val
,
5010 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
5012 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
5013 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
5014 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
5015 gfc_build_const (type
, integer_one_node
));
5016 gfc_add_modify (&ifblock2
, resvar
, res1
);
5017 gfc_add_modify (&ifblock2
, scale
, absX
);
5018 res1
= gfc_finish_block (&ifblock2
);
5020 gfc_init_block (&ifblock3
);
5021 gfc_add_modify (&ifblock3
, val
,
5022 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
5024 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
5025 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
5026 gfc_add_modify (&ifblock3
, resvar
, res2
);
5027 res2
= gfc_finish_block (&ifblock3
);
5029 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
5031 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
5032 gfc_add_expr_to_block (&ifblock1
, tmp
);
5033 tmp
= gfc_finish_block (&ifblock1
);
5035 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
5037 gfc_build_const (type
, integer_zero_node
));
5039 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
5040 gfc_add_expr_to_block (&block
, tmp
);
5044 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
5045 gfc_add_modify (&block
, resvar
, tmp
);
5048 gfc_add_block_to_block (&block
, &arrayse
.post
);
5050 if (maskexpr
&& maskexpr
->rank
> 0)
5052 /* We enclose the above in if (mask) {...} . If the mask is an
5053 optional argument, generate
5054 IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
5056 tmp
= gfc_finish_block (&block
);
5057 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5058 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5059 build_empty_stmt (input_location
));
5062 tmp
= gfc_finish_block (&block
);
5063 gfc_add_expr_to_block (&body
, tmp
);
5065 gfc_trans_scalarizing_loops (ploop
, &body
);
5067 /* For a scalar mask, enclose the loop in an if statement. */
5068 if (maskexpr
&& maskexpr
->rank
== 0)
5070 gfc_init_block (&block
);
5071 gfc_add_block_to_block (&block
, &ploop
->pre
);
5072 gfc_add_block_to_block (&block
, &ploop
->post
);
5073 tmp
= gfc_finish_block (&block
);
5077 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
5078 build_empty_stmt (input_location
));
5079 gfc_advance_se_ss_chain (se
);
5085 gcc_assert (expr
->rank
== 0);
5086 gfc_init_se (&maskse
, NULL
);
5087 gfc_conv_expr_val (&maskse
, maskexpr
);
5088 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5089 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5090 build_empty_stmt (input_location
));
5093 gfc_add_expr_to_block (&block
, tmp
);
5094 gfc_add_block_to_block (&se
->pre
, &block
);
5095 gcc_assert (se
->post
.head
== NULL
);
5099 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
5100 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
5103 if (expr
->rank
== 0)
5104 gfc_cleanup_loop (ploop
);
5108 /* result = scale * sqrt(result). */
5110 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
5111 resvar
= build_call_expr_loc (input_location
,
5113 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
5120 /* Inline implementation of the dot_product intrinsic. This function
5121 is based on gfc_conv_intrinsic_arith (the previous function). */
5123 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
5131 gfc_actual_arglist
*actual
;
5132 gfc_ss
*arrayss1
, *arrayss2
;
5133 gfc_se arrayse1
, arrayse2
;
5134 gfc_expr
*arrayexpr1
, *arrayexpr2
;
5136 type
= gfc_typenode_for_spec (&expr
->ts
);
5138 /* Initialize the result. */
5139 resvar
= gfc_create_var (type
, "val");
5140 if (expr
->ts
.type
== BT_LOGICAL
)
5141 tmp
= build_int_cst (type
, 0);
5143 tmp
= gfc_build_const (type
, integer_zero_node
);
5145 gfc_add_modify (&se
->pre
, resvar
, tmp
);
5147 /* Walk argument #1. */
5148 actual
= expr
->value
.function
.actual
;
5149 arrayexpr1
= actual
->expr
;
5150 arrayss1
= gfc_walk_expr (arrayexpr1
);
5151 gcc_assert (arrayss1
!= gfc_ss_terminator
);
5153 /* Walk argument #2. */
5154 actual
= actual
->next
;
5155 arrayexpr2
= actual
->expr
;
5156 arrayss2
= gfc_walk_expr (arrayexpr2
);
5157 gcc_assert (arrayss2
!= gfc_ss_terminator
);
5159 /* Initialize the scalarizer. */
5160 gfc_init_loopinfo (&loop
);
5161 gfc_add_ss_to_loop (&loop
, arrayss1
);
5162 gfc_add_ss_to_loop (&loop
, arrayss2
);
5164 /* Initialize the loop. */
5165 gfc_conv_ss_startstride (&loop
);
5166 gfc_conv_loop_setup (&loop
, &expr
->where
);
5168 gfc_mark_ss_chain_used (arrayss1
, 1);
5169 gfc_mark_ss_chain_used (arrayss2
, 1);
5171 /* Generate the loop body. */
5172 gfc_start_scalarized_body (&loop
, &body
);
5173 gfc_init_block (&block
);
5175 /* Make the tree expression for [conjg(]array1[)]. */
5176 gfc_init_se (&arrayse1
, NULL
);
5177 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
5178 arrayse1
.ss
= arrayss1
;
5179 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
5180 if (expr
->ts
.type
== BT_COMPLEX
)
5181 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
5183 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
5185 /* Make the tree expression for array2. */
5186 gfc_init_se (&arrayse2
, NULL
);
5187 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
5188 arrayse2
.ss
= arrayss2
;
5189 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
5190 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
5192 /* Do the actual product and sum. */
5193 if (expr
->ts
.type
== BT_LOGICAL
)
5195 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
5196 arrayse1
.expr
, arrayse2
.expr
);
5197 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
5201 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
5203 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
5205 gfc_add_modify (&block
, resvar
, tmp
);
5207 /* Finish up the loop block and the loop. */
5208 tmp
= gfc_finish_block (&block
);
5209 gfc_add_expr_to_block (&body
, tmp
);
5211 gfc_trans_scalarizing_loops (&loop
, &body
);
5212 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5213 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5214 gfc_cleanup_loop (&loop
);
5220 /* Remove unneeded kind= argument from actual argument list when the
5221 result conversion is dealt with in a different place. */
5224 strip_kind_from_actual (gfc_actual_arglist
* actual
)
5226 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
5228 if (a
&& a
->name
&& strcmp (a
->name
, "kind") == 0)
5230 gfc_free_expr (a
->expr
);
5236 /* Emit code for minloc or maxloc intrinsic. There are many different cases
5237 we need to handle. For performance reasons we sometimes create two
5238 loops instead of one, where the second one is much simpler.
5239 Examples for minloc intrinsic:
5240 1) Result is an array, a call is generated
5241 2) Array mask is used and NaNs need to be supported:
5247 if (pos == 0) pos = S + (1 - from);
5248 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5255 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5259 3) NaNs need to be supported, but it is known at compile time or cheaply
5260 at runtime whether array is nonempty or not:
5265 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5268 if (from <= to) pos = 1;
5272 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5276 4) NaNs aren't supported, array mask is used:
5277 limit = infinities_supported ? Infinity : huge (limit);
5281 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5287 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5291 5) Same without array mask:
5292 limit = infinities_supported ? Infinity : huge (limit);
5293 pos = (from <= to) ? 1 : 0;
5296 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5299 For 3) and 5), if mask is scalar, this all goes into a conditional,
5300 setting pos = 0; in the else branch.
5302 Since we now also support the BACK argument, instead of using
5303 if (a[S] < limit), we now use
5306 cond = a[S] <= limit;
5308 cond = a[S] < limit;
5312 The optimizer is smart enough to move the condition out of the loop.
5313 The are now marked as unlikely to for further speedup. */
5316 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5320 stmtblock_t ifblock
;
5321 stmtblock_t elseblock
;
5333 gfc_actual_arglist
*actual
;
5338 gfc_expr
*arrayexpr
;
5346 actual
= expr
->value
.function
.actual
;
5348 /* The last argument, BACK, is passed by value. Ensure that
5349 by setting its name to %VAL. */
5350 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
5352 if (a
->next
== NULL
)
5358 gfc_conv_intrinsic_funcall (se
, expr
);
5362 arrayexpr
= actual
->expr
;
5364 /* Special case for character maxloc. Remove unneeded actual
5365 arguments, then call a library function. */
5367 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5369 gfc_actual_arglist
*a
;
5371 strip_kind_from_actual (a
);
5374 if (a
->name
&& strcmp (a
->name
, "dim") == 0)
5376 gfc_free_expr (a
->expr
);
5381 gfc_conv_intrinsic_funcall (se
, expr
);
5385 /* Initialize the result. */
5386 pos
= gfc_create_var (gfc_array_index_type
, "pos");
5387 offset
= gfc_create_var (gfc_array_index_type
, "offset");
5388 type
= gfc_typenode_for_spec (&expr
->ts
);
5390 /* Walk the arguments. */
5391 arrayss
= gfc_walk_expr (arrayexpr
);
5392 gcc_assert (arrayss
!= gfc_ss_terminator
);
5394 actual
= actual
->next
->next
;
5395 gcc_assert (actual
);
5396 maskexpr
= actual
->expr
;
5397 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5398 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5399 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5400 backexpr
= actual
->next
->next
->expr
;
5402 if (maskexpr
&& maskexpr
->rank
!= 0)
5404 maskss
= gfc_walk_expr (maskexpr
);
5405 gcc_assert (maskss
!= gfc_ss_terminator
);
5410 if (gfc_array_size (arrayexpr
, &asize
))
5412 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5414 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5415 logical_type_node
, nonempty
,
5416 gfc_index_zero_node
);
5421 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
5422 switch (arrayexpr
->ts
.type
)
5425 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
5429 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
5430 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
5431 arrayexpr
->ts
.kind
);
5438 /* We start with the most negative possible value for MAXLOC, and the most
5439 positive possible value for MINLOC. The most negative possible value is
5440 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5441 possible value is HUGE in both cases. */
5443 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5444 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
5445 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
5446 build_int_cst (TREE_TYPE (tmp
), 1));
5448 gfc_add_modify (&se
->pre
, limit
, tmp
);
5450 /* Initialize the scalarizer. */
5451 gfc_init_loopinfo (&loop
);
5453 /* We add the mask first because the number of iterations is taken
5454 from the last ss, and this breaks if an absent optional argument
5455 is used for mask. */
5458 gfc_add_ss_to_loop (&loop
, maskss
);
5460 gfc_add_ss_to_loop (&loop
, arrayss
);
5462 /* Initialize the loop. */
5463 gfc_conv_ss_startstride (&loop
);
5465 /* The code generated can have more than one loop in sequence (see the
5466 comment at the function header). This doesn't work well with the
5467 scalarizer, which changes arrays' offset when the scalarization loops
5468 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
5469 are currently inlined in the scalar case only (for which loop is of rank
5470 one). As there is no dependency to care about in that case, there is no
5471 temporary, so that we can use the scalarizer temporary code to handle
5472 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
5473 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
5475 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
5476 should eventually go away. We could either create two loops properly,
5477 or find another way to save/restore the array offsets between the two
5478 loops (without conflicting with temporary management), or use a single
5479 loop minmaxloc implementation. See PR 31067. */
5480 loop
.temp_dim
= loop
.dimen
;
5481 gfc_conv_loop_setup (&loop
, &expr
->where
);
5483 gcc_assert (loop
.dimen
== 1);
5484 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
5485 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5486 loop
.from
[0], loop
.to
[0]);
5490 /* Initialize the position to zero, following Fortran 2003. We are free
5491 to do this because Fortran 95 allows the result of an entirely false
5492 mask to be processor dependent. If we know at compile time the array
5493 is non-empty and no MASK is used, we can initialize to 1 to simplify
5495 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
5496 gfc_add_modify (&loop
.pre
, pos
,
5497 fold_build3_loc (input_location
, COND_EXPR
,
5498 gfc_array_index_type
,
5499 nonempty
, gfc_index_one_node
,
5500 gfc_index_zero_node
));
5503 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
5504 lab1
= gfc_build_label_decl (NULL_TREE
);
5505 TREE_USED (lab1
) = 1;
5506 lab2
= gfc_build_label_decl (NULL_TREE
);
5507 TREE_USED (lab2
) = 1;
5510 /* An offset must be added to the loop
5511 counter to obtain the required position. */
5512 gcc_assert (loop
.from
[0]);
5514 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5515 gfc_index_one_node
, loop
.from
[0]);
5516 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5518 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
5520 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
5521 /* Generate the loop body. */
5522 gfc_start_scalarized_body (&loop
, &body
);
5524 /* If we have a mask, only check this element if the mask is set. */
5527 gfc_init_se (&maskse
, NULL
);
5528 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5530 gfc_conv_expr_val (&maskse
, maskexpr
);
5531 gfc_add_block_to_block (&body
, &maskse
.pre
);
5533 gfc_start_block (&block
);
5536 gfc_init_block (&block
);
5538 /* Compare with the current limit. */
5539 gfc_init_se (&arrayse
, NULL
);
5540 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5541 arrayse
.ss
= arrayss
;
5542 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5543 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5545 gfc_init_se (&backse
, NULL
);
5546 gfc_conv_expr_val (&backse
, backexpr
);
5547 gfc_add_block_to_block (&block
, &backse
.pre
);
5549 /* We do the following if this is a more extreme value. */
5550 gfc_start_block (&ifblock
);
5552 /* Assign the value to the limit... */
5553 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5555 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
5557 stmtblock_t ifblock2
;
5560 gfc_start_block (&ifblock2
);
5561 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5562 loop
.loopvar
[0], offset
);
5563 gfc_add_modify (&ifblock2
, pos
, tmp
);
5564 ifbody2
= gfc_finish_block (&ifblock2
);
5565 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pos
,
5566 gfc_index_zero_node
);
5567 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
5568 build_empty_stmt (input_location
));
5569 gfc_add_expr_to_block (&block
, tmp
);
5572 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5573 loop
.loopvar
[0], offset
);
5574 gfc_add_modify (&ifblock
, pos
, tmp
);
5577 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
5579 ifbody
= gfc_finish_block (&ifblock
);
5581 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
5584 cond
= fold_build2_loc (input_location
,
5585 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5586 logical_type_node
, arrayse
.expr
, limit
);
5589 tree ifbody2
, elsebody2
;
5591 /* We switch to > or >= depending on the value of the BACK argument. */
5592 cond
= gfc_create_var (logical_type_node
, "cond");
5594 gfc_start_block (&ifblock
);
5595 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5596 logical_type_node
, arrayse
.expr
, limit
);
5598 gfc_add_modify (&ifblock
, cond
, b_if
);
5599 ifbody2
= gfc_finish_block (&ifblock
);
5601 gfc_start_block (&elseblock
);
5602 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5603 arrayse
.expr
, limit
);
5605 gfc_add_modify (&elseblock
, cond
, b_else
);
5606 elsebody2
= gfc_finish_block (&elseblock
);
5608 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5609 backse
.expr
, ifbody2
, elsebody2
);
5611 gfc_add_expr_to_block (&block
, tmp
);
5614 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5615 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
5616 build_empty_stmt (input_location
));
5618 gfc_add_expr_to_block (&block
, ifbody
);
5622 /* We enclose the above in if (mask) {...}. If the mask is an
5623 optional argument, generate IF (.NOT. PRESENT(MASK)
5627 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5628 tmp
= gfc_finish_block (&block
);
5629 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5630 build_empty_stmt (input_location
));
5633 tmp
= gfc_finish_block (&block
);
5634 gfc_add_expr_to_block (&body
, tmp
);
5638 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5640 if (HONOR_NANS (DECL_MODE (limit
)))
5642 if (nonempty
!= NULL
)
5644 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
5645 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
5646 build_empty_stmt (input_location
));
5647 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
5651 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
5652 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
5654 /* If we have a mask, only check this element if the mask is set. */
5657 gfc_init_se (&maskse
, NULL
);
5658 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5660 gfc_conv_expr_val (&maskse
, maskexpr
);
5661 gfc_add_block_to_block (&body
, &maskse
.pre
);
5663 gfc_start_block (&block
);
5666 gfc_init_block (&block
);
5668 /* Compare with the current limit. */
5669 gfc_init_se (&arrayse
, NULL
);
5670 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5671 arrayse
.ss
= arrayss
;
5672 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5673 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5675 /* We do the following if this is a more extreme value. */
5676 gfc_start_block (&ifblock
);
5678 /* Assign the value to the limit... */
5679 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5681 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5682 loop
.loopvar
[0], offset
);
5683 gfc_add_modify (&ifblock
, pos
, tmp
);
5685 ifbody
= gfc_finish_block (&ifblock
);
5687 /* We switch to > or >= depending on the value of the BACK argument. */
5689 tree ifbody2
, elsebody2
;
5691 cond
= gfc_create_var (logical_type_node
, "cond");
5693 gfc_start_block (&ifblock
);
5694 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5695 logical_type_node
, arrayse
.expr
, limit
);
5697 gfc_add_modify (&ifblock
, cond
, b_if
);
5698 ifbody2
= gfc_finish_block (&ifblock
);
5700 gfc_start_block (&elseblock
);
5701 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5702 arrayse
.expr
, limit
);
5704 gfc_add_modify (&elseblock
, cond
, b_else
);
5705 elsebody2
= gfc_finish_block (&elseblock
);
5707 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5708 backse
.expr
, ifbody2
, elsebody2
);
5711 gfc_add_expr_to_block (&block
, tmp
);
5712 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5713 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
5714 build_empty_stmt (input_location
));
5716 gfc_add_expr_to_block (&block
, tmp
);
5720 /* We enclose the above in if (mask) {...}. If the mask is
5721 an optional argument, generate IF (.NOT. PRESENT(MASK)
5725 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5726 tmp
= gfc_finish_block (&block
);
5727 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5728 build_empty_stmt (input_location
));
5731 tmp
= gfc_finish_block (&block
);
5732 gfc_add_expr_to_block (&body
, tmp
);
5733 /* Avoid initializing loopvar[0] again, it should be left where
5734 it finished by the first loop. */
5735 loop
.from
[0] = loop
.loopvar
[0];
5738 gfc_trans_scalarizing_loops (&loop
, &body
);
5741 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
5743 /* For a scalar mask, enclose the loop in an if statement. */
5744 if (maskexpr
&& maskss
== NULL
)
5748 gfc_init_se (&maskse
, NULL
);
5749 gfc_conv_expr_val (&maskse
, maskexpr
);
5750 gfc_init_block (&block
);
5751 gfc_add_block_to_block (&block
, &loop
.pre
);
5752 gfc_add_block_to_block (&block
, &loop
.post
);
5753 tmp
= gfc_finish_block (&block
);
5755 /* For the else part of the scalar mask, just initialize
5756 the pos variable the same way as above. */
5758 gfc_init_block (&elseblock
);
5759 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
5760 elsetmp
= gfc_finish_block (&elseblock
);
5761 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5762 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
, elsetmp
);
5763 gfc_add_expr_to_block (&block
, tmp
);
5764 gfc_add_block_to_block (&se
->pre
, &block
);
5768 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5769 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5771 gfc_cleanup_loop (&loop
);
5773 se
->expr
= convert (type
, pos
);
5776 /* Emit code for findloc. */
5779 gfc_conv_intrinsic_findloc (gfc_se
*se
, gfc_expr
*expr
)
5781 gfc_actual_arglist
*array_arg
, *value_arg
, *dim_arg
, *mask_arg
,
5782 *kind_arg
, *back_arg
;
5783 gfc_expr
*value_expr
;
5788 stmtblock_t loopblock
;
5792 tree forward_branch
= NULL_TREE
;
5807 array_arg
= expr
->value
.function
.actual
;
5808 value_arg
= array_arg
->next
;
5809 dim_arg
= value_arg
->next
;
5810 mask_arg
= dim_arg
->next
;
5811 kind_arg
= mask_arg
->next
;
5812 back_arg
= kind_arg
->next
;
5814 /* Remove kind and set ikind. */
5817 ikind
= mpz_get_si (kind_arg
->expr
->value
.integer
);
5818 gfc_free_expr (kind_arg
->expr
);
5819 kind_arg
->expr
= NULL
;
5822 ikind
= gfc_default_integer_kind
;
5824 value_expr
= value_arg
->expr
;
5826 /* Unless it's a string, pass VALUE by value. */
5827 if (value_expr
->ts
.type
!= BT_CHARACTER
)
5828 value_arg
->name
= "%VAL";
5830 /* Pass BACK argument by value. */
5831 back_arg
->name
= "%VAL";
5833 /* Call the library if we have a character function or if
5835 if (se
->ss
|| array_arg
->expr
->ts
.type
== BT_CHARACTER
)
5837 se
->ignore_optional
= 1;
5838 if (expr
->rank
== 0)
5840 /* Remove dim argument. */
5841 gfc_free_expr (dim_arg
->expr
);
5842 dim_arg
->expr
= NULL
;
5844 gfc_conv_intrinsic_funcall (se
, expr
);
5848 type
= gfc_get_int_type (ikind
);
5850 /* Initialize the result. */
5851 resvar
= gfc_create_var (gfc_array_index_type
, "pos");
5852 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (gfc_array_index_type
, 0));
5853 offset
= gfc_create_var (gfc_array_index_type
, "offset");
5855 maskexpr
= mask_arg
->expr
;
5856 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
5857 && maskexpr
->symtree
->n
.sym
->attr
.dummy
5858 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
5860 /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5862 for (i
= 0 ; i
< 2; i
++)
5864 /* Walk the arguments. */
5865 arrayss
= gfc_walk_expr (array_arg
->expr
);
5866 gcc_assert (arrayss
!= gfc_ss_terminator
);
5868 if (maskexpr
&& maskexpr
->rank
!= 0)
5870 maskss
= gfc_walk_expr (maskexpr
);
5871 gcc_assert (maskss
!= gfc_ss_terminator
);
5876 /* Initialize the scalarizer. */
5877 gfc_init_loopinfo (&loop
);
5878 exit_label
= gfc_build_label_decl (NULL_TREE
);
5879 TREE_USED (exit_label
) = 1;
5881 /* We add the mask first because the number of iterations is
5882 taken from the last ss, and this breaks if an absent
5883 optional argument is used for mask. */
5886 gfc_add_ss_to_loop (&loop
, maskss
);
5887 gfc_add_ss_to_loop (&loop
, arrayss
);
5889 /* Initialize the loop. */
5890 gfc_conv_ss_startstride (&loop
);
5891 gfc_conv_loop_setup (&loop
, &expr
->where
);
5893 /* Calculate the offset. */
5894 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5895 gfc_index_one_node
, loop
.from
[0]);
5896 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5898 gfc_mark_ss_chain_used (arrayss
, 1);
5900 gfc_mark_ss_chain_used (maskss
, 1);
5902 /* The first loop is for BACK=.true. */
5904 loop
.reverse
[0] = GFC_REVERSE_SET
;
5906 /* Generate the loop body. */
5907 gfc_start_scalarized_body (&loop
, &body
);
5909 /* If we have an array mask, only add the element if it is
5913 gfc_init_se (&maskse
, NULL
);
5914 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5916 gfc_conv_expr_val (&maskse
, maskexpr
);
5917 gfc_add_block_to_block (&body
, &maskse
.pre
);
5920 /* If the condition matches then set the return value. */
5921 gfc_start_block (&block
);
5923 /* Add the offset. */
5924 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5926 loop
.loopvar
[0], offset
);
5927 gfc_add_modify (&block
, resvar
, tmp
);
5928 /* And break out of the loop. */
5929 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5930 gfc_add_expr_to_block (&block
, tmp
);
5932 found
= gfc_finish_block (&block
);
5934 /* Check this element. */
5935 gfc_init_se (&arrayse
, NULL
);
5936 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5937 arrayse
.ss
= arrayss
;
5938 gfc_conv_expr_val (&arrayse
, array_arg
->expr
);
5939 gfc_add_block_to_block (&body
, &arrayse
.pre
);
5941 gfc_init_se (&valuese
, NULL
);
5942 gfc_conv_expr_val (&valuese
, value_arg
->expr
);
5943 gfc_add_block_to_block (&body
, &valuese
.pre
);
5945 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5946 arrayse
.expr
, valuese
.expr
);
5948 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
5951 /* We enclose the above in if (mask) {...}. If the mask is
5952 an optional argument, generate IF (.NOT. PRESENT(MASK)
5956 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5957 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
5958 build_empty_stmt (input_location
));
5961 gfc_add_expr_to_block (&body
, tmp
);
5962 gfc_add_block_to_block (&body
, &arrayse
.post
);
5964 gfc_trans_scalarizing_loops (&loop
, &body
);
5966 /* Add the exit label. */
5967 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5968 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5969 gfc_start_block (&loopblock
);
5970 gfc_add_block_to_block (&loopblock
, &loop
.pre
);
5971 gfc_add_block_to_block (&loopblock
, &loop
.post
);
5973 forward_branch
= gfc_finish_block (&loopblock
);
5975 back_branch
= gfc_finish_block (&loopblock
);
5977 gfc_cleanup_loop (&loop
);
5980 /* Enclose the two loops in an IF statement. */
5982 gfc_init_se (&backse
, NULL
);
5983 gfc_conv_expr_val (&backse
, back_arg
->expr
);
5984 gfc_add_block_to_block (&se
->pre
, &backse
.pre
);
5985 tmp
= build3_v (COND_EXPR
, backse
.expr
, forward_branch
, back_branch
);
5987 /* For a scalar mask, enclose the loop in an if statement. */
5988 if (maskexpr
&& maskss
== NULL
)
5993 gfc_init_se (&maskse
, NULL
);
5994 gfc_conv_expr_val (&maskse
, maskexpr
);
5995 gfc_init_block (&block
);
5996 gfc_add_expr_to_block (&block
, maskse
.expr
);
5997 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
5998 if_stmt
= build3_v (COND_EXPR
, ifmask
, tmp
,
5999 build_empty_stmt (input_location
));
6000 gfc_add_expr_to_block (&block
, if_stmt
);
6001 tmp
= gfc_finish_block (&block
);
6004 gfc_add_expr_to_block (&se
->pre
, tmp
);
6005 se
->expr
= convert (type
, resvar
);
6009 /* Emit code for minval or maxval intrinsic. There are many different cases
6010 we need to handle. For performance reasons we sometimes create two
6011 loops instead of one, where the second one is much simpler.
6012 Examples for minval intrinsic:
6013 1) Result is an array, a call is generated
6014 2) Array mask is used and NaNs need to be supported, rank 1:
6019 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
6022 limit = nonempty ? NaN : huge (limit);
6024 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6025 3) NaNs need to be supported, but it is known at compile time or cheaply
6026 at runtime whether array is nonempty or not, rank 1:
6029 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
6030 limit = (from <= to) ? NaN : huge (limit);
6032 while (S <= to) { limit = min (a[S], limit); S++; }
6033 4) Array mask is used and NaNs need to be supported, rank > 1:
6042 if (fast) limit = min (a[S1][S2], limit);
6045 if (a[S1][S2] <= limit) {
6056 limit = nonempty ? NaN : huge (limit);
6057 5) NaNs need to be supported, but it is known at compile time or cheaply
6058 at runtime whether array is nonempty or not, rank > 1:
6065 if (fast) limit = min (a[S1][S2], limit);
6067 if (a[S1][S2] <= limit) {
6077 limit = (nonempty_array) ? NaN : huge (limit);
6078 6) NaNs aren't supported, but infinities are. Array mask is used:
6083 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6086 limit = nonempty ? limit : huge (limit);
6087 7) Same without array mask:
6090 while (S <= to) { limit = min (a[S], limit); S++; }
6091 limit = (from <= to) ? limit : huge (limit);
6092 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6093 limit = huge (limit);
6095 while (S <= to) { limit = min (a[S], limit); S++); }
6097 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6098 with array mask instead).
6099 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6100 setting limit = huge (limit); in the else branch. */
6103 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6113 tree huge_cst
= NULL
, nan_cst
= NULL
;
6115 stmtblock_t block
, block2
;
6117 gfc_actual_arglist
*actual
;
6122 gfc_expr
*arrayexpr
;
6129 gfc_conv_intrinsic_funcall (se
, expr
);
6133 actual
= expr
->value
.function
.actual
;
6134 arrayexpr
= actual
->expr
;
6136 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
6138 gfc_actual_arglist
*dim
= actual
->next
;
6139 if (expr
->rank
== 0 && dim
->expr
!= 0)
6141 gfc_free_expr (dim
->expr
);
6144 gfc_conv_intrinsic_funcall (se
, expr
);
6148 type
= gfc_typenode_for_spec (&expr
->ts
);
6149 /* Initialize the result. */
6150 limit
= gfc_create_var (type
, "limit");
6151 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
6152 switch (expr
->ts
.type
)
6155 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
6157 if (HONOR_INFINITIES (DECL_MODE (limit
)))
6159 REAL_VALUE_TYPE real
;
6161 tmp
= build_real (type
, real
);
6165 if (HONOR_NANS (DECL_MODE (limit
)))
6166 nan_cst
= gfc_build_nan (type
, "");
6170 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
6177 /* We start with the most negative possible value for MAXVAL, and the most
6178 positive possible value for MINVAL. The most negative possible value is
6179 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6180 possible value is HUGE in both cases. */
6183 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
6185 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
6186 TREE_TYPE (huge_cst
), huge_cst
);
6189 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
6190 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
6191 tmp
, build_int_cst (type
, 1));
6193 gfc_add_modify (&se
->pre
, limit
, tmp
);
6195 /* Walk the arguments. */
6196 arrayss
= gfc_walk_expr (arrayexpr
);
6197 gcc_assert (arrayss
!= gfc_ss_terminator
);
6199 actual
= actual
->next
->next
;
6200 gcc_assert (actual
);
6201 maskexpr
= actual
->expr
;
6202 optional_mask
= maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
6203 && maskexpr
->symtree
->n
.sym
->attr
.dummy
6204 && maskexpr
->symtree
->n
.sym
->attr
.optional
;
6206 if (maskexpr
&& maskexpr
->rank
!= 0)
6208 maskss
= gfc_walk_expr (maskexpr
);
6209 gcc_assert (maskss
!= gfc_ss_terminator
);
6214 if (gfc_array_size (arrayexpr
, &asize
))
6216 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
6218 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
6219 logical_type_node
, nonempty
,
6220 gfc_index_zero_node
);
6225 /* Initialize the scalarizer. */
6226 gfc_init_loopinfo (&loop
);
6228 /* We add the mask first because the number of iterations is taken
6229 from the last ss, and this breaks if an absent optional argument
6230 is used for mask. */
6233 gfc_add_ss_to_loop (&loop
, maskss
);
6234 gfc_add_ss_to_loop (&loop
, arrayss
);
6236 /* Initialize the loop. */
6237 gfc_conv_ss_startstride (&loop
);
6239 /* The code generated can have more than one loop in sequence (see the
6240 comment at the function header). This doesn't work well with the
6241 scalarizer, which changes arrays' offset when the scalarization loops
6242 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6243 are currently inlined in the scalar case only. As there is no dependency
6244 to care about in that case, there is no temporary, so that we can use the
6245 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6246 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6247 gfc_trans_scalarized_loop_boundary even later to restore offset.
6248 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6249 should eventually go away. We could either create two loops properly,
6250 or find another way to save/restore the array offsets between the two
6251 loops (without conflicting with temporary management), or use a single
6252 loop minmaxval implementation. See PR 31067. */
6253 loop
.temp_dim
= loop
.dimen
;
6254 gfc_conv_loop_setup (&loop
, &expr
->where
);
6256 if (nonempty
== NULL
&& maskss
== NULL
6257 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
6258 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
6259 loop
.from
[0], loop
.to
[0]);
6260 nonempty_var
= NULL
;
6261 if (nonempty
== NULL
6262 && (HONOR_INFINITIES (DECL_MODE (limit
))
6263 || HONOR_NANS (DECL_MODE (limit
))))
6265 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
6266 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
6267 nonempty
= nonempty_var
;
6271 if (HONOR_NANS (DECL_MODE (limit
)))
6273 if (loop
.dimen
== 1)
6275 lab
= gfc_build_label_decl (NULL_TREE
);
6276 TREE_USED (lab
) = 1;
6280 fast
= gfc_create_var (logical_type_node
, "fast");
6281 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
6285 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
6287 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
6288 /* Generate the loop body. */
6289 gfc_start_scalarized_body (&loop
, &body
);
6291 /* If we have a mask, only add this element if the mask is set. */
6294 gfc_init_se (&maskse
, NULL
);
6295 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
6297 gfc_conv_expr_val (&maskse
, maskexpr
);
6298 gfc_add_block_to_block (&body
, &maskse
.pre
);
6300 gfc_start_block (&block
);
6303 gfc_init_block (&block
);
6305 /* Compare with the current limit. */
6306 gfc_init_se (&arrayse
, NULL
);
6307 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
6308 arrayse
.ss
= arrayss
;
6309 gfc_conv_expr_val (&arrayse
, arrayexpr
);
6310 gfc_add_block_to_block (&block
, &arrayse
.pre
);
6312 gfc_init_block (&block2
);
6315 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
6317 if (HONOR_NANS (DECL_MODE (limit
)))
6319 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
6320 logical_type_node
, arrayse
.expr
, limit
);
6322 ifbody
= build1_v (GOTO_EXPR
, lab
);
6325 stmtblock_t ifblock
;
6327 gfc_init_block (&ifblock
);
6328 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
6329 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
6330 ifbody
= gfc_finish_block (&ifblock
);
6332 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
6333 build_empty_stmt (input_location
));
6334 gfc_add_expr_to_block (&block2
, tmp
);
6338 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6340 tmp
= fold_build2_loc (input_location
,
6341 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6342 type
, arrayse
.expr
, limit
);
6343 gfc_add_modify (&block2
, limit
, tmp
);
6348 tree elsebody
= gfc_finish_block (&block2
);
6350 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6352 if (HONOR_NANS (DECL_MODE (limit
)))
6354 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
6355 arrayse
.expr
, limit
);
6356 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
6357 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
6358 build_empty_stmt (input_location
));
6362 tmp
= fold_build2_loc (input_location
,
6363 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6364 type
, arrayse
.expr
, limit
);
6365 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
6367 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
6368 gfc_add_expr_to_block (&block
, tmp
);
6371 gfc_add_block_to_block (&block
, &block2
);
6373 gfc_add_block_to_block (&block
, &arrayse
.post
);
6375 tmp
= gfc_finish_block (&block
);
6378 /* We enclose the above in if (mask) {...}. If the mask is an
6379 optional argument, generate IF (.NOT. PRESENT(MASK)
6382 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6383 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6384 build_empty_stmt (input_location
));
6386 gfc_add_expr_to_block (&body
, tmp
);
6390 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
6392 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
6394 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
6395 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
6397 /* If we have a mask, only add this element if the mask is set. */
6400 gfc_init_se (&maskse
, NULL
);
6401 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
6403 gfc_conv_expr_val (&maskse
, maskexpr
);
6404 gfc_add_block_to_block (&body
, &maskse
.pre
);
6406 gfc_start_block (&block
);
6409 gfc_init_block (&block
);
6411 /* Compare with the current limit. */
6412 gfc_init_se (&arrayse
, NULL
);
6413 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
6414 arrayse
.ss
= arrayss
;
6415 gfc_conv_expr_val (&arrayse
, arrayexpr
);
6416 gfc_add_block_to_block (&block
, &arrayse
.pre
);
6418 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6420 if (HONOR_NANS (DECL_MODE (limit
)))
6422 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
6423 arrayse
.expr
, limit
);
6424 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
6425 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
6426 build_empty_stmt (input_location
));
6427 gfc_add_expr_to_block (&block
, tmp
);
6431 tmp
= fold_build2_loc (input_location
,
6432 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
6433 type
, arrayse
.expr
, limit
);
6434 gfc_add_modify (&block
, limit
, tmp
);
6437 gfc_add_block_to_block (&block
, &arrayse
.post
);
6439 tmp
= gfc_finish_block (&block
);
6441 /* We enclose the above in if (mask) {...}. */
6444 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6445 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
,
6446 build_empty_stmt (input_location
));
6449 gfc_add_expr_to_block (&body
, tmp
);
6450 /* Avoid initializing loopvar[0] again, it should be left where
6451 it finished by the first loop. */
6452 loop
.from
[0] = loop
.loopvar
[0];
6454 gfc_trans_scalarizing_loops (&loop
, &body
);
6458 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
6460 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
6461 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
6463 gfc_add_expr_to_block (&loop
.pre
, tmp
);
6465 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
6467 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
6469 gfc_add_modify (&loop
.pre
, limit
, tmp
);
6472 /* For a scalar mask, enclose the loop in an if statement. */
6473 if (maskexpr
&& maskss
== NULL
)
6478 gfc_init_se (&maskse
, NULL
);
6479 gfc_conv_expr_val (&maskse
, maskexpr
);
6480 gfc_init_block (&block
);
6481 gfc_add_block_to_block (&block
, &loop
.pre
);
6482 gfc_add_block_to_block (&block
, &loop
.post
);
6483 tmp
= gfc_finish_block (&block
);
6485 if (HONOR_INFINITIES (DECL_MODE (limit
)))
6486 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
6488 else_stmt
= build_empty_stmt (input_location
);
6490 ifmask
= conv_mask_condition (&maskse
, maskexpr
, optional_mask
);
6491 tmp
= build3_v (COND_EXPR
, ifmask
, tmp
, else_stmt
);
6492 gfc_add_expr_to_block (&block
, tmp
);
6493 gfc_add_block_to_block (&se
->pre
, &block
);
6497 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
6498 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
6501 gfc_cleanup_loop (&loop
);
6506 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6508 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
6514 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6515 type
= TREE_TYPE (args
[0]);
6517 /* Optionally generate code for runtime argument check. */
6518 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6520 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6521 logical_type_node
, args
[1],
6522 build_int_cst (TREE_TYPE (args
[1]), 0));
6523 tree nbits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6524 tree above
= fold_build2_loc (input_location
, GE_EXPR
,
6525 logical_type_node
, args
[1], nbits
);
6526 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6527 logical_type_node
, below
, above
);
6528 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6529 "POS argument (%ld) out of range 0:%ld "
6530 "in intrinsic BTEST",
6531 fold_convert (long_integer_type_node
, args
[1]),
6532 fold_convert (long_integer_type_node
, nbits
));
6535 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
6536 build_int_cst (type
, 1), args
[1]);
6537 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
6538 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
6539 build_int_cst (type
, 0));
6540 type
= gfc_typenode_for_spec (&expr
->ts
);
6541 se
->expr
= convert (type
, tmp
);
6545 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6547 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6551 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6553 /* Convert both arguments to the unsigned type of the same size. */
6554 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
6555 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
6557 /* If they have unequal type size, convert to the larger one. */
6558 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
6559 > TYPE_PRECISION (TREE_TYPE (args
[1])))
6560 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
6561 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
6562 > TYPE_PRECISION (TREE_TYPE (args
[0])))
6563 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
6565 /* Now, we compare them. */
6566 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
6571 /* Generate code to perform the specified operation. */
6573 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6577 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6578 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
6584 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
6588 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6589 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6590 TREE_TYPE (arg
), arg
);
6593 /* Set or clear a single bit. */
6595 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
6602 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6603 type
= TREE_TYPE (args
[0]);
6605 /* Optionally generate code for runtime argument check. */
6606 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6608 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6609 logical_type_node
, args
[1],
6610 build_int_cst (TREE_TYPE (args
[1]), 0));
6611 tree nbits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6612 tree above
= fold_build2_loc (input_location
, GE_EXPR
,
6613 logical_type_node
, args
[1], nbits
);
6614 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6615 logical_type_node
, below
, above
);
6616 size_t len_name
= strlen (expr
->value
.function
.isym
->name
);
6617 char *name
= XALLOCAVEC (char, len_name
+ 1);
6618 for (size_t i
= 0; i
< len_name
; i
++)
6619 name
[i
] = TOUPPER (expr
->value
.function
.isym
->name
[i
]);
6620 name
[len_name
] = '\0';
6621 tree iname
= gfc_build_addr_expr (pchar_type_node
,
6622 gfc_build_cstring_const (name
));
6623 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6624 "POS argument (%ld) out of range 0:%ld "
6626 fold_convert (long_integer_type_node
, args
[1]),
6627 fold_convert (long_integer_type_node
, nbits
),
6631 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
6632 build_int_cst (type
, 1), args
[1]);
6638 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
6640 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
6643 /* Extract a sequence of bits.
6644 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6646 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
6653 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6654 type
= TREE_TYPE (args
[0]);
6656 /* Optionally generate code for runtime argument check. */
6657 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6659 tree tmp1
= fold_convert (long_integer_type_node
, args
[1]);
6660 tree tmp2
= fold_convert (long_integer_type_node
, args
[2]);
6661 tree nbits
= build_int_cst (long_integer_type_node
,
6662 TYPE_PRECISION (type
));
6663 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6664 logical_type_node
, args
[1],
6665 build_int_cst (TREE_TYPE (args
[1]), 0));
6666 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6667 logical_type_node
, tmp1
, nbits
);
6668 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6669 logical_type_node
, below
, above
);
6670 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6671 "POS argument (%ld) out of range 0:%ld "
6672 "in intrinsic IBITS", tmp1
, nbits
);
6673 below
= fold_build2_loc (input_location
, LT_EXPR
,
6674 logical_type_node
, args
[2],
6675 build_int_cst (TREE_TYPE (args
[2]), 0));
6676 above
= fold_build2_loc (input_location
, GT_EXPR
,
6677 logical_type_node
, tmp2
, nbits
);
6678 scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6679 logical_type_node
, below
, above
);
6680 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6681 "LEN argument (%ld) out of range 0:%ld "
6682 "in intrinsic IBITS", tmp2
, nbits
);
6683 above
= fold_build2_loc (input_location
, PLUS_EXPR
,
6684 long_integer_type_node
, tmp1
, tmp2
);
6685 scond
= fold_build2_loc (input_location
, GT_EXPR
,
6686 logical_type_node
, above
, nbits
);
6687 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6688 "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6689 "in intrinsic IBITS", tmp1
, tmp2
, nbits
);
6692 mask
= build_int_cst (type
, -1);
6693 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
6694 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
6696 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
6698 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
6702 gfc_conv_intrinsic_shape (gfc_se
*se
, gfc_expr
*expr
)
6704 gfc_actual_arglist
*s
, *k
;
6709 /* Remove the KIND argument, if present. */
6710 s
= expr
->value
.function
.actual
;
6716 gfc_conv_intrinsic_funcall (se
, expr
);
6718 as
= gfc_get_full_arrayspec_from_expr (s
->expr
);;
6719 ss
= gfc_walk_expr (s
->expr
);
6721 /* According to F2018 16.9.172, para 5, an assumed rank entity, argument
6722 associated with an assumed size array, has the ubound of the final
6723 dimension set to -1 and SHAPE must return this. */
6724 if (as
&& as
->type
== AS_ASSUMED_RANK
6725 && se
->expr
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
->expr
))
6726 && ss
&& ss
->info
->type
== GFC_SS_SECTION
)
6728 tree desc
, rank
, minus_one
, cond
, ubound
, tmp
;
6732 minus_one
= build_int_cst (gfc_array_index_type
, -1);
6734 /* Recover the descriptor for the array. */
6735 gfc_init_se (&ase
, NULL
);
6736 ase
.descriptor_only
= 1;
6737 gfc_conv_expr_lhs (&ase
, ss
->info
->expr
);
6739 /* Obtain rank-1 so that we can address both descriptors. */
6740 rank
= gfc_conv_descriptor_rank (ase
.expr
);
6741 rank
= fold_convert (gfc_array_index_type
, rank
);
6742 rank
= fold_build2_loc (input_location
, PLUS_EXPR
,
6743 gfc_array_index_type
,
6745 rank
= gfc_evaluate_now (rank
, &se
->pre
);
6747 /* The ubound for the final dimension will be tested for being -1. */
6748 ubound
= gfc_conv_descriptor_ubound_get (ase
.expr
, rank
);
6749 ubound
= gfc_evaluate_now (ubound
, &se
->pre
);
6750 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6754 /* Obtain the last element of the result from the library shape
6755 intrinsic and set it to -1 if that is the value of ubound. */
6757 tmp
= gfc_conv_array_data (desc
);
6758 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6759 tmp
= gfc_build_array_ref (tmp
, rank
, NULL
, NULL
);
6761 gfc_init_block (&block
);
6762 gfc_add_modify (&block
, tmp
, build_int_cst (TREE_TYPE (tmp
), -1));
6764 cond
= build3_v (COND_EXPR
, cond
,
6765 gfc_finish_block (&block
),
6766 build_empty_stmt (input_location
));
6767 gfc_add_expr_to_block (&se
->pre
, cond
);
6773 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
6776 tree args
[2], type
, num_bits
, cond
;
6779 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6781 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6782 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6783 type
= TREE_TYPE (args
[0]);
6786 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
6788 gcc_assert (right_shift
);
6790 se
->expr
= fold_build2_loc (input_location
,
6791 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
6792 TREE_TYPE (args
[0]), args
[0], args
[1]);
6795 se
->expr
= fold_convert (type
, se
->expr
);
6798 bigshift
= build_int_cst (type
, 0);
6801 tree nonneg
= fold_build2_loc (input_location
, GE_EXPR
,
6802 logical_type_node
, args
[0],
6803 build_int_cst (TREE_TYPE (args
[0]), 0));
6804 bigshift
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonneg
,
6805 build_int_cst (type
, 0),
6806 build_int_cst (type
, -1));
6809 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6810 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6812 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6814 /* Optionally generate code for runtime argument check. */
6815 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6817 tree below
= fold_build2_loc (input_location
, LT_EXPR
,
6818 logical_type_node
, args
[1],
6819 build_int_cst (TREE_TYPE (args
[1]), 0));
6820 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6821 logical_type_node
, args
[1], num_bits
);
6822 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6823 logical_type_node
, below
, above
);
6824 size_t len_name
= strlen (expr
->value
.function
.isym
->name
);
6825 char *name
= XALLOCAVEC (char, len_name
+ 1);
6826 for (size_t i
= 0; i
< len_name
; i
++)
6827 name
[i
] = TOUPPER (expr
->value
.function
.isym
->name
[i
]);
6828 name
[len_name
] = '\0';
6829 tree iname
= gfc_build_addr_expr (pchar_type_node
,
6830 gfc_build_cstring_const (name
));
6831 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6832 "SHIFT argument (%ld) out of range 0:%ld "
6834 fold_convert (long_integer_type_node
, args
[1]),
6835 fold_convert (long_integer_type_node
, num_bits
),
6839 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6842 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6843 bigshift
, se
->expr
);
6846 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
6848 : ((shift >= 0) ? i << shift : i >> -shift)
6849 where all shifts are logical shifts. */
6851 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
6863 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6865 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6866 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6868 type
= TREE_TYPE (args
[0]);
6869 utype
= unsigned_type_for (type
);
6871 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
6874 /* Left shift if positive. */
6875 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
6877 /* Right shift if negative.
6878 We convert to an unsigned type because we want a logical shift.
6879 The standard doesn't define the case of shifting negative
6880 numbers, and we try to be compatible with other compilers, most
6881 notably g77, here. */
6882 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
6883 utype
, convert (utype
, args
[0]), width
));
6885 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
6886 build_int_cst (TREE_TYPE (args
[1]), 0));
6887 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
6889 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6890 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6892 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6894 /* Optionally generate code for runtime argument check. */
6895 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6897 tree outside
= fold_build2_loc (input_location
, GT_EXPR
,
6898 logical_type_node
, width
, num_bits
);
6899 gfc_trans_runtime_check (true, false, outside
, &se
->pre
, &expr
->where
,
6900 "SHIFT argument (%ld) out of range -%ld:%ld "
6901 "in intrinsic ISHFT",
6902 fold_convert (long_integer_type_node
, args
[1]),
6903 fold_convert (long_integer_type_node
, num_bits
),
6904 fold_convert (long_integer_type_node
, num_bits
));
6907 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
6909 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6910 build_int_cst (type
, 0), tmp
);
6914 /* Circular shift. AKA rotate or barrel shift. */
6917 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
6926 unsigned int num_args
;
6928 num_args
= gfc_intrinsic_argument_list_length (expr
);
6929 args
= XALLOCAVEC (tree
, num_args
);
6931 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6933 type
= TREE_TYPE (args
[0]);
6934 nbits
= build_int_cst (long_integer_type_node
, TYPE_PRECISION (type
));
6938 /* Use a library function for the 3 parameter version. */
6939 tree int4type
= gfc_get_int_type (4);
6941 /* We convert the first argument to at least 4 bytes, and
6942 convert back afterwards. This removes the need for library
6943 functions for all argument sizes, and function will be
6944 aligned to at least 32 bits, so there's no loss. */
6945 if (expr
->ts
.kind
< 4)
6946 args
[0] = convert (int4type
, args
[0]);
6948 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
6949 need loads of library functions. They cannot have values >
6950 BIT_SIZE (I) so the conversion is safe. */
6951 args
[1] = convert (int4type
, args
[1]);
6952 args
[2] = convert (int4type
, args
[2]);
6954 /* Optionally generate code for runtime argument check. */
6955 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
6957 tree size
= fold_convert (long_integer_type_node
, args
[2]);
6958 tree below
= fold_build2_loc (input_location
, LE_EXPR
,
6959 logical_type_node
, size
,
6960 build_int_cst (TREE_TYPE (args
[1]), 0));
6961 tree above
= fold_build2_loc (input_location
, GT_EXPR
,
6962 logical_type_node
, size
, nbits
);
6963 tree scond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6964 logical_type_node
, below
, above
);
6965 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6966 "SIZE argument (%ld) out of range 1:%ld "
6967 "in intrinsic ISHFTC", size
, nbits
);
6968 tree width
= fold_convert (long_integer_type_node
, args
[1]);
6969 width
= fold_build1_loc (input_location
, ABS_EXPR
,
6970 long_integer_type_node
, width
);
6971 scond
= fold_build2_loc (input_location
, GT_EXPR
,
6972 logical_type_node
, width
, size
);
6973 gfc_trans_runtime_check (true, false, scond
, &se
->pre
, &expr
->where
,
6974 "SHIFT argument (%ld) out of range -%ld:%ld "
6975 "in intrinsic ISHFTC",
6976 fold_convert (long_integer_type_node
, args
[1]),
6980 switch (expr
->ts
.kind
)
6985 tmp
= gfor_fndecl_math_ishftc4
;
6988 tmp
= gfor_fndecl_math_ishftc8
;
6991 tmp
= gfor_fndecl_math_ishftc16
;
6996 se
->expr
= build_call_expr_loc (input_location
,
6997 tmp
, 3, args
[0], args
[1], args
[2]);
6998 /* Convert the result back to the original type, if we extended
6999 the first argument's width above. */
7000 if (expr
->ts
.kind
< 4)
7001 se
->expr
= convert (type
, se
->expr
);
7006 /* Evaluate arguments only once. */
7007 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
7008 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
7010 /* Optionally generate code for runtime argument check. */
7011 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
7013 tree width
= fold_convert (long_integer_type_node
, args
[1]);
7014 width
= fold_build1_loc (input_location
, ABS_EXPR
,
7015 long_integer_type_node
, width
);
7016 tree outside
= fold_build2_loc (input_location
, GT_EXPR
,
7017 logical_type_node
, width
, nbits
);
7018 gfc_trans_runtime_check (true, false, outside
, &se
->pre
, &expr
->where
,
7019 "SHIFT argument (%ld) out of range -%ld:%ld "
7020 "in intrinsic ISHFTC",
7021 fold_convert (long_integer_type_node
, args
[1]),
7025 /* Rotate left if positive. */
7026 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
7028 /* Rotate right if negative. */
7029 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
7031 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
7033 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
7034 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
7036 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
7038 /* Do nothing if shift == 0. */
7039 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
7041 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
7046 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7047 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7049 The conditional expression is necessary because the result of LEADZ(0)
7050 is defined, but the result of __builtin_clz(0) is undefined for most
7053 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7054 difference in bit size between the argument of LEADZ and the C int. */
7057 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
7069 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7070 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
7072 /* Which variant of __builtin_clz* should we call? */
7073 if (argsize
<= INT_TYPE_SIZE
)
7075 arg_type
= unsigned_type_node
;
7076 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
7078 else if (argsize
<= LONG_TYPE_SIZE
)
7080 arg_type
= long_unsigned_type_node
;
7081 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
7083 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
7085 arg_type
= long_long_unsigned_type_node
;
7086 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
7090 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
7091 arg_type
= gfc_build_uint_type (argsize
);
7095 /* Convert the actual argument twice: first, to the unsigned type of the
7096 same size; then, to the proper argument type for the built-in
7097 function. But the return type is of the default INTEGER kind. */
7098 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7099 arg
= fold_convert (arg_type
, arg
);
7100 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7101 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7103 /* Compute LEADZ for the case i .ne. 0. */
7106 s
= TYPE_PRECISION (arg_type
) - argsize
;
7107 tmp
= fold_convert (result_type
,
7108 build_call_expr_loc (input_location
, func
,
7110 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
7111 tmp
, build_int_cst (result_type
, s
));
7115 /* We end up here if the argument type is larger than 'long long'.
7116 We generate this code:
7118 if (x & (ULL_MAX << ULL_SIZE) != 0)
7119 return clzll ((unsigned long long) (x >> ULLSIZE));
7121 return ULL_SIZE + clzll ((unsigned long long) x);
7122 where ULL_MAX is the largest value that a ULL_MAX can hold
7123 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7124 is the bit-size of the long long type (64 in this example). */
7125 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
7127 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
7128 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7129 long_long_unsigned_type_node
,
7130 build_int_cst (long_long_unsigned_type_node
,
7133 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
7134 fold_convert (arg_type
, ullmax
), ullsize
);
7135 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
7137 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7138 cond
, build_int_cst (arg_type
, 0));
7140 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
7142 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
7143 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
7144 tmp1
= fold_convert (result_type
,
7145 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
7147 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
7148 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
7149 tmp2
= fold_convert (result_type
,
7150 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
7151 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7154 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
7158 /* Build BIT_SIZE. */
7159 bit_size
= build_int_cst (result_type
, argsize
);
7161 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7162 arg
, build_int_cst (arg_type
, 0));
7163 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
7168 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7170 The conditional expression is necessary because the result of TRAILZ(0)
7171 is defined, but the result of __builtin_ctz(0) is undefined for most
7175 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
7186 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7187 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
7189 /* Which variant of __builtin_ctz* should we call? */
7190 if (argsize
<= INT_TYPE_SIZE
)
7192 arg_type
= unsigned_type_node
;
7193 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
7195 else if (argsize
<= LONG_TYPE_SIZE
)
7197 arg_type
= long_unsigned_type_node
;
7198 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
7200 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
7202 arg_type
= long_long_unsigned_type_node
;
7203 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7207 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
7208 arg_type
= gfc_build_uint_type (argsize
);
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
7214 function. But the return type is of the default INTEGER kind. */
7215 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7216 arg
= fold_convert (arg_type
, arg
);
7217 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7218 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7220 /* Compute TRAILZ for the case i .ne. 0. */
7222 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
7226 /* We end up here if the argument type is larger than 'long long'.
7227 We generate this code:
7229 if ((x & ULL_MAX) == 0)
7230 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7232 return ctzll ((unsigned long long) x);
7234 where ULL_MAX is the largest value that a ULL_MAX can hold
7235 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7236 is the bit-size of the long long type (64 in this example). */
7237 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
7239 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
7240 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7241 long_long_unsigned_type_node
,
7242 build_int_cst (long_long_unsigned_type_node
, 0));
7244 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
7245 fold_convert (arg_type
, ullmax
));
7246 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
7247 build_int_cst (arg_type
, 0));
7249 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
7251 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
7252 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7253 tmp1
= fold_convert (result_type
,
7254 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
7255 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7258 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
7259 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
7260 tmp2
= fold_convert (result_type
,
7261 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
7263 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
7267 /* Build BIT_SIZE. */
7268 bit_size
= build_int_cst (result_type
, argsize
);
7270 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7271 arg
, build_int_cst (arg_type
, 0));
7272 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
7276 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7277 for types larger than "long long", we call the long long built-in for
7278 the lower and higher bits and combine the result. */
7281 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
7289 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7290 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
7291 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
7293 /* Which variant of the builtin should we call? */
7294 if (argsize
<= INT_TYPE_SIZE
)
7296 arg_type
= unsigned_type_node
;
7297 func
= builtin_decl_explicit (parity
7299 : BUILT_IN_POPCOUNT
);
7301 else if (argsize
<= LONG_TYPE_SIZE
)
7303 arg_type
= long_unsigned_type_node
;
7304 func
= builtin_decl_explicit (parity
7306 : BUILT_IN_POPCOUNTL
);
7308 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
7310 arg_type
= long_long_unsigned_type_node
;
7311 func
= builtin_decl_explicit (parity
7313 : BUILT_IN_POPCOUNTLL
);
7317 /* Our argument type is larger than 'long long', which mean none
7318 of the POPCOUNT builtins covers it. We thus call the 'long long'
7319 variant multiple times, and add the results. */
7320 tree utype
, arg2
, call1
, call2
;
7322 /* For now, we only cover the case where argsize is twice as large
7324 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
7326 func
= builtin_decl_explicit (parity
7328 : BUILT_IN_POPCOUNTLL
);
7330 /* Convert it to an integer, and store into a variable. */
7331 utype
= gfc_build_uint_type (argsize
);
7332 arg
= fold_convert (utype
, arg
);
7333 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7335 /* Call the builtin twice. */
7336 call1
= build_call_expr_loc (input_location
, func
, 1,
7337 fold_convert (long_long_unsigned_type_node
,
7340 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
7341 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
7342 call2
= build_call_expr_loc (input_location
, func
, 1,
7343 fold_convert (long_long_unsigned_type_node
,
7346 /* Combine the results. */
7348 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
7351 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
7357 /* Convert the actual argument twice: first, to the unsigned type of the
7358 same size; then, to the proper argument type for the built-in
7360 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
7361 arg
= fold_convert (arg_type
, arg
);
7363 se
->expr
= fold_convert (result_type
,
7364 build_call_expr_loc (input_location
, func
, 1, arg
));
7368 /* Process an intrinsic with unspecified argument-types that has an optional
7369 argument (which could be of type character), e.g. EOSHIFT. For those, we
7370 need to append the string length of the optional argument if it is not
7371 present and the type is really character.
7372 primary specifies the position (starting at 1) of the non-optional argument
7373 specifying the type and optional gives the position of the optional
7374 argument in the arglist. */
7377 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
7378 unsigned primary
, unsigned optional
)
7380 gfc_actual_arglist
* prim_arg
;
7381 gfc_actual_arglist
* opt_arg
;
7383 gfc_actual_arglist
* arg
;
7385 vec
<tree
, va_gc
> *append_args
;
7387 /* Find the two arguments given as position. */
7391 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
7395 if (cur_pos
== primary
)
7397 if (cur_pos
== optional
)
7400 if (cur_pos
>= primary
&& cur_pos
>= optional
)
7403 gcc_assert (prim_arg
);
7404 gcc_assert (prim_arg
->expr
);
7405 gcc_assert (opt_arg
);
7407 /* If we do have type CHARACTER and the optional argument is really absent,
7408 append a dummy 0 as string length. */
7410 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
7414 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
7415 vec_alloc (append_args
, 1);
7416 append_args
->quick_push (dummy
);
7419 /* Build the call itself. */
7420 gcc_assert (!se
->ignore_optional
);
7421 sym
= gfc_get_symbol_for_expr (expr
, false);
7422 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
7424 gfc_free_symbol (sym
);
7427 /* The length of a character string. */
7429 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
7438 gcc_assert (!se
->ss
);
7440 arg
= expr
->value
.function
.actual
->expr
;
7442 type
= gfc_typenode_for_spec (&expr
->ts
);
7443 switch (arg
->expr_type
)
7446 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
7450 /* Obtain the string length from the function used by
7451 trans-array.c(gfc_trans_array_constructor). */
7453 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
7457 if (arg
->ref
== NULL
7458 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
7460 /* This doesn't catch all cases.
7461 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7462 and the surrounding thread. */
7463 sym
= arg
->symtree
->n
.sym
;
7464 decl
= gfc_get_symbol_decl (sym
);
7465 if (decl
== current_function_decl
&& sym
->attr
.function
7466 && (sym
->result
== sym
))
7467 decl
= gfc_get_fake_result_decl (sym
, 0);
7469 len
= sym
->ts
.u
.cl
->backend_decl
;
7477 gfc_init_se (&argse
, se
);
7479 gfc_conv_expr (&argse
, arg
);
7481 gfc_conv_expr_descriptor (&argse
, arg
);
7482 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7483 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7484 len
= argse
.string_length
;
7487 se
->expr
= convert (type
, len
);
7490 /* The length of a character string not including trailing blanks. */
7492 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
7494 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7495 tree args
[2], type
, fndecl
;
7497 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7498 type
= gfc_typenode_for_spec (&expr
->ts
);
7501 fndecl
= gfor_fndecl_string_len_trim
;
7503 fndecl
= gfor_fndecl_string_len_trim_char4
;
7507 se
->expr
= build_call_expr_loc (input_location
,
7508 fndecl
, 2, args
[0], args
[1]);
7509 se
->expr
= convert (type
, se
->expr
);
7513 /* Returns the starting position of a substring within a string. */
7516 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
7519 tree logical4_type_node
= gfc_get_logical_type (4);
7523 unsigned int num_args
;
7525 args
= XALLOCAVEC (tree
, 5);
7527 /* Get number of arguments; characters count double due to the
7528 string length argument. Kind= is not passed to the library
7529 and thus ignored. */
7530 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
7535 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
7536 type
= gfc_typenode_for_spec (&expr
->ts
);
7539 args
[4] = build_int_cst (logical4_type_node
, 0);
7541 args
[4] = convert (logical4_type_node
, args
[4]);
7543 fndecl
= build_addr (function
);
7544 se
->expr
= build_call_array_loc (input_location
,
7545 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7547 se
->expr
= convert (type
, se
->expr
);
7551 /* The ascii value for a single character. */
7553 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
7555 tree args
[3], type
, pchartype
;
7558 nargs
= gfc_intrinsic_argument_list_length (expr
);
7559 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
7560 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
7561 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
7562 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
7563 type
= gfc_typenode_for_spec (&expr
->ts
);
7565 se
->expr
= build_fold_indirect_ref_loc (input_location
,
7567 se
->expr
= convert (type
, se
->expr
);
7571 /* Intrinsic ISNAN calls __builtin_isnan. */
7574 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
7578 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7579 se
->expr
= build_call_expr_loc (input_location
,
7580 builtin_decl_explicit (BUILT_IN_ISNAN
),
7582 STRIP_TYPE_NOPS (se
->expr
);
7583 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7587 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7588 their argument against a constant integer value. */
7591 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
7595 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7596 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
7597 gfc_typenode_for_spec (&expr
->ts
),
7598 arg
, build_int_cst (TREE_TYPE (arg
), value
));
7603 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7606 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
7614 unsigned int num_args
;
7616 num_args
= gfc_intrinsic_argument_list_length (expr
);
7617 args
= XALLOCAVEC (tree
, num_args
);
7619 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
7620 if (expr
->ts
.type
!= BT_CHARACTER
)
7628 /* We do the same as in the non-character case, but the argument
7629 list is different because of the string length arguments. We
7630 also have to set the string length for the result. */
7637 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
7639 se
->string_length
= len
;
7641 type
= TREE_TYPE (tsource
);
7642 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
7643 fold_convert (type
, fsource
));
7647 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7650 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
7652 tree args
[3], mask
, type
;
7654 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7655 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
7657 type
= TREE_TYPE (args
[0]);
7658 gcc_assert (TREE_TYPE (args
[1]) == type
);
7659 gcc_assert (TREE_TYPE (mask
) == type
);
7661 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
7662 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
7663 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
7665 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
7670 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7671 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7674 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
7676 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
7679 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7680 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7682 type
= gfc_get_int_type (expr
->ts
.kind
);
7683 utype
= unsigned_type_for (type
);
7685 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
7686 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
7688 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
7689 build_int_cst (utype
, 0));
7693 /* Left-justified mask. */
7694 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
7696 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
7697 fold_convert (utype
, res
));
7699 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7700 smaller than type width. */
7701 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
7702 build_int_cst (TREE_TYPE (arg
), 0));
7703 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
7704 build_int_cst (utype
, 0), res
);
7708 /* Right-justified mask. */
7709 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
7710 fold_convert (utype
, arg
));
7711 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
7713 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7714 strictly smaller than type width. */
7715 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7717 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
7718 cond
, allones
, res
);
7721 se
->expr
= fold_convert (type
, res
);
7725 /* FRACTION (s) is translated into:
7726 isfinite (s) ? frexp (s, &dummy_int) : NaN */
7728 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
7730 tree arg
, type
, tmp
, res
, frexp
, cond
;
7732 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7734 type
= gfc_typenode_for_spec (&expr
->ts
);
7735 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7736 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7738 cond
= build_call_expr_loc (input_location
,
7739 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7742 tmp
= gfc_create_var (integer_type_node
, NULL
);
7743 res
= build_call_expr_loc (input_location
, frexp
, 2,
7744 fold_convert (type
, arg
),
7745 gfc_build_addr_expr (NULL_TREE
, tmp
));
7746 res
= fold_convert (type
, res
);
7748 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
7749 cond
, res
, gfc_build_nan (type
, ""));
7753 /* NEAREST (s, dir) is translated into
7754 tmp = copysign (HUGE_VAL, dir);
7755 return nextafter (s, tmp);
7758 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
7760 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
7762 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
7763 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
7765 type
= gfc_typenode_for_spec (&expr
->ts
);
7766 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7768 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
7769 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
7770 fold_convert (type
, args
[1]));
7771 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
7772 fold_convert (type
, args
[0]), tmp
);
7773 se
->expr
= fold_convert (type
, se
->expr
);
7777 /* SPACING (s) is translated into
7787 e = MAX_EXPR (e, emin);
7788 res = scalbn (1., e);
7792 where prec is the precision of s, gfc_real_kinds[k].digits,
7793 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7794 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7797 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
7799 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
7800 tree cond
, nan
, tmp
, frexp
, scalbn
;
7804 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7805 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
7806 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
7807 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
7809 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7810 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7812 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7813 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7815 type
= gfc_typenode_for_spec (&expr
->ts
);
7816 e
= gfc_create_var (integer_type_node
, NULL
);
7817 res
= gfc_create_var (type
, NULL
);
7820 /* Build the block for s /= 0. */
7821 gfc_start_block (&block
);
7822 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7823 gfc_build_addr_expr (NULL_TREE
, e
));
7824 gfc_add_expr_to_block (&block
, tmp
);
7826 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
7828 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
7829 integer_type_node
, tmp
, emin
));
7831 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
7832 build_real_from_int_cst (type
, integer_one_node
), e
);
7833 gfc_add_modify (&block
, res
, tmp
);
7835 /* Finish by building the IF statement for value zero. */
7836 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
7837 build_real_from_int_cst (type
, integer_zero_node
));
7838 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
7839 gfc_finish_block (&block
));
7841 /* And deal with infinities and NaNs. */
7842 cond
= build_call_expr_loc (input_location
,
7843 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7845 nan
= gfc_build_nan (type
, "");
7846 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
7848 gfc_add_expr_to_block (&se
->pre
, tmp
);
7853 /* RRSPACING (s) is translated into
7862 x = scalbn (x, precision - e);
7869 where precision is gfc_real_kinds[k].digits. */
7872 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
7874 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
7878 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7879 prec
= gfc_real_kinds
[k
].digits
;
7881 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7882 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7883 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
7885 type
= gfc_typenode_for_spec (&expr
->ts
);
7886 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7887 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7889 e
= gfc_create_var (integer_type_node
, NULL
);
7890 x
= gfc_create_var (type
, NULL
);
7891 gfc_add_modify (&se
->pre
, x
,
7892 build_call_expr_loc (input_location
, fabs
, 1, arg
));
7895 gfc_start_block (&block
);
7896 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7897 gfc_build_addr_expr (NULL_TREE
, e
));
7898 gfc_add_expr_to_block (&block
, tmp
);
7900 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
7901 build_int_cst (integer_type_node
, prec
), e
);
7902 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
7903 gfc_add_modify (&block
, x
, tmp
);
7904 stmt
= gfc_finish_block (&block
);
7907 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
7908 build_real_from_int_cst (type
, integer_zero_node
));
7909 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
7911 /* And deal with infinities and NaNs. */
7912 cond
= build_call_expr_loc (input_location
,
7913 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7915 nan
= gfc_build_nan (type
, "");
7916 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
7918 gfc_add_expr_to_block (&se
->pre
, tmp
);
7919 se
->expr
= fold_convert (type
, x
);
7923 /* SCALE (s, i) is translated into scalbn (s, i). */
7925 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
7927 tree args
[2], type
, scalbn
;
7929 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7931 type
= gfc_typenode_for_spec (&expr
->ts
);
7932 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7933 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
7934 fold_convert (type
, args
[0]),
7935 fold_convert (integer_type_node
, args
[1]));
7936 se
->expr
= fold_convert (type
, se
->expr
);
7940 /* SET_EXPONENT (s, i) is translated into
7941 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
7943 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
7945 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
7947 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7948 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7950 type
= gfc_typenode_for_spec (&expr
->ts
);
7951 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7952 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
7954 tmp
= gfc_create_var (integer_type_node
, NULL
);
7955 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
7956 fold_convert (type
, args
[0]),
7957 gfc_build_addr_expr (NULL_TREE
, tmp
));
7958 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
7959 fold_convert (integer_type_node
, args
[1]));
7960 res
= fold_convert (type
, res
);
7962 /* Call to isfinite */
7963 cond
= build_call_expr_loc (input_location
,
7964 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7966 nan
= gfc_build_nan (type
, "");
7968 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
7974 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
7976 gfc_actual_arglist
*actual
;
7983 gfc_symbol
*sym
= NULL
;
7985 gfc_init_se (&argse
, NULL
);
7986 actual
= expr
->value
.function
.actual
;
7988 if (actual
->expr
->ts
.type
== BT_CLASS
)
7989 gfc_add_class_array_ref (actual
->expr
);
7993 /* These are emerging from the interface mapping, when a class valued
7994 function appears as the rhs in a realloc on assign statement, where
7995 the size of the result is that of one of the actual arguments. */
7996 if (e
->expr_type
== EXPR_VARIABLE
7997 && e
->symtree
->n
.sym
->ns
== NULL
/* This is distinctive! */
7998 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
7999 && e
->ref
&& e
->ref
->type
== REF_COMPONENT
8000 && strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0)
8001 sym
= e
->symtree
->n
.sym
;
8003 if ((gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
)
8005 && (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
))
8007 symbol_attribute attr
;
8010 attr
= gfc_expr_attr (e
);
8011 if (attr
.allocatable
)
8012 msg
= xasprintf ("Allocatable argument '%s' is not allocated",
8013 e
->symtree
->n
.sym
->name
);
8014 else if (attr
.pointer
)
8015 msg
= xasprintf ("Pointer argument '%s' is not associated",
8016 e
->symtree
->n
.sym
->name
);
8020 argse
.descriptor_only
= 1;
8021 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
8022 tree temp
= gfc_conv_descriptor_data_get (argse
.expr
);
8023 tree cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8024 logical_type_node
, temp
,
8025 fold_convert (TREE_TYPE (temp
),
8026 null_pointer_node
));
8027 gfc_trans_runtime_check (true, false, cond
, &argse
.pre
, &e
->where
, msg
);
8032 argse
.data_not_needed
= 1;
8033 if (gfc_is_class_array_function (e
))
8035 /* For functions that return a class array conv_expr_descriptor is not
8036 able to get the descriptor right. Therefore this special case. */
8037 gfc_conv_expr_reference (&argse
, e
);
8038 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
8039 gfc_class_data_get (argse
.expr
));
8041 else if (sym
&& sym
->backend_decl
)
8043 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
8044 argse
.expr
= sym
->backend_decl
;
8045 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
8046 gfc_class_data_get (argse
.expr
));
8050 argse
.want_pointer
= 1;
8051 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
8053 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8054 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8055 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
8057 /* Build the call to size0. */
8058 fncall0
= build_call_expr_loc (input_location
,
8059 gfor_fndecl_size0
, 1, arg1
);
8061 actual
= actual
->next
;
8065 gfc_init_se (&argse
, NULL
);
8066 gfc_conv_expr_type (&argse
, actual
->expr
,
8067 gfc_array_index_type
);
8068 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8070 /* Unusually, for an intrinsic, size does not exclude
8071 an optional arg2, so we must test for it. */
8072 if (actual
->expr
->expr_type
== EXPR_VARIABLE
8073 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
8074 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
8077 /* Build the call to size1. */
8078 fncall1
= build_call_expr_loc (input_location
,
8079 gfor_fndecl_size1
, 2,
8082 gfc_init_se (&argse
, NULL
);
8083 argse
.want_pointer
= 1;
8084 argse
.data_not_needed
= 1;
8085 gfc_conv_expr (&argse
, actual
->expr
);
8086 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8087 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8088 argse
.expr
, null_pointer_node
);
8089 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
8090 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
8091 pvoid_type_node
, tmp
, fncall1
, fncall0
);
8095 se
->expr
= NULL_TREE
;
8096 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
8097 gfc_array_index_type
,
8098 argse
.expr
, gfc_index_one_node
);
8101 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
8103 argse
.expr
= gfc_index_zero_node
;
8104 se
->expr
= NULL_TREE
;
8109 if (se
->expr
== NULL_TREE
)
8111 tree ubound
, lbound
;
8113 arg1
= build_fold_indirect_ref_loc (input_location
,
8115 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
8116 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
8117 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
8118 gfc_array_index_type
, ubound
, lbound
);
8119 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
8120 gfc_array_index_type
,
8121 se
->expr
, gfc_index_one_node
);
8122 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
8123 gfc_array_index_type
, se
->expr
,
8124 gfc_index_zero_node
);
8127 type
= gfc_typenode_for_spec (&expr
->ts
);
8128 se
->expr
= convert (type
, se
->expr
);
8132 /* Helper function to compute the size of a character variable,
8133 excluding the terminating null characters. The result has
8134 gfc_array_index_type type. */
8137 size_of_string_in_bytes (int kind
, tree string_length
)
8140 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
8142 bytesize
= build_int_cst (gfc_array_index_type
,
8143 gfc_character_kinds
[i
].bit_size
/ 8);
8145 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8147 fold_convert (gfc_array_index_type
, string_length
));
8152 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
8164 gfc_init_se (&argse
, NULL
);
8165 arg
= expr
->value
.function
.actual
->expr
;
8167 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
8168 gfc_conv_expr_descriptor (&argse
, arg
);
8170 gfc_conv_expr_reference (&argse
, arg
);
8172 if (arg
->ts
.type
== BT_ASSUMED
)
8174 /* This only works if an array descriptor has been passed; thus, extract
8175 the size from the descriptor. */
8176 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
8177 == TYPE_PRECISION (size_type_node
));
8178 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
8179 tmp
= DECL_LANG_SPECIFIC (tmp
)
8180 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
8181 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
8182 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
8183 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8185 tmp
= gfc_conv_descriptor_dtype (tmp
);
8186 field
= gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8187 GFC_DTYPE_ELEM_LEN
);
8188 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
8189 tmp
, field
, NULL_TREE
);
8191 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
8193 else if (arg
->ts
.type
== BT_CLASS
)
8195 /* Conv_expr_descriptor returns a component_ref to _data component of the
8196 class object. The class object may be a non-pointer object, e.g.
8197 located on the stack, or a memory location pointed to, e.g. a
8198 parameter, i.e., an indirect_ref. */
8200 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
8201 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
8202 && GFC_DECL_CLASS (TREE_OPERAND (
8203 TREE_OPERAND (argse
.expr
, 0), 0)))
8204 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
8205 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
8206 else if (arg
->rank
> 0
8208 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
8209 /* The scalarizer added an additional temp. To get the class' vptr
8210 one has to look at the original backend_decl. */
8211 byte_size
= gfc_class_vtab_size_get (
8212 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
8214 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
8218 if (arg
->ts
.type
== BT_CHARACTER
)
8219 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
8223 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8226 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8227 byte_size
= fold_convert (gfc_array_index_type
,
8228 size_in_bytes (byte_size
));
8233 se
->expr
= byte_size
;
8236 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
8237 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
8239 if (arg
->rank
== -1)
8241 tree cond
, loop_var
, exit_label
;
8244 tmp
= fold_convert (gfc_array_index_type
,
8245 gfc_conv_descriptor_rank (argse
.expr
));
8246 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
8247 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
8248 exit_label
= gfc_build_label_decl (NULL_TREE
);
8255 source_bytes = source_bytes * array.dim[i].extent;
8259 gfc_start_block (&body
);
8260 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
8262 tmp
= build1_v (GOTO_EXPR
, exit_label
);
8263 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
8264 cond
, tmp
, build_empty_stmt (input_location
));
8265 gfc_add_expr_to_block (&body
, tmp
);
8267 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
8268 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
8269 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
8270 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8271 gfc_array_index_type
, tmp
, source_bytes
);
8272 gfc_add_modify (&body
, source_bytes
, tmp
);
8274 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8275 gfc_array_index_type
, loop_var
,
8276 gfc_index_one_node
);
8277 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
8279 tmp
= gfc_finish_block (&body
);
8281 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
8283 gfc_add_expr_to_block (&argse
.pre
, tmp
);
8285 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8286 gfc_add_expr_to_block (&argse
.pre
, tmp
);
8290 /* Obtain the size of the array in bytes. */
8291 for (n
= 0; n
< arg
->rank
; n
++)
8294 idx
= gfc_rank_cst
[n
];
8295 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
8296 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
8297 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
8298 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8299 gfc_array_index_type
, tmp
, source_bytes
);
8300 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8303 se
->expr
= source_bytes
;
8306 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8311 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
8315 tree type
, result_type
, tmp
;
8317 arg
= expr
->value
.function
.actual
->expr
;
8319 gfc_init_se (&argse
, NULL
);
8320 result_type
= gfc_get_int_type (expr
->ts
.kind
);
8324 if (arg
->ts
.type
== BT_CLASS
)
8326 gfc_add_vptr_component (arg
);
8327 gfc_add_size_component (arg
);
8328 gfc_conv_expr (&argse
, arg
);
8329 tmp
= fold_convert (result_type
, argse
.expr
);
8333 gfc_conv_expr_reference (&argse
, arg
);
8334 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8339 argse
.want_pointer
= 0;
8340 gfc_conv_expr_descriptor (&argse
, arg
);
8341 if (arg
->ts
.type
== BT_CLASS
)
8344 tmp
= gfc_class_vtab_size_get (
8345 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
8347 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
8348 tmp
= fold_convert (result_type
, tmp
);
8351 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8354 /* Obtain the argument's word length. */
8355 if (arg
->ts
.type
== BT_CHARACTER
)
8356 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
8358 tmp
= size_in_bytes (type
);
8359 tmp
= fold_convert (result_type
, tmp
);
8362 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
8363 build_int_cst (result_type
, BITS_PER_UNIT
));
8364 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8368 /* Intrinsic string comparison functions. */
8371 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
8375 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
8378 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
8379 expr
->value
.function
.actual
->expr
->ts
.kind
,
8381 se
->expr
= fold_build2_loc (input_location
, op
,
8382 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
8383 build_int_cst (TREE_TYPE (se
->expr
), 0));
8386 /* Generate a call to the adjustl/adjustr library function. */
8388 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
8396 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
8399 type
= TREE_TYPE (args
[2]);
8400 var
= gfc_conv_string_tmp (se
, type
, len
);
8403 tmp
= build_call_expr_loc (input_location
,
8404 fndecl
, 3, args
[0], args
[1], args
[2]);
8405 gfc_add_expr_to_block (&se
->pre
, tmp
);
8407 se
->string_length
= len
;
8411 /* Generate code for the TRANSFER intrinsic:
8413 DEST = TRANSFER (SOURCE, MOLD)
8415 typeof<DEST> = typeof<MOLD>
8420 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8422 typeof<DEST> = typeof<MOLD>
8424 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8425 sizeof (DEST(0) * SIZE). */
8427 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
8443 tree class_ref
= NULL_TREE
;
8444 gfc_actual_arglist
*arg
;
8446 gfc_array_info
*info
;
8450 gfc_expr
*source_expr
, *mold_expr
, *class_expr
;
8454 info
= &se
->ss
->info
->data
.array
;
8456 /* Convert SOURCE. The output from this stage is:-
8457 source_bytes = length of the source in bytes
8458 source = pointer to the source data. */
8459 arg
= expr
->value
.function
.actual
;
8460 source_expr
= arg
->expr
;
8462 /* Ensure double transfer through LOGICAL preserves all
8464 if (arg
->expr
->expr_type
== EXPR_FUNCTION
8465 && arg
->expr
->value
.function
.esym
== NULL
8466 && arg
->expr
->value
.function
.isym
!= NULL
8467 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
8468 && arg
->expr
->ts
.type
== BT_LOGICAL
8469 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
8470 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
8472 gfc_init_se (&argse
, NULL
);
8474 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
8476 /* Obtain the pointer to source and the length of source in bytes. */
8477 if (arg
->expr
->rank
== 0)
8479 gfc_conv_expr_reference (&argse
, arg
->expr
);
8480 if (arg
->expr
->ts
.type
== BT_CLASS
)
8482 tmp
= build_fold_indirect_ref_loc (input_location
, argse
.expr
);
8483 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
8484 source
= gfc_class_data_get (tmp
);
8487 /* Array elements are evaluated as a reference to the data.
8488 To obtain the vptr for the element size, the argument
8489 expression must be stripped to the class reference and
8490 re-evaluated. The pre and post blocks are not needed. */
8491 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
8492 source
= argse
.expr
;
8493 class_expr
= gfc_find_and_cut_at_last_class_ref (arg
->expr
);
8494 gfc_init_se (&argse
, NULL
);
8495 gfc_conv_expr (&argse
, class_expr
);
8496 class_ref
= argse
.expr
;
8500 source
= argse
.expr
;
8502 /* Obtain the source word length. */
8503 switch (arg
->expr
->ts
.type
)
8506 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
8507 argse
.string_length
);
8510 if (class_ref
!= NULL_TREE
)
8511 tmp
= gfc_class_vtab_size_get (class_ref
);
8513 tmp
= gfc_class_vtab_size_get (argse
.expr
);
8516 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8518 tmp
= fold_convert (gfc_array_index_type
,
8519 size_in_bytes (source_type
));
8525 argse
.want_pointer
= 0;
8526 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
8527 source
= gfc_conv_descriptor_data_get (argse
.expr
);
8528 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8530 /* Repack the source if not simply contiguous. */
8531 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
8533 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
8535 if (warn_array_temporaries
)
8536 gfc_warning (OPT_Warray_temporaries
,
8537 "Creating array temporary at %L", &expr
->where
);
8539 source
= build_call_expr_loc (input_location
,
8540 gfor_fndecl_in_pack
, 1, tmp
);
8541 source
= gfc_evaluate_now (source
, &argse
.pre
);
8543 /* Free the temporary. */
8544 gfc_start_block (&block
);
8545 tmp
= gfc_call_free (source
);
8546 gfc_add_expr_to_block (&block
, tmp
);
8547 stmt
= gfc_finish_block (&block
);
8549 /* Clean up if it was repacked. */
8550 gfc_init_block (&block
);
8551 tmp
= gfc_conv_array_data (argse
.expr
);
8552 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8554 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
8555 build_empty_stmt (input_location
));
8556 gfc_add_expr_to_block (&block
, tmp
);
8557 gfc_add_block_to_block (&block
, &se
->post
);
8558 gfc_init_block (&se
->post
);
8559 gfc_add_block_to_block (&se
->post
, &block
);
8562 /* Obtain the source word length. */
8563 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
8564 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
8565 argse
.string_length
);
8567 tmp
= fold_convert (gfc_array_index_type
,
8568 size_in_bytes (source_type
));
8570 /* Obtain the size of the array in bytes. */
8571 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
8572 for (n
= 0; n
< arg
->expr
->rank
; n
++)
8575 idx
= gfc_rank_cst
[n
];
8576 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8577 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
8578 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
8579 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8580 gfc_array_index_type
, upper
, lower
);
8581 gfc_add_modify (&argse
.pre
, extent
, tmp
);
8582 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8583 gfc_array_index_type
, extent
,
8584 gfc_index_one_node
);
8585 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8586 gfc_array_index_type
, tmp
, source_bytes
);
8590 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
8591 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8592 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8594 /* Now convert MOLD. The outputs are:
8595 mold_type = the TREE type of MOLD
8596 dest_word_len = destination word length in bytes. */
8598 mold_expr
= arg
->expr
;
8600 gfc_init_se (&argse
, NULL
);
8602 scalar_mold
= arg
->expr
->rank
== 0;
8604 if (arg
->expr
->rank
== 0)
8606 gfc_conv_expr_reference (&argse
, arg
->expr
);
8607 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
8612 gfc_init_se (&argse
, NULL
);
8613 argse
.want_pointer
= 0;
8614 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
8615 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
8618 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8619 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8621 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
8623 /* If this TRANSFER is nested in another TRANSFER, use a type
8624 that preserves all bits. */
8625 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
8626 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
8629 /* Obtain the destination word length. */
8630 switch (arg
->expr
->ts
.type
)
8633 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
8634 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
8637 tmp
= gfc_class_vtab_size_get (argse
.expr
);
8640 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
8643 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
8644 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
8646 /* Finally convert SIZE, if it is present. */
8648 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
8652 gfc_init_se (&argse
, NULL
);
8653 gfc_conv_expr_reference (&argse
, arg
->expr
);
8654 tmp
= convert (gfc_array_index_type
,
8655 build_fold_indirect_ref_loc (input_location
,
8657 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8658 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8663 /* Separate array and scalar results. */
8664 if (scalar_mold
&& tmp
== NULL_TREE
)
8665 goto scalar_transfer
;
8667 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
8668 if (tmp
!= NULL_TREE
)
8669 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8670 tmp
, dest_word_len
);
8674 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
8675 gfc_add_modify (&se
->pre
, size_words
,
8676 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
8677 gfc_array_index_type
,
8678 size_bytes
, dest_word_len
));
8680 /* Evaluate the bounds of the result. If the loop range exists, we have
8681 to check if it is too large. If so, we modify loop->to be consistent
8682 with min(size, size(source)). Otherwise, size is made consistent with
8683 the loop range, so that the right number of bytes is transferred.*/
8684 n
= se
->loop
->order
[0];
8685 if (se
->loop
->to
[n
] != NULL_TREE
)
8687 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8688 se
->loop
->to
[n
], se
->loop
->from
[n
]);
8689 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8690 tmp
, gfc_index_one_node
);
8691 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
8693 gfc_add_modify (&se
->pre
, size_words
, tmp
);
8694 gfc_add_modify (&se
->pre
, size_bytes
,
8695 fold_build2_loc (input_location
, MULT_EXPR
,
8696 gfc_array_index_type
,
8697 size_words
, dest_word_len
));
8698 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8699 size_words
, se
->loop
->from
[n
]);
8700 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8701 upper
, gfc_index_one_node
);
8705 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8706 size_words
, gfc_index_one_node
);
8707 se
->loop
->from
[n
] = gfc_index_zero_node
;
8710 se
->loop
->to
[n
] = upper
;
8712 /* Build a destination descriptor, using the pointer, source, as the
8714 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
8715 NULL_TREE
, false, true, false, &expr
->where
);
8717 /* Cast the pointer to the result. */
8718 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
8719 tmp
= fold_convert (pvoid_type_node
, tmp
);
8721 /* Use memcpy to do the transfer. */
8723 = build_call_expr_loc (input_location
,
8724 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
8725 fold_convert (pvoid_type_node
, source
),
8726 fold_convert (size_type_node
,
8727 fold_build2_loc (input_location
,
8729 gfc_array_index_type
,
8732 gfc_add_expr_to_block (&se
->pre
, tmp
);
8734 se
->expr
= info
->descriptor
;
8735 if (expr
->ts
.type
== BT_CHARACTER
)
8736 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
8740 /* Deal with scalar results. */
8742 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
8743 dest_word_len
, source_bytes
);
8744 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
8745 extent
, gfc_index_zero_node
);
8747 if (expr
->ts
.type
== BT_CHARACTER
)
8749 tree direct
, indirect
, free
;
8751 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
8752 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
8755 /* If source is longer than the destination, use a pointer to
8756 the source directly. */
8757 gfc_init_block (&block
);
8758 gfc_add_modify (&block
, tmpdecl
, ptr
);
8759 direct
= gfc_finish_block (&block
);
8761 /* Otherwise, allocate a string with the length of the destination
8762 and copy the source into it. */
8763 gfc_init_block (&block
);
8764 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
8765 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
8766 gfc_add_modify (&block
, tmpdecl
,
8767 fold_convert (TREE_TYPE (ptr
), tmp
));
8768 tmp
= build_call_expr_loc (input_location
,
8769 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
8770 fold_convert (pvoid_type_node
, tmpdecl
),
8771 fold_convert (pvoid_type_node
, ptr
),
8772 fold_convert (size_type_node
, extent
));
8773 gfc_add_expr_to_block (&block
, tmp
);
8774 indirect
= gfc_finish_block (&block
);
8776 /* Wrap it up with the condition. */
8777 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
8778 dest_word_len
, source_bytes
);
8779 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
8780 gfc_add_expr_to_block (&se
->pre
, tmp
);
8782 /* Free the temporary string, if necessary. */
8783 free
= gfc_call_free (tmpdecl
);
8784 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8785 dest_word_len
, source_bytes
);
8786 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
8787 gfc_add_expr_to_block (&se
->post
, tmp
);
8790 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
8794 tmpdecl
= gfc_create_var (mold_type
, "transfer");
8796 ptr
= convert (build_pointer_type (mold_type
), source
);
8798 /* For CLASS results, allocate the needed memory first. */
8799 if (mold_expr
->ts
.type
== BT_CLASS
)
8802 cdata
= gfc_class_data_get (tmpdecl
);
8803 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
8804 gfc_add_modify (&se
->pre
, cdata
, tmp
);
8807 /* Use memcpy to do the transfer. */
8808 if (mold_expr
->ts
.type
== BT_CLASS
)
8809 tmp
= gfc_class_data_get (tmpdecl
);
8811 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
8813 tmp
= build_call_expr_loc (input_location
,
8814 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
8815 fold_convert (pvoid_type_node
, tmp
),
8816 fold_convert (pvoid_type_node
, ptr
),
8817 fold_convert (size_type_node
, extent
));
8818 gfc_add_expr_to_block (&se
->pre
, tmp
);
8820 /* For CLASS results, set the _vptr. */
8821 if (mold_expr
->ts
.type
== BT_CLASS
)
8825 vptr
= gfc_class_vptr_get (tmpdecl
);
8826 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
8828 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
8829 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
8837 /* Generate a call to caf_is_present. */
8840 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
8842 tree caf_reference
, caf_decl
, token
, image_index
;
8844 /* Compile the reference chain. */
8845 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
8846 gcc_assert (caf_reference
!= NULL_TREE
);
8848 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
8849 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8850 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8851 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
8852 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
8855 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
8856 3, token
, image_index
, caf_reference
);
8860 /* Test whether this ref-chain refs this image only. */
8863 caf_this_image_ref (gfc_ref
*ref
)
8865 for ( ; ref
; ref
= ref
->next
)
8866 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
8867 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
8873 /* Generate code for the ALLOCATED intrinsic.
8874 Generate inline code that directly check the address of the argument. */
8877 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
8879 gfc_actual_arglist
*arg1
;
8882 symbol_attribute caf_attr
;
8884 gfc_init_se (&arg1se
, NULL
);
8885 arg1
= expr
->value
.function
.actual
;
8887 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8889 /* Make sure that class array expressions have both a _data
8890 component reference and an array reference.... */
8891 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
8892 gfc_add_class_array_ref (arg1
->expr
);
8893 /* .... whilst scalars only need the _data component. */
8895 gfc_add_data_component (arg1
->expr
);
8898 /* When arg1 references an allocatable component in a coarray, then call
8899 the caf-library function caf_is_present (). */
8900 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
8901 && arg1
->expr
->value
.function
.isym
8902 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8903 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
8905 gfc_clear_attr (&caf_attr
);
8906 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
8907 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
8908 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
8911 if (arg1
->expr
->rank
== 0)
8913 /* Allocatable scalar. */
8914 arg1se
.want_pointer
= 1;
8915 gfc_conv_expr (&arg1se
, arg1
->expr
);
8920 /* Allocatable array. */
8921 arg1se
.descriptor_only
= 1;
8922 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8923 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8926 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
8927 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
8930 /* Components of pointer array references sometimes come back with a pre block. */
8931 if (arg1se
.pre
.head
)
8932 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8934 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
8938 /* Generate code for the ASSOCIATED intrinsic.
8939 If both POINTER and TARGET are arrays, generate a call to library function
8940 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
8941 In other cases, generate inline code that directly compare the address of
8942 POINTER with the address of TARGET. */
8945 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
8947 gfc_actual_arglist
*arg1
;
8948 gfc_actual_arglist
*arg2
;
8953 tree nonzero_arraylen
;
8957 gfc_init_se (&arg1se
, NULL
);
8958 gfc_init_se (&arg2se
, NULL
);
8959 arg1
= expr
->value
.function
.actual
;
8962 /* Check whether the expression is a scalar or not; we cannot use
8963 arg1->expr->rank as it can be nonzero for proc pointers. */
8964 ss
= gfc_walk_expr (arg1
->expr
);
8965 scalar
= ss
== gfc_ss_terminator
;
8967 gfc_free_ss_chain (ss
);
8971 /* No optional target. */
8974 /* A pointer to a scalar. */
8975 arg1se
.want_pointer
= 1;
8976 gfc_conv_expr (&arg1se
, arg1
->expr
);
8977 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8978 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
8979 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
8981 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8983 tmp2
= gfc_class_data_get (arg1se
.expr
);
8984 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
8985 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
8992 /* A pointer to an array. */
8993 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8994 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8996 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8997 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8998 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
8999 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
9004 /* An optional target. */
9005 if (arg2
->expr
->ts
.type
== BT_CLASS
9006 && arg2
->expr
->expr_type
!= EXPR_FUNCTION
)
9007 gfc_add_data_component (arg2
->expr
);
9011 /* A pointer to a scalar. */
9012 arg1se
.want_pointer
= 1;
9013 gfc_conv_expr (&arg1se
, arg1
->expr
);
9014 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
9015 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
9016 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
9018 if (arg1
->expr
->ts
.type
== BT_CLASS
)
9019 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
9021 arg2se
.want_pointer
= 1;
9022 gfc_conv_expr (&arg2se
, arg2
->expr
);
9023 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
9024 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
9025 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
9027 if (arg2
->expr
->ts
.type
== BT_CLASS
)
9029 arg2se
.expr
= gfc_evaluate_now (arg2se
.expr
, &arg2se
.pre
);
9030 arg2se
.expr
= gfc_class_data_get (arg2se
.expr
);
9032 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
9033 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
9034 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
9035 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
9036 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9037 arg1se
.expr
, arg2se
.expr
);
9038 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9039 arg1se
.expr
, null_pointer_node
);
9040 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9041 logical_type_node
, tmp
, tmp2
);
9045 /* An array pointer of zero length is not associated if target is
9047 arg1se
.descriptor_only
= 1;
9048 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
9049 if (arg1
->expr
->rank
== -1)
9051 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
9052 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9053 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
9056 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
9057 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
9058 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
9059 logical_type_node
, tmp
,
9060 build_int_cst (TREE_TYPE (tmp
), 0));
9062 /* A pointer to an array, call library function _gfor_associated. */
9063 arg1se
.want_pointer
= 1;
9064 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
9065 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
9066 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
9068 arg2se
.want_pointer
= 1;
9069 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
9070 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
9071 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
9072 se
->expr
= build_call_expr_loc (input_location
,
9073 gfor_fndecl_associated
, 2,
9074 arg1se
.expr
, arg2se
.expr
);
9075 se
->expr
= convert (logical_type_node
, se
->expr
);
9076 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9077 logical_type_node
, se
->expr
,
9081 /* If target is present zero character length pointers cannot
9083 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
9085 tmp
= arg1se
.string_length
;
9086 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9087 logical_type_node
, tmp
,
9088 build_zero_cst (TREE_TYPE (tmp
)));
9089 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9090 logical_type_node
, se
->expr
, tmp
);
9094 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9098 /* Generate code for the SAME_TYPE_AS intrinsic.
9099 Generate inline code that directly checks the vindices. */
9102 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
9107 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
9109 gfc_init_se (&se1
, NULL
);
9110 gfc_init_se (&se2
, NULL
);
9112 a
= expr
->value
.function
.actual
->expr
;
9113 b
= expr
->value
.function
.actual
->next
->expr
;
9115 if (UNLIMITED_POLY (a
))
9117 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
9118 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9119 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
9122 if (UNLIMITED_POLY (b
))
9124 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
9125 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9126 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
9129 if (a
->ts
.type
== BT_CLASS
)
9131 gfc_add_vptr_component (a
);
9132 gfc_add_hash_component (a
);
9134 else if (a
->ts
.type
== BT_DERIVED
)
9135 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
9136 a
->ts
.u
.derived
->hash_value
);
9138 if (b
->ts
.type
== BT_CLASS
)
9140 gfc_add_vptr_component (b
);
9141 gfc_add_hash_component (b
);
9143 else if (b
->ts
.type
== BT_DERIVED
)
9144 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
9145 b
->ts
.u
.derived
->hash_value
);
9147 gfc_conv_expr (&se1
, a
);
9148 gfc_conv_expr (&se2
, b
);
9150 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
9151 logical_type_node
, se1
.expr
,
9152 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
9155 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
9156 logical_type_node
, conda
, tmp
);
9159 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
9160 logical_type_node
, condb
, tmp
);
9162 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
9166 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9169 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
9173 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
9174 se
->expr
= build_call_expr_loc (input_location
,
9175 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
9176 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9180 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9183 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
9187 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
9189 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9190 type
= gfc_get_int_type (4);
9191 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
9193 /* Convert it to the required type. */
9194 type
= gfc_typenode_for_spec (&expr
->ts
);
9195 se
->expr
= build_call_expr_loc (input_location
,
9196 gfor_fndecl_si_kind
, 1, arg
);
9197 se
->expr
= fold_convert (type
, se
->expr
);
9201 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9204 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
9206 gfc_actual_arglist
*actual
;
9209 vec
<tree
, va_gc
> *args
= NULL
;
9211 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
9213 gfc_init_se (&argse
, se
);
9215 /* Pass a NULL pointer for an absent arg. */
9216 if (actual
->expr
== NULL
)
9217 argse
.expr
= null_pointer_node
;
9223 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
9225 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9226 ts
.type
= BT_INTEGER
;
9227 ts
.kind
= gfc_c_int_kind
;
9228 gfc_convert_type (actual
->expr
, &ts
, 2);
9230 gfc_conv_expr_reference (&argse
, actual
->expr
);
9233 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
9234 gfc_add_block_to_block (&se
->post
, &argse
.post
);
9235 vec_safe_push (args
, argse
.expr
);
9238 /* Convert it to the required type. */
9239 type
= gfc_typenode_for_spec (&expr
->ts
);
9240 se
->expr
= build_call_expr_loc_vec (input_location
,
9241 gfor_fndecl_sr_kind
, args
);
9242 se
->expr
= fold_convert (type
, se
->expr
);
9246 /* Generate code for TRIM (A) intrinsic function. */
9249 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
9259 unsigned int num_args
;
9261 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
9262 args
= XALLOCAVEC (tree
, num_args
);
9264 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
9265 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
9266 len
= gfc_create_var (gfc_charlen_type_node
, "len");
9268 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
9269 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
9272 if (expr
->ts
.kind
== 1)
9273 function
= gfor_fndecl_string_trim
;
9274 else if (expr
->ts
.kind
== 4)
9275 function
= gfor_fndecl_string_trim_char4
;
9279 fndecl
= build_addr (function
);
9280 tmp
= build_call_array_loc (input_location
,
9281 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
9283 gfc_add_expr_to_block (&se
->pre
, tmp
);
9285 /* Free the temporary afterwards, if necessary. */
9286 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
9287 len
, build_int_cst (TREE_TYPE (len
), 0));
9288 tmp
= gfc_call_free (var
);
9289 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
9290 gfc_add_expr_to_block (&se
->post
, tmp
);
9293 se
->string_length
= len
;
9297 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9300 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
9302 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
9303 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
9305 stmtblock_t block
, body
;
9308 /* We store in charsize the size of a character. */
9309 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
9310 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
9312 /* Get the arguments. */
9313 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
9314 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
9316 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
9317 ncopies_type
= TREE_TYPE (ncopies
);
9319 /* Check that NCOPIES is not negative. */
9320 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
9321 build_int_cst (ncopies_type
, 0));
9322 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
9323 "Argument NCOPIES of REPEAT intrinsic is negative "
9324 "(its value is %ld)",
9325 fold_convert (long_integer_type_node
, ncopies
));
9327 /* If the source length is zero, any non negative value of NCOPIES
9328 is valid, and nothing happens. */
9329 n
= gfc_create_var (ncopies_type
, "ncopies");
9330 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
9332 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
9333 build_int_cst (ncopies_type
, 0), ncopies
);
9334 gfc_add_modify (&se
->pre
, n
, tmp
);
9337 /* Check that ncopies is not too large: ncopies should be less than
9338 (or equal to) MAX / slen, where MAX is the maximal integer of
9339 the gfc_charlen_type_node type. If slen == 0, we need a special
9340 case to avoid the division by zero. */
9341 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
9342 fold_convert (sizetype
,
9343 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
9345 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
9346 ? sizetype
: ncopies_type
;
9347 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
9348 fold_convert (largest
, ncopies
),
9349 fold_convert (largest
, max
));
9350 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
9352 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
9353 logical_false_node
, cond
);
9354 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
9355 "Argument NCOPIES of REPEAT intrinsic is too large");
9357 /* Compute the destination length. */
9358 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
9359 fold_convert (gfc_charlen_type_node
, slen
),
9360 fold_convert (gfc_charlen_type_node
, ncopies
));
9361 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
9362 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
9364 /* Generate the code to do the repeat operation:
9365 for (i = 0; i < ncopies; i++)
9366 memmove (dest + (i * slen * size), src, slen*size); */
9367 gfc_start_block (&block
);
9368 count
= gfc_create_var (sizetype
, "count");
9369 gfc_add_modify (&block
, count
, size_zero_node
);
9370 exit_label
= gfc_build_label_decl (NULL_TREE
);
9372 /* Start the loop body. */
9373 gfc_start_block (&body
);
9375 /* Exit the loop if count >= ncopies. */
9376 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
9377 fold_convert (sizetype
, ncopies
));
9378 tmp
= build1_v (GOTO_EXPR
, exit_label
);
9379 TREE_USED (exit_label
) = 1;
9380 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
9381 build_empty_stmt (input_location
));
9382 gfc_add_expr_to_block (&body
, tmp
);
9384 /* Call memmove (dest + (i*slen*size), src, slen*size). */
9385 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
9387 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
9389 tmp
= fold_build_pointer_plus_loc (input_location
,
9390 fold_convert (pvoid_type_node
, dest
), tmp
);
9391 tmp
= build_call_expr_loc (input_location
,
9392 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
9394 fold_build2_loc (input_location
, MULT_EXPR
,
9395 size_type_node
, slen
, size
));
9396 gfc_add_expr_to_block (&body
, tmp
);
9398 /* Increment count. */
9399 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
9400 count
, size_one_node
);
9401 gfc_add_modify (&body
, count
, tmp
);
9403 /* Build the loop. */
9404 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
9405 gfc_add_expr_to_block (&block
, tmp
);
9407 /* Add the exit label. */
9408 tmp
= build1_v (LABEL_EXPR
, exit_label
);
9409 gfc_add_expr_to_block (&block
, tmp
);
9411 /* Finish the block. */
9412 tmp
= gfc_finish_block (&block
);
9413 gfc_add_expr_to_block (&se
->pre
, tmp
);
9415 /* Set the result value. */
9417 se
->string_length
= dlen
;
9421 /* Generate code for the IARGC intrinsic. */
9424 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
9430 /* Call the library function. This always returns an INTEGER(4). */
9431 fndecl
= gfor_fndecl_iargc
;
9432 tmp
= build_call_expr_loc (input_location
,
9435 /* Convert it to the required type. */
9436 type
= gfc_typenode_for_spec (&expr
->ts
);
9437 tmp
= fold_convert (type
, tmp
);
9443 /* Generate code for the KILL intrinsic. */
9446 conv_intrinsic_kill (gfc_se
*se
, gfc_expr
*expr
)
9449 tree int4_type_node
= gfc_get_int_type (4);
9453 unsigned int num_args
;
9455 num_args
= gfc_intrinsic_argument_list_length (expr
);
9456 args
= XALLOCAVEC (tree
, num_args
);
9457 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
9459 /* Convert PID to a INTEGER(4) entity. */
9460 pid
= convert (int4_type_node
, args
[0]);
9462 /* Convert SIG to a INTEGER(4) entity. */
9463 sig
= convert (int4_type_node
, args
[1]);
9465 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill
, 2, pid
, sig
);
9467 se
->expr
= fold_convert (TREE_TYPE (args
[0]), tmp
);
9472 conv_intrinsic_kill_sub (gfc_code
*code
)
9476 tree int4_type_node
= gfc_get_int_type (4);
9482 /* Make the function call. */
9483 gfc_init_block (&block
);
9484 gfc_init_se (&se
, NULL
);
9486 /* Convert PID to a INTEGER(4) entity. */
9487 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
9488 gfc_add_block_to_block (&block
, &se
.pre
);
9489 pid
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
9490 gfc_add_block_to_block (&block
, &se
.post
);
9492 /* Convert SIG to a INTEGER(4) entity. */
9493 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
9494 gfc_add_block_to_block (&block
, &se
.pre
);
9495 sig
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
9496 gfc_add_block_to_block (&block
, &se
.post
);
9498 /* Deal with an optional STATUS. */
9499 if (code
->ext
.actual
->next
->next
->expr
)
9501 gfc_init_se (&se_stat
, NULL
);
9502 gfc_conv_expr (&se_stat
, code
->ext
.actual
->next
->next
->expr
);
9503 statp
= gfc_create_var (gfc_get_int_type (4), "_statp");
9508 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill_sub
, 3, pid
, sig
,
9509 statp
? gfc_build_addr_expr (NULL_TREE
, statp
) : null_pointer_node
);
9511 gfc_add_expr_to_block (&block
, tmp
);
9513 if (statp
&& statp
!= se_stat
.expr
)
9514 gfc_add_modify (&block
, se_stat
.expr
,
9515 fold_convert (TREE_TYPE (se_stat
.expr
), statp
));
9517 return gfc_finish_block (&block
);
9522 /* The loc intrinsic returns the address of its argument as
9523 gfc_index_integer_kind integer. */
9526 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
9531 gcc_assert (!se
->ss
);
9533 arg_expr
= expr
->value
.function
.actual
->expr
;
9534 if (arg_expr
->rank
== 0)
9536 if (arg_expr
->ts
.type
== BT_CLASS
)
9537 gfc_add_data_component (arg_expr
);
9538 gfc_conv_expr_reference (se
, arg_expr
);
9541 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
9542 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
9544 /* Create a temporary variable for loc return value. Without this,
9545 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
9546 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
9547 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
9548 se
->expr
= temp_var
;
9552 /* The following routine generates code for the intrinsic
9553 functions from the ISO_C_BINDING module:
9559 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
9561 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
9563 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
9565 if (arg
->expr
->rank
== 0)
9566 gfc_conv_expr_reference (se
, arg
->expr
);
9567 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
9568 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
9571 gfc_conv_expr_descriptor (se
, arg
->expr
);
9572 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
9575 /* TODO -- the following two lines shouldn't be necessary, but if
9576 they're removed, a bug is exposed later in the code path.
9577 This workaround was thus introduced, but will have to be
9578 removed; please see PR 35150 for details about the issue. */
9579 se
->expr
= convert (pvoid_type_node
, se
->expr
);
9580 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
9582 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
9583 gfc_conv_expr_reference (se
, arg
->expr
);
9584 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
9589 /* Build the addr_expr for the first argument. The argument is
9590 already an *address* so we don't need to set want_pointer in
9592 gfc_init_se (&arg1se
, NULL
);
9593 gfc_conv_expr (&arg1se
, arg
->expr
);
9594 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
9595 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
9597 /* See if we were given two arguments. */
9598 if (arg
->next
->expr
== NULL
)
9599 /* Only given one arg so generate a null and do a
9600 not-equal comparison against the first arg. */
9601 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9603 fold_convert (TREE_TYPE (arg1se
.expr
),
9604 null_pointer_node
));
9610 /* Given two arguments so build the arg2se from second arg. */
9611 gfc_init_se (&arg2se
, NULL
);
9612 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
9613 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
9614 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
9616 /* Generate test to compare that the two args are equal. */
9617 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9618 arg1se
.expr
, arg2se
.expr
);
9619 /* Generate test to ensure that the first arg is not null. */
9620 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
9622 arg1se
.expr
, null_pointer_node
);
9624 /* Finally, the generated test must check that both arg1 is not
9625 NULL and that it is equal to the second arg. */
9626 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9628 not_null_expr
, eq_expr
);
9636 /* The following routine generates code for the intrinsic
9637 subroutines from the ISO_C_BINDING module:
9639 * C_F_PROCPOINTER. */
9642 conv_isocbinding_subroutine (gfc_code
*code
)
9649 tree desc
, dim
, tmp
, stride
, offset
;
9650 stmtblock_t body
, block
;
9652 gfc_actual_arglist
*arg
= code
->ext
.actual
;
9654 gfc_init_se (&se
, NULL
);
9655 gfc_init_se (&cptrse
, NULL
);
9656 gfc_conv_expr (&cptrse
, arg
->expr
);
9657 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
9658 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
9660 gfc_init_se (&fptrse
, NULL
);
9661 if (arg
->next
->expr
->rank
== 0)
9663 fptrse
.want_pointer
= 1;
9664 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
9665 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
9666 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
9667 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
9668 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
9669 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
9671 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
9672 TREE_TYPE (fptrse
.expr
),
9674 fold_convert (TREE_TYPE (fptrse
.expr
),
9676 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
9677 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9678 return gfc_finish_block (&se
.pre
);
9681 gfc_start_block (&block
);
9683 /* Get the descriptor of the Fortran pointer. */
9684 fptrse
.descriptor_only
= 1;
9685 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
9686 gfc_add_block_to_block (&block
, &fptrse
.pre
);
9689 /* Set the span field. */
9690 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
9691 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9692 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
9694 /* Set data value, dtype, and offset. */
9695 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
9696 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
9697 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
9698 gfc_get_dtype (TREE_TYPE (desc
)));
9700 /* Start scalarization of the bounds, using the shape argument. */
9702 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
9703 gcc_assert (shape_ss
!= gfc_ss_terminator
);
9704 gfc_init_se (&shapese
, NULL
);
9706 gfc_init_loopinfo (&loop
);
9707 gfc_add_ss_to_loop (&loop
, shape_ss
);
9708 gfc_conv_ss_startstride (&loop
);
9709 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
9710 gfc_mark_ss_chain_used (shape_ss
, 1);
9712 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
9713 shapese
.ss
= shape_ss
;
9715 stride
= gfc_create_var (gfc_array_index_type
, "stride");
9716 offset
= gfc_create_var (gfc_array_index_type
, "offset");
9717 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
9718 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
9721 gfc_start_scalarized_body (&loop
, &body
);
9723 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
9724 loop
.loopvar
[0], loop
.from
[0]);
9726 /* Set bounds and stride. */
9727 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
9728 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
9730 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
9731 gfc_add_block_to_block (&body
, &shapese
.pre
);
9732 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
9733 gfc_add_block_to_block (&body
, &shapese
.post
);
9735 /* Calculate offset. */
9736 gfc_add_modify (&body
, offset
,
9737 fold_build2_loc (input_location
, PLUS_EXPR
,
9738 gfc_array_index_type
, offset
, stride
));
9739 /* Update stride. */
9740 gfc_add_modify (&body
, stride
,
9741 fold_build2_loc (input_location
, MULT_EXPR
,
9742 gfc_array_index_type
, stride
,
9743 fold_convert (gfc_array_index_type
,
9745 /* Finish scalarization loop. */
9746 gfc_trans_scalarizing_loops (&loop
, &body
);
9747 gfc_add_block_to_block (&block
, &loop
.pre
);
9748 gfc_add_block_to_block (&block
, &loop
.post
);
9749 gfc_add_block_to_block (&block
, &fptrse
.post
);
9750 gfc_cleanup_loop (&loop
);
9752 gfc_add_modify (&block
, offset
,
9753 fold_build1_loc (input_location
, NEGATE_EXPR
,
9754 gfc_array_index_type
, offset
));
9755 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
9757 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
9758 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9759 return gfc_finish_block (&se
.pre
);
9763 /* Save and restore floating-point state. */
9766 gfc_save_fp_state (stmtblock_t
*block
)
9768 tree type
, fpstate
, tmp
;
9770 type
= build_array_type (char_type_node
,
9771 build_range_type (size_type_node
, size_zero_node
,
9772 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
9773 fpstate
= gfc_create_var (type
, "fpstate");
9774 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
9776 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
9778 gfc_add_expr_to_block (block
, tmp
);
9785 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
9789 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
9791 gfc_add_expr_to_block (block
, tmp
);
9795 /* Generate code for arguments of IEEE functions. */
9798 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
9801 gfc_actual_arglist
*actual
;
9806 actual
= expr
->value
.function
.actual
;
9807 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
9809 gcc_assert (actual
);
9812 gfc_init_se (&argse
, se
);
9813 gfc_conv_expr_val (&argse
, e
);
9815 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
9816 gfc_add_block_to_block (&se
->post
, &argse
.post
);
9817 argarray
[arg
] = argse
.expr
;
9822 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
9823 and IEEE_UNORDERED, which translate directly to GCC type-generic
9827 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
9828 enum built_in_function code
, int nargs
)
9831 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
9833 conv_ieee_function_args (se
, expr
, args
, nargs
);
9834 se
->expr
= build_call_expr_loc_array (input_location
,
9835 builtin_decl_explicit (code
),
9837 STRIP_TYPE_NOPS (se
->expr
);
9838 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9842 /* Generate code for IEEE_IS_NORMAL intrinsic:
9843 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
9846 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
9848 tree arg
, isnormal
, iszero
;
9850 /* Convert arg, evaluate it only once. */
9851 conv_ieee_function_args (se
, expr
, &arg
, 1);
9852 arg
= gfc_evaluate_now (arg
, &se
->pre
);
9854 isnormal
= build_call_expr_loc (input_location
,
9855 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
9857 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
9858 build_real_from_int_cst (TREE_TYPE (arg
),
9859 integer_zero_node
));
9860 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9861 logical_type_node
, isnormal
, iszero
);
9862 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9866 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
9867 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
9870 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
9872 tree arg
, signbit
, isnan
;
9874 /* Convert arg, evaluate it only once. */
9875 conv_ieee_function_args (se
, expr
, &arg
, 1);
9876 arg
= gfc_evaluate_now (arg
, &se
->pre
);
9878 isnan
= build_call_expr_loc (input_location
,
9879 builtin_decl_explicit (BUILT_IN_ISNAN
),
9881 STRIP_TYPE_NOPS (isnan
);
9883 signbit
= build_call_expr_loc (input_location
,
9884 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
9886 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9887 signbit
, integer_zero_node
);
9889 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
9890 logical_type_node
, signbit
,
9891 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
9892 TREE_TYPE(isnan
), isnan
));
9894 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
9898 /* Generate code for IEEE_LOGB and IEEE_RINT. */
9901 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
9902 enum built_in_function code
)
9904 tree arg
, decl
, call
, fpstate
;
9907 conv_ieee_function_args (se
, expr
, &arg
, 1);
9908 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
9909 decl
= builtin_decl_for_precision (code
, argprec
);
9911 /* Save floating-point state. */
9912 fpstate
= gfc_save_fp_state (&se
->pre
);
9914 /* Make the function call. */
9915 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
9916 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
9918 /* Restore floating-point state. */
9919 gfc_restore_fp_state (&se
->post
, fpstate
);
9923 /* Generate code for IEEE_REM. */
9926 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
9928 tree args
[2], decl
, call
, fpstate
;
9931 conv_ieee_function_args (se
, expr
, args
, 2);
9933 /* If arguments have unequal size, convert them to the larger. */
9934 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
9935 > TYPE_PRECISION (TREE_TYPE (args
[1])))
9936 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
9937 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
9938 > TYPE_PRECISION (TREE_TYPE (args
[0])))
9939 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
9941 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9942 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
9944 /* Save floating-point state. */
9945 fpstate
= gfc_save_fp_state (&se
->pre
);
9947 /* Make the function call. */
9948 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9949 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9951 /* Restore floating-point state. */
9952 gfc_restore_fp_state (&se
->post
, fpstate
);
9956 /* Generate code for IEEE_NEXT_AFTER. */
9959 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
9961 tree args
[2], decl
, call
, fpstate
;
9964 conv_ieee_function_args (se
, expr
, args
, 2);
9966 /* Result has the characteristics of first argument. */
9967 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
9968 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9969 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
9971 /* Save floating-point state. */
9972 fpstate
= gfc_save_fp_state (&se
->pre
);
9974 /* Make the function call. */
9975 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9976 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9978 /* Restore floating-point state. */
9979 gfc_restore_fp_state (&se
->post
, fpstate
);
9983 /* Generate code for IEEE_SCALB. */
9986 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
9988 tree args
[2], decl
, call
, huge
, type
;
9991 conv_ieee_function_args (se
, expr
, args
, 2);
9993 /* Result has the characteristics of first argument. */
9994 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9995 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
9997 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
9999 /* We need to fold the integer into the range of a C int. */
10000 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
10001 type
= TREE_TYPE (args
[1]);
10003 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
10004 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
10006 huge
= fold_convert (type
, huge
);
10007 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
10009 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
10010 fold_build1_loc (input_location
, NEGATE_EXPR
,
10014 args
[1] = fold_convert (integer_type_node
, args
[1]);
10016 /* Make the function call. */
10017 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
10018 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
10022 /* Generate code for IEEE_COPY_SIGN. */
10025 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
10027 tree args
[2], decl
, sign
;
10030 conv_ieee_function_args (se
, expr
, args
, 2);
10032 /* Get the sign of the second argument. */
10033 sign
= build_call_expr_loc (input_location
,
10034 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
10036 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10037 sign
, integer_zero_node
);
10039 /* Create a value of one, with the right sign. */
10040 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
10042 fold_build1_loc (input_location
, NEGATE_EXPR
,
10046 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
10048 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
10049 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
10051 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
10055 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
10059 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
10061 const char *name
= expr
->value
.function
.name
;
10063 if (gfc_str_startswith (name
, "_gfortran_ieee_is_nan"))
10064 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
10065 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_finite"))
10066 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
10067 else if (gfc_str_startswith (name
, "_gfortran_ieee_unordered"))
10068 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
10069 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_normal"))
10070 conv_intrinsic_ieee_is_normal (se
, expr
);
10071 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_negative"))
10072 conv_intrinsic_ieee_is_negative (se
, expr
);
10073 else if (gfc_str_startswith (name
, "_gfortran_ieee_copy_sign"))
10074 conv_intrinsic_ieee_copy_sign (se
, expr
);
10075 else if (gfc_str_startswith (name
, "_gfortran_ieee_scalb"))
10076 conv_intrinsic_ieee_scalb (se
, expr
);
10077 else if (gfc_str_startswith (name
, "_gfortran_ieee_next_after"))
10078 conv_intrinsic_ieee_next_after (se
, expr
);
10079 else if (gfc_str_startswith (name
, "_gfortran_ieee_rem"))
10080 conv_intrinsic_ieee_rem (se
, expr
);
10081 else if (gfc_str_startswith (name
, "_gfortran_ieee_logb"))
10082 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
10083 else if (gfc_str_startswith (name
, "_gfortran_ieee_rint"))
10084 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
10086 /* It is not among the functions we translate directly. We return
10087 false, so a library function call is emitted. */
10094 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
10097 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
10099 tree arg
, res
, restype
;
10101 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
10102 arg
= fold_convert (size_type_node
, arg
);
10103 res
= build_call_expr_loc (input_location
,
10104 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
10105 restype
= gfc_typenode_for_spec (&expr
->ts
);
10106 se
->expr
= fold_convert (restype
, res
);
10110 /* Generate code for an intrinsic function. Some map directly to library
10111 calls, others get special handling. In some cases the name of the function
10112 used depends on the type specifiers. */
10115 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
10121 name
= &expr
->value
.function
.name
[2];
10123 if (expr
->rank
> 0)
10125 lib
= gfc_is_intrinsic_libcall (expr
);
10129 se
->ignore_optional
= 1;
10131 switch (expr
->value
.function
.isym
->id
)
10133 case GFC_ISYM_EOSHIFT
:
10134 case GFC_ISYM_PACK
:
10135 case GFC_ISYM_RESHAPE
:
10136 /* For all of those the first argument specifies the type and the
10137 third is optional. */
10138 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
10141 case GFC_ISYM_FINDLOC
:
10142 gfc_conv_intrinsic_findloc (se
, expr
);
10145 case GFC_ISYM_MINLOC
:
10146 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
10149 case GFC_ISYM_MAXLOC
:
10150 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
10153 case GFC_ISYM_SHAPE
:
10154 gfc_conv_intrinsic_shape (se
, expr
);
10158 gfc_conv_intrinsic_funcall (se
, expr
);
10166 switch (expr
->value
.function
.isym
->id
)
10168 case GFC_ISYM_NONE
:
10169 gcc_unreachable ();
10171 case GFC_ISYM_REPEAT
:
10172 gfc_conv_intrinsic_repeat (se
, expr
);
10175 case GFC_ISYM_TRIM
:
10176 gfc_conv_intrinsic_trim (se
, expr
);
10179 case GFC_ISYM_SC_KIND
:
10180 gfc_conv_intrinsic_sc_kind (se
, expr
);
10183 case GFC_ISYM_SI_KIND
:
10184 gfc_conv_intrinsic_si_kind (se
, expr
);
10187 case GFC_ISYM_SR_KIND
:
10188 gfc_conv_intrinsic_sr_kind (se
, expr
);
10191 case GFC_ISYM_EXPONENT
:
10192 gfc_conv_intrinsic_exponent (se
, expr
);
10195 case GFC_ISYM_SCAN
:
10196 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10198 fndecl
= gfor_fndecl_string_scan
;
10199 else if (kind
== 4)
10200 fndecl
= gfor_fndecl_string_scan_char4
;
10202 gcc_unreachable ();
10204 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10207 case GFC_ISYM_VERIFY
:
10208 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10210 fndecl
= gfor_fndecl_string_verify
;
10211 else if (kind
== 4)
10212 fndecl
= gfor_fndecl_string_verify_char4
;
10214 gcc_unreachable ();
10216 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10219 case GFC_ISYM_ALLOCATED
:
10220 gfc_conv_allocated (se
, expr
);
10223 case GFC_ISYM_ASSOCIATED
:
10224 gfc_conv_associated(se
, expr
);
10227 case GFC_ISYM_SAME_TYPE_AS
:
10228 gfc_conv_same_type_as (se
, expr
);
10232 gfc_conv_intrinsic_abs (se
, expr
);
10235 case GFC_ISYM_ADJUSTL
:
10236 if (expr
->ts
.kind
== 1)
10237 fndecl
= gfor_fndecl_adjustl
;
10238 else if (expr
->ts
.kind
== 4)
10239 fndecl
= gfor_fndecl_adjustl_char4
;
10241 gcc_unreachable ();
10243 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
10246 case GFC_ISYM_ADJUSTR
:
10247 if (expr
->ts
.kind
== 1)
10248 fndecl
= gfor_fndecl_adjustr
;
10249 else if (expr
->ts
.kind
== 4)
10250 fndecl
= gfor_fndecl_adjustr_char4
;
10252 gcc_unreachable ();
10254 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
10257 case GFC_ISYM_AIMAG
:
10258 gfc_conv_intrinsic_imagpart (se
, expr
);
10261 case GFC_ISYM_AINT
:
10262 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
10266 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
10269 case GFC_ISYM_ANINT
:
10270 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
10274 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
10278 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
10281 case GFC_ISYM_ACOSD
:
10282 case GFC_ISYM_ASIND
:
10283 case GFC_ISYM_ATAND
:
10284 gfc_conv_intrinsic_atrigd (se
, expr
, expr
->value
.function
.isym
->id
);
10287 case GFC_ISYM_COTAN
:
10288 gfc_conv_intrinsic_cotan (se
, expr
);
10291 case GFC_ISYM_COTAND
:
10292 gfc_conv_intrinsic_cotand (se
, expr
);
10295 case GFC_ISYM_ATAN2D
:
10296 gfc_conv_intrinsic_atan2d (se
, expr
);
10299 case GFC_ISYM_BTEST
:
10300 gfc_conv_intrinsic_btest (se
, expr
);
10304 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
10308 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
10312 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
10316 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
10319 case GFC_ISYM_C_ASSOCIATED
:
10320 case GFC_ISYM_C_FUNLOC
:
10321 case GFC_ISYM_C_LOC
:
10322 conv_isocbinding_function (se
, expr
);
10325 case GFC_ISYM_ACHAR
:
10326 case GFC_ISYM_CHAR
:
10327 gfc_conv_intrinsic_char (se
, expr
);
10330 case GFC_ISYM_CONVERSION
:
10331 case GFC_ISYM_DBLE
:
10332 case GFC_ISYM_DFLOAT
:
10333 case GFC_ISYM_FLOAT
:
10334 case GFC_ISYM_LOGICAL
:
10335 case GFC_ISYM_REAL
:
10336 case GFC_ISYM_REALPART
:
10337 case GFC_ISYM_SNGL
:
10338 gfc_conv_intrinsic_conversion (se
, expr
);
10341 /* Integer conversions are handled separately to make sure we get the
10342 correct rounding mode. */
10344 case GFC_ISYM_INT2
:
10345 case GFC_ISYM_INT8
:
10346 case GFC_ISYM_LONG
:
10347 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
10350 case GFC_ISYM_NINT
:
10351 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
10354 case GFC_ISYM_CEILING
:
10355 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
10358 case GFC_ISYM_FLOOR
:
10359 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
10363 gfc_conv_intrinsic_mod (se
, expr
, 0);
10366 case GFC_ISYM_MODULO
:
10367 gfc_conv_intrinsic_mod (se
, expr
, 1);
10370 case GFC_ISYM_CAF_GET
:
10371 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10375 case GFC_ISYM_CMPLX
:
10376 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
10379 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
10380 gfc_conv_intrinsic_iargc (se
, expr
);
10383 case GFC_ISYM_COMPLEX
:
10384 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
10387 case GFC_ISYM_CONJG
:
10388 gfc_conv_intrinsic_conjg (se
, expr
);
10391 case GFC_ISYM_COUNT
:
10392 gfc_conv_intrinsic_count (se
, expr
);
10395 case GFC_ISYM_CTIME
:
10396 gfc_conv_intrinsic_ctime (se
, expr
);
10400 gfc_conv_intrinsic_dim (se
, expr
);
10403 case GFC_ISYM_DOT_PRODUCT
:
10404 gfc_conv_intrinsic_dot_product (se
, expr
);
10407 case GFC_ISYM_DPROD
:
10408 gfc_conv_intrinsic_dprod (se
, expr
);
10411 case GFC_ISYM_DSHIFTL
:
10412 gfc_conv_intrinsic_dshift (se
, expr
, true);
10415 case GFC_ISYM_DSHIFTR
:
10416 gfc_conv_intrinsic_dshift (se
, expr
, false);
10419 case GFC_ISYM_FDATE
:
10420 gfc_conv_intrinsic_fdate (se
, expr
);
10423 case GFC_ISYM_FRACTION
:
10424 gfc_conv_intrinsic_fraction (se
, expr
);
10427 case GFC_ISYM_IALL
:
10428 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
10431 case GFC_ISYM_IAND
:
10432 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
10435 case GFC_ISYM_IANY
:
10436 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
10439 case GFC_ISYM_IBCLR
:
10440 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
10443 case GFC_ISYM_IBITS
:
10444 gfc_conv_intrinsic_ibits (se
, expr
);
10447 case GFC_ISYM_IBSET
:
10448 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
10451 case GFC_ISYM_IACHAR
:
10452 case GFC_ISYM_ICHAR
:
10453 /* We assume ASCII character sequence. */
10454 gfc_conv_intrinsic_ichar (se
, expr
);
10457 case GFC_ISYM_IARGC
:
10458 gfc_conv_intrinsic_iargc (se
, expr
);
10461 case GFC_ISYM_IEOR
:
10462 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
10465 case GFC_ISYM_INDEX
:
10466 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
10468 fndecl
= gfor_fndecl_string_index
;
10469 else if (kind
== 4)
10470 fndecl
= gfor_fndecl_string_index_char4
;
10472 gcc_unreachable ();
10474 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
10478 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
10481 case GFC_ISYM_IPARITY
:
10482 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
10485 case GFC_ISYM_IS_IOSTAT_END
:
10486 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
10489 case GFC_ISYM_IS_IOSTAT_EOR
:
10490 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
10493 case GFC_ISYM_IS_CONTIGUOUS
:
10494 gfc_conv_intrinsic_is_contiguous (se
, expr
);
10497 case GFC_ISYM_ISNAN
:
10498 gfc_conv_intrinsic_isnan (se
, expr
);
10501 case GFC_ISYM_KILL
:
10502 conv_intrinsic_kill (se
, expr
);
10505 case GFC_ISYM_LSHIFT
:
10506 gfc_conv_intrinsic_shift (se
, expr
, false, false);
10509 case GFC_ISYM_RSHIFT
:
10510 gfc_conv_intrinsic_shift (se
, expr
, true, true);
10513 case GFC_ISYM_SHIFTA
:
10514 gfc_conv_intrinsic_shift (se
, expr
, true, true);
10517 case GFC_ISYM_SHIFTL
:
10518 gfc_conv_intrinsic_shift (se
, expr
, false, false);
10521 case GFC_ISYM_SHIFTR
:
10522 gfc_conv_intrinsic_shift (se
, expr
, true, false);
10525 case GFC_ISYM_ISHFT
:
10526 gfc_conv_intrinsic_ishft (se
, expr
);
10529 case GFC_ISYM_ISHFTC
:
10530 gfc_conv_intrinsic_ishftc (se
, expr
);
10533 case GFC_ISYM_LEADZ
:
10534 gfc_conv_intrinsic_leadz (se
, expr
);
10537 case GFC_ISYM_TRAILZ
:
10538 gfc_conv_intrinsic_trailz (se
, expr
);
10541 case GFC_ISYM_POPCNT
:
10542 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
10545 case GFC_ISYM_POPPAR
:
10546 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
10549 case GFC_ISYM_LBOUND
:
10550 gfc_conv_intrinsic_bound (se
, expr
, 0);
10553 case GFC_ISYM_LCOBOUND
:
10554 conv_intrinsic_cobound (se
, expr
);
10557 case GFC_ISYM_TRANSPOSE
:
10558 /* The scalarizer has already been set up for reversed dimension access
10559 order ; now we just get the argument value normally. */
10560 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
10564 gfc_conv_intrinsic_len (se
, expr
);
10567 case GFC_ISYM_LEN_TRIM
:
10568 gfc_conv_intrinsic_len_trim (se
, expr
);
10572 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
10576 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
10580 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
10584 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
10587 case GFC_ISYM_MALLOC
:
10588 gfc_conv_intrinsic_malloc (se
, expr
);
10591 case GFC_ISYM_MASKL
:
10592 gfc_conv_intrinsic_mask (se
, expr
, 1);
10595 case GFC_ISYM_MASKR
:
10596 gfc_conv_intrinsic_mask (se
, expr
, 0);
10600 if (expr
->ts
.type
== BT_CHARACTER
)
10601 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
10603 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
10606 case GFC_ISYM_MAXLOC
:
10607 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
10610 case GFC_ISYM_FINDLOC
:
10611 gfc_conv_intrinsic_findloc (se
, expr
);
10614 case GFC_ISYM_MAXVAL
:
10615 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
10618 case GFC_ISYM_MERGE
:
10619 gfc_conv_intrinsic_merge (se
, expr
);
10622 case GFC_ISYM_MERGE_BITS
:
10623 gfc_conv_intrinsic_merge_bits (se
, expr
);
10627 if (expr
->ts
.type
== BT_CHARACTER
)
10628 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
10630 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
10633 case GFC_ISYM_MINLOC
:
10634 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
10637 case GFC_ISYM_MINVAL
:
10638 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
10641 case GFC_ISYM_NEAREST
:
10642 gfc_conv_intrinsic_nearest (se
, expr
);
10645 case GFC_ISYM_NORM2
:
10646 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
10650 gfc_conv_intrinsic_not (se
, expr
);
10654 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
10657 case GFC_ISYM_PARITY
:
10658 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
10661 case GFC_ISYM_PRESENT
:
10662 gfc_conv_intrinsic_present (se
, expr
);
10665 case GFC_ISYM_PRODUCT
:
10666 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
10669 case GFC_ISYM_RANK
:
10670 gfc_conv_intrinsic_rank (se
, expr
);
10673 case GFC_ISYM_RRSPACING
:
10674 gfc_conv_intrinsic_rrspacing (se
, expr
);
10677 case GFC_ISYM_SET_EXPONENT
:
10678 gfc_conv_intrinsic_set_exponent (se
, expr
);
10681 case GFC_ISYM_SCALE
:
10682 gfc_conv_intrinsic_scale (se
, expr
);
10685 case GFC_ISYM_SIGN
:
10686 gfc_conv_intrinsic_sign (se
, expr
);
10689 case GFC_ISYM_SIZE
:
10690 gfc_conv_intrinsic_size (se
, expr
);
10693 case GFC_ISYM_SIZEOF
:
10694 case GFC_ISYM_C_SIZEOF
:
10695 gfc_conv_intrinsic_sizeof (se
, expr
);
10698 case GFC_ISYM_STORAGE_SIZE
:
10699 gfc_conv_intrinsic_storage_size (se
, expr
);
10702 case GFC_ISYM_SPACING
:
10703 gfc_conv_intrinsic_spacing (se
, expr
);
10706 case GFC_ISYM_STRIDE
:
10707 conv_intrinsic_stride (se
, expr
);
10711 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
10714 case GFC_ISYM_TEAM_NUMBER
:
10715 conv_intrinsic_team_number (se
, expr
);
10718 case GFC_ISYM_TRANSFER
:
10719 if (se
->ss
&& se
->ss
->info
->useflags
)
10720 /* Access the previously obtained result. */
10721 gfc_conv_tmp_array_ref (se
);
10723 gfc_conv_intrinsic_transfer (se
, expr
);
10726 case GFC_ISYM_TTYNAM
:
10727 gfc_conv_intrinsic_ttynam (se
, expr
);
10730 case GFC_ISYM_UBOUND
:
10731 gfc_conv_intrinsic_bound (se
, expr
, 1);
10734 case GFC_ISYM_UCOBOUND
:
10735 conv_intrinsic_cobound (se
, expr
);
10739 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
10743 gfc_conv_intrinsic_loc (se
, expr
);
10746 case GFC_ISYM_THIS_IMAGE
:
10747 /* For num_images() == 1, handle as LCOBOUND. */
10748 if (expr
->value
.function
.actual
->expr
10749 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
10750 conv_intrinsic_cobound (se
, expr
);
10752 trans_this_image (se
, expr
);
10755 case GFC_ISYM_IMAGE_INDEX
:
10756 trans_image_index (se
, expr
);
10759 case GFC_ISYM_IMAGE_STATUS
:
10760 conv_intrinsic_image_status (se
, expr
);
10763 case GFC_ISYM_NUM_IMAGES
:
10764 trans_num_images (se
, expr
);
10767 case GFC_ISYM_ACCESS
:
10768 case GFC_ISYM_CHDIR
:
10769 case GFC_ISYM_CHMOD
:
10770 case GFC_ISYM_DTIME
:
10771 case GFC_ISYM_ETIME
:
10772 case GFC_ISYM_EXTENDS_TYPE_OF
:
10773 case GFC_ISYM_FGET
:
10774 case GFC_ISYM_FGETC
:
10775 case GFC_ISYM_FNUM
:
10776 case GFC_ISYM_FPUT
:
10777 case GFC_ISYM_FPUTC
:
10778 case GFC_ISYM_FSTAT
:
10779 case GFC_ISYM_FTELL
:
10780 case GFC_ISYM_GETCWD
:
10781 case GFC_ISYM_GETGID
:
10782 case GFC_ISYM_GETPID
:
10783 case GFC_ISYM_GETUID
:
10784 case GFC_ISYM_HOSTNM
:
10785 case GFC_ISYM_IERRNO
:
10786 case GFC_ISYM_IRAND
:
10787 case GFC_ISYM_ISATTY
:
10789 case GFC_ISYM_LINK
:
10790 case GFC_ISYM_LSTAT
:
10791 case GFC_ISYM_MATMUL
:
10792 case GFC_ISYM_MCLOCK
:
10793 case GFC_ISYM_MCLOCK8
:
10794 case GFC_ISYM_RAND
:
10795 case GFC_ISYM_RENAME
:
10796 case GFC_ISYM_SECOND
:
10797 case GFC_ISYM_SECNDS
:
10798 case GFC_ISYM_SIGNAL
:
10799 case GFC_ISYM_STAT
:
10800 case GFC_ISYM_SYMLNK
:
10801 case GFC_ISYM_SYSTEM
:
10802 case GFC_ISYM_TIME
:
10803 case GFC_ISYM_TIME8
:
10804 case GFC_ISYM_UMASK
:
10805 case GFC_ISYM_UNLINK
:
10807 gfc_conv_intrinsic_funcall (se
, expr
);
10810 case GFC_ISYM_EOSHIFT
:
10811 case GFC_ISYM_PACK
:
10812 case GFC_ISYM_RESHAPE
:
10813 /* For those, expr->rank should always be >0 and thus the if above the
10814 switch should have matched. */
10815 gcc_unreachable ();
10819 gfc_conv_intrinsic_lib_function (se
, expr
);
10826 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
10828 gfc_ss
*arg_ss
, *tmp_ss
;
10829 gfc_actual_arglist
*arg
;
10831 arg
= expr
->value
.function
.actual
;
10833 gcc_assert (arg
->expr
);
10835 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
10836 gcc_assert (arg_ss
!= gfc_ss_terminator
);
10838 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
10840 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
10841 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
10843 gcc_assert (tmp_ss
->dimen
== 2);
10845 /* We just invert dimensions. */
10846 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
10849 /* Stop when tmp_ss points to the last valid element of the chain... */
10850 if (tmp_ss
->next
== gfc_ss_terminator
)
10854 /* ... so that we can attach the rest of the chain to it. */
10861 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
10862 This has the side effect of reversing the nested list, so there is no
10863 need to call gfc_reverse_ss on it (the given list is assumed not to be
10867 nest_loop_dimension (gfc_ss
*ss
, int dim
)
10870 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
10871 gfc_loopinfo
*new_loop
;
10873 gcc_assert (ss
!= gfc_ss_terminator
);
10875 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
10877 new_ss
= gfc_get_ss ();
10878 new_ss
->next
= prev_ss
;
10879 new_ss
->parent
= ss
;
10880 new_ss
->info
= ss
->info
;
10881 new_ss
->info
->refcount
++;
10882 if (ss
->dimen
!= 0)
10884 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
10885 && ss
->info
->type
!= GFC_SS_REFERENCE
);
10888 new_ss
->dim
[0] = ss
->dim
[dim
];
10890 gcc_assert (dim
< ss
->dimen
);
10892 ss_dim
= --ss
->dimen
;
10893 for (i
= dim
; i
< ss_dim
; i
++)
10894 ss
->dim
[i
] = ss
->dim
[i
+ 1];
10896 ss
->dim
[ss_dim
] = 0;
10902 ss
->nested_ss
->parent
= new_ss
;
10903 new_ss
->nested_ss
= ss
->nested_ss
;
10905 ss
->nested_ss
= new_ss
;
10908 new_loop
= gfc_get_loopinfo ();
10909 gfc_init_loopinfo (new_loop
);
10911 gcc_assert (prev_ss
!= NULL
);
10912 gcc_assert (prev_ss
!= gfc_ss_terminator
);
10913 gfc_add_ss_to_loop (new_loop
, prev_ss
);
10914 return new_ss
->parent
;
10918 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
10919 is to be inlined. */
10922 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
10924 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
10925 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
10927 bool scalar_mask
= false;
10929 /* The rank of the result will be determined later. */
10930 arg1
= expr
->value
.function
.actual
;
10933 gcc_assert (arg3
!= NULL
);
10935 if (expr
->rank
== 0)
10938 tmp_ss
= gfc_ss_terminator
;
10944 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
10945 if (mask_ss
== tmp_ss
)
10951 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
10952 gcc_assert (array_ss
!= tmp_ss
);
10954 /* Odd thing: If the mask is scalar, it is used by the frontend after
10955 the array (to make an if around the nested loop). Thus it shall
10956 be after array_ss once the gfc_ss list is reversed. */
10958 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
10962 /* "Hide" the dimension on which we will sum in the first arg's scalarization
10964 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
10965 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
10973 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
10976 switch (expr
->value
.function
.isym
->id
)
10978 case GFC_ISYM_PRODUCT
:
10980 return walk_inline_intrinsic_arith (ss
, expr
);
10982 case GFC_ISYM_TRANSPOSE
:
10983 return walk_inline_intrinsic_transpose (ss
, expr
);
10986 gcc_unreachable ();
10988 gcc_unreachable ();
10992 /* This generates code to execute before entering the scalarization loop.
10993 Currently does nothing. */
10996 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
10998 switch (ss
->info
->expr
->value
.function
.isym
->id
)
11000 case GFC_ISYM_UBOUND
:
11001 case GFC_ISYM_LBOUND
:
11002 case GFC_ISYM_UCOBOUND
:
11003 case GFC_ISYM_LCOBOUND
:
11004 case GFC_ISYM_THIS_IMAGE
:
11008 gcc_unreachable ();
11013 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
11014 are expanded into code inside the scalarization loop. */
11017 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
11019 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
11020 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
11022 /* The two argument version returns a scalar. */
11023 if (expr
->value
.function
.actual
->next
->expr
)
11026 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
11030 /* Walk an intrinsic array libcall. */
11033 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
11035 gcc_assert (expr
->rank
> 0);
11036 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
11040 /* Return whether the function call expression EXPR will be expanded
11041 inline by gfc_conv_intrinsic_function. */
11044 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
11046 gfc_actual_arglist
*args
, *dim_arg
, *mask_arg
;
11047 gfc_expr
*maskexpr
;
11049 if (!expr
->value
.function
.isym
)
11052 switch (expr
->value
.function
.isym
->id
)
11054 case GFC_ISYM_PRODUCT
:
11056 /* Disable inline expansion if code size matters. */
11060 args
= expr
->value
.function
.actual
;
11061 dim_arg
= args
->next
;
11063 /* We need to be able to subset the SUM argument at compile-time. */
11064 if (dim_arg
->expr
&& dim_arg
->expr
->expr_type
!= EXPR_CONSTANT
)
11067 /* FIXME: If MASK is optional for a more than two-dimensional
11068 argument, the scalarizer gets confused if the mask is
11069 absent. See PR 82995. For now, fall back to the library
11072 mask_arg
= dim_arg
->next
;
11073 maskexpr
= mask_arg
->expr
;
11075 if (expr
->rank
> 0 && maskexpr
&& maskexpr
->expr_type
== EXPR_VARIABLE
11076 && maskexpr
->symtree
->n
.sym
->attr
.dummy
11077 && maskexpr
->symtree
->n
.sym
->attr
.optional
)
11082 case GFC_ISYM_TRANSPOSE
:
11091 /* Returns nonzero if the specified intrinsic function call maps directly to
11092 an external library call. Should only be used for functions that return
11096 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
11098 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
11099 gcc_assert (expr
->rank
> 0);
11101 if (gfc_inline_intrinsic_function_p (expr
))
11104 switch (expr
->value
.function
.isym
->id
)
11108 case GFC_ISYM_COUNT
:
11109 case GFC_ISYM_FINDLOC
:
11111 case GFC_ISYM_IANY
:
11112 case GFC_ISYM_IALL
:
11113 case GFC_ISYM_IPARITY
:
11114 case GFC_ISYM_MATMUL
:
11115 case GFC_ISYM_MAXLOC
:
11116 case GFC_ISYM_MAXVAL
:
11117 case GFC_ISYM_MINLOC
:
11118 case GFC_ISYM_MINVAL
:
11119 case GFC_ISYM_NORM2
:
11120 case GFC_ISYM_PARITY
:
11121 case GFC_ISYM_PRODUCT
:
11123 case GFC_ISYM_SHAPE
:
11124 case GFC_ISYM_SPREAD
:
11126 /* Ignore absent optional parameters. */
11129 case GFC_ISYM_CSHIFT
:
11130 case GFC_ISYM_EOSHIFT
:
11131 case GFC_ISYM_GET_TEAM
:
11132 case GFC_ISYM_FAILED_IMAGES
:
11133 case GFC_ISYM_STOPPED_IMAGES
:
11134 case GFC_ISYM_PACK
:
11135 case GFC_ISYM_RESHAPE
:
11136 case GFC_ISYM_UNPACK
:
11137 /* Pass absent optional parameters. */
11145 /* Walk an intrinsic function. */
11147 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
11148 gfc_intrinsic_sym
* isym
)
11152 if (isym
->elemental
)
11153 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
11154 NULL
, GFC_SS_SCALAR
);
11156 if (expr
->rank
== 0)
11159 if (gfc_inline_intrinsic_function_p (expr
))
11160 return walk_inline_intrinsic_function (ss
, expr
);
11162 if (gfc_is_intrinsic_libcall (expr
))
11163 return gfc_walk_intrinsic_libfunc (ss
, expr
);
11165 /* Special cases. */
11168 case GFC_ISYM_LBOUND
:
11169 case GFC_ISYM_LCOBOUND
:
11170 case GFC_ISYM_UBOUND
:
11171 case GFC_ISYM_UCOBOUND
:
11172 case GFC_ISYM_THIS_IMAGE
:
11173 return gfc_walk_intrinsic_bound (ss
, expr
);
11175 case GFC_ISYM_TRANSFER
:
11176 case GFC_ISYM_CAF_GET
:
11177 return gfc_walk_intrinsic_libfunc (ss
, expr
);
11180 /* This probably meant someone forgot to add an intrinsic to the above
11181 list(s) when they implemented it, or something's gone horribly
11183 gcc_unreachable ();
11188 conv_co_collective (gfc_code
*code
)
11191 stmtblock_t block
, post_block
;
11192 tree fndecl
, array
= NULL_TREE
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
11193 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
11195 gfc_start_block (&block
);
11196 gfc_init_block (&post_block
);
11198 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
11200 opr_expr
= code
->ext
.actual
->next
->expr
;
11201 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
11202 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11203 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
11208 image_idx_expr
= code
->ext
.actual
->next
->expr
;
11209 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
11210 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11216 gfc_init_se (&argse
, NULL
);
11217 gfc_conv_expr (&argse
, stat_expr
);
11218 gfc_add_block_to_block (&block
, &argse
.pre
);
11219 gfc_add_block_to_block (&post_block
, &argse
.post
);
11221 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
11222 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
11224 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
11227 stat
= null_pointer_node
;
11229 /* Early exit for GFC_FCOARRAY_SINGLE. */
11230 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
11232 if (stat
!= NULL_TREE
)
11233 gfc_add_modify (&block
, stat
,
11234 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
11235 return gfc_finish_block (&block
);
11238 /* Handle the array. */
11239 gfc_init_se (&argse
, NULL
);
11240 if (code
->ext
.actual
->expr
->rank
== 0)
11242 symbol_attribute attr
;
11243 gfc_clear_attr (&attr
);
11244 gfc_init_se (&argse
, NULL
);
11245 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
11246 gfc_add_block_to_block (&block
, &argse
.pre
);
11247 gfc_add_block_to_block (&post_block
, &argse
.post
);
11248 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
11249 array
= gfc_build_addr_expr (NULL_TREE
, array
);
11253 argse
.want_pointer
= 1;
11254 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
11255 array
= argse
.expr
;
11258 gfc_add_block_to_block (&block
, &argse
.pre
);
11259 gfc_add_block_to_block (&post_block
, &argse
.post
);
11261 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
11262 strlen
= argse
.string_length
;
11264 strlen
= integer_zero_node
;
11267 if (image_idx_expr
)
11269 gfc_init_se (&argse
, NULL
);
11270 gfc_conv_expr (&argse
, image_idx_expr
);
11271 gfc_add_block_to_block (&block
, &argse
.pre
);
11272 gfc_add_block_to_block (&post_block
, &argse
.post
);
11273 image_index
= fold_convert (integer_type_node
, argse
.expr
);
11276 image_index
= integer_zero_node
;
11281 gfc_init_se (&argse
, NULL
);
11282 gfc_conv_expr (&argse
, errmsg_expr
);
11283 gfc_add_block_to_block (&block
, &argse
.pre
);
11284 gfc_add_block_to_block (&post_block
, &argse
.post
);
11285 errmsg
= argse
.expr
;
11286 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
11290 errmsg
= null_pointer_node
;
11291 errmsg_len
= build_zero_cst (size_type_node
);
11294 /* Generate the function call. */
11295 switch (code
->resolved_isym
->id
)
11297 case GFC_ISYM_CO_BROADCAST
:
11298 fndecl
= gfor_fndecl_co_broadcast
;
11300 case GFC_ISYM_CO_MAX
:
11301 fndecl
= gfor_fndecl_co_max
;
11303 case GFC_ISYM_CO_MIN
:
11304 fndecl
= gfor_fndecl_co_min
;
11306 case GFC_ISYM_CO_REDUCE
:
11307 fndecl
= gfor_fndecl_co_reduce
;
11309 case GFC_ISYM_CO_SUM
:
11310 fndecl
= gfor_fndecl_co_sum
;
11313 gcc_unreachable ();
11316 gfc_symbol
*derived
= code
->ext
.actual
->expr
->ts
.type
== BT_DERIVED
11317 ? code
->ext
.actual
->expr
->ts
.u
.derived
: NULL
;
11319 if (derived
&& derived
->attr
.alloc_comp
11320 && code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
11321 /* The derived type has the attribute 'alloc_comp'. */
11323 tree tmp
= gfc_bcast_alloc_comp (derived
, code
->ext
.actual
->expr
,
11324 code
->ext
.actual
->expr
->rank
,
11325 image_index
, stat
, errmsg
, errmsg_len
);
11326 gfc_add_expr_to_block (&block
, tmp
);
11330 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
11331 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
11332 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
11333 image_index
, stat
, errmsg
, errmsg_len
);
11334 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
11335 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
,
11336 image_index
, stat
, errmsg
,
11337 strlen
, errmsg_len
);
11340 tree opr
, opr_flags
;
11342 // FIXME: Handle TS29113's bind(C) strings with descriptor.
11344 if (gfc_is_proc_ptr_comp (opr_expr
))
11346 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
11347 opr_flag_int
= sym
->attr
.dimension
11348 || (sym
->ts
.type
== BT_CHARACTER
11349 && !sym
->attr
.is_bind_c
)
11350 ? GFC_CAF_BYREF
: 0;
11351 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
11352 && !sym
->attr
.is_bind_c
11353 ? GFC_CAF_HIDDENLEN
: 0;
11354 opr_flag_int
|= sym
->formal
->sym
->attr
.value
11355 ? GFC_CAF_ARG_VALUE
: 0;
11359 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
11360 ? GFC_CAF_BYREF
: 0;
11361 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
11362 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
11363 ? GFC_CAF_HIDDENLEN
: 0;
11364 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
11365 ? GFC_CAF_ARG_VALUE
: 0;
11367 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
11368 gfc_conv_expr (&argse
, opr_expr
);
11370 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
,
11371 opr_flags
, image_index
, stat
, errmsg
,
11372 strlen
, errmsg_len
);
11376 gfc_add_expr_to_block (&block
, fndecl
);
11377 gfc_add_block_to_block (&block
, &post_block
);
11379 return gfc_finish_block (&block
);
11384 conv_intrinsic_atomic_op (gfc_code
*code
)
11387 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
11388 stmtblock_t block
, post_block
;
11389 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
11390 gfc_expr
*stat_expr
;
11391 built_in_function fn
;
11393 if (atom_expr
->expr_type
== EXPR_FUNCTION
11394 && atom_expr
->value
.function
.isym
11395 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11396 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11398 gfc_start_block (&block
);
11399 gfc_init_block (&post_block
);
11401 gfc_init_se (&argse
, NULL
);
11402 argse
.want_pointer
= 1;
11403 gfc_conv_expr (&argse
, atom_expr
);
11404 gfc_add_block_to_block (&block
, &argse
.pre
);
11405 gfc_add_block_to_block (&post_block
, &argse
.post
);
11408 gfc_init_se (&argse
, NULL
);
11409 if (flag_coarray
== GFC_FCOARRAY_LIB
11410 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
11411 argse
.want_pointer
= 1;
11412 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
11413 gfc_add_block_to_block (&block
, &argse
.pre
);
11414 gfc_add_block_to_block (&post_block
, &argse
.post
);
11415 value
= argse
.expr
;
11417 switch (code
->resolved_isym
->id
)
11419 case GFC_ISYM_ATOMIC_ADD
:
11420 case GFC_ISYM_ATOMIC_AND
:
11421 case GFC_ISYM_ATOMIC_DEF
:
11422 case GFC_ISYM_ATOMIC_OR
:
11423 case GFC_ISYM_ATOMIC_XOR
:
11424 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
11425 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11426 old
= null_pointer_node
;
11429 gfc_init_se (&argse
, NULL
);
11430 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11431 argse
.want_pointer
= 1;
11432 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
11433 gfc_add_block_to_block (&block
, &argse
.pre
);
11434 gfc_add_block_to_block (&post_block
, &argse
.post
);
11436 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
11440 if (stat_expr
!= NULL
)
11442 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
11443 gfc_init_se (&argse
, NULL
);
11444 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11445 argse
.want_pointer
= 1;
11446 gfc_conv_expr_val (&argse
, stat_expr
);
11447 gfc_add_block_to_block (&block
, &argse
.pre
);
11448 gfc_add_block_to_block (&post_block
, &argse
.post
);
11451 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11452 stat
= null_pointer_node
;
11454 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11456 tree image_index
, caf_decl
, offset
, token
;
11459 switch (code
->resolved_isym
->id
)
11461 case GFC_ISYM_ATOMIC_ADD
:
11462 case GFC_ISYM_ATOMIC_FETCH_ADD
:
11463 op
= (int) GFC_CAF_ATOMIC_ADD
;
11465 case GFC_ISYM_ATOMIC_AND
:
11466 case GFC_ISYM_ATOMIC_FETCH_AND
:
11467 op
= (int) GFC_CAF_ATOMIC_AND
;
11469 case GFC_ISYM_ATOMIC_OR
:
11470 case GFC_ISYM_ATOMIC_FETCH_OR
:
11471 op
= (int) GFC_CAF_ATOMIC_OR
;
11473 case GFC_ISYM_ATOMIC_XOR
:
11474 case GFC_ISYM_ATOMIC_FETCH_XOR
:
11475 op
= (int) GFC_CAF_ATOMIC_XOR
;
11477 case GFC_ISYM_ATOMIC_DEF
:
11478 op
= 0; /* Unused. */
11481 gcc_unreachable ();
11484 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
11485 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
11486 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
11488 if (gfc_is_coindexed (atom_expr
))
11489 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
11491 image_index
= integer_zero_node
;
11493 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
11495 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
11496 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
11497 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11500 gfc_init_se (&argse
, NULL
);
11501 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
11504 gfc_add_block_to_block (&block
, &argse
.pre
);
11505 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
11506 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
11507 token
, offset
, image_index
, value
, stat
,
11508 build_int_cst (integer_type_node
,
11509 (int) atom_expr
->ts
.type
),
11510 build_int_cst (integer_type_node
,
11511 (int) atom_expr
->ts
.kind
));
11513 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
11514 build_int_cst (integer_type_node
, op
),
11515 token
, offset
, image_index
, value
, old
, stat
,
11516 build_int_cst (integer_type_node
,
11517 (int) atom_expr
->ts
.type
),
11518 build_int_cst (integer_type_node
,
11519 (int) atom_expr
->ts
.kind
));
11521 gfc_add_expr_to_block (&block
, tmp
);
11522 gfc_add_block_to_block (&block
, &argse
.post
);
11523 gfc_add_block_to_block (&block
, &post_block
);
11524 return gfc_finish_block (&block
);
11528 switch (code
->resolved_isym
->id
)
11530 case GFC_ISYM_ATOMIC_ADD
:
11531 case GFC_ISYM_ATOMIC_FETCH_ADD
:
11532 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
11534 case GFC_ISYM_ATOMIC_AND
:
11535 case GFC_ISYM_ATOMIC_FETCH_AND
:
11536 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
11538 case GFC_ISYM_ATOMIC_DEF
:
11539 fn
= BUILT_IN_ATOMIC_STORE_N
;
11541 case GFC_ISYM_ATOMIC_OR
:
11542 case GFC_ISYM_ATOMIC_FETCH_OR
:
11543 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
11545 case GFC_ISYM_ATOMIC_XOR
:
11546 case GFC_ISYM_ATOMIC_FETCH_XOR
:
11547 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
11550 gcc_unreachable ();
11553 tmp
= TREE_TYPE (TREE_TYPE (atom
));
11554 fn
= (built_in_function
) ((int) fn
11555 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
11557 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
11558 tmp
= builtin_decl_explicit (fn
);
11560 switch (code
->resolved_isym
->id
)
11562 case GFC_ISYM_ATOMIC_ADD
:
11563 case GFC_ISYM_ATOMIC_AND
:
11564 case GFC_ISYM_ATOMIC_DEF
:
11565 case GFC_ISYM_ATOMIC_OR
:
11566 case GFC_ISYM_ATOMIC_XOR
:
11567 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
11568 fold_convert (itype
, value
),
11569 build_int_cst (NULL
, MEMMODEL_RELAXED
));
11570 gfc_add_expr_to_block (&block
, tmp
);
11573 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
11574 fold_convert (itype
, value
),
11575 build_int_cst (NULL
, MEMMODEL_RELAXED
));
11576 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
11580 if (stat
!= NULL_TREE
)
11581 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11582 gfc_add_block_to_block (&block
, &post_block
);
11583 return gfc_finish_block (&block
);
11588 conv_intrinsic_atomic_ref (gfc_code
*code
)
11591 tree tmp
, atom
, value
, stat
= NULL_TREE
;
11592 stmtblock_t block
, post_block
;
11593 built_in_function fn
;
11594 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
11596 if (atom_expr
->expr_type
== EXPR_FUNCTION
11597 && atom_expr
->value
.function
.isym
11598 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11599 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11601 gfc_start_block (&block
);
11602 gfc_init_block (&post_block
);
11603 gfc_init_se (&argse
, NULL
);
11604 argse
.want_pointer
= 1;
11605 gfc_conv_expr (&argse
, atom_expr
);
11606 gfc_add_block_to_block (&block
, &argse
.pre
);
11607 gfc_add_block_to_block (&post_block
, &argse
.post
);
11610 gfc_init_se (&argse
, NULL
);
11611 if (flag_coarray
== GFC_FCOARRAY_LIB
11612 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
11613 argse
.want_pointer
= 1;
11614 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
11615 gfc_add_block_to_block (&block
, &argse
.pre
);
11616 gfc_add_block_to_block (&post_block
, &argse
.post
);
11617 value
= argse
.expr
;
11620 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
11622 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
11624 gfc_init_se (&argse
, NULL
);
11625 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11626 argse
.want_pointer
= 1;
11627 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
11628 gfc_add_block_to_block (&block
, &argse
.pre
);
11629 gfc_add_block_to_block (&post_block
, &argse
.post
);
11632 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11633 stat
= null_pointer_node
;
11635 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11637 tree image_index
, caf_decl
, offset
, token
;
11638 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
11640 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
11641 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
11642 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
11644 if (gfc_is_coindexed (atom_expr
))
11645 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
11647 image_index
= integer_zero_node
;
11649 gfc_init_se (&argse
, NULL
);
11650 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
11652 gfc_add_block_to_block (&block
, &argse
.pre
);
11654 /* Different type, need type conversion. */
11655 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
11657 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
11658 orig_value
= value
;
11659 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
11662 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
11663 token
, offset
, image_index
, value
, stat
,
11664 build_int_cst (integer_type_node
,
11665 (int) atom_expr
->ts
.type
),
11666 build_int_cst (integer_type_node
,
11667 (int) atom_expr
->ts
.kind
));
11668 gfc_add_expr_to_block (&block
, tmp
);
11669 if (vardecl
!= NULL_TREE
)
11670 gfc_add_modify (&block
, orig_value
,
11671 fold_convert (TREE_TYPE (orig_value
), vardecl
));
11672 gfc_add_block_to_block (&block
, &argse
.post
);
11673 gfc_add_block_to_block (&block
, &post_block
);
11674 return gfc_finish_block (&block
);
11677 tmp
= TREE_TYPE (TREE_TYPE (atom
));
11678 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
11679 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
11681 tmp
= builtin_decl_explicit (fn
);
11682 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
11683 build_int_cst (integer_type_node
,
11684 MEMMODEL_RELAXED
));
11685 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
11687 if (stat
!= NULL_TREE
)
11688 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11689 gfc_add_block_to_block (&block
, &post_block
);
11690 return gfc_finish_block (&block
);
11695 conv_intrinsic_atomic_cas (gfc_code
*code
)
11698 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
11699 stmtblock_t block
, post_block
;
11700 built_in_function fn
;
11701 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
11703 if (atom_expr
->expr_type
== EXPR_FUNCTION
11704 && atom_expr
->value
.function
.isym
11705 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11706 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
11708 gfc_init_block (&block
);
11709 gfc_init_block (&post_block
);
11710 gfc_init_se (&argse
, NULL
);
11711 argse
.want_pointer
= 1;
11712 gfc_conv_expr (&argse
, atom_expr
);
11715 gfc_init_se (&argse
, NULL
);
11716 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11717 argse
.want_pointer
= 1;
11718 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
11719 gfc_add_block_to_block (&block
, &argse
.pre
);
11720 gfc_add_block_to_block (&post_block
, &argse
.post
);
11723 gfc_init_se (&argse
, NULL
);
11724 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11725 argse
.want_pointer
= 1;
11726 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
11727 gfc_add_block_to_block (&block
, &argse
.pre
);
11728 gfc_add_block_to_block (&post_block
, &argse
.post
);
11731 gfc_init_se (&argse
, NULL
);
11732 if (flag_coarray
== GFC_FCOARRAY_LIB
11733 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
11734 == atom_expr
->ts
.kind
)
11735 argse
.want_pointer
= 1;
11736 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
11737 gfc_add_block_to_block (&block
, &argse
.pre
);
11738 gfc_add_block_to_block (&post_block
, &argse
.post
);
11739 new_val
= argse
.expr
;
11742 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
11744 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
11746 gfc_init_se (&argse
, NULL
);
11747 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11748 argse
.want_pointer
= 1;
11749 gfc_conv_expr_val (&argse
,
11750 code
->ext
.actual
->next
->next
->next
->next
->expr
);
11751 gfc_add_block_to_block (&block
, &argse
.pre
);
11752 gfc_add_block_to_block (&post_block
, &argse
.post
);
11755 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11756 stat
= null_pointer_node
;
11758 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11760 tree image_index
, caf_decl
, offset
, token
;
11762 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
11763 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
11764 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
11766 if (gfc_is_coindexed (atom_expr
))
11767 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
11769 image_index
= integer_zero_node
;
11771 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
11773 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
11774 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
11775 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11778 /* Convert a constant to a pointer. */
11779 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
11781 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
11782 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
11783 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11786 gfc_init_se (&argse
, NULL
);
11787 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
11789 gfc_add_block_to_block (&block
, &argse
.pre
);
11791 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
11792 token
, offset
, image_index
, old
, comp
, new_val
,
11793 stat
, build_int_cst (integer_type_node
,
11794 (int) atom_expr
->ts
.type
),
11795 build_int_cst (integer_type_node
,
11796 (int) atom_expr
->ts
.kind
));
11797 gfc_add_expr_to_block (&block
, tmp
);
11798 gfc_add_block_to_block (&block
, &argse
.post
);
11799 gfc_add_block_to_block (&block
, &post_block
);
11800 return gfc_finish_block (&block
);
11803 tmp
= TREE_TYPE (TREE_TYPE (atom
));
11804 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
11805 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
11807 tmp
= builtin_decl_explicit (fn
);
11809 gfc_add_modify (&block
, old
, comp
);
11810 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
11811 gfc_build_addr_expr (NULL
, old
),
11812 fold_convert (TREE_TYPE (old
), new_val
),
11813 boolean_false_node
,
11814 build_int_cst (NULL
, MEMMODEL_RELAXED
),
11815 build_int_cst (NULL
, MEMMODEL_RELAXED
));
11816 gfc_add_expr_to_block (&block
, tmp
);
11818 if (stat
!= NULL_TREE
)
11819 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11820 gfc_add_block_to_block (&block
, &post_block
);
11821 return gfc_finish_block (&block
);
11825 conv_intrinsic_event_query (gfc_code
*code
)
11828 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
11829 tree count
= NULL_TREE
, count2
= NULL_TREE
;
11831 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
11833 if (code
->ext
.actual
->next
->next
->expr
)
11835 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
11837 gfc_init_se (&argse
, NULL
);
11838 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
11841 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
11842 stat
= null_pointer_node
;
11844 if (code
->ext
.actual
->next
->expr
)
11846 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
11847 gfc_init_se (&argse
, NULL
);
11848 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
11849 count
= argse
.expr
;
11852 gfc_start_block (&se
.pre
);
11853 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11855 tree tmp
, token
, image_index
;
11856 tree index
= build_zero_cst (gfc_array_index_type
);
11858 if (event_expr
->expr_type
== EXPR_FUNCTION
11859 && event_expr
->value
.function
.isym
11860 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
11861 event_expr
= event_expr
->value
.function
.actual
->expr
;
11863 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
11865 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
11866 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
11867 != INTMOD_ISO_FORTRAN_ENV
11868 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
11869 != ISOFORTRAN_EVENT_TYPE
)
11871 gfc_error ("Sorry, the event component of derived type at %L is not "
11872 "yet supported", &event_expr
->where
);
11876 if (gfc_is_coindexed (event_expr
))
11878 gfc_error ("The event variable at %L shall not be coindexed",
11879 &event_expr
->where
);
11883 image_index
= integer_zero_node
;
11885 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
11888 /* For arrays, obtain the array index. */
11889 if (gfc_expr_attr (event_expr
).dimension
)
11891 tree desc
, tmp
, extent
, lbound
, ubound
;
11892 gfc_array_ref
*ar
, ar2
;
11895 /* TODO: Extend this, once DT components are supported. */
11896 ar
= &event_expr
->ref
->u
.ar
;
11898 memset (ar
, '\0', sizeof (*ar
));
11900 ar
->type
= AR_FULL
;
11902 gfc_init_se (&argse
, NULL
);
11903 argse
.descriptor_only
= 1;
11904 gfc_conv_expr_descriptor (&argse
, event_expr
);
11905 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
11909 extent
= build_one_cst (gfc_array_index_type
);
11910 for (i
= 0; i
< ar
->dimen
; i
++)
11912 gfc_init_se (&argse
, NULL
);
11913 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
11914 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
11915 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
11916 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
11917 TREE_TYPE (lbound
), argse
.expr
, lbound
);
11918 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
11919 TREE_TYPE (tmp
), extent
, tmp
);
11920 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
11921 TREE_TYPE (tmp
), index
, tmp
);
11922 if (i
< ar
->dimen
- 1)
11924 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
11925 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
11926 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
11927 TREE_TYPE (tmp
), extent
, tmp
);
11932 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
11935 count
= gfc_create_var (integer_type_node
, "count");
11938 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
11941 stat
= gfc_create_var (integer_type_node
, "stat");
11944 index
= fold_convert (size_type_node
, index
);
11945 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
11946 token
, index
, image_index
, count
11947 ? gfc_build_addr_expr (NULL
, count
) : count
,
11948 stat
!= null_pointer_node
11949 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
11950 gfc_add_expr_to_block (&se
.pre
, tmp
);
11952 if (count2
!= NULL_TREE
)
11953 gfc_add_modify (&se
.pre
, count2
,
11954 fold_convert (TREE_TYPE (count2
), count
));
11956 if (stat2
!= NULL_TREE
)
11957 gfc_add_modify (&se
.pre
, stat2
,
11958 fold_convert (TREE_TYPE (stat2
), stat
));
11960 return gfc_finish_block (&se
.pre
);
11963 gfc_init_se (&argse
, NULL
);
11964 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
11965 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
11967 if (stat
!= NULL_TREE
)
11968 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11970 return gfc_finish_block (&se
.pre
);
11974 /* This is a peculiar case because of the need to do dependency checking.
11975 It is called via trans-stmt.c(gfc_trans_call), where it is picked out as
11976 a special case and this function called instead of
11977 gfc_conv_procedure_call. */
11979 gfc_conv_intrinsic_mvbits (gfc_se
*se
, gfc_actual_arglist
*actual_args
,
11980 gfc_loopinfo
*loop
)
11982 gfc_actual_arglist
*actual
;
11988 tree from
, frompos
, len
, to
, topos
;
11989 tree lenmask
, oldbits
, newbits
, bitsize
;
11990 tree type
, utype
, above
, mask1
, mask2
;
11995 lss
= gfc_ss_terminator
;
11997 actual
= actual_args
;
11998 for (n
= 0; n
< 5; n
++, actual
= actual
->next
)
12000 arg
[n
] = actual
->expr
;
12001 gfc_init_se (&argse
[n
], NULL
);
12003 if (lss
!= gfc_ss_terminator
)
12005 gfc_copy_loopinfo_to_se (&argse
[n
], loop
);
12006 /* Find the ss for the expression if it is there. */
12008 gfc_mark_ss_chain_used (lss
, 1);
12011 gfc_conv_expr (&argse
[n
], arg
[n
]);
12017 from
= argse
[0].expr
;
12018 frompos
= argse
[1].expr
;
12019 len
= argse
[2].expr
;
12020 to
= argse
[3].expr
;
12021 topos
= argse
[4].expr
;
12023 /* The type of the result (TO). */
12024 type
= TREE_TYPE (to
);
12025 bitsize
= build_int_cst (integer_type_node
, TYPE_PRECISION (type
));
12027 /* Optionally generate code for runtime argument check. */
12028 if (gfc_option
.rtcheck
& GFC_RTCHECK_BITS
)
12030 tree nbits
, below
, ccond
;
12031 tree fp
= fold_convert (long_integer_type_node
, frompos
);
12032 tree ln
= fold_convert (long_integer_type_node
, len
);
12033 tree tp
= fold_convert (long_integer_type_node
, topos
);
12034 below
= fold_build2_loc (input_location
, LT_EXPR
,
12035 logical_type_node
, frompos
,
12036 build_int_cst (TREE_TYPE (frompos
), 0));
12037 above
= fold_build2_loc (input_location
, GT_EXPR
,
12038 logical_type_node
, frompos
,
12039 fold_convert (TREE_TYPE (frompos
), bitsize
));
12040 ccond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
12041 logical_type_node
, below
, above
);
12042 gfc_trans_runtime_check (true, false, ccond
, &argse
[1].pre
,
12044 "FROMPOS argument (%ld) out of range 0:%d "
12045 "in intrinsic MVBITS", fp
, bitsize
);
12046 below
= fold_build2_loc (input_location
, LT_EXPR
,
12047 logical_type_node
, len
,
12048 build_int_cst (TREE_TYPE (len
), 0));
12049 above
= fold_build2_loc (input_location
, GT_EXPR
,
12050 logical_type_node
, len
,
12051 fold_convert (TREE_TYPE (len
), bitsize
));
12052 ccond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
12053 logical_type_node
, below
, above
);
12054 gfc_trans_runtime_check (true, false, ccond
, &argse
[2].pre
,
12056 "LEN argument (%ld) out of range 0:%d "
12057 "in intrinsic MVBITS", ln
, bitsize
);
12058 below
= fold_build2_loc (input_location
, LT_EXPR
,
12059 logical_type_node
, topos
,
12060 build_int_cst (TREE_TYPE (topos
), 0));
12061 above
= fold_build2_loc (input_location
, GT_EXPR
,
12062 logical_type_node
, topos
,
12063 fold_convert (TREE_TYPE (topos
), bitsize
));
12064 ccond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
12065 logical_type_node
, below
, above
);
12066 gfc_trans_runtime_check (true, false, ccond
, &argse
[4].pre
,
12068 "TOPOS argument (%ld) out of range 0:%d "
12069 "in intrinsic MVBITS", tp
, bitsize
);
12071 /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
12072 integers. Additions below cannot overflow. */
12073 nbits
= fold_convert (long_integer_type_node
, bitsize
);
12074 above
= fold_build2_loc (input_location
, PLUS_EXPR
,
12075 long_integer_type_node
, fp
, ln
);
12076 ccond
= fold_build2_loc (input_location
, GT_EXPR
,
12077 logical_type_node
, above
, nbits
);
12078 gfc_trans_runtime_check (true, false, ccond
, &argse
[1].pre
,
12080 "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12081 "in intrinsic MVBITS", fp
, ln
, bitsize
);
12082 above
= fold_build2_loc (input_location
, PLUS_EXPR
,
12083 long_integer_type_node
, tp
, ln
);
12084 ccond
= fold_build2_loc (input_location
, GT_EXPR
,
12085 logical_type_node
, above
, nbits
);
12086 gfc_trans_runtime_check (true, false, ccond
, &argse
[4].pre
,
12088 "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12089 "in intrinsic MVBITS", tp
, ln
, bitsize
);
12092 for (n
= 0; n
< 5; n
++)
12094 gfc_add_block_to_block (&se
->pre
, &argse
[n
].pre
);
12095 gfc_add_block_to_block (&se
->post
, &argse
[n
].post
);
12098 /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
12099 above
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
12100 len
, fold_convert (TREE_TYPE (len
), bitsize
));
12101 mask1
= build_int_cst (type
, -1);
12102 mask2
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
12103 build_int_cst (type
, 1), len
);
12104 mask2
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
12105 mask2
, build_int_cst (type
, 1));
12106 lenmask
= fold_build3_loc (input_location
, COND_EXPR
, type
,
12107 above
, mask1
, mask2
);
12109 /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
12110 * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
12111 * not strictly necessary; artificial bits from rshift will be masked. */
12112 utype
= unsigned_type_for (type
);
12113 newbits
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
12114 fold_convert (utype
, from
), frompos
);
12115 newbits
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
12116 fold_convert (type
, newbits
), lenmask
);
12117 newbits
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
12120 /* oldbits = TO & (~(lenmask << TOPOS)). */
12121 oldbits
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
12123 oldbits
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, oldbits
);
12124 oldbits
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, oldbits
, to
);
12126 /* TO = newbits | oldbits. */
12127 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
12130 /* Return the assignment. */
12131 se
->expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
12132 void_type_node
, to
, se
->expr
);
12137 conv_intrinsic_move_alloc (gfc_code
*code
)
12140 gfc_expr
*from_expr
, *to_expr
;
12141 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
12142 gfc_se from_se
, to_se
;
12146 gfc_start_block (&block
);
12148 from_expr
= code
->ext
.actual
->expr
;
12149 to_expr
= code
->ext
.actual
->next
->expr
;
12151 gfc_init_se (&from_se
, NULL
);
12152 gfc_init_se (&to_se
, NULL
);
12154 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
12155 || to_expr
->ts
.type
== BT_CLASS
);
12156 coarray
= gfc_get_corank (from_expr
) != 0;
12158 if (from_expr
->rank
== 0 && !coarray
)
12160 if (from_expr
->ts
.type
!= BT_CLASS
)
12161 from_expr2
= from_expr
;
12164 from_expr2
= gfc_copy_expr (from_expr
);
12165 gfc_add_data_component (from_expr2
);
12168 if (to_expr
->ts
.type
!= BT_CLASS
)
12169 to_expr2
= to_expr
;
12172 to_expr2
= gfc_copy_expr (to_expr
);
12173 gfc_add_data_component (to_expr2
);
12176 from_se
.want_pointer
= 1;
12177 to_se
.want_pointer
= 1;
12178 gfc_conv_expr (&from_se
, from_expr2
);
12179 gfc_conv_expr (&to_se
, to_expr2
);
12180 gfc_add_block_to_block (&block
, &from_se
.pre
);
12181 gfc_add_block_to_block (&block
, &to_se
.pre
);
12183 /* Deallocate "to". */
12184 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
12185 true, to_expr
, to_expr
->ts
);
12186 gfc_add_expr_to_block (&block
, tmp
);
12188 /* Assign (_data) pointers. */
12189 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
12190 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
12192 /* Set "from" to NULL. */
12193 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
12194 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
12196 gfc_add_block_to_block (&block
, &from_se
.post
);
12197 gfc_add_block_to_block (&block
, &to_se
.post
);
12200 if (to_expr
->ts
.type
== BT_CLASS
)
12204 gfc_free_expr (to_expr2
);
12205 gfc_init_se (&to_se
, NULL
);
12206 to_se
.want_pointer
= 1;
12207 gfc_add_vptr_component (to_expr
);
12208 gfc_conv_expr (&to_se
, to_expr
);
12210 if (from_expr
->ts
.type
== BT_CLASS
)
12212 if (UNLIMITED_POLY (from_expr
))
12216 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
12220 gfc_free_expr (from_expr2
);
12221 gfc_init_se (&from_se
, NULL
);
12222 from_se
.want_pointer
= 1;
12223 gfc_add_vptr_component (from_expr
);
12224 gfc_conv_expr (&from_se
, from_expr
);
12225 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
12226 fold_convert (TREE_TYPE (to_se
.expr
),
12229 /* Reset _vptr component to declared type. */
12231 /* Unlimited polymorphic. */
12232 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
12233 fold_convert (TREE_TYPE (from_se
.expr
),
12234 null_pointer_node
));
12237 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
12238 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
12239 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
12244 vtab
= gfc_find_vtab (&from_expr
->ts
);
12246 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
12247 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
12248 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
12252 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
12254 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
12255 fold_convert (TREE_TYPE (to_se
.string_length
),
12256 from_se
.string_length
));
12257 if (from_expr
->ts
.deferred
)
12258 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
12259 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
12262 return gfc_finish_block (&block
);
12265 /* Update _vptr component. */
12266 if (to_expr
->ts
.type
== BT_CLASS
)
12270 to_se
.want_pointer
= 1;
12271 to_expr2
= gfc_copy_expr (to_expr
);
12272 gfc_add_vptr_component (to_expr2
);
12273 gfc_conv_expr (&to_se
, to_expr2
);
12275 if (from_expr
->ts
.type
== BT_CLASS
)
12277 if (UNLIMITED_POLY (from_expr
))
12281 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
12285 from_se
.want_pointer
= 1;
12286 from_expr2
= gfc_copy_expr (from_expr
);
12287 gfc_add_vptr_component (from_expr2
);
12288 gfc_conv_expr (&from_se
, from_expr2
);
12289 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
12290 fold_convert (TREE_TYPE (to_se
.expr
),
12293 /* Reset _vptr component to declared type. */
12295 /* Unlimited polymorphic. */
12296 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
12297 fold_convert (TREE_TYPE (from_se
.expr
),
12298 null_pointer_node
));
12301 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
12302 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
12303 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
12308 vtab
= gfc_find_vtab (&from_expr
->ts
);
12310 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
12311 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
12312 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
12315 gfc_free_expr (to_expr2
);
12316 gfc_init_se (&to_se
, NULL
);
12318 if (from_expr
->ts
.type
== BT_CLASS
)
12320 gfc_free_expr (from_expr2
);
12321 gfc_init_se (&from_se
, NULL
);
12326 /* Deallocate "to". */
12327 if (from_expr
->rank
== 0)
12329 to_se
.want_coarray
= 1;
12330 from_se
.want_coarray
= 1;
12332 gfc_conv_expr_descriptor (&to_se
, to_expr
);
12333 gfc_conv_expr_descriptor (&from_se
, from_expr
);
12335 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
12336 is an image control "statement", cf. IR F08/0040 in 12-006A. */
12337 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
12341 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
12342 NULL_TREE
, NULL_TREE
, true, to_expr
,
12343 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
12344 gfc_add_expr_to_block (&block
, tmp
);
12346 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
12347 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
12348 logical_type_node
, tmp
,
12349 fold_convert (TREE_TYPE (tmp
),
12350 null_pointer_node
));
12351 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
12352 3, null_pointer_node
, null_pointer_node
,
12353 build_int_cst (integer_type_node
, 0));
12355 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
12356 tmp
, build_empty_stmt (input_location
));
12357 gfc_add_expr_to_block (&block
, tmp
);
12361 if (to_expr
->ts
.type
== BT_DERIVED
12362 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
12364 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
12365 to_se
.expr
, to_expr
->rank
);
12366 gfc_add_expr_to_block (&block
, tmp
);
12369 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
12370 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
12371 NULL_TREE
, true, to_expr
,
12372 GFC_CAF_COARRAY_NOCOARRAY
);
12373 gfc_add_expr_to_block (&block
, tmp
);
12376 /* Move the pointer and update the array descriptor data. */
12377 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
12379 /* Set "from" to NULL. */
12380 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
12381 gfc_add_modify_loc (input_location
, &block
, tmp
,
12382 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
12385 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
12387 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
12388 fold_convert (TREE_TYPE (to_se
.string_length
),
12389 from_se
.string_length
));
12390 if (from_expr
->ts
.deferred
)
12391 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
12392 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
12395 return gfc_finish_block (&block
);
12400 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
12404 gcc_assert (code
->resolved_isym
);
12406 switch (code
->resolved_isym
->id
)
12408 case GFC_ISYM_MOVE_ALLOC
:
12409 res
= conv_intrinsic_move_alloc (code
);
12412 case GFC_ISYM_ATOMIC_CAS
:
12413 res
= conv_intrinsic_atomic_cas (code
);
12416 case GFC_ISYM_ATOMIC_ADD
:
12417 case GFC_ISYM_ATOMIC_AND
:
12418 case GFC_ISYM_ATOMIC_DEF
:
12419 case GFC_ISYM_ATOMIC_OR
:
12420 case GFC_ISYM_ATOMIC_XOR
:
12421 case GFC_ISYM_ATOMIC_FETCH_ADD
:
12422 case GFC_ISYM_ATOMIC_FETCH_AND
:
12423 case GFC_ISYM_ATOMIC_FETCH_OR
:
12424 case GFC_ISYM_ATOMIC_FETCH_XOR
:
12425 res
= conv_intrinsic_atomic_op (code
);
12428 case GFC_ISYM_ATOMIC_REF
:
12429 res
= conv_intrinsic_atomic_ref (code
);
12432 case GFC_ISYM_EVENT_QUERY
:
12433 res
= conv_intrinsic_event_query (code
);
12436 case GFC_ISYM_C_F_POINTER
:
12437 case GFC_ISYM_C_F_PROCPOINTER
:
12438 res
= conv_isocbinding_subroutine (code
);
12441 case GFC_ISYM_CAF_SEND
:
12442 res
= conv_caf_send (code
);
12445 case GFC_ISYM_CO_BROADCAST
:
12446 case GFC_ISYM_CO_MIN
:
12447 case GFC_ISYM_CO_MAX
:
12448 case GFC_ISYM_CO_REDUCE
:
12449 case GFC_ISYM_CO_SUM
:
12450 res
= conv_co_collective (code
);
12453 case GFC_ISYM_FREE
:
12454 res
= conv_intrinsic_free (code
);
12457 case GFC_ISYM_RANDOM_INIT
:
12458 res
= conv_intrinsic_random_init (code
);
12461 case GFC_ISYM_KILL
:
12462 res
= conv_intrinsic_kill_sub (code
);
12465 case GFC_ISYM_MVBITS
:
12469 case GFC_ISYM_SYSTEM_CLOCK
:
12470 res
= conv_intrinsic_system_clock (code
);
12481 #include "gt-fortran-trans-intrinsic.h"