1 /* Intrinsic translation
2 Copyright (C) 2002-2016 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"
27 #include "tm.h" /* For UNITS_PER_WORD. */
31 #include "stringpool.h"
32 #include "fold-const.h"
33 #include "tree-nested.h"
34 #include "stor-layout.h"
35 #include "toplev.h" /* For rest_of_decl_compilation. */
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 #include "dependency.h" /* For CAF array alias analysis. */
41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 /* This maps Fortran intrinsic math functions to external library or GCC
45 typedef struct GTY(()) gfc_intrinsic_map_t
{
46 /* The explicit enum is required to work around inadequacies in the
47 garbage collection/gengtype parsing mechanism. */
50 /* Enum value from the "language-independent", aka C-centric, part
51 of gcc, or END_BUILTINS of no such value set. */
52 enum built_in_function float_built_in
;
53 enum built_in_function double_built_in
;
54 enum built_in_function long_double_built_in
;
55 enum built_in_function complex_float_built_in
;
56 enum built_in_function complex_double_built_in
;
57 enum built_in_function complex_long_double_built_in
;
59 /* True if the naming pattern is to prepend "c" for complex and
60 append "f" for kind=4. False if the naming pattern is to
61 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
64 /* True if a complex version of the function exists. */
65 bool complex_available
;
67 /* True if the function should be marked const. */
70 /* The base library name of this function. */
73 /* Cache decls created for the various operand types. */
85 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
86 defines complex variants of all of the entries in mathbuiltins.def
88 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
89 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
90 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
91 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
92 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
94 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
97 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
101 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
102 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
104 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
106 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
107 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
108 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
112 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
114 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
115 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
116 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
117 #include "mathbuiltins.def"
119 /* Functions in libgfortran. */
120 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
123 LIB_FUNCTION (NONE
, NULL
, false)
128 #undef DEFINE_MATH_BUILTIN
129 #undef DEFINE_MATH_BUILTIN_C
132 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
135 /* Find the correct variant of a given builtin from its argument. */
137 builtin_decl_for_precision (enum built_in_function base_built_in
,
140 enum built_in_function i
= END_BUILTINS
;
142 gfc_intrinsic_map_t
*m
;
143 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
146 if (precision
== TYPE_PRECISION (float_type_node
))
147 i
= m
->float_built_in
;
148 else if (precision
== TYPE_PRECISION (double_type_node
))
149 i
= m
->double_built_in
;
150 else if (precision
== TYPE_PRECISION (long_double_type_node
))
151 i
= m
->long_double_built_in
;
152 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
154 /* Special treatment, because it is not exactly a built-in, but
155 a library function. */
156 return m
->real16_decl
;
159 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
164 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
167 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
169 if (gfc_real_kinds
[i
].c_float128
)
171 /* For __float128, the story is a bit different, because we return
172 a decl to a library function rather than a built-in. */
173 gfc_intrinsic_map_t
*m
;
174 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
177 return m
->real16_decl
;
180 return builtin_decl_for_precision (double_built_in
,
181 gfc_real_kinds
[i
].mode_precision
);
185 /* Evaluate the arguments to an intrinsic function. The value
186 of NARGS may be less than the actual number of arguments in EXPR
187 to allow optional "KIND" arguments that are not included in the
188 generated code to be ignored. */
191 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
192 tree
*argarray
, int nargs
)
194 gfc_actual_arglist
*actual
;
196 gfc_intrinsic_arg
*formal
;
200 formal
= expr
->value
.function
.isym
->formal
;
201 actual
= expr
->value
.function
.actual
;
203 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
204 actual
= actual
->next
,
205 formal
= formal
? formal
->next
: NULL
)
209 /* Skip omitted optional arguments. */
216 /* Evaluate the parameter. This will substitute scalarized
217 references automatically. */
218 gfc_init_se (&argse
, se
);
220 if (e
->ts
.type
== BT_CHARACTER
)
222 gfc_conv_expr (&argse
, e
);
223 gfc_conv_string_parameter (&argse
);
224 argarray
[curr_arg
++] = argse
.string_length
;
225 gcc_assert (curr_arg
< nargs
);
228 gfc_conv_expr_val (&argse
, e
);
230 /* If an optional argument is itself an optional dummy argument,
231 check its presence and substitute a null if absent. */
232 if (e
->expr_type
== EXPR_VARIABLE
233 && e
->symtree
->n
.sym
->attr
.optional
236 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
238 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
239 gfc_add_block_to_block (&se
->post
, &argse
.post
);
240 argarray
[curr_arg
] = argse
.expr
;
244 /* Count the number of actual arguments to the intrinsic function EXPR
245 including any "hidden" string length arguments. */
248 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
251 gfc_actual_arglist
*actual
;
253 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
258 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
268 /* Conversions between different types are output by the frontend as
269 intrinsic functions. We implement these directly with inline code. */
272 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
278 nargs
= gfc_intrinsic_argument_list_length (expr
);
279 args
= XALLOCAVEC (tree
, nargs
);
281 /* Evaluate all the arguments passed. Whilst we're only interested in the
282 first one here, there are other parts of the front-end that assume this
283 and will trigger an ICE if it's not the case. */
284 type
= gfc_typenode_for_spec (&expr
->ts
);
285 gcc_assert (expr
->value
.function
.actual
->expr
);
286 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
288 /* Conversion between character kinds involves a call to a library
290 if (expr
->ts
.type
== BT_CHARACTER
)
292 tree fndecl
, var
, addr
, tmp
;
294 if (expr
->ts
.kind
== 1
295 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
296 fndecl
= gfor_fndecl_convert_char4_to_char1
;
297 else if (expr
->ts
.kind
== 4
298 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
299 fndecl
= gfor_fndecl_convert_char1_to_char4
;
303 /* Create the variable storing the converted value. */
304 type
= gfc_get_pchar_type (expr
->ts
.kind
);
305 var
= gfc_create_var (type
, "str");
306 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
308 /* Call the library function that will perform the conversion. */
309 gcc_assert (nargs
>= 2);
310 tmp
= build_call_expr_loc (input_location
,
311 fndecl
, 3, addr
, args
[0], args
[1]);
312 gfc_add_expr_to_block (&se
->pre
, tmp
);
314 /* Free the temporary afterwards. */
315 tmp
= gfc_call_free (var
);
316 gfc_add_expr_to_block (&se
->post
, tmp
);
319 se
->string_length
= args
[0];
324 /* Conversion from complex to non-complex involves taking the real
325 component of the value. */
326 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
327 && expr
->ts
.type
!= BT_COMPLEX
)
331 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
332 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
336 se
->expr
= convert (type
, args
[0]);
339 /* This is needed because the gcc backend only implements
340 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
341 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
342 Similarly for CEILING. */
345 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
352 argtype
= TREE_TYPE (arg
);
353 arg
= gfc_evaluate_now (arg
, pblock
);
355 intval
= convert (type
, arg
);
356 intval
= gfc_evaluate_now (intval
, pblock
);
358 tmp
= convert (argtype
, intval
);
359 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
360 boolean_type_node
, tmp
, arg
);
362 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
363 intval
, build_int_cst (type
, 1));
364 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
369 /* Round to nearest integer, away from zero. */
372 build_round_expr (tree arg
, tree restype
)
376 int argprec
, resprec
;
378 argtype
= TREE_TYPE (arg
);
379 argprec
= TYPE_PRECISION (argtype
);
380 resprec
= TYPE_PRECISION (restype
);
382 /* Depending on the type of the result, choose the int intrinsic
383 (iround, available only as a builtin, therefore cannot use it for
384 __float128), long int intrinsic (lround family) or long long
385 intrinsic (llround). We might also need to convert the result
387 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
388 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
389 else if (resprec
<= LONG_TYPE_SIZE
)
390 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
391 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
392 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
396 return fold_convert (restype
, build_call_expr_loc (input_location
,
401 /* Convert a real to an integer using a specific rounding mode.
402 Ideally we would just build the corresponding GENERIC node,
403 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
406 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
407 enum rounding_mode op
)
412 return build_fixbound_expr (pblock
, arg
, type
, 0);
416 return build_fixbound_expr (pblock
, arg
, type
, 1);
420 return build_round_expr (arg
, type
);
424 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
433 /* Round a real value using the specified rounding mode.
434 We use a temporary integer of that same kind size as the result.
435 Values larger than those that can be represented by this kind are
436 unchanged, as they will not be accurate enough to represent the
438 huge = HUGE (KIND (a))
439 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
443 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
455 kind
= expr
->ts
.kind
;
456 nargs
= gfc_intrinsic_argument_list_length (expr
);
459 /* We have builtin functions for some cases. */
463 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
467 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
474 /* Evaluate the argument. */
475 gcc_assert (expr
->value
.function
.actual
->expr
);
476 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
478 /* Use a builtin function if one exists. */
479 if (decl
!= NULL_TREE
)
481 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
485 /* This code is probably redundant, but we'll keep it lying around just
487 type
= gfc_typenode_for_spec (&expr
->ts
);
488 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
490 /* Test if the value is too large to handle sensibly. */
491 gfc_set_model_kind (kind
);
493 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
494 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
495 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
496 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
499 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
500 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
501 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
503 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
505 itype
= gfc_get_int_type (kind
);
507 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
508 tmp
= convert (type
, tmp
);
509 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
515 /* Convert to an integer using the specified rounding mode. */
518 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
524 nargs
= gfc_intrinsic_argument_list_length (expr
);
525 args
= XALLOCAVEC (tree
, nargs
);
527 /* Evaluate the argument, we process all arguments even though we only
528 use the first one for code generation purposes. */
529 type
= gfc_typenode_for_spec (&expr
->ts
);
530 gcc_assert (expr
->value
.function
.actual
->expr
);
531 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
533 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
535 /* Conversion to a different integer kind. */
536 se
->expr
= convert (type
, args
[0]);
540 /* Conversion from complex to non-complex involves taking the real
541 component of the value. */
542 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
543 && expr
->ts
.type
!= BT_COMPLEX
)
547 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
548 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
552 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
557 /* Get the imaginary component of a value. */
560 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
564 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
565 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
566 TREE_TYPE (TREE_TYPE (arg
)), arg
);
570 /* Get the complex conjugate of a value. */
573 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
577 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
578 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
584 define_quad_builtin (const char *name
, tree type
, bool is_const
)
587 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
590 /* Mark the decl as external. */
591 DECL_EXTERNAL (fndecl
) = 1;
592 TREE_PUBLIC (fndecl
) = 1;
594 /* Mark it __attribute__((const)). */
595 TREE_READONLY (fndecl
) = is_const
;
597 rest_of_decl_compilation (fndecl
, 1, 0);
604 /* Initialize function decls for library functions. The external functions
605 are created as required. Builtin functions are added here. */
608 gfc_build_intrinsic_lib_fndecls (void)
610 gfc_intrinsic_map_t
*m
;
611 tree quad_decls
[END_BUILTINS
+ 1];
613 if (gfc_real16_is_float128
)
615 /* If we have soft-float types, we create the decls for their
616 C99-like library functions. For now, we only handle __float128
617 q-suffixed functions. */
619 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
620 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
622 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
624 type
= gfc_float128_type_node
;
625 complex_type
= gfc_complex_float128_type_node
;
626 /* type (*) (type) */
627 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
629 func_iround
= build_function_type_list (integer_type_node
,
631 /* long (*) (type) */
632 func_lround
= build_function_type_list (long_integer_type_node
,
634 /* long long (*) (type) */
635 func_llround
= build_function_type_list (long_long_integer_type_node
,
637 /* type (*) (type, type) */
638 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
639 /* type (*) (type, &int) */
641 = build_function_type_list (type
,
643 build_pointer_type (integer_type_node
),
645 /* type (*) (type, int) */
646 func_scalbn
= build_function_type_list (type
,
647 type
, integer_type_node
, NULL_TREE
);
648 /* type (*) (complex type) */
649 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
650 /* complex type (*) (complex type, complex type) */
652 = build_function_type_list (complex_type
,
653 complex_type
, complex_type
, NULL_TREE
);
655 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
656 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
657 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
659 /* Only these built-ins are actually needed here. These are used directly
660 from the code, when calling builtin_decl_for_precision() or
661 builtin_decl_for_float_type(). The others are all constructed by
662 gfc_get_intrinsic_lib_fndecl(). */
663 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
664 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
666 #include "mathbuiltins.def"
670 #undef DEFINE_MATH_BUILTIN
671 #undef DEFINE_MATH_BUILTIN_C
673 /* There is one built-in we defined manually, because it gets called
674 with builtin_decl_for_precision() or builtin_decl_for_float_type()
675 even though it is not an OTHER_BUILTIN: it is SQRT. */
676 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
680 /* Add GCC builtin functions. */
681 for (m
= gfc_intrinsic_map
;
682 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
684 if (m
->float_built_in
!= END_BUILTINS
)
685 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
686 if (m
->complex_float_built_in
!= END_BUILTINS
)
687 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
688 if (m
->double_built_in
!= END_BUILTINS
)
689 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
690 if (m
->complex_double_built_in
!= END_BUILTINS
)
691 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
693 /* If real(kind=10) exists, it is always long double. */
694 if (m
->long_double_built_in
!= END_BUILTINS
)
695 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
696 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
698 = builtin_decl_explicit (m
->complex_long_double_built_in
);
700 if (!gfc_real16_is_float128
)
702 if (m
->long_double_built_in
!= END_BUILTINS
)
703 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
704 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
706 = builtin_decl_explicit (m
->complex_long_double_built_in
);
708 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
710 /* Quad-precision function calls are constructed when first
711 needed by builtin_decl_for_precision(), except for those
712 that will be used directly (define by OTHER_BUILTIN). */
713 m
->real16_decl
= quad_decls
[m
->double_built_in
];
715 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
717 /* Same thing for the complex ones. */
718 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
724 /* Create a fndecl for a simple intrinsic library function. */
727 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
730 vec
<tree
, va_gc
> *argtypes
;
732 gfc_actual_arglist
*actual
;
735 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
738 if (ts
->type
== BT_REAL
)
743 pdecl
= &m
->real4_decl
;
746 pdecl
= &m
->real8_decl
;
749 pdecl
= &m
->real10_decl
;
752 pdecl
= &m
->real16_decl
;
758 else if (ts
->type
== BT_COMPLEX
)
760 gcc_assert (m
->complex_available
);
765 pdecl
= &m
->complex4_decl
;
768 pdecl
= &m
->complex8_decl
;
771 pdecl
= &m
->complex10_decl
;
774 pdecl
= &m
->complex16_decl
;
788 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
789 if (gfc_real_kinds
[n
].c_float
)
790 snprintf (name
, sizeof (name
), "%s%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
792 else if (gfc_real_kinds
[n
].c_double
)
793 snprintf (name
, sizeof (name
), "%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
795 else if (gfc_real_kinds
[n
].c_long_double
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
798 else if (gfc_real_kinds
[n
].c_float128
)
799 snprintf (name
, sizeof (name
), "%s%s%s",
800 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
806 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
807 ts
->type
== BT_COMPLEX
? 'c' : 'r',
812 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
814 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
815 vec_safe_push (argtypes
, type
);
817 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
818 fndecl
= build_decl (input_location
,
819 FUNCTION_DECL
, get_identifier (name
), type
);
821 /* Mark the decl as external. */
822 DECL_EXTERNAL (fndecl
) = 1;
823 TREE_PUBLIC (fndecl
) = 1;
825 /* Mark it __attribute__((const)), if possible. */
826 TREE_READONLY (fndecl
) = m
->is_constant
;
828 rest_of_decl_compilation (fndecl
, 1, 0);
835 /* Convert an intrinsic function into an external or builtin call. */
838 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
840 gfc_intrinsic_map_t
*m
;
844 unsigned int num_args
;
847 id
= expr
->value
.function
.isym
->id
;
848 /* Find the entry for this function. */
849 for (m
= gfc_intrinsic_map
;
850 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
856 if (m
->id
== GFC_ISYM_NONE
)
858 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
859 expr
->value
.function
.name
, id
);
862 /* Get the decl and generate the call. */
863 num_args
= gfc_intrinsic_argument_list_length (expr
);
864 args
= XALLOCAVEC (tree
, num_args
);
866 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
867 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
868 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
870 fndecl
= build_addr (fndecl
);
871 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
875 /* If bounds-checking is enabled, create code to verify at runtime that the
876 string lengths for both expressions are the same (needed for e.g. MERGE).
877 If bounds-checking is not enabled, does nothing. */
880 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
881 tree a
, tree b
, stmtblock_t
* target
)
886 /* If bounds-checking is disabled, do nothing. */
887 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
890 /* Compare the two string lengths. */
891 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
893 /* Output the runtime-check. */
894 name
= gfc_build_cstring_const (intr_name
);
895 name
= gfc_build_addr_expr (pchar_type_node
, name
);
896 gfc_trans_runtime_check (true, false, cond
, target
, where
,
897 "Unequal character lengths (%ld/%ld) in %s",
898 fold_convert (long_integer_type_node
, a
),
899 fold_convert (long_integer_type_node
, b
), name
);
903 /* The EXPONENT(X) intrinsic function is translated into
905 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
906 so that if X is a NaN or infinity, the result is HUGE(0).
910 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
912 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
915 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
916 expr
->value
.function
.actual
->expr
->ts
.kind
);
918 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
919 arg
= gfc_evaluate_now (arg
, &se
->pre
);
921 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
922 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
923 cond
= build_call_expr_loc (input_location
,
924 builtin_decl_explicit (BUILT_IN_ISFINITE
),
927 res
= gfc_create_var (integer_type_node
, NULL
);
928 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
929 gfc_build_addr_expr (NULL_TREE
, res
));
930 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
932 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
935 type
= gfc_typenode_for_spec (&expr
->ts
);
936 se
->expr
= fold_convert (type
, se
->expr
);
940 /* Fill in the following structure
941 struct caf_vector_t {
942 size_t nvec; // size of the vector
949 ptrdiff_t lower_bound;
950 ptrdiff_t upper_bound;
957 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
958 tree lower
, tree upper
, tree stride
,
959 tree vector
, int kind
, tree nvec
)
961 tree field
, type
, tmp
;
963 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
964 type
= TREE_TYPE (desc
);
966 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
967 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
968 desc
, field
, NULL_TREE
);
969 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
972 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
973 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
974 desc
, field
, NULL_TREE
);
975 type
= TREE_TYPE (desc
);
977 /* Access the inner struct. */
978 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
979 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
980 desc
, field
, NULL_TREE
);
981 type
= TREE_TYPE (desc
);
983 if (vector
!= NULL_TREE
)
985 /* Set vector and kind. */
986 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
987 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
988 desc
, field
, NULL_TREE
);
989 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
990 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
991 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
992 desc
, field
, NULL_TREE
);
993 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
997 /* Set dim.lower/upper/stride. */
998 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
999 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1000 desc
, field
, NULL_TREE
);
1001 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1003 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1004 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1005 desc
, field
, NULL_TREE
);
1006 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1008 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1009 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1010 desc
, field
, NULL_TREE
);
1011 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1017 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1020 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1021 tree lbound
, ubound
, tmp
;
1024 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1026 for (i
= 0; i
< ar
->dimen
; i
++)
1027 switch (ar
->dimen_type
[i
])
1032 gfc_init_se (&argse
, NULL
);
1033 gfc_conv_expr (&argse
, ar
->end
[i
]);
1034 gfc_add_block_to_block (block
, &argse
.pre
);
1035 upper
= gfc_evaluate_now (argse
.expr
, block
);
1038 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1041 gfc_init_se (&argse
, NULL
);
1042 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1043 gfc_add_block_to_block (block
, &argse
.pre
);
1044 stride
= gfc_evaluate_now (argse
.expr
, block
);
1047 stride
= gfc_index_one_node
;
1053 gfc_init_se (&argse
, NULL
);
1054 gfc_conv_expr (&argse
, ar
->start
[i
]);
1055 gfc_add_block_to_block (block
, &argse
.pre
);
1056 lower
= gfc_evaluate_now (argse
.expr
, block
);
1059 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1060 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1063 stride
= gfc_index_one_node
;
1066 nvec
= size_zero_node
;
1067 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1072 gfc_init_se (&argse
, NULL
);
1073 argse
.descriptor_only
= 1;
1074 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1075 gfc_add_block_to_block (block
, &argse
.pre
);
1076 vector
= argse
.expr
;
1077 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1078 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1079 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1080 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1081 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1082 TREE_TYPE (nvec
), nvec
, tmp
);
1083 lower
= gfc_index_zero_node
;
1084 upper
= gfc_index_zero_node
;
1085 stride
= gfc_index_zero_node
;
1086 vector
= gfc_conv_descriptor_data_get (vector
);
1087 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1088 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1093 return gfc_build_addr_expr (NULL_TREE
, var
);
1098 compute_component_offset (tree field
, tree type
)
1101 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1102 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1104 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1105 DECL_FIELD_BIT_OFFSET (field
),
1107 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1110 return DECL_FIELD_OFFSET (field
);
1115 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1117 gfc_ref
*ref
= expr
->ref
;
1118 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1119 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1120 start
, end
, stride
, vector
, nvec
;
1122 bool ref_static_array
= false;
1123 tree last_component_ref_tree
= NULL_TREE
;
1128 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1129 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
;
1132 /* Prevent uninit-warning. */
1133 reference_type
= NULL_TREE
;
1134 last_type
= gfc_typenode_for_spec (&expr
->symtree
->n
.sym
->ts
);
1135 last_type_n
= expr
->symtree
->n
.sym
->ts
.type
;
1138 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0
1139 && ref
->u
.ar
.dimen
== 0)
1141 /* Skip pure coindexes. */
1145 tmp
= gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1146 reference_type
= TREE_TYPE (tmp
);
1148 if (caf_ref
== NULL_TREE
)
1151 /* Construct the chain of refs. */
1152 if (prev_caf_ref
!= NULL_TREE
)
1154 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1155 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1156 TREE_TYPE (field
), prev_caf_ref
, field
,
1158 gfc_add_modify (block
, tmp2
, gfc_build_addr_expr (TREE_TYPE (field
),
1166 last_type
= gfc_typenode_for_spec (&ref
->u
.c
.component
->ts
);
1167 last_type_n
= ref
->u
.c
.component
->ts
.type
;
1168 /* Set the type of the ref. */
1169 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1170 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1171 TREE_TYPE (field
), prev_caf_ref
, field
,
1173 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1174 GFC_CAF_REF_COMPONENT
));
1176 /* Ref the c in union u. */
1177 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1178 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1179 TREE_TYPE (field
), prev_caf_ref
, field
,
1181 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 0);
1182 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1183 TREE_TYPE (field
), tmp
, field
,
1186 /* Set the offset. */
1187 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1188 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1189 TREE_TYPE (field
), inner_struct
, field
,
1191 /* Computing the offset is somewhat harder. The bit_offset has to be
1192 taken into account. When the bit_offset in the field_decl is non-
1193 null, divide it by the bitsize_unit and add it to the regular
1195 tmp2
= compute_component_offset (ref
->u
.c
.component
->backend_decl
,
1197 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1199 /* Set caf_token_offset. */
1200 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 1);
1201 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1202 TREE_TYPE (field
), inner_struct
, field
,
1204 if (ref
->u
.c
.component
->attr
.allocatable
1205 && ref
->u
.c
.component
->attr
.dimension
)
1207 tree arr_desc_token_offset
;
1208 /* Get the token from the descriptor. */
1209 arr_desc_token_offset
= gfc_advance_chain (
1210 TYPE_FIELDS (TREE_TYPE (ref
->u
.c
.component
->backend_decl
)),
1211 4 /* CAF_TOKEN_FIELD */);
1212 arr_desc_token_offset
1213 = compute_component_offset (arr_desc_token_offset
,
1215 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
,
1216 TREE_TYPE (tmp2
), tmp2
,
1217 arr_desc_token_offset
);
1219 else if (ref
->u
.c
.component
->caf_token
)
1220 tmp2
= compute_component_offset (ref
->u
.c
.component
->caf_token
,
1223 tmp2
= integer_zero_node
;
1224 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1226 /* Remember whether this ref was to a non-allocatable/non-pointer
1227 component so the next array ref can be tailored correctly. */
1228 ref_static_array
= !ref
->u
.c
.component
->attr
.allocatable
;
1229 last_component_ref_tree
= ref_static_array
1230 ? ref
->u
.c
.component
->backend_decl
: NULL_TREE
;
1233 if (ref_static_array
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
)
1234 ref_static_array
= false;
1235 /* Set the type of the ref. */
1236 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1237 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1238 TREE_TYPE (field
), prev_caf_ref
, field
,
1240 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1242 ? GFC_CAF_REF_STATIC_ARRAY
1243 : GFC_CAF_REF_ARRAY
));
1245 /* Ref the a in union u. */
1246 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1247 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1248 TREE_TYPE (field
), prev_caf_ref
, field
,
1250 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 1);
1251 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1252 TREE_TYPE (field
), tmp
, field
,
1255 /* Set the static_array_type in a for static arrays. */
1256 if (ref_static_array
)
1258 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)),
1260 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1261 TREE_TYPE (field
), inner_struct
, field
,
1263 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (tmp
),
1266 /* Ref the mode in the inner_struct. */
1267 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1268 mode
= fold_build3_loc (input_location
, COMPONENT_REF
,
1269 TREE_TYPE (field
), inner_struct
, field
,
1271 /* Ref the dim in the inner_struct. */
1272 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 2);
1273 dim_array
= fold_build3_loc (input_location
, COMPONENT_REF
,
1274 TREE_TYPE (field
), inner_struct
, field
,
1276 for (i
= 0; i
< ref
->u
.ar
.dimen
; ++i
)
1279 dim
= gfc_build_array_ref (dim_array
, gfc_rank_cst
[i
], NULL_TREE
);
1280 dim_type
= TREE_TYPE (dim
);
1281 mode_rhs
= start
= end
= stride
= NULL_TREE
;
1282 switch (ref
->u
.ar
.dimen_type
[i
])
1285 if (ref
->u
.ar
.end
[i
])
1287 gfc_init_se (&se
, NULL
);
1288 gfc_conv_expr (&se
, ref
->u
.ar
.end
[i
]);
1289 gfc_add_block_to_block (block
, &se
.pre
);
1290 if (ref_static_array
)
1292 /* Make the index zero-based, when reffing a static
1295 gfc_init_se (&se
, NULL
);
1296 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1297 gfc_add_block_to_block (block
, &se
.pre
);
1298 se
.expr
= fold_build2 (MINUS_EXPR
,
1299 gfc_array_index_type
,
1301 gfc_array_index_type
,
1304 end
= gfc_evaluate_now (fold_convert (
1305 gfc_array_index_type
,
1309 else if (ref_static_array
)
1310 end
= fold_build2 (MINUS_EXPR
,
1311 gfc_array_index_type
,
1312 gfc_conv_array_ubound (
1313 last_component_ref_tree
, i
),
1314 gfc_conv_array_lbound (
1315 last_component_ref_tree
, i
));
1319 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1320 GFC_CAF_ARR_REF_OPEN_END
);
1322 if (ref
->u
.ar
.stride
[i
])
1324 gfc_init_se (&se
, NULL
);
1325 gfc_conv_expr (&se
, ref
->u
.ar
.stride
[i
]);
1326 gfc_add_block_to_block (block
, &se
.pre
);
1327 stride
= gfc_evaluate_now (fold_convert (
1328 gfc_array_index_type
,
1331 if (ref_static_array
)
1333 /* Make the index zero-based, when reffing a static
1335 stride
= fold_build2 (MULT_EXPR
,
1336 gfc_array_index_type
,
1337 gfc_conv_array_stride (
1338 last_component_ref_tree
,
1341 gcc_assert (end
!= NULL_TREE
);
1342 /* Multiply with the product of array's stride and
1343 the step of the ref to a virtual upper bound.
1344 We can not compute the actual upper bound here or
1345 the caflib would compute the extend
1347 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1348 end
, gfc_conv_array_stride (
1349 last_component_ref_tree
,
1351 end
= gfc_evaluate_now (end
, block
);
1352 stride
= gfc_evaluate_now (stride
, block
);
1355 else if (ref_static_array
)
1357 stride
= gfc_conv_array_stride (last_component_ref_tree
,
1359 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1361 end
= gfc_evaluate_now (end
, block
);
1364 /* Always set a ref stride of one to make caflib's
1366 stride
= gfc_index_one_node
;
1370 if (ref
->u
.ar
.start
[i
])
1372 gfc_init_se (&se
, NULL
);
1373 gfc_conv_expr (&se
, ref
->u
.ar
.start
[i
]);
1374 gfc_add_block_to_block (block
, &se
.pre
);
1375 if (ref_static_array
)
1377 /* Make the index zero-based, when reffing a static
1379 start
= fold_convert (gfc_array_index_type
, se
.expr
);
1380 gfc_init_se (&se
, NULL
);
1381 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1382 gfc_add_block_to_block (block
, &se
.pre
);
1383 se
.expr
= fold_build2 (MINUS_EXPR
,
1384 gfc_array_index_type
,
1385 start
, fold_convert (
1386 gfc_array_index_type
,
1388 /* Multiply with the stride. */
1389 se
.expr
= fold_build2 (MULT_EXPR
,
1390 gfc_array_index_type
,
1392 gfc_conv_array_stride (
1393 last_component_ref_tree
,
1396 start
= gfc_evaluate_now (fold_convert (
1397 gfc_array_index_type
,
1400 if (mode_rhs
== NULL_TREE
)
1401 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1402 ref
->u
.ar
.dimen_type
[i
]
1404 ? GFC_CAF_ARR_REF_SINGLE
1405 : GFC_CAF_ARR_REF_RANGE
);
1407 else if (ref_static_array
)
1409 start
= integer_zero_node
;
1410 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1411 ref
->u
.ar
.start
[i
] == NULL
1412 ? GFC_CAF_ARR_REF_FULL
1413 : GFC_CAF_ARR_REF_RANGE
);
1415 else if (end
== NULL_TREE
)
1416 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1417 GFC_CAF_ARR_REF_FULL
);
1419 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1420 GFC_CAF_ARR_REF_OPEN_START
);
1422 /* Ref the s in dim. */
1423 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 0);
1424 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1425 TREE_TYPE (field
), dim
, field
,
1428 /* Set start in s. */
1429 if (start
!= NULL_TREE
)
1431 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1433 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1434 TREE_TYPE (field
), tmp
, field
,
1436 gfc_add_modify (block
, tmp2
,
1437 fold_convert (TREE_TYPE (tmp2
), start
));
1441 if (end
!= NULL_TREE
)
1443 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1445 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1446 TREE_TYPE (field
), tmp
, field
,
1448 gfc_add_modify (block
, tmp2
,
1449 fold_convert (TREE_TYPE (tmp2
), end
));
1453 if (stride
!= NULL_TREE
)
1455 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1457 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1458 TREE_TYPE (field
), tmp
, field
,
1460 gfc_add_modify (block
, tmp2
,
1461 fold_convert (TREE_TYPE (tmp2
), stride
));
1465 /* TODO: In case of static array. */
1466 gcc_assert (!ref_static_array
);
1467 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1468 GFC_CAF_ARR_REF_VECTOR
);
1469 gfc_init_se (&se
, NULL
);
1470 se
.descriptor_only
= 1;
1471 gfc_conv_expr_descriptor (&se
, ref
->u
.ar
.start
[i
]);
1472 gfc_add_block_to_block (block
, &se
.pre
);
1474 tmp
= gfc_conv_descriptor_lbound_get (vector
,
1476 tmp2
= gfc_conv_descriptor_ubound_get (vector
,
1478 nvec
= gfc_conv_array_extent_dim (tmp
, tmp2
, NULL
);
1479 tmp
= gfc_conv_descriptor_stride_get (vector
,
1481 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1482 TREE_TYPE (nvec
), nvec
, tmp
);
1483 vector
= gfc_conv_descriptor_data_get (vector
);
1485 /* Ref the v in dim. */
1486 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 1);
1487 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1488 TREE_TYPE (field
), dim
, field
,
1491 /* Set vector in v. */
1492 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 0);
1493 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1494 TREE_TYPE (field
), tmp
, field
,
1496 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1499 /* Set nvec in v. */
1500 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 1);
1501 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1502 TREE_TYPE (field
), tmp
, field
,
1504 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1507 /* Set kind in v. */
1508 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 2);
1509 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1510 TREE_TYPE (field
), tmp
, field
,
1512 gfc_add_modify (block
, tmp2
, build_int_cst (integer_type_node
,
1513 ref
->u
.ar
.start
[i
]->ts
.kind
));
1518 /* Set the mode for dim i. */
1519 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1520 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
),
1524 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1525 if (i
< GFC_MAX_DIMENSIONS
)
1527 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1528 gfc_add_modify (block
, tmp
,
1529 build_int_cst (unsigned_char_type_node
,
1530 GFC_CAF_ARR_REF_NONE
));
1537 /* Set the size of the current type. */
1538 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 2);
1539 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1540 prev_caf_ref
, field
, NULL_TREE
);
1541 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1542 TYPE_SIZE_UNIT (last_type
)));
1547 if (prev_caf_ref
!= NULL_TREE
)
1549 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1550 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1551 prev_caf_ref
, field
, NULL_TREE
);
1552 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1553 null_pointer_node
));
1555 return caf_ref
!= NULL_TREE
? gfc_build_addr_expr (NULL_TREE
, caf_ref
)
1559 /* Get data from a remote coarray. */
1562 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1563 tree may_require_tmp
, bool may_realloc
,
1564 symbol_attribute
*caf_attr
)
1566 gfc_expr
*array_expr
, *tmp_stat
;
1568 tree caf_decl
, token
, offset
, image_index
, tmp
;
1569 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
1571 symbol_attribute caf_attr_store
;
1573 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1575 if (se
->ss
&& se
->ss
->info
->useflags
)
1577 /* Access the previously obtained result. */
1578 gfc_conv_tmp_array_ref (se
);
1582 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1583 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1584 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1586 if (caf_attr
== NULL
)
1588 caf_attr_store
= gfc_caf_attr (array_expr
);
1589 caf_attr
= &caf_attr_store
;
1595 vec
= null_pointer_node
;
1596 tmp_stat
= gfc_find_stat_co (expr
);
1601 gfc_init_se (&stat_se
, NULL
);
1602 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1603 stat
= stat_se
.expr
;
1604 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1605 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1608 stat
= null_pointer_node
;
1610 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1611 is reallocatable or the right-hand side has allocatable components. */
1612 if (caf_attr
->alloc_comp
|| may_realloc
)
1614 /* Get using caf_get_by_ref. */
1615 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, array_expr
);
1617 if (caf_reference
!= NULL_TREE
)
1619 if (lhs
== NULL_TREE
)
1621 if (array_expr
->ts
.type
== BT_CHARACTER
)
1622 gfc_init_se (&argse
, NULL
);
1623 if (array_expr
->rank
== 0)
1625 symbol_attribute attr
;
1626 gfc_clear_attr (&attr
);
1627 if (array_expr
->ts
.type
== BT_CHARACTER
)
1629 res_var
= gfc_conv_string_tmp (se
,
1630 build_pointer_type (type
),
1631 array_expr
->ts
.u
.cl
->backend_decl
);
1632 argse
.string_length
= array_expr
->ts
.u
.cl
->backend_decl
;
1635 res_var
= gfc_create_var (type
, "caf_res");
1636 dst_var
= gfc_conv_scalar_to_descriptor (se
, res_var
, attr
);
1637 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1641 /* Create temporary. */
1642 if (array_expr
->ts
.type
== BT_CHARACTER
)
1643 gfc_conv_expr_descriptor (&argse
, array_expr
);
1644 may_realloc
= gfc_trans_create_temp_array (&se
->pre
,
1651 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1652 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1655 tmp
= gfc_conv_descriptor_data_get (res_var
);
1656 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
,
1657 NULL_TREE
, NULL_TREE
,
1660 gfc_add_expr_to_block (&se
->post
, tmp
);
1665 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1666 if (lhs_kind
== NULL_TREE
)
1669 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1670 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1671 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1672 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1674 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1677 /* No overlap possible as we have generated a temporary. */
1678 if (lhs
== NULL_TREE
)
1679 may_require_tmp
= boolean_false_node
;
1681 /* It guarantees memory consistency within the same segment. */
1682 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1683 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1684 gfc_build_string_const (1, ""), NULL_TREE
,
1685 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1687 ASM_VOLATILE_P (tmp
) = 1;
1688 gfc_add_expr_to_block (&se
->pre
, tmp
);
1690 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1691 9, token
, image_index
, dst_var
,
1692 caf_reference
, lhs_kind
, kind
,
1694 may_realloc
? boolean_true_node
:
1698 gfc_add_expr_to_block (&se
->pre
, tmp
);
1701 gfc_advance_se_ss_chain (se
);
1704 if (array_expr
->ts
.type
== BT_CHARACTER
)
1705 se
->string_length
= argse
.string_length
;
1711 gfc_init_se (&argse
, NULL
);
1712 if (array_expr
->rank
== 0)
1714 symbol_attribute attr
;
1716 gfc_clear_attr (&attr
);
1717 gfc_conv_expr (&argse
, array_expr
);
1719 if (lhs
== NULL_TREE
)
1721 gfc_clear_attr (&attr
);
1722 if (array_expr
->ts
.type
== BT_CHARACTER
)
1723 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1724 argse
.string_length
);
1726 res_var
= gfc_create_var (type
, "caf_res");
1727 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1728 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1730 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1731 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1735 /* If has_vector, pass descriptor for whole array and the
1736 vector bounds separately. */
1737 gfc_array_ref
*ar
, ar2
;
1738 bool has_vector
= false;
1740 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1743 ar
= gfc_find_array_ref (expr
);
1745 memset (ar
, '\0', sizeof (*ar
));
1749 gfc_conv_expr_descriptor (&argse
, array_expr
);
1750 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1751 has the wrong type if component references are done. */
1752 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1753 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1758 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1762 if (lhs
== NULL_TREE
)
1764 /* Create temporary. */
1765 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1766 if (se
->loop
->to
[n
] == NULL_TREE
)
1768 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1770 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1773 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1774 NULL_TREE
, false, true, false,
1775 &array_expr
->where
);
1776 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1777 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1779 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1782 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1783 if (lhs_kind
== NULL_TREE
)
1786 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1787 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1789 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1790 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1791 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1792 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1793 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1796 /* No overlap possible as we have generated a temporary. */
1797 if (lhs
== NULL_TREE
)
1798 may_require_tmp
= boolean_false_node
;
1800 /* It guarantees memory consistency within the same segment. */
1801 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1802 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1803 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1804 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1805 ASM_VOLATILE_P (tmp
) = 1;
1806 gfc_add_expr_to_block (&se
->pre
, tmp
);
1808 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1809 token
, offset
, image_index
, argse
.expr
, vec
,
1810 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1812 gfc_add_expr_to_block (&se
->pre
, tmp
);
1815 gfc_advance_se_ss_chain (se
);
1818 if (array_expr
->ts
.type
== BT_CHARACTER
)
1819 se
->string_length
= argse
.string_length
;
1823 /* Send data to a remote coarray. */
1826 conv_caf_send (gfc_code
*code
) {
1827 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
;
1828 gfc_se lhs_se
, rhs_se
;
1830 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1831 tree may_require_tmp
, src_stat
, dst_stat
;
1832 tree lhs_type
= NULL_TREE
;
1833 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1834 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1836 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1838 lhs_expr
= code
->ext
.actual
->expr
;
1839 rhs_expr
= code
->ext
.actual
->next
->expr
;
1840 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1841 ? boolean_false_node
: boolean_true_node
;
1842 gfc_init_block (&block
);
1844 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1845 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1846 src_stat
= dst_stat
= null_pointer_node
;
1849 gfc_init_se (&lhs_se
, NULL
);
1850 if (lhs_expr
->rank
== 0)
1852 symbol_attribute attr
;
1853 gfc_clear_attr (&attr
);
1854 gfc_conv_expr (&lhs_se
, lhs_expr
);
1855 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1856 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1857 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1859 else if (lhs_caf_attr
.alloc_comp
&& lhs_caf_attr
.codimension
)
1861 lhs_se
.want_pointer
= 1;
1862 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1863 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1864 has the wrong type if component references are done. */
1865 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1866 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1867 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1868 gfc_get_dtype_rank_type (
1869 gfc_has_vector_subscript (lhs_expr
)
1870 ? gfc_find_array_ref (lhs_expr
)->dimen
1876 /* If has_vector, pass descriptor for whole array and the
1877 vector bounds separately. */
1878 gfc_array_ref
*ar
, ar2
;
1879 bool has_vector
= false;
1881 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1884 ar
= gfc_find_array_ref (lhs_expr
);
1886 memset (ar
, '\0', sizeof (*ar
));
1890 lhs_se
.want_pointer
= 1;
1891 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1892 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1893 has the wrong type if component references are done. */
1894 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1895 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1896 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1897 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1902 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1907 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1909 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1910 temporary and a loop. */
1911 if (!gfc_is_coindexed (lhs_expr
) && !lhs_caf_attr
.codimension
)
1913 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
1914 gcc_assert (gfc_is_coindexed (rhs_expr
));
1915 gfc_init_se (&rhs_se
, NULL
);
1916 if (lhs_expr
->rank
== 0 && gfc_expr_attr (lhs_expr
).allocatable
)
1919 gfc_init_se (&scal_se
, NULL
);
1920 scal_se
.want_pointer
= 1;
1921 gfc_conv_expr (&scal_se
, lhs_expr
);
1922 /* Ensure scalar on lhs is allocated. */
1923 gfc_add_block_to_block (&block
, &scal_se
.pre
);
1925 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
1927 gfc_typenode_for_spec (&lhs_expr
->ts
)),
1929 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, scal_se
.expr
,
1931 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1932 tmp
, gfc_finish_block (&scal_se
.pre
),
1933 build_empty_stmt (input_location
));
1934 gfc_add_expr_to_block (&block
, tmp
);
1937 lhs_may_realloc
= lhs_may_realloc
1938 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
1939 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1940 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1941 may_require_tmp
, lhs_may_realloc
,
1943 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1944 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1945 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1946 return gfc_finish_block (&block
);
1949 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1951 /* Obtain token, offset and image index for the LHS. */
1952 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1953 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1954 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1955 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1957 if (lhs_caf_attr
.alloc_comp
)
1958 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
1961 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
1966 gfc_init_se (&rhs_se
, NULL
);
1967 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1968 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1969 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1970 if (rhs_expr
->rank
== 0)
1972 symbol_attribute attr
;
1973 gfc_clear_attr (&attr
);
1974 gfc_conv_expr (&rhs_se
, rhs_expr
);
1975 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
1976 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
1978 else if (rhs_caf_attr
.alloc_comp
&& rhs_caf_attr
.codimension
)
1981 rhs_se
.want_pointer
= 1;
1982 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
1983 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1984 has the wrong type if component references are done. */
1985 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
1986 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
1987 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1988 gfc_get_dtype_rank_type (
1989 gfc_has_vector_subscript (rhs_expr
)
1990 ? gfc_find_array_ref (rhs_expr
)->dimen
1996 /* If has_vector, pass descriptor for whole array and the
1997 vector bounds separately. */
1998 gfc_array_ref
*ar
, ar2
;
1999 bool has_vector
= false;
2002 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2005 ar
= gfc_find_array_ref (rhs_expr
);
2007 memset (ar
, '\0', sizeof (*ar
));
2011 rhs_se
.want_pointer
= 1;
2012 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2013 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2014 has the wrong type if component references are done. */
2015 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2016 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2017 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2018 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2023 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2028 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2030 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2032 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2037 gfc_init_se (&stat_se
, NULL
);
2038 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2039 dst_stat
= stat_se
.expr
;
2040 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2041 gfc_add_block_to_block (&block
, &stat_se
.post
);
2044 if (!gfc_is_coindexed (rhs_expr
) && !rhs_caf_attr
.codimension
)
2046 if (lhs_caf_attr
.alloc_comp
)
2048 tree reference
, dst_realloc
;
2049 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2050 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2051 : boolean_false_node
;
2052 tmp
= build_call_expr_loc (input_location
,
2053 gfor_fndecl_caf_send_by_ref
,
2054 9, token
, image_index
, rhs_se
.expr
,
2055 reference
, lhs_kind
, rhs_kind
,
2056 may_require_tmp
, dst_realloc
, src_stat
);
2059 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 10,
2060 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2061 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2062 may_require_tmp
, src_stat
);
2066 tree rhs_token
, rhs_offset
, rhs_image_index
;
2068 /* It guarantees memory consistency within the same segment. */
2069 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2070 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2071 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2072 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2073 ASM_VOLATILE_P (tmp
) = 1;
2074 gfc_add_expr_to_block (&block
, tmp
);
2076 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2077 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2078 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2079 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2081 if (rhs_caf_attr
.alloc_comp
)
2083 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2088 gfc_init_se (&stat_se
, NULL
);
2089 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2090 src_stat
= stat_se
.expr
;
2091 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2092 gfc_add_block_to_block (&block
, &stat_se
.post
);
2095 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2097 tree lhs_reference
, rhs_reference
;
2098 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2099 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2100 tmp
= build_call_expr_loc (input_location
,
2101 gfor_fndecl_caf_sendget_by_ref
, 11,
2102 token
, image_index
, lhs_reference
,
2103 rhs_token
, rhs_image_index
, rhs_reference
,
2104 lhs_kind
, rhs_kind
, may_require_tmp
,
2105 dst_stat
, src_stat
);
2109 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2111 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2112 14, token
, offset
, image_index
,
2113 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2114 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2115 rhs_kind
, may_require_tmp
, src_stat
);
2118 gfc_add_expr_to_block (&block
, tmp
);
2119 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2120 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2122 /* It guarantees memory consistency within the same segment. */
2123 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2124 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2125 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2126 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2127 ASM_VOLATILE_P (tmp
) = 1;
2128 gfc_add_expr_to_block (&block
, tmp
);
2130 return gfc_finish_block (&block
);
2135 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2138 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2139 lbound
, ubound
, extent
, ml
;
2142 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2144 if (expr
->value
.function
.actual
->expr
2145 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2146 distance
= expr
->value
.function
.actual
->expr
;
2148 /* The case -fcoarray=single is handled elsewhere. */
2149 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2151 /* Argument-free version: THIS_IMAGE(). */
2152 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2156 gfc_init_se (&argse
, NULL
);
2157 gfc_conv_expr_val (&argse
, distance
);
2158 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2159 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2160 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2163 tmp
= integer_zero_node
;
2164 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2166 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2171 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2173 type
= gfc_get_int_type (gfc_default_integer_kind
);
2174 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2175 rank
= expr
->value
.function
.actual
->expr
->rank
;
2177 /* Obtain the descriptor of the COARRAY. */
2178 gfc_init_se (&argse
, NULL
);
2179 argse
.want_coarray
= 1;
2180 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2181 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2182 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2187 /* Create an implicit second parameter from the loop variable. */
2188 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2189 gcc_assert (corank
> 0);
2190 gcc_assert (se
->loop
->dimen
== 1);
2191 gcc_assert (se
->ss
->info
->expr
== expr
);
2193 dim_arg
= se
->loop
->loopvar
[0];
2194 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2195 gfc_array_index_type
, dim_arg
,
2196 build_int_cst (TREE_TYPE (dim_arg
), 1));
2197 gfc_advance_se_ss_chain (se
);
2201 /* Use the passed DIM= argument. */
2202 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2203 gfc_init_se (&argse
, NULL
);
2204 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2205 gfc_array_index_type
);
2206 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2207 dim_arg
= argse
.expr
;
2209 if (INTEGER_CST_P (dim_arg
))
2211 if (wi::ltu_p (dim_arg
, 1)
2212 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2213 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2214 "dimension index", expr
->value
.function
.isym
->name
,
2217 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2219 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2220 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2222 build_int_cst (TREE_TYPE (dim_arg
), 1));
2223 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2224 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2226 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2227 boolean_type_node
, cond
, tmp
);
2228 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2233 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2234 one always has a dim_arg argument.
2236 m = this_image() - 1
2239 sub(1) = m + lcobound(corank)
2243 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2246 extent = gfc_extent(i)
2254 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2255 : m + lcobound(corank)
2258 /* this_image () - 1. */
2259 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2261 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2262 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2265 /* sub(1) = m + lcobound(corank). */
2266 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2267 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2269 lbound
= fold_convert (type
, lbound
);
2270 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2276 m
= gfc_create_var (type
, NULL
);
2277 ml
= gfc_create_var (type
, NULL
);
2278 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2279 min_var
= gfc_create_var (integer_type_node
, NULL
);
2281 /* m = this_image () - 1. */
2282 gfc_add_modify (&se
->pre
, m
, tmp
);
2284 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2285 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2286 fold_convert (integer_type_node
, dim_arg
),
2287 build_int_cst (integer_type_node
, rank
- 1));
2288 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2289 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2291 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2294 tmp
= build_int_cst (integer_type_node
, rank
);
2295 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2297 exit_label
= gfc_build_label_decl (NULL_TREE
);
2298 TREE_USED (exit_label
) = 1;
2301 gfc_init_block (&loop
);
2304 gfc_add_modify (&loop
, ml
, m
);
2307 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2308 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2309 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2310 extent
= fold_convert (type
, extent
);
2313 gfc_add_modify (&loop
, m
,
2314 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2317 /* Exit condition: if (i >= min_var) goto exit_label. */
2318 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
2320 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2321 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2322 build_empty_stmt (input_location
));
2323 gfc_add_expr_to_block (&loop
, tmp
);
2325 /* Increment loop variable: i++. */
2326 gfc_add_modify (&loop
, loop_var
,
2327 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2329 build_int_cst (integer_type_node
, 1)));
2331 /* Making the loop... actually loop! */
2332 tmp
= gfc_finish_block (&loop
);
2333 tmp
= build1_v (LOOP_EXPR
, tmp
);
2334 gfc_add_expr_to_block (&se
->pre
, tmp
);
2336 /* The exit label. */
2337 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2338 gfc_add_expr_to_block (&se
->pre
, tmp
);
2340 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2341 : m + lcobound(corank) */
2343 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
2344 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2346 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2347 fold_build2_loc (input_location
, PLUS_EXPR
,
2348 gfc_array_index_type
, dim_arg
,
2349 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2350 lbound
= fold_convert (type
, lbound
);
2352 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2353 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2355 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2357 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2358 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2364 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2366 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2368 gfc_se argse
, subse
;
2369 int rank
, corank
, codim
;
2371 type
= gfc_get_int_type (gfc_default_integer_kind
);
2372 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2373 rank
= expr
->value
.function
.actual
->expr
->rank
;
2375 /* Obtain the descriptor of the COARRAY. */
2376 gfc_init_se (&argse
, NULL
);
2377 argse
.want_coarray
= 1;
2378 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2379 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2380 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2383 /* Obtain a handle to the SUB argument. */
2384 gfc_init_se (&subse
, NULL
);
2385 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2386 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2387 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2388 subdesc
= build_fold_indirect_ref_loc (input_location
,
2389 gfc_conv_descriptor_data_get (subse
.expr
));
2391 /* Fortran 2008 does not require that the values remain in the cobounds,
2392 thus we need explicitly check this - and return 0 if they are exceeded. */
2394 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2395 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2396 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2397 fold_convert (gfc_array_index_type
, tmp
),
2400 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2402 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2403 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2404 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2405 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2406 fold_convert (gfc_array_index_type
, tmp
),
2408 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2409 boolean_type_node
, invalid_bound
, cond
);
2410 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2411 fold_convert (gfc_array_index_type
, tmp
),
2413 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2414 boolean_type_node
, invalid_bound
, cond
);
2417 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2419 /* See Fortran 2008, C.10 for the following algorithm. */
2421 /* coindex = sub(corank) - lcobound(n). */
2422 coindex
= fold_convert (gfc_array_index_type
,
2423 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2425 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2426 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2427 fold_convert (gfc_array_index_type
, coindex
),
2430 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2432 tree extent
, ubound
;
2434 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2435 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2436 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2437 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2439 /* coindex *= extent. */
2440 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2441 gfc_array_index_type
, coindex
, extent
);
2443 /* coindex += sub(codim). */
2444 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2445 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2446 gfc_array_index_type
, coindex
,
2447 fold_convert (gfc_array_index_type
, tmp
));
2449 /* coindex -= lbound(codim). */
2450 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2451 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2452 gfc_array_index_type
, coindex
, lbound
);
2455 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2456 fold_convert(type
, coindex
),
2457 build_int_cst (type
, 1));
2459 /* Return 0 if "coindex" exceeds num_images(). */
2461 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2462 num_images
= build_int_cst (type
, 1);
2465 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2467 build_int_cst (integer_type_node
, -1));
2468 num_images
= fold_convert (type
, tmp
);
2471 tmp
= gfc_create_var (type
, NULL
);
2472 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2474 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
2476 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
2478 fold_convert (boolean_type_node
, invalid_bound
));
2479 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2480 build_int_cst (type
, 0), tmp
);
2485 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2487 tree tmp
, distance
, failed
;
2490 if (expr
->value
.function
.actual
->expr
)
2492 gfc_init_se (&argse
, NULL
);
2493 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2494 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2495 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2496 distance
= fold_convert (integer_type_node
, argse
.expr
);
2499 distance
= integer_zero_node
;
2501 if (expr
->value
.function
.actual
->next
->expr
)
2503 gfc_init_se (&argse
, NULL
);
2504 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2505 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2506 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2507 failed
= fold_convert (integer_type_node
, argse
.expr
);
2510 failed
= build_int_cst (integer_type_node
, -1);
2512 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2514 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2519 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2523 gfc_init_se (&argse
, NULL
);
2524 argse
.data_not_needed
= 1;
2525 argse
.descriptor_only
= 1;
2527 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2528 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2529 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2531 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2535 /* Evaluate a single upper or lower bound. */
2536 /* TODO: bound intrinsic generates way too much unnecessary code. */
2539 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2541 gfc_actual_arglist
*arg
;
2542 gfc_actual_arglist
*arg2
;
2547 tree cond
, cond1
, cond3
, cond4
, size
;
2551 gfc_array_spec
* as
;
2552 bool assumed_rank_lb_one
;
2554 arg
= expr
->value
.function
.actual
;
2559 /* Create an implicit second parameter from the loop variable. */
2560 gcc_assert (!arg2
->expr
);
2561 gcc_assert (se
->loop
->dimen
== 1);
2562 gcc_assert (se
->ss
->info
->expr
== expr
);
2563 gfc_advance_se_ss_chain (se
);
2564 bound
= se
->loop
->loopvar
[0];
2565 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2566 gfc_array_index_type
, bound
,
2571 /* use the passed argument. */
2572 gcc_assert (arg2
->expr
);
2573 gfc_init_se (&argse
, NULL
);
2574 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2575 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2577 /* Convert from one based to zero based. */
2578 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2579 gfc_array_index_type
, bound
,
2580 gfc_index_one_node
);
2583 /* TODO: don't re-evaluate the descriptor on each iteration. */
2584 /* Get a descriptor for the first parameter. */
2585 gfc_init_se (&argse
, NULL
);
2586 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2587 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2588 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2592 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2594 if (INTEGER_CST_P (bound
))
2596 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2597 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2598 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
2599 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2600 "dimension index", upper
? "UBOUND" : "LBOUND",
2604 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
2606 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2608 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2609 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2610 bound
, build_int_cst (TREE_TYPE (bound
), 0));
2611 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2612 tmp
= gfc_conv_descriptor_rank (desc
);
2614 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
2615 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2616 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
2617 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2618 boolean_type_node
, cond
, tmp
);
2619 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2624 /* Take care of the lbound shift for assumed-rank arrays, which are
2625 nonallocatable and nonpointers. Those has a lbound of 1. */
2626 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
2627 && ((arg
->expr
->ts
.type
!= BT_CLASS
2628 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
2629 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
2630 || (arg
->expr
->ts
.type
== BT_CLASS
2631 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
2632 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
2634 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2635 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2637 /* 13.14.53: Result value for LBOUND
2639 Case (i): For an array section or for an array expression other than a
2640 whole array or array structure component, LBOUND(ARRAY, DIM)
2641 has the value 1. For a whole array or array structure
2642 component, LBOUND(ARRAY, DIM) has the value:
2643 (a) equal to the lower bound for subscript DIM of ARRAY if
2644 dimension DIM of ARRAY does not have extent zero
2645 or if ARRAY is an assumed-size array of rank DIM,
2648 13.14.113: Result value for UBOUND
2650 Case (i): For an array section or for an array expression other than a
2651 whole array or array structure component, UBOUND(ARRAY, DIM)
2652 has the value equal to the number of elements in the given
2653 dimension; otherwise, it has a value equal to the upper bound
2654 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2655 not have size zero and has value zero if dimension DIM has
2658 if (!upper
&& assumed_rank_lb_one
)
2659 se
->expr
= gfc_index_one_node
;
2662 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
2664 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2666 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2667 stride
, gfc_index_zero_node
);
2668 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2669 boolean_type_node
, cond3
, cond1
);
2670 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2671 stride
, gfc_index_zero_node
);
2676 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2677 boolean_type_node
, cond3
, cond4
);
2678 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2679 gfc_index_one_node
, lbound
);
2680 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2681 boolean_type_node
, cond4
, cond5
);
2683 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2684 boolean_type_node
, cond
, cond5
);
2686 if (assumed_rank_lb_one
)
2688 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2689 gfc_array_index_type
, ubound
, lbound
);
2690 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2691 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2696 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2697 gfc_array_index_type
, cond
,
2698 tmp
, gfc_index_zero_node
);
2702 if (as
->type
== AS_ASSUMED_SIZE
)
2703 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2704 bound
, build_int_cst (TREE_TYPE (bound
),
2705 arg
->expr
->rank
- 1));
2707 cond
= boolean_false_node
;
2709 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2710 boolean_type_node
, cond3
, cond4
);
2711 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2712 boolean_type_node
, cond
, cond1
);
2714 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2715 gfc_array_index_type
, cond
,
2716 lbound
, gfc_index_one_node
);
2723 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2724 gfc_array_index_type
, ubound
, lbound
);
2725 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2726 gfc_array_index_type
, size
,
2727 gfc_index_one_node
);
2728 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2729 gfc_array_index_type
, se
->expr
,
2730 gfc_index_zero_node
);
2733 se
->expr
= gfc_index_one_node
;
2736 type
= gfc_typenode_for_spec (&expr
->ts
);
2737 se
->expr
= convert (type
, se
->expr
);
2742 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2744 gfc_actual_arglist
*arg
;
2745 gfc_actual_arglist
*arg2
;
2747 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2751 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2752 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2753 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2755 arg
= expr
->value
.function
.actual
;
2758 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2759 corank
= gfc_get_corank (arg
->expr
);
2761 gfc_init_se (&argse
, NULL
);
2762 argse
.want_coarray
= 1;
2764 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2765 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2766 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2771 /* Create an implicit second parameter from the loop variable. */
2772 gcc_assert (!arg2
->expr
);
2773 gcc_assert (corank
> 0);
2774 gcc_assert (se
->loop
->dimen
== 1);
2775 gcc_assert (se
->ss
->info
->expr
== expr
);
2777 bound
= se
->loop
->loopvar
[0];
2778 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2779 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2780 gfc_advance_se_ss_chain (se
);
2784 /* use the passed argument. */
2785 gcc_assert (arg2
->expr
);
2786 gfc_init_se (&argse
, NULL
);
2787 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2788 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2791 if (INTEGER_CST_P (bound
))
2793 if (wi::ltu_p (bound
, 1)
2794 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2795 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2796 "dimension index", expr
->value
.function
.isym
->name
,
2799 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2801 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2802 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2803 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2804 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2805 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2807 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2808 boolean_type_node
, cond
, tmp
);
2809 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2814 /* Subtract 1 to get to zero based and add dimensions. */
2815 switch (arg
->expr
->rank
)
2818 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2819 gfc_array_index_type
, bound
,
2820 gfc_index_one_node
);
2824 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2825 gfc_array_index_type
, bound
,
2826 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2830 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2832 /* Handle UCOBOUND with special handling of the last codimension. */
2833 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2835 /* Last codimension: For -fcoarray=single just return
2836 the lcobound - otherwise add
2837 ceiling (real (num_images ()) / real (size)) - 1
2838 = (num_images () + size - 1) / size - 1
2839 = (num_images - 1) / size(),
2840 where size is the product of the extent of all but the last
2843 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2847 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2848 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2849 2, integer_zero_node
,
2850 build_int_cst (integer_type_node
, -1));
2851 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2852 gfc_array_index_type
,
2853 fold_convert (gfc_array_index_type
, tmp
),
2854 build_int_cst (gfc_array_index_type
, 1));
2855 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2856 gfc_array_index_type
, tmp
,
2857 fold_convert (gfc_array_index_type
, cosize
));
2858 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2859 gfc_array_index_type
, resbound
, tmp
);
2861 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2863 /* ubound = lbound + num_images() - 1. */
2864 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2865 2, integer_zero_node
,
2866 build_int_cst (integer_type_node
, -1));
2867 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2868 gfc_array_index_type
,
2869 fold_convert (gfc_array_index_type
, tmp
),
2870 build_int_cst (gfc_array_index_type
, 1));
2871 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2872 gfc_array_index_type
, resbound
, tmp
);
2877 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2879 build_int_cst (TREE_TYPE (bound
),
2880 arg
->expr
->rank
+ corank
- 1));
2882 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2883 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2884 gfc_array_index_type
, cond
,
2885 resbound
, resbound2
);
2888 se
->expr
= resbound
;
2891 se
->expr
= resbound
;
2893 type
= gfc_typenode_for_spec (&expr
->ts
);
2894 se
->expr
= convert (type
, se
->expr
);
2899 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2901 gfc_actual_arglist
*array_arg
;
2902 gfc_actual_arglist
*dim_arg
;
2906 array_arg
= expr
->value
.function
.actual
;
2907 dim_arg
= array_arg
->next
;
2909 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2911 gfc_init_se (&argse
, NULL
);
2912 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2913 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2914 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2917 gcc_assert (dim_arg
->expr
);
2918 gfc_init_se (&argse
, NULL
);
2919 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2920 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2921 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2922 argse
.expr
, gfc_index_one_node
);
2923 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2928 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2932 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2934 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
2938 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
2943 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
2944 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
2953 /* Create a complex value from one or two real components. */
2956 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
2962 unsigned int num_args
;
2964 num_args
= gfc_intrinsic_argument_list_length (expr
);
2965 args
= XALLOCAVEC (tree
, num_args
);
2967 type
= gfc_typenode_for_spec (&expr
->ts
);
2968 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2969 real
= convert (TREE_TYPE (type
), args
[0]);
2971 imag
= convert (TREE_TYPE (type
), args
[1]);
2972 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
2974 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2975 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
2976 imag
= convert (TREE_TYPE (type
), imag
);
2979 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
2981 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
2985 /* Remainder function MOD(A, P) = A - INT(A / P) * P
2986 MODULO(A, P) = A - FLOOR (A / P) * P
2988 The obvious algorithms above are numerically instable for large
2989 arguments, hence these intrinsics are instead implemented via calls
2990 to the fmod family of functions. It is the responsibility of the
2991 user to ensure that the second argument is non-zero. */
2994 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3004 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3006 switch (expr
->ts
.type
)
3009 /* Integer case is easy, we've got a builtin op. */
3010 type
= TREE_TYPE (args
[0]);
3013 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3016 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3022 /* Check if we have a builtin fmod. */
3023 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3025 /* The builtin should always be available. */
3026 gcc_assert (fmod
!= NULL_TREE
);
3028 tmp
= build_addr (fmod
);
3029 se
->expr
= build_call_array_loc (input_location
,
3030 TREE_TYPE (TREE_TYPE (fmod
)),
3035 type
= TREE_TYPE (args
[0]);
3037 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3038 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3041 modulo = arg - floor (arg/arg2) * arg2
3043 In order to calculate the result accurately, we use the fmod
3044 function as follows.
3046 res = fmod (arg, arg2);
3049 if ((arg < 0) xor (arg2 < 0))
3053 res = copysign (0., arg2);
3055 => As two nested ternary exprs:
3057 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3058 : copysign (0., arg2);
3062 zero
= gfc_build_const (type
, integer_zero_node
);
3063 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3064 if (!flag_signed_zeros
)
3066 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3068 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3070 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3071 boolean_type_node
, test
, test2
);
3072 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3074 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3075 boolean_type_node
, test
, test2
);
3076 test
= gfc_evaluate_now (test
, &se
->pre
);
3077 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3078 fold_build2_loc (input_location
,
3080 type
, tmp
, args
[1]),
3085 tree expr1
, copysign
, cscall
;
3086 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3088 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3090 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3092 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3093 boolean_type_node
, test
, test2
);
3094 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3095 fold_build2_loc (input_location
,
3097 type
, tmp
, args
[1]),
3099 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3101 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3103 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3113 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3114 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3115 where the right shifts are logical (i.e. 0's are shifted in).
3116 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3117 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3119 DSHIFTL(I,J,BITSIZE) = J
3121 DSHIFTR(I,J,BITSIZE) = I. */
3124 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3126 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3127 tree args
[3], cond
, tmp
;
3130 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3132 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3133 type
= TREE_TYPE (args
[0]);
3134 bitsize
= TYPE_PRECISION (type
);
3135 utype
= unsigned_type_for (type
);
3136 stype
= TREE_TYPE (args
[2]);
3138 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3139 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3140 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3142 /* The generic case. */
3143 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3144 build_int_cst (stype
, bitsize
), shift
);
3145 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3146 arg1
, dshiftl
? shift
: tmp
);
3148 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3149 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3150 right
= fold_convert (type
, right
);
3152 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3154 /* Special cases. */
3155 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
3156 build_int_cst (stype
, 0));
3157 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3158 dshiftl
? arg1
: arg2
, res
);
3160 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
3161 build_int_cst (stype
, bitsize
));
3162 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3163 dshiftl
? arg2
: arg1
, res
);
3169 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3172 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3180 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3181 type
= TREE_TYPE (args
[0]);
3183 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3184 val
= gfc_evaluate_now (val
, &se
->pre
);
3186 zero
= gfc_build_const (type
, integer_zero_node
);
3187 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
3188 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3192 /* SIGN(A, B) is absolute value of A times sign of B.
3193 The real value versions use library functions to ensure the correct
3194 handling of negative zero. Integer case implemented as:
3195 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3199 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3205 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3206 if (expr
->ts
.type
== BT_REAL
)
3210 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3211 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3213 /* We explicitly have to ignore the minus sign. We do so by using
3214 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3216 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3219 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3220 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3222 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3223 TREE_TYPE (args
[0]), cond
,
3224 build_call_expr_loc (input_location
, abs
, 1,
3226 build_call_expr_loc (input_location
, tmp
, 2,
3230 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3235 /* Having excluded floating point types, we know we are now dealing
3236 with signed integer types. */
3237 type
= TREE_TYPE (args
[0]);
3239 /* Args[0] is used multiple times below. */
3240 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3242 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3243 the signs of A and B are the same, and of all ones if they differ. */
3244 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3245 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3246 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3247 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3249 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3250 is all ones (i.e. -1). */
3251 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3252 fold_build2_loc (input_location
, PLUS_EXPR
,
3253 type
, args
[0], tmp
), tmp
);
3257 /* Test for the presence of an optional argument. */
3260 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3264 arg
= expr
->value
.function
.actual
->expr
;
3265 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3266 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3267 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3271 /* Calculate the double precision product of two single precision values. */
3274 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3279 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3281 /* Convert the args to double precision before multiplying. */
3282 type
= gfc_typenode_for_spec (&expr
->ts
);
3283 args
[0] = convert (type
, args
[0]);
3284 args
[1] = convert (type
, args
[1]);
3285 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3290 /* Return a length one character string containing an ascii character. */
3293 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3298 unsigned int num_args
;
3300 num_args
= gfc_intrinsic_argument_list_length (expr
);
3301 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3303 type
= gfc_get_char_type (expr
->ts
.kind
);
3304 var
= gfc_create_var (type
, "char");
3306 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3307 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3308 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3309 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3314 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3322 unsigned int num_args
;
3324 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3325 args
= XALLOCAVEC (tree
, num_args
);
3327 var
= gfc_create_var (pchar_type_node
, "pstr");
3328 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3330 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3331 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3332 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3334 fndecl
= build_addr (gfor_fndecl_ctime
);
3335 tmp
= build_call_array_loc (input_location
,
3336 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3337 fndecl
, num_args
, args
);
3338 gfc_add_expr_to_block (&se
->pre
, tmp
);
3340 /* Free the temporary afterwards, if necessary. */
3341 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3342 len
, build_int_cst (TREE_TYPE (len
), 0));
3343 tmp
= gfc_call_free (var
);
3344 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3345 gfc_add_expr_to_block (&se
->post
, tmp
);
3348 se
->string_length
= len
;
3353 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3361 unsigned int num_args
;
3363 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3364 args
= XALLOCAVEC (tree
, num_args
);
3366 var
= gfc_create_var (pchar_type_node
, "pstr");
3367 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3369 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3370 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3371 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3373 fndecl
= build_addr (gfor_fndecl_fdate
);
3374 tmp
= build_call_array_loc (input_location
,
3375 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3376 fndecl
, num_args
, args
);
3377 gfc_add_expr_to_block (&se
->pre
, tmp
);
3379 /* Free the temporary afterwards, if necessary. */
3380 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3381 len
, build_int_cst (TREE_TYPE (len
), 0));
3382 tmp
= gfc_call_free (var
);
3383 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3384 gfc_add_expr_to_block (&se
->post
, tmp
);
3387 se
->string_length
= len
;
3391 /* Generate a direct call to free() for the FREE subroutine. */
3394 conv_intrinsic_free (gfc_code
*code
)
3400 gfc_init_se (&argse
, NULL
);
3401 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3402 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3404 gfc_init_block (&block
);
3405 call
= build_call_expr_loc (input_location
,
3406 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3407 gfc_add_expr_to_block (&block
, call
);
3408 return gfc_finish_block (&block
);
3412 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3416 conv_intrinsic_system_clock (gfc_code
*code
)
3419 gfc_se count_se
, count_rate_se
, count_max_se
;
3420 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3424 gfc_expr
*count
= code
->ext
.actual
->expr
;
3425 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3426 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3428 /* Evaluate our arguments. */
3431 gfc_init_se (&count_se
, NULL
);
3432 gfc_conv_expr (&count_se
, count
);
3437 gfc_init_se (&count_rate_se
, NULL
);
3438 gfc_conv_expr (&count_rate_se
, count_rate
);
3443 gfc_init_se (&count_max_se
, NULL
);
3444 gfc_conv_expr (&count_max_se
, count_max
);
3447 /* Find the smallest kind found of the arguments. */
3449 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3450 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3452 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3455 /* Prepare temporary variables. */
3460 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3461 else if (least
== 4)
3462 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3463 else if (count
->ts
.kind
== 1)
3464 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3467 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3474 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3475 else if (least
== 4)
3476 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3478 arg2
= integer_zero_node
;
3484 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3485 else if (least
== 4)
3486 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3488 arg3
= integer_zero_node
;
3491 /* Make the function call. */
3492 gfc_init_block (&block
);
3498 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3499 : null_pointer_node
;
3500 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3501 : null_pointer_node
;
3502 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3503 : null_pointer_node
;
3508 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3509 : null_pointer_node
;
3510 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3511 : null_pointer_node
;
3512 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3513 : null_pointer_node
;
3520 tmp
= build_call_expr_loc (input_location
,
3521 gfor_fndecl_system_clock4
, 3,
3522 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3523 : null_pointer_node
,
3524 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3525 : null_pointer_node
,
3526 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3527 : null_pointer_node
);
3528 gfc_add_expr_to_block (&block
, tmp
);
3530 /* Handle kind>=8, 10, or 16 arguments */
3533 tmp
= build_call_expr_loc (input_location
,
3534 gfor_fndecl_system_clock8
, 3,
3535 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3536 : null_pointer_node
,
3537 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3538 : null_pointer_node
,
3539 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3540 : null_pointer_node
);
3541 gfc_add_expr_to_block (&block
, tmp
);
3545 /* And store values back if needed. */
3546 if (arg1
&& arg1
!= count_se
.expr
)
3547 gfc_add_modify (&block
, count_se
.expr
,
3548 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
3549 if (arg2
&& arg2
!= count_rate_se
.expr
)
3550 gfc_add_modify (&block
, count_rate_se
.expr
,
3551 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
3552 if (arg3
&& arg3
!= count_max_se
.expr
)
3553 gfc_add_modify (&block
, count_max_se
.expr
,
3554 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
3556 return gfc_finish_block (&block
);
3560 /* Return a character string containing the tty name. */
3563 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
3571 unsigned int num_args
;
3573 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3574 args
= XALLOCAVEC (tree
, num_args
);
3576 var
= gfc_create_var (pchar_type_node
, "pstr");
3577 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3579 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3580 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3581 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3583 fndecl
= build_addr (gfor_fndecl_ttynam
);
3584 tmp
= build_call_array_loc (input_location
,
3585 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
3586 fndecl
, num_args
, args
);
3587 gfc_add_expr_to_block (&se
->pre
, tmp
);
3589 /* Free the temporary afterwards, if necessary. */
3590 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3591 len
, build_int_cst (TREE_TYPE (len
), 0));
3592 tmp
= gfc_call_free (var
);
3593 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3594 gfc_add_expr_to_block (&se
->post
, tmp
);
3597 se
->string_length
= len
;
3601 /* Get the minimum/maximum value of all the parameters.
3602 minmax (a1, a2, a3, ...)
3605 if (a2 .op. mvar || isnan (mvar))
3607 if (a3 .op. mvar || isnan (mvar))
3614 /* TODO: Mismatching types can occur when specific names are used.
3615 These should be handled during resolution. */
3617 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3625 gfc_actual_arglist
*argexpr
;
3626 unsigned int i
, nargs
;
3628 nargs
= gfc_intrinsic_argument_list_length (expr
);
3629 args
= XALLOCAVEC (tree
, nargs
);
3631 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
3632 type
= gfc_typenode_for_spec (&expr
->ts
);
3634 argexpr
= expr
->value
.function
.actual
;
3635 if (TREE_TYPE (args
[0]) != type
)
3636 args
[0] = convert (type
, args
[0]);
3637 /* Only evaluate the argument once. */
3638 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
3639 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3641 mvar
= gfc_create_var (type
, "M");
3642 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
3643 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
3649 /* Handle absent optional arguments by ignoring the comparison. */
3650 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
3651 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
3652 && TREE_CODE (val
) == INDIRECT_REF
)
3653 cond
= fold_build2_loc (input_location
,
3654 NE_EXPR
, boolean_type_node
,
3655 TREE_OPERAND (val
, 0),
3656 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
3661 /* Only evaluate the argument once. */
3662 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
3663 val
= gfc_evaluate_now (val
, &se
->pre
);
3666 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
3668 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3669 convert (type
, val
), mvar
);
3671 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3672 __builtin_isnan might be made dependent on that module being loaded,
3673 to help performance of programs that don't rely on IEEE semantics. */
3674 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
3676 isnan
= build_call_expr_loc (input_location
,
3677 builtin_decl_explicit (BUILT_IN_ISNAN
),
3679 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3680 boolean_type_node
, tmp
,
3681 fold_convert (boolean_type_node
, isnan
));
3683 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
3684 build_empty_stmt (input_location
));
3686 if (cond
!= NULL_TREE
)
3687 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
3688 build_empty_stmt (input_location
));
3690 gfc_add_expr_to_block (&se
->pre
, tmp
);
3691 argexpr
= argexpr
->next
;
3697 /* Generate library calls for MIN and MAX intrinsics for character
3700 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
3703 tree var
, len
, fndecl
, tmp
, cond
, function
;
3706 nargs
= gfc_intrinsic_argument_list_length (expr
);
3707 args
= XALLOCAVEC (tree
, nargs
+ 4);
3708 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
3710 /* Create the result variables. */
3711 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3712 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3713 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3714 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3715 args
[2] = build_int_cst (integer_type_node
, op
);
3716 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3718 if (expr
->ts
.kind
== 1)
3719 function
= gfor_fndecl_string_minmax
;
3720 else if (expr
->ts
.kind
== 4)
3721 function
= gfor_fndecl_string_minmax_char4
;
3725 /* Make the function call. */
3726 fndecl
= build_addr (function
);
3727 tmp
= build_call_array_loc (input_location
,
3728 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3730 gfc_add_expr_to_block (&se
->pre
, tmp
);
3732 /* Free the temporary afterwards, if necessary. */
3733 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3734 len
, build_int_cst (TREE_TYPE (len
), 0));
3735 tmp
= gfc_call_free (var
);
3736 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3737 gfc_add_expr_to_block (&se
->post
, tmp
);
3740 se
->string_length
= len
;
3744 /* Create a symbol node for this intrinsic. The symbol from the frontend
3745 has the generic name. */
3748 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3752 /* TODO: Add symbols for intrinsic function to the global namespace. */
3753 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3754 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3757 sym
->attr
.external
= 1;
3758 sym
->attr
.function
= 1;
3759 sym
->attr
.always_explicit
= 1;
3760 sym
->attr
.proc
= PROC_INTRINSIC
;
3761 sym
->attr
.flavor
= FL_PROCEDURE
;
3765 sym
->attr
.dimension
= 1;
3766 sym
->as
= gfc_get_array_spec ();
3767 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3768 sym
->as
->rank
= expr
->rank
;
3771 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3772 ignore_optional
? expr
->value
.function
.actual
3778 /* Generate a call to an external intrinsic function. */
3780 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3783 vec
<tree
, va_gc
> *append_args
;
3785 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3788 gcc_assert (expr
->rank
> 0);
3790 gcc_assert (expr
->rank
== 0);
3792 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3794 /* Calls to libgfortran_matmul need to be appended special arguments,
3795 to be able to call the BLAS ?gemm functions if required and possible. */
3797 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3798 && sym
->ts
.type
!= BT_LOGICAL
)
3800 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3802 if (flag_external_blas
3803 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3804 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3808 if (sym
->ts
.type
== BT_REAL
)
3810 if (sym
->ts
.kind
== 4)
3811 gemm_fndecl
= gfor_fndecl_sgemm
;
3813 gemm_fndecl
= gfor_fndecl_dgemm
;
3817 if (sym
->ts
.kind
== 4)
3818 gemm_fndecl
= gfor_fndecl_cgemm
;
3820 gemm_fndecl
= gfor_fndecl_zgemm
;
3823 vec_alloc (append_args
, 3);
3824 append_args
->quick_push (build_int_cst (cint
, 1));
3825 append_args
->quick_push (build_int_cst (cint
,
3826 flag_blas_matmul_limit
));
3827 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3832 vec_alloc (append_args
, 3);
3833 append_args
->quick_push (build_int_cst (cint
, 0));
3834 append_args
->quick_push (build_int_cst (cint
, 0));
3835 append_args
->quick_push (null_pointer_node
);
3839 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3841 gfc_free_symbol (sym
);
3844 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3864 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3873 gfc_actual_arglist
*actual
;
3880 gfc_conv_intrinsic_funcall (se
, expr
);
3884 actual
= expr
->value
.function
.actual
;
3885 type
= gfc_typenode_for_spec (&expr
->ts
);
3886 /* Initialize the result. */
3887 resvar
= gfc_create_var (type
, "test");
3889 tmp
= convert (type
, boolean_true_node
);
3891 tmp
= convert (type
, boolean_false_node
);
3892 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3894 /* Walk the arguments. */
3895 arrayss
= gfc_walk_expr (actual
->expr
);
3896 gcc_assert (arrayss
!= gfc_ss_terminator
);
3898 /* Initialize the scalarizer. */
3899 gfc_init_loopinfo (&loop
);
3900 exit_label
= gfc_build_label_decl (NULL_TREE
);
3901 TREE_USED (exit_label
) = 1;
3902 gfc_add_ss_to_loop (&loop
, arrayss
);
3904 /* Initialize the loop. */
3905 gfc_conv_ss_startstride (&loop
);
3906 gfc_conv_loop_setup (&loop
, &expr
->where
);
3908 gfc_mark_ss_chain_used (arrayss
, 1);
3909 /* Generate the loop body. */
3910 gfc_start_scalarized_body (&loop
, &body
);
3912 /* If the condition matches then set the return value. */
3913 gfc_start_block (&block
);
3915 tmp
= convert (type
, boolean_false_node
);
3917 tmp
= convert (type
, boolean_true_node
);
3918 gfc_add_modify (&block
, resvar
, tmp
);
3920 /* And break out of the loop. */
3921 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3922 gfc_add_expr_to_block (&block
, tmp
);
3924 found
= gfc_finish_block (&block
);
3926 /* Check this element. */
3927 gfc_init_se (&arrayse
, NULL
);
3928 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3929 arrayse
.ss
= arrayss
;
3930 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3932 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3933 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3934 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3935 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3936 gfc_add_expr_to_block (&body
, tmp
);
3937 gfc_add_block_to_block (&body
, &arrayse
.post
);
3939 gfc_trans_scalarizing_loops (&loop
, &body
);
3941 /* Add the exit label. */
3942 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3943 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3945 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3946 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3947 gfc_cleanup_loop (&loop
);
3952 /* COUNT(A) = Number of true elements in A. */
3954 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
3961 gfc_actual_arglist
*actual
;
3967 gfc_conv_intrinsic_funcall (se
, expr
);
3971 actual
= expr
->value
.function
.actual
;
3973 type
= gfc_typenode_for_spec (&expr
->ts
);
3974 /* Initialize the result. */
3975 resvar
= gfc_create_var (type
, "count");
3976 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
3978 /* Walk the arguments. */
3979 arrayss
= gfc_walk_expr (actual
->expr
);
3980 gcc_assert (arrayss
!= gfc_ss_terminator
);
3982 /* Initialize the scalarizer. */
3983 gfc_init_loopinfo (&loop
);
3984 gfc_add_ss_to_loop (&loop
, arrayss
);
3986 /* Initialize the loop. */
3987 gfc_conv_ss_startstride (&loop
);
3988 gfc_conv_loop_setup (&loop
, &expr
->where
);
3990 gfc_mark_ss_chain_used (arrayss
, 1);
3991 /* Generate the loop body. */
3992 gfc_start_scalarized_body (&loop
, &body
);
3994 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
3995 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
3996 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
3998 gfc_init_se (&arrayse
, NULL
);
3999 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4000 arrayse
.ss
= arrayss
;
4001 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4002 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4003 build_empty_stmt (input_location
));
4005 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4006 gfc_add_expr_to_block (&body
, tmp
);
4007 gfc_add_block_to_block (&body
, &arrayse
.post
);
4009 gfc_trans_scalarizing_loops (&loop
, &body
);
4011 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4012 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4013 gfc_cleanup_loop (&loop
);
4019 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4020 struct and return the corresponding loopinfo. */
4022 static gfc_loopinfo
*
4023 enter_nested_loop (gfc_se
*se
)
4025 se
->ss
= se
->ss
->nested_ss
;
4026 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4028 return se
->ss
->loop
;
4032 /* Inline implementation of the sum and product intrinsics. */
4034 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4038 tree scale
= NULL_TREE
;
4043 gfc_loopinfo loop
, *ploop
;
4044 gfc_actual_arglist
*arg_array
, *arg_mask
;
4045 gfc_ss
*arrayss
= NULL
;
4046 gfc_ss
*maskss
= NULL
;
4050 gfc_expr
*arrayexpr
;
4055 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4061 type
= gfc_typenode_for_spec (&expr
->ts
);
4062 /* Initialize the result. */
4063 resvar
= gfc_create_var (type
, "val");
4068 scale
= gfc_create_var (type
, "scale");
4069 gfc_add_modify (&se
->pre
, scale
,
4070 gfc_build_const (type
, integer_one_node
));
4071 tmp
= gfc_build_const (type
, integer_zero_node
);
4073 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4074 tmp
= gfc_build_const (type
, integer_zero_node
);
4075 else if (op
== NE_EXPR
)
4077 tmp
= convert (type
, boolean_false_node
);
4078 else if (op
== BIT_AND_EXPR
)
4079 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4080 type
, integer_one_node
));
4082 tmp
= gfc_build_const (type
, integer_one_node
);
4084 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4086 arg_array
= expr
->value
.function
.actual
;
4088 arrayexpr
= arg_array
->expr
;
4090 if (op
== NE_EXPR
|| norm2
)
4091 /* PARITY and NORM2. */
4095 arg_mask
= arg_array
->next
->next
;
4096 gcc_assert (arg_mask
!= NULL
);
4097 maskexpr
= arg_mask
->expr
;
4100 if (expr
->rank
== 0)
4102 /* Walk the arguments. */
4103 arrayss
= gfc_walk_expr (arrayexpr
);
4104 gcc_assert (arrayss
!= gfc_ss_terminator
);
4106 if (maskexpr
&& maskexpr
->rank
> 0)
4108 maskss
= gfc_walk_expr (maskexpr
);
4109 gcc_assert (maskss
!= gfc_ss_terminator
);
4114 /* Initialize the scalarizer. */
4115 gfc_init_loopinfo (&loop
);
4116 gfc_add_ss_to_loop (&loop
, arrayss
);
4117 if (maskexpr
&& maskexpr
->rank
> 0)
4118 gfc_add_ss_to_loop (&loop
, maskss
);
4120 /* Initialize the loop. */
4121 gfc_conv_ss_startstride (&loop
);
4122 gfc_conv_loop_setup (&loop
, &expr
->where
);
4124 gfc_mark_ss_chain_used (arrayss
, 1);
4125 if (maskexpr
&& maskexpr
->rank
> 0)
4126 gfc_mark_ss_chain_used (maskss
, 1);
4131 /* All the work has been done in the parent loops. */
4132 ploop
= enter_nested_loop (se
);
4136 /* Generate the loop body. */
4137 gfc_start_scalarized_body (ploop
, &body
);
4139 /* If we have a mask, only add this element if the mask is set. */
4140 if (maskexpr
&& maskexpr
->rank
> 0)
4142 gfc_init_se (&maskse
, parent_se
);
4143 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4144 if (expr
->rank
== 0)
4146 gfc_conv_expr_val (&maskse
, maskexpr
);
4147 gfc_add_block_to_block (&body
, &maskse
.pre
);
4149 gfc_start_block (&block
);
4152 gfc_init_block (&block
);
4154 /* Do the actual summation/product. */
4155 gfc_init_se (&arrayse
, parent_se
);
4156 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4157 if (expr
->rank
== 0)
4158 arrayse
.ss
= arrayss
;
4159 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4160 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4164 /* if (x (i) != 0.0)
4170 result = 1.0 + result * val * val;
4176 result += val * val;
4179 tree res1
, res2
, cond
, absX
, val
;
4180 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4182 gfc_init_block (&ifblock1
);
4184 absX
= gfc_create_var (type
, "absX");
4185 gfc_add_modify (&ifblock1
, absX
,
4186 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4188 val
= gfc_create_var (type
, "val");
4189 gfc_add_expr_to_block (&ifblock1
, val
);
4191 gfc_init_block (&ifblock2
);
4192 gfc_add_modify (&ifblock2
, val
,
4193 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4195 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4196 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4197 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4198 gfc_build_const (type
, integer_one_node
));
4199 gfc_add_modify (&ifblock2
, resvar
, res1
);
4200 gfc_add_modify (&ifblock2
, scale
, absX
);
4201 res1
= gfc_finish_block (&ifblock2
);
4203 gfc_init_block (&ifblock3
);
4204 gfc_add_modify (&ifblock3
, val
,
4205 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4207 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4208 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4209 gfc_add_modify (&ifblock3
, resvar
, res2
);
4210 res2
= gfc_finish_block (&ifblock3
);
4212 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
4214 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4215 gfc_add_expr_to_block (&ifblock1
, tmp
);
4216 tmp
= gfc_finish_block (&ifblock1
);
4218 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4220 gfc_build_const (type
, integer_zero_node
));
4222 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4223 gfc_add_expr_to_block (&block
, tmp
);
4227 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4228 gfc_add_modify (&block
, resvar
, tmp
);
4231 gfc_add_block_to_block (&block
, &arrayse
.post
);
4233 if (maskexpr
&& maskexpr
->rank
> 0)
4235 /* We enclose the above in if (mask) {...} . */
4237 tmp
= gfc_finish_block (&block
);
4238 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4239 build_empty_stmt (input_location
));
4242 tmp
= gfc_finish_block (&block
);
4243 gfc_add_expr_to_block (&body
, tmp
);
4245 gfc_trans_scalarizing_loops (ploop
, &body
);
4247 /* For a scalar mask, enclose the loop in an if statement. */
4248 if (maskexpr
&& maskexpr
->rank
== 0)
4250 gfc_init_block (&block
);
4251 gfc_add_block_to_block (&block
, &ploop
->pre
);
4252 gfc_add_block_to_block (&block
, &ploop
->post
);
4253 tmp
= gfc_finish_block (&block
);
4257 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4258 build_empty_stmt (input_location
));
4259 gfc_advance_se_ss_chain (se
);
4263 gcc_assert (expr
->rank
== 0);
4264 gfc_init_se (&maskse
, NULL
);
4265 gfc_conv_expr_val (&maskse
, maskexpr
);
4266 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4267 build_empty_stmt (input_location
));
4270 gfc_add_expr_to_block (&block
, tmp
);
4271 gfc_add_block_to_block (&se
->pre
, &block
);
4272 gcc_assert (se
->post
.head
== NULL
);
4276 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4277 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4280 if (expr
->rank
== 0)
4281 gfc_cleanup_loop (ploop
);
4285 /* result = scale * sqrt(result). */
4287 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4288 resvar
= build_call_expr_loc (input_location
,
4290 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4297 /* Inline implementation of the dot_product intrinsic. This function
4298 is based on gfc_conv_intrinsic_arith (the previous function). */
4300 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4308 gfc_actual_arglist
*actual
;
4309 gfc_ss
*arrayss1
, *arrayss2
;
4310 gfc_se arrayse1
, arrayse2
;
4311 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4313 type
= gfc_typenode_for_spec (&expr
->ts
);
4315 /* Initialize the result. */
4316 resvar
= gfc_create_var (type
, "val");
4317 if (expr
->ts
.type
== BT_LOGICAL
)
4318 tmp
= build_int_cst (type
, 0);
4320 tmp
= gfc_build_const (type
, integer_zero_node
);
4322 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4324 /* Walk argument #1. */
4325 actual
= expr
->value
.function
.actual
;
4326 arrayexpr1
= actual
->expr
;
4327 arrayss1
= gfc_walk_expr (arrayexpr1
);
4328 gcc_assert (arrayss1
!= gfc_ss_terminator
);
4330 /* Walk argument #2. */
4331 actual
= actual
->next
;
4332 arrayexpr2
= actual
->expr
;
4333 arrayss2
= gfc_walk_expr (arrayexpr2
);
4334 gcc_assert (arrayss2
!= gfc_ss_terminator
);
4336 /* Initialize the scalarizer. */
4337 gfc_init_loopinfo (&loop
);
4338 gfc_add_ss_to_loop (&loop
, arrayss1
);
4339 gfc_add_ss_to_loop (&loop
, arrayss2
);
4341 /* Initialize the loop. */
4342 gfc_conv_ss_startstride (&loop
);
4343 gfc_conv_loop_setup (&loop
, &expr
->where
);
4345 gfc_mark_ss_chain_used (arrayss1
, 1);
4346 gfc_mark_ss_chain_used (arrayss2
, 1);
4348 /* Generate the loop body. */
4349 gfc_start_scalarized_body (&loop
, &body
);
4350 gfc_init_block (&block
);
4352 /* Make the tree expression for [conjg(]array1[)]. */
4353 gfc_init_se (&arrayse1
, NULL
);
4354 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
4355 arrayse1
.ss
= arrayss1
;
4356 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
4357 if (expr
->ts
.type
== BT_COMPLEX
)
4358 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
4360 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
4362 /* Make the tree expression for array2. */
4363 gfc_init_se (&arrayse2
, NULL
);
4364 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
4365 arrayse2
.ss
= arrayss2
;
4366 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
4367 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
4369 /* Do the actual product and sum. */
4370 if (expr
->ts
.type
== BT_LOGICAL
)
4372 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
4373 arrayse1
.expr
, arrayse2
.expr
);
4374 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
4378 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
4380 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
4382 gfc_add_modify (&block
, resvar
, tmp
);
4384 /* Finish up the loop block and the loop. */
4385 tmp
= gfc_finish_block (&block
);
4386 gfc_add_expr_to_block (&body
, tmp
);
4388 gfc_trans_scalarizing_loops (&loop
, &body
);
4389 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4390 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4391 gfc_cleanup_loop (&loop
);
4397 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4398 we need to handle. For performance reasons we sometimes create two
4399 loops instead of one, where the second one is much simpler.
4400 Examples for minloc intrinsic:
4401 1) Result is an array, a call is generated
4402 2) Array mask is used and NaNs need to be supported:
4408 if (pos == 0) pos = S + (1 - from);
4409 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4416 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4420 3) NaNs need to be supported, but it is known at compile time or cheaply
4421 at runtime whether array is nonempty or not:
4426 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4429 if (from <= to) pos = 1;
4433 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4437 4) NaNs aren't supported, array mask is used:
4438 limit = infinities_supported ? Infinity : huge (limit);
4442 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4448 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4452 5) Same without array mask:
4453 limit = infinities_supported ? Infinity : huge (limit);
4454 pos = (from <= to) ? 1 : 0;
4457 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4460 For 3) and 5), if mask is scalar, this all goes into a conditional,
4461 setting pos = 0; in the else branch. */
4464 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4468 stmtblock_t ifblock
;
4469 stmtblock_t elseblock
;
4480 gfc_actual_arglist
*actual
;
4485 gfc_expr
*arrayexpr
;
4492 gfc_conv_intrinsic_funcall (se
, expr
);
4496 /* Initialize the result. */
4497 pos
= gfc_create_var (gfc_array_index_type
, "pos");
4498 offset
= gfc_create_var (gfc_array_index_type
, "offset");
4499 type
= gfc_typenode_for_spec (&expr
->ts
);
4501 /* Walk the arguments. */
4502 actual
= expr
->value
.function
.actual
;
4503 arrayexpr
= actual
->expr
;
4504 arrayss
= gfc_walk_expr (arrayexpr
);
4505 gcc_assert (arrayss
!= gfc_ss_terminator
);
4507 actual
= actual
->next
->next
;
4508 gcc_assert (actual
);
4509 maskexpr
= actual
->expr
;
4511 if (maskexpr
&& maskexpr
->rank
!= 0)
4513 maskss
= gfc_walk_expr (maskexpr
);
4514 gcc_assert (maskss
!= gfc_ss_terminator
);
4519 if (gfc_array_size (arrayexpr
, &asize
))
4521 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4523 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4524 boolean_type_node
, nonempty
,
4525 gfc_index_zero_node
);
4530 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
4531 switch (arrayexpr
->ts
.type
)
4534 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
4538 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
4539 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
4540 arrayexpr
->ts
.kind
);
4547 /* We start with the most negative possible value for MAXLOC, and the most
4548 positive possible value for MINLOC. The most negative possible value is
4549 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4550 possible value is HUGE in both cases. */
4552 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4553 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
4554 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
4555 build_int_cst (TREE_TYPE (tmp
), 1));
4557 gfc_add_modify (&se
->pre
, limit
, tmp
);
4559 /* Initialize the scalarizer. */
4560 gfc_init_loopinfo (&loop
);
4561 gfc_add_ss_to_loop (&loop
, arrayss
);
4563 gfc_add_ss_to_loop (&loop
, maskss
);
4565 /* Initialize the loop. */
4566 gfc_conv_ss_startstride (&loop
);
4568 /* The code generated can have more than one loop in sequence (see the
4569 comment at the function header). This doesn't work well with the
4570 scalarizer, which changes arrays' offset when the scalarization loops
4571 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4572 are currently inlined in the scalar case only (for which loop is of rank
4573 one). As there is no dependency to care about in that case, there is no
4574 temporary, so that we can use the scalarizer temporary code to handle
4575 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4576 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4578 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4579 should eventually go away. We could either create two loops properly,
4580 or find another way to save/restore the array offsets between the two
4581 loops (without conflicting with temporary management), or use a single
4582 loop minmaxloc implementation. See PR 31067. */
4583 loop
.temp_dim
= loop
.dimen
;
4584 gfc_conv_loop_setup (&loop
, &expr
->where
);
4586 gcc_assert (loop
.dimen
== 1);
4587 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
4588 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4589 loop
.from
[0], loop
.to
[0]);
4593 /* Initialize the position to zero, following Fortran 2003. We are free
4594 to do this because Fortran 95 allows the result of an entirely false
4595 mask to be processor dependent. If we know at compile time the array
4596 is non-empty and no MASK is used, we can initialize to 1 to simplify
4598 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
4599 gfc_add_modify (&loop
.pre
, pos
,
4600 fold_build3_loc (input_location
, COND_EXPR
,
4601 gfc_array_index_type
,
4602 nonempty
, gfc_index_one_node
,
4603 gfc_index_zero_node
));
4606 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
4607 lab1
= gfc_build_label_decl (NULL_TREE
);
4608 TREE_USED (lab1
) = 1;
4609 lab2
= gfc_build_label_decl (NULL_TREE
);
4610 TREE_USED (lab2
) = 1;
4613 /* An offset must be added to the loop
4614 counter to obtain the required position. */
4615 gcc_assert (loop
.from
[0]);
4617 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4618 gfc_index_one_node
, loop
.from
[0]);
4619 gfc_add_modify (&loop
.pre
, offset
, tmp
);
4621 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
4623 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
4624 /* Generate the loop body. */
4625 gfc_start_scalarized_body (&loop
, &body
);
4627 /* If we have a mask, only check this element if the mask is set. */
4630 gfc_init_se (&maskse
, NULL
);
4631 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4633 gfc_conv_expr_val (&maskse
, maskexpr
);
4634 gfc_add_block_to_block (&body
, &maskse
.pre
);
4636 gfc_start_block (&block
);
4639 gfc_init_block (&block
);
4641 /* Compare with the current limit. */
4642 gfc_init_se (&arrayse
, NULL
);
4643 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4644 arrayse
.ss
= arrayss
;
4645 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4646 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4648 /* We do the following if this is a more extreme value. */
4649 gfc_start_block (&ifblock
);
4651 /* Assign the value to the limit... */
4652 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4654 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
4656 stmtblock_t ifblock2
;
4659 gfc_start_block (&ifblock2
);
4660 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4661 loop
.loopvar
[0], offset
);
4662 gfc_add_modify (&ifblock2
, pos
, tmp
);
4663 ifbody2
= gfc_finish_block (&ifblock2
);
4664 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
4665 gfc_index_zero_node
);
4666 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
4667 build_empty_stmt (input_location
));
4668 gfc_add_expr_to_block (&block
, tmp
);
4671 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4672 loop
.loopvar
[0], offset
);
4673 gfc_add_modify (&ifblock
, pos
, tmp
);
4676 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
4678 ifbody
= gfc_finish_block (&ifblock
);
4680 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
4683 cond
= fold_build2_loc (input_location
,
4684 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4685 boolean_type_node
, arrayse
.expr
, limit
);
4687 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4688 arrayse
.expr
, limit
);
4690 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
4691 build_empty_stmt (input_location
));
4693 gfc_add_expr_to_block (&block
, ifbody
);
4697 /* We enclose the above in if (mask) {...}. */
4698 tmp
= gfc_finish_block (&block
);
4700 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4701 build_empty_stmt (input_location
));
4704 tmp
= gfc_finish_block (&block
);
4705 gfc_add_expr_to_block (&body
, tmp
);
4709 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4711 if (HONOR_NANS (DECL_MODE (limit
)))
4713 if (nonempty
!= NULL
)
4715 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
4716 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
4717 build_empty_stmt (input_location
));
4718 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
4722 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
4723 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
4725 /* If we have a mask, only check this element if the mask is set. */
4728 gfc_init_se (&maskse
, NULL
);
4729 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4731 gfc_conv_expr_val (&maskse
, maskexpr
);
4732 gfc_add_block_to_block (&body
, &maskse
.pre
);
4734 gfc_start_block (&block
);
4737 gfc_init_block (&block
);
4739 /* Compare with the current limit. */
4740 gfc_init_se (&arrayse
, NULL
);
4741 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4742 arrayse
.ss
= arrayss
;
4743 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4744 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4746 /* We do the following if this is a more extreme value. */
4747 gfc_start_block (&ifblock
);
4749 /* Assign the value to the limit... */
4750 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4752 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4753 loop
.loopvar
[0], offset
);
4754 gfc_add_modify (&ifblock
, pos
, tmp
);
4756 ifbody
= gfc_finish_block (&ifblock
);
4758 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4759 arrayse
.expr
, limit
);
4761 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4762 build_empty_stmt (input_location
));
4763 gfc_add_expr_to_block (&block
, tmp
);
4767 /* We enclose the above in if (mask) {...}. */
4768 tmp
= gfc_finish_block (&block
);
4770 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4771 build_empty_stmt (input_location
));
4774 tmp
= gfc_finish_block (&block
);
4775 gfc_add_expr_to_block (&body
, tmp
);
4776 /* Avoid initializing loopvar[0] again, it should be left where
4777 it finished by the first loop. */
4778 loop
.from
[0] = loop
.loopvar
[0];
4781 gfc_trans_scalarizing_loops (&loop
, &body
);
4784 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4786 /* For a scalar mask, enclose the loop in an if statement. */
4787 if (maskexpr
&& maskss
== NULL
)
4789 gfc_init_se (&maskse
, NULL
);
4790 gfc_conv_expr_val (&maskse
, maskexpr
);
4791 gfc_init_block (&block
);
4792 gfc_add_block_to_block (&block
, &loop
.pre
);
4793 gfc_add_block_to_block (&block
, &loop
.post
);
4794 tmp
= gfc_finish_block (&block
);
4796 /* For the else part of the scalar mask, just initialize
4797 the pos variable the same way as above. */
4799 gfc_init_block (&elseblock
);
4800 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4801 elsetmp
= gfc_finish_block (&elseblock
);
4803 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4804 gfc_add_expr_to_block (&block
, tmp
);
4805 gfc_add_block_to_block (&se
->pre
, &block
);
4809 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4810 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4812 gfc_cleanup_loop (&loop
);
4814 se
->expr
= convert (type
, pos
);
4817 /* Emit code for minval or maxval intrinsic. There are many different cases
4818 we need to handle. For performance reasons we sometimes create two
4819 loops instead of one, where the second one is much simpler.
4820 Examples for minval intrinsic:
4821 1) Result is an array, a call is generated
4822 2) Array mask is used and NaNs need to be supported, rank 1:
4827 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4830 limit = nonempty ? NaN : huge (limit);
4832 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4833 3) NaNs need to be supported, but it is known at compile time or cheaply
4834 at runtime whether array is nonempty or not, rank 1:
4837 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4838 limit = (from <= to) ? NaN : huge (limit);
4840 while (S <= to) { limit = min (a[S], limit); S++; }
4841 4) Array mask is used and NaNs need to be supported, rank > 1:
4850 if (fast) limit = min (a[S1][S2], limit);
4853 if (a[S1][S2] <= limit) {
4864 limit = nonempty ? NaN : huge (limit);
4865 5) NaNs need to be supported, but it is known at compile time or cheaply
4866 at runtime whether array is nonempty or not, rank > 1:
4873 if (fast) limit = min (a[S1][S2], limit);
4875 if (a[S1][S2] <= limit) {
4885 limit = (nonempty_array) ? NaN : huge (limit);
4886 6) NaNs aren't supported, but infinities are. Array mask is used:
4891 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4894 limit = nonempty ? limit : huge (limit);
4895 7) Same without array mask:
4898 while (S <= to) { limit = min (a[S], limit); S++; }
4899 limit = (from <= to) ? limit : huge (limit);
4900 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4901 limit = huge (limit);
4903 while (S <= to) { limit = min (a[S], limit); S++); }
4905 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4906 with array mask instead).
4907 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4908 setting limit = huge (limit); in the else branch. */
4911 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4921 tree huge_cst
= NULL
, nan_cst
= NULL
;
4923 stmtblock_t block
, block2
;
4925 gfc_actual_arglist
*actual
;
4930 gfc_expr
*arrayexpr
;
4936 gfc_conv_intrinsic_funcall (se
, expr
);
4940 type
= gfc_typenode_for_spec (&expr
->ts
);
4941 /* Initialize the result. */
4942 limit
= gfc_create_var (type
, "limit");
4943 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
4944 switch (expr
->ts
.type
)
4947 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
4949 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4951 REAL_VALUE_TYPE real
;
4953 tmp
= build_real (type
, real
);
4957 if (HONOR_NANS (DECL_MODE (limit
)))
4958 nan_cst
= gfc_build_nan (type
, "");
4962 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
4969 /* We start with the most negative possible value for MAXVAL, and the most
4970 positive possible value for MINVAL. The most negative possible value is
4971 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4972 possible value is HUGE in both cases. */
4975 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4977 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
4978 TREE_TYPE (huge_cst
), huge_cst
);
4981 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
4982 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
4983 tmp
, build_int_cst (type
, 1));
4985 gfc_add_modify (&se
->pre
, limit
, tmp
);
4987 /* Walk the arguments. */
4988 actual
= expr
->value
.function
.actual
;
4989 arrayexpr
= actual
->expr
;
4990 arrayss
= gfc_walk_expr (arrayexpr
);
4991 gcc_assert (arrayss
!= gfc_ss_terminator
);
4993 actual
= actual
->next
->next
;
4994 gcc_assert (actual
);
4995 maskexpr
= actual
->expr
;
4997 if (maskexpr
&& maskexpr
->rank
!= 0)
4999 maskss
= gfc_walk_expr (maskexpr
);
5000 gcc_assert (maskss
!= gfc_ss_terminator
);
5005 if (gfc_array_size (arrayexpr
, &asize
))
5007 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5009 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5010 boolean_type_node
, nonempty
,
5011 gfc_index_zero_node
);
5016 /* Initialize the scalarizer. */
5017 gfc_init_loopinfo (&loop
);
5018 gfc_add_ss_to_loop (&loop
, arrayss
);
5020 gfc_add_ss_to_loop (&loop
, maskss
);
5022 /* Initialize the loop. */
5023 gfc_conv_ss_startstride (&loop
);
5025 /* The code generated can have more than one loop in sequence (see the
5026 comment at the function header). This doesn't work well with the
5027 scalarizer, which changes arrays' offset when the scalarization loops
5028 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5029 are currently inlined in the scalar case only. As there is no dependency
5030 to care about in that case, there is no temporary, so that we can use the
5031 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5032 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5033 gfc_trans_scalarized_loop_boundary even later to restore offset.
5034 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5035 should eventually go away. We could either create two loops properly,
5036 or find another way to save/restore the array offsets between the two
5037 loops (without conflicting with temporary management), or use a single
5038 loop minmaxval implementation. See PR 31067. */
5039 loop
.temp_dim
= loop
.dimen
;
5040 gfc_conv_loop_setup (&loop
, &expr
->where
);
5042 if (nonempty
== NULL
&& maskss
== NULL
5043 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5044 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5045 loop
.from
[0], loop
.to
[0]);
5046 nonempty_var
= NULL
;
5047 if (nonempty
== NULL
5048 && (HONOR_INFINITIES (DECL_MODE (limit
))
5049 || HONOR_NANS (DECL_MODE (limit
))))
5051 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
5052 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
5053 nonempty
= nonempty_var
;
5057 if (HONOR_NANS (DECL_MODE (limit
)))
5059 if (loop
.dimen
== 1)
5061 lab
= gfc_build_label_decl (NULL_TREE
);
5062 TREE_USED (lab
) = 1;
5066 fast
= gfc_create_var (boolean_type_node
, "fast");
5067 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
5071 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5073 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5074 /* Generate the loop body. */
5075 gfc_start_scalarized_body (&loop
, &body
);
5077 /* If we have a mask, only add this element if the mask is set. */
5080 gfc_init_se (&maskse
, NULL
);
5081 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5083 gfc_conv_expr_val (&maskse
, maskexpr
);
5084 gfc_add_block_to_block (&body
, &maskse
.pre
);
5086 gfc_start_block (&block
);
5089 gfc_init_block (&block
);
5091 /* Compare with the current limit. */
5092 gfc_init_se (&arrayse
, NULL
);
5093 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5094 arrayse
.ss
= arrayss
;
5095 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5096 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5098 gfc_init_block (&block2
);
5101 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
5103 if (HONOR_NANS (DECL_MODE (limit
)))
5105 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5106 boolean_type_node
, arrayse
.expr
, limit
);
5108 ifbody
= build1_v (GOTO_EXPR
, lab
);
5111 stmtblock_t ifblock
;
5113 gfc_init_block (&ifblock
);
5114 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5115 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
5116 ifbody
= gfc_finish_block (&ifblock
);
5118 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5119 build_empty_stmt (input_location
));
5120 gfc_add_expr_to_block (&block2
, tmp
);
5124 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5126 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5128 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5129 arrayse
.expr
, limit
);
5130 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5131 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5132 build_empty_stmt (input_location
));
5133 gfc_add_expr_to_block (&block2
, tmp
);
5137 tmp
= fold_build2_loc (input_location
,
5138 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5139 type
, arrayse
.expr
, limit
);
5140 gfc_add_modify (&block2
, limit
, tmp
);
5146 tree elsebody
= gfc_finish_block (&block2
);
5148 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5150 if (HONOR_NANS (DECL_MODE (limit
))
5151 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5153 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5154 arrayse
.expr
, limit
);
5155 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5156 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5157 build_empty_stmt (input_location
));
5161 tmp
= fold_build2_loc (input_location
,
5162 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5163 type
, arrayse
.expr
, limit
);
5164 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5166 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5167 gfc_add_expr_to_block (&block
, tmp
);
5170 gfc_add_block_to_block (&block
, &block2
);
5172 gfc_add_block_to_block (&block
, &arrayse
.post
);
5174 tmp
= gfc_finish_block (&block
);
5176 /* We enclose the above in if (mask) {...}. */
5177 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5178 build_empty_stmt (input_location
));
5179 gfc_add_expr_to_block (&body
, tmp
);
5183 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5185 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5187 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
5188 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
5190 /* If we have a mask, only add this element if the mask is set. */
5193 gfc_init_se (&maskse
, NULL
);
5194 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5196 gfc_conv_expr_val (&maskse
, maskexpr
);
5197 gfc_add_block_to_block (&body
, &maskse
.pre
);
5199 gfc_start_block (&block
);
5202 gfc_init_block (&block
);
5204 /* Compare with the current limit. */
5205 gfc_init_se (&arrayse
, NULL
);
5206 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5207 arrayse
.ss
= arrayss
;
5208 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5209 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5211 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5213 if (HONOR_NANS (DECL_MODE (limit
))
5214 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5216 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5217 arrayse
.expr
, limit
);
5218 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5219 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5220 build_empty_stmt (input_location
));
5221 gfc_add_expr_to_block (&block
, tmp
);
5225 tmp
= fold_build2_loc (input_location
,
5226 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5227 type
, arrayse
.expr
, limit
);
5228 gfc_add_modify (&block
, limit
, tmp
);
5231 gfc_add_block_to_block (&block
, &arrayse
.post
);
5233 tmp
= gfc_finish_block (&block
);
5235 /* We enclose the above in if (mask) {...}. */
5236 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5237 build_empty_stmt (input_location
));
5238 gfc_add_expr_to_block (&body
, tmp
);
5239 /* Avoid initializing loopvar[0] again, it should be left where
5240 it finished by the first loop. */
5241 loop
.from
[0] = loop
.loopvar
[0];
5243 gfc_trans_scalarizing_loops (&loop
, &body
);
5247 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5249 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5250 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
5252 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5254 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
5256 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
5258 gfc_add_modify (&loop
.pre
, limit
, tmp
);
5261 /* For a scalar mask, enclose the loop in an if statement. */
5262 if (maskexpr
&& maskss
== NULL
)
5266 gfc_init_se (&maskse
, NULL
);
5267 gfc_conv_expr_val (&maskse
, maskexpr
);
5268 gfc_init_block (&block
);
5269 gfc_add_block_to_block (&block
, &loop
.pre
);
5270 gfc_add_block_to_block (&block
, &loop
.post
);
5271 tmp
= gfc_finish_block (&block
);
5273 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5274 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
5276 else_stmt
= build_empty_stmt (input_location
);
5277 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
5278 gfc_add_expr_to_block (&block
, tmp
);
5279 gfc_add_block_to_block (&se
->pre
, &block
);
5283 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5284 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5287 gfc_cleanup_loop (&loop
);
5292 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5294 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
5300 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5301 type
= TREE_TYPE (args
[0]);
5303 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5304 build_int_cst (type
, 1), args
[1]);
5305 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
5306 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5307 build_int_cst (type
, 0));
5308 type
= gfc_typenode_for_spec (&expr
->ts
);
5309 se
->expr
= convert (type
, tmp
);
5313 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5315 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5319 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5321 /* Convert both arguments to the unsigned type of the same size. */
5322 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
5323 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
5325 /* If they have unequal type size, convert to the larger one. */
5326 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
5327 > TYPE_PRECISION (TREE_TYPE (args
[1])))
5328 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
5329 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
5330 > TYPE_PRECISION (TREE_TYPE (args
[0])))
5331 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
5333 /* Now, we compare them. */
5334 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5339 /* Generate code to perform the specified operation. */
5341 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5345 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5346 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
5352 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
5356 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5357 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5358 TREE_TYPE (arg
), arg
);
5361 /* Set or clear a single bit. */
5363 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
5370 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5371 type
= TREE_TYPE (args
[0]);
5373 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5374 build_int_cst (type
, 1), args
[1]);
5380 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
5382 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
5385 /* Extract a sequence of bits.
5386 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5388 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
5395 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5396 type
= TREE_TYPE (args
[0]);
5398 mask
= build_int_cst (type
, -1);
5399 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
5400 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
5402 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
5404 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
5408 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
5411 tree args
[2], type
, num_bits
, cond
;
5413 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5415 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5416 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5417 type
= TREE_TYPE (args
[0]);
5420 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
5422 gcc_assert (right_shift
);
5424 se
->expr
= fold_build2_loc (input_location
,
5425 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
5426 TREE_TYPE (args
[0]), args
[0], args
[1]);
5429 se
->expr
= fold_convert (type
, se
->expr
);
5431 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5432 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5434 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5435 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5438 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5439 build_int_cst (type
, 0), se
->expr
);
5442 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5444 : ((shift >= 0) ? i << shift : i >> -shift)
5445 where all shifts are logical shifts. */
5447 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
5459 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5461 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5462 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5464 type
= TREE_TYPE (args
[0]);
5465 utype
= unsigned_type_for (type
);
5467 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
5470 /* Left shift if positive. */
5471 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
5473 /* Right shift if negative.
5474 We convert to an unsigned type because we want a logical shift.
5475 The standard doesn't define the case of shifting negative
5476 numbers, and we try to be compatible with other compilers, most
5477 notably g77, here. */
5478 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
5479 utype
, convert (utype
, args
[0]), width
));
5481 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
5482 build_int_cst (TREE_TYPE (args
[1]), 0));
5483 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
5485 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5486 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5488 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5489 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
5491 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5492 build_int_cst (type
, 0), tmp
);
5496 /* Circular shift. AKA rotate or barrel shift. */
5499 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
5507 unsigned int num_args
;
5509 num_args
= gfc_intrinsic_argument_list_length (expr
);
5510 args
= XALLOCAVEC (tree
, num_args
);
5512 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5516 /* Use a library function for the 3 parameter version. */
5517 tree int4type
= gfc_get_int_type (4);
5519 type
= TREE_TYPE (args
[0]);
5520 /* We convert the first argument to at least 4 bytes, and
5521 convert back afterwards. This removes the need for library
5522 functions for all argument sizes, and function will be
5523 aligned to at least 32 bits, so there's no loss. */
5524 if (expr
->ts
.kind
< 4)
5525 args
[0] = convert (int4type
, args
[0]);
5527 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5528 need loads of library functions. They cannot have values >
5529 BIT_SIZE (I) so the conversion is safe. */
5530 args
[1] = convert (int4type
, args
[1]);
5531 args
[2] = convert (int4type
, args
[2]);
5533 switch (expr
->ts
.kind
)
5538 tmp
= gfor_fndecl_math_ishftc4
;
5541 tmp
= gfor_fndecl_math_ishftc8
;
5544 tmp
= gfor_fndecl_math_ishftc16
;
5549 se
->expr
= build_call_expr_loc (input_location
,
5550 tmp
, 3, args
[0], args
[1], args
[2]);
5551 /* Convert the result back to the original type, if we extended
5552 the first argument's width above. */
5553 if (expr
->ts
.kind
< 4)
5554 se
->expr
= convert (type
, se
->expr
);
5558 type
= TREE_TYPE (args
[0]);
5560 /* Evaluate arguments only once. */
5561 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5562 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5564 /* Rotate left if positive. */
5565 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
5567 /* Rotate right if negative. */
5568 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
5570 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
5572 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
5573 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
5575 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
5577 /* Do nothing if shift == 0. */
5578 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
5580 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
5585 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5586 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5588 The conditional expression is necessary because the result of LEADZ(0)
5589 is defined, but the result of __builtin_clz(0) is undefined for most
5592 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5593 difference in bit size between the argument of LEADZ and the C int. */
5596 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
5608 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5609 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5611 /* Which variant of __builtin_clz* should we call? */
5612 if (argsize
<= INT_TYPE_SIZE
)
5614 arg_type
= unsigned_type_node
;
5615 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
5617 else if (argsize
<= LONG_TYPE_SIZE
)
5619 arg_type
= long_unsigned_type_node
;
5620 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
5622 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5624 arg_type
= long_long_unsigned_type_node
;
5625 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5629 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5630 arg_type
= gfc_build_uint_type (argsize
);
5634 /* Convert the actual argument twice: first, to the unsigned type of the
5635 same size; then, to the proper argument type for the built-in
5636 function. But the return type is of the default INTEGER kind. */
5637 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5638 arg
= fold_convert (arg_type
, arg
);
5639 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5640 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5642 /* Compute LEADZ for the case i .ne. 0. */
5645 s
= TYPE_PRECISION (arg_type
) - argsize
;
5646 tmp
= fold_convert (result_type
,
5647 build_call_expr_loc (input_location
, func
,
5649 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
5650 tmp
, build_int_cst (result_type
, s
));
5654 /* We end up here if the argument type is larger than 'long long'.
5655 We generate this code:
5657 if (x & (ULL_MAX << ULL_SIZE) != 0)
5658 return clzll ((unsigned long long) (x >> ULLSIZE));
5660 return ULL_SIZE + clzll ((unsigned long long) x);
5661 where ULL_MAX is the largest value that a ULL_MAX can hold
5662 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5663 is the bit-size of the long long type (64 in this example). */
5664 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5666 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5667 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5668 long_long_unsigned_type_node
,
5669 build_int_cst (long_long_unsigned_type_node
,
5672 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
5673 fold_convert (arg_type
, ullmax
), ullsize
);
5674 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
5676 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5677 cond
, build_int_cst (arg_type
, 0));
5679 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5681 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5682 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5683 tmp1
= fold_convert (result_type
,
5684 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5686 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5687 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5688 tmp2
= fold_convert (result_type
,
5689 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5690 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5693 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5697 /* Build BIT_SIZE. */
5698 bit_size
= build_int_cst (result_type
, argsize
);
5700 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5701 arg
, build_int_cst (arg_type
, 0));
5702 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5707 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5709 The conditional expression is necessary because the result of TRAILZ(0)
5710 is defined, but the result of __builtin_ctz(0) is undefined for most
5714 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
5725 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5726 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5728 /* Which variant of __builtin_ctz* should we call? */
5729 if (argsize
<= INT_TYPE_SIZE
)
5731 arg_type
= unsigned_type_node
;
5732 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5734 else if (argsize
<= LONG_TYPE_SIZE
)
5736 arg_type
= long_unsigned_type_node
;
5737 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5739 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5741 arg_type
= long_long_unsigned_type_node
;
5742 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5746 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5747 arg_type
= gfc_build_uint_type (argsize
);
5751 /* Convert the actual argument twice: first, to the unsigned type of the
5752 same size; then, to the proper argument type for the built-in
5753 function. But the return type is of the default INTEGER kind. */
5754 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5755 arg
= fold_convert (arg_type
, arg
);
5756 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5757 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5759 /* Compute TRAILZ for the case i .ne. 0. */
5761 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5765 /* We end up here if the argument type is larger than 'long long'.
5766 We generate this code:
5768 if ((x & ULL_MAX) == 0)
5769 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5771 return ctzll ((unsigned long long) x);
5773 where ULL_MAX is the largest value that a ULL_MAX can hold
5774 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5775 is the bit-size of the long long type (64 in this example). */
5776 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5778 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5779 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5780 long_long_unsigned_type_node
,
5781 build_int_cst (long_long_unsigned_type_node
, 0));
5783 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5784 fold_convert (arg_type
, ullmax
));
5785 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
5786 build_int_cst (arg_type
, 0));
5788 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5790 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5791 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5792 tmp1
= fold_convert (result_type
,
5793 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5794 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5797 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5798 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5799 tmp2
= fold_convert (result_type
,
5800 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5802 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5806 /* Build BIT_SIZE. */
5807 bit_size
= build_int_cst (result_type
, argsize
);
5809 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5810 arg
, build_int_cst (arg_type
, 0));
5811 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5815 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5816 for types larger than "long long", we call the long long built-in for
5817 the lower and higher bits and combine the result. */
5820 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5828 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5829 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5830 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5832 /* Which variant of the builtin should we call? */
5833 if (argsize
<= INT_TYPE_SIZE
)
5835 arg_type
= unsigned_type_node
;
5836 func
= builtin_decl_explicit (parity
5838 : BUILT_IN_POPCOUNT
);
5840 else if (argsize
<= LONG_TYPE_SIZE
)
5842 arg_type
= long_unsigned_type_node
;
5843 func
= builtin_decl_explicit (parity
5845 : BUILT_IN_POPCOUNTL
);
5847 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5849 arg_type
= long_long_unsigned_type_node
;
5850 func
= builtin_decl_explicit (parity
5852 : BUILT_IN_POPCOUNTLL
);
5856 /* Our argument type is larger than 'long long', which mean none
5857 of the POPCOUNT builtins covers it. We thus call the 'long long'
5858 variant multiple times, and add the results. */
5859 tree utype
, arg2
, call1
, call2
;
5861 /* For now, we only cover the case where argsize is twice as large
5863 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5865 func
= builtin_decl_explicit (parity
5867 : BUILT_IN_POPCOUNTLL
);
5869 /* Convert it to an integer, and store into a variable. */
5870 utype
= gfc_build_uint_type (argsize
);
5871 arg
= fold_convert (utype
, arg
);
5872 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5874 /* Call the builtin twice. */
5875 call1
= build_call_expr_loc (input_location
, func
, 1,
5876 fold_convert (long_long_unsigned_type_node
,
5879 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5880 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5881 call2
= build_call_expr_loc (input_location
, func
, 1,
5882 fold_convert (long_long_unsigned_type_node
,
5885 /* Combine the results. */
5887 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5890 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5896 /* Convert the actual argument twice: first, to the unsigned type of the
5897 same size; then, to the proper argument type for the built-in
5899 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5900 arg
= fold_convert (arg_type
, arg
);
5902 se
->expr
= fold_convert (result_type
,
5903 build_call_expr_loc (input_location
, func
, 1, arg
));
5907 /* Process an intrinsic with unspecified argument-types that has an optional
5908 argument (which could be of type character), e.g. EOSHIFT. For those, we
5909 need to append the string length of the optional argument if it is not
5910 present and the type is really character.
5911 primary specifies the position (starting at 1) of the non-optional argument
5912 specifying the type and optional gives the position of the optional
5913 argument in the arglist. */
5916 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5917 unsigned primary
, unsigned optional
)
5919 gfc_actual_arglist
* prim_arg
;
5920 gfc_actual_arglist
* opt_arg
;
5922 gfc_actual_arglist
* arg
;
5924 vec
<tree
, va_gc
> *append_args
;
5926 /* Find the two arguments given as position. */
5930 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5934 if (cur_pos
== primary
)
5936 if (cur_pos
== optional
)
5939 if (cur_pos
>= primary
&& cur_pos
>= optional
)
5942 gcc_assert (prim_arg
);
5943 gcc_assert (prim_arg
->expr
);
5944 gcc_assert (opt_arg
);
5946 /* If we do have type CHARACTER and the optional argument is really absent,
5947 append a dummy 0 as string length. */
5949 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
5953 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
5954 vec_alloc (append_args
, 1);
5955 append_args
->quick_push (dummy
);
5958 /* Build the call itself. */
5959 gcc_assert (!se
->ignore_optional
);
5960 sym
= gfc_get_symbol_for_expr (expr
, false);
5961 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5963 gfc_free_symbol (sym
);
5967 /* The length of a character string. */
5969 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
5978 gcc_assert (!se
->ss
);
5980 arg
= expr
->value
.function
.actual
->expr
;
5982 type
= gfc_typenode_for_spec (&expr
->ts
);
5983 switch (arg
->expr_type
)
5986 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
5990 /* Obtain the string length from the function used by
5991 trans-array.c(gfc_trans_array_constructor). */
5993 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
5997 if (arg
->ref
== NULL
5998 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6000 /* This doesn't catch all cases.
6001 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6002 and the surrounding thread. */
6003 sym
= arg
->symtree
->n
.sym
;
6004 decl
= gfc_get_symbol_decl (sym
);
6005 if (decl
== current_function_decl
&& sym
->attr
.function
6006 && (sym
->result
== sym
))
6007 decl
= gfc_get_fake_result_decl (sym
, 0);
6009 len
= sym
->ts
.u
.cl
->backend_decl
;
6017 /* Anybody stupid enough to do this deserves inefficient code. */
6018 gfc_init_se (&argse
, se
);
6020 gfc_conv_expr (&argse
, arg
);
6022 gfc_conv_expr_descriptor (&argse
, arg
);
6023 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6024 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6025 len
= argse
.string_length
;
6028 se
->expr
= convert (type
, len
);
6031 /* The length of a character string not including trailing blanks. */
6033 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6035 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6036 tree args
[2], type
, fndecl
;
6038 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6039 type
= gfc_typenode_for_spec (&expr
->ts
);
6042 fndecl
= gfor_fndecl_string_len_trim
;
6044 fndecl
= gfor_fndecl_string_len_trim_char4
;
6048 se
->expr
= build_call_expr_loc (input_location
,
6049 fndecl
, 2, args
[0], args
[1]);
6050 se
->expr
= convert (type
, se
->expr
);
6054 /* Returns the starting position of a substring within a string. */
6057 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6060 tree logical4_type_node
= gfc_get_logical_type (4);
6064 unsigned int num_args
;
6066 args
= XALLOCAVEC (tree
, 5);
6068 /* Get number of arguments; characters count double due to the
6069 string length argument. Kind= is not passed to the library
6070 and thus ignored. */
6071 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6076 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6077 type
= gfc_typenode_for_spec (&expr
->ts
);
6080 args
[4] = build_int_cst (logical4_type_node
, 0);
6082 args
[4] = convert (logical4_type_node
, args
[4]);
6084 fndecl
= build_addr (function
);
6085 se
->expr
= build_call_array_loc (input_location
,
6086 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6088 se
->expr
= convert (type
, se
->expr
);
6092 /* The ascii value for a single character. */
6094 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6096 tree args
[3], type
, pchartype
;
6099 nargs
= gfc_intrinsic_argument_list_length (expr
);
6100 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6101 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6102 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6103 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6104 type
= gfc_typenode_for_spec (&expr
->ts
);
6106 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6108 se
->expr
= convert (type
, se
->expr
);
6112 /* Intrinsic ISNAN calls __builtin_isnan. */
6115 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6119 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6120 se
->expr
= build_call_expr_loc (input_location
,
6121 builtin_decl_explicit (BUILT_IN_ISNAN
),
6123 STRIP_TYPE_NOPS (se
->expr
);
6124 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6128 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6129 their argument against a constant integer value. */
6132 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6136 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6137 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6138 gfc_typenode_for_spec (&expr
->ts
),
6139 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6144 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6147 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
6155 unsigned int num_args
;
6157 num_args
= gfc_intrinsic_argument_list_length (expr
);
6158 args
= XALLOCAVEC (tree
, num_args
);
6160 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6161 if (expr
->ts
.type
!= BT_CHARACTER
)
6169 /* We do the same as in the non-character case, but the argument
6170 list is different because of the string length arguments. We
6171 also have to set the string length for the result. */
6178 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
6180 se
->string_length
= len
;
6182 type
= TREE_TYPE (tsource
);
6183 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
6184 fold_convert (type
, fsource
));
6188 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6191 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
6193 tree args
[3], mask
, type
;
6195 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6196 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
6198 type
= TREE_TYPE (args
[0]);
6199 gcc_assert (TREE_TYPE (args
[1]) == type
);
6200 gcc_assert (TREE_TYPE (mask
) == type
);
6202 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
6203 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
6204 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6206 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
6211 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6212 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6215 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
6217 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
6220 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6221 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6223 type
= gfc_get_int_type (expr
->ts
.kind
);
6224 utype
= unsigned_type_for (type
);
6226 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
6227 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
6229 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
6230 build_int_cst (utype
, 0));
6234 /* Left-justified mask. */
6235 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
6237 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6238 fold_convert (utype
, res
));
6240 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6241 smaller than type width. */
6242 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
6243 build_int_cst (TREE_TYPE (arg
), 0));
6244 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
6245 build_int_cst (utype
, 0), res
);
6249 /* Right-justified mask. */
6250 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6251 fold_convert (utype
, arg
));
6252 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
6254 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6255 strictly smaller than type width. */
6256 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6258 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
6259 cond
, allones
, res
);
6262 se
->expr
= fold_convert (type
, res
);
6266 /* FRACTION (s) is translated into:
6267 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6269 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
6271 tree arg
, type
, tmp
, res
, frexp
, cond
;
6273 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6275 type
= gfc_typenode_for_spec (&expr
->ts
);
6276 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6277 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6279 cond
= build_call_expr_loc (input_location
,
6280 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6283 tmp
= gfc_create_var (integer_type_node
, NULL
);
6284 res
= build_call_expr_loc (input_location
, frexp
, 2,
6285 fold_convert (type
, arg
),
6286 gfc_build_addr_expr (NULL_TREE
, tmp
));
6287 res
= fold_convert (type
, res
);
6289 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
6290 cond
, res
, gfc_build_nan (type
, ""));
6294 /* NEAREST (s, dir) is translated into
6295 tmp = copysign (HUGE_VAL, dir);
6296 return nextafter (s, tmp);
6299 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
6301 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
6303 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
6304 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
6306 type
= gfc_typenode_for_spec (&expr
->ts
);
6307 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6309 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
6310 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
6311 fold_convert (type
, args
[1]));
6312 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
6313 fold_convert (type
, args
[0]), tmp
);
6314 se
->expr
= fold_convert (type
, se
->expr
);
6318 /* SPACING (s) is translated into
6328 e = MAX_EXPR (e, emin);
6329 res = scalbn (1., e);
6333 where prec is the precision of s, gfc_real_kinds[k].digits,
6334 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6335 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6338 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
6340 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
6341 tree cond
, nan
, tmp
, frexp
, scalbn
;
6345 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6346 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
6347 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
6348 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
6350 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6351 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6353 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6354 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6356 type
= gfc_typenode_for_spec (&expr
->ts
);
6357 e
= gfc_create_var (integer_type_node
, NULL
);
6358 res
= gfc_create_var (type
, NULL
);
6361 /* Build the block for s /= 0. */
6362 gfc_start_block (&block
);
6363 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6364 gfc_build_addr_expr (NULL_TREE
, e
));
6365 gfc_add_expr_to_block (&block
, tmp
);
6367 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
6369 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
6370 integer_type_node
, tmp
, emin
));
6372 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
6373 build_real_from_int_cst (type
, integer_one_node
), e
);
6374 gfc_add_modify (&block
, res
, tmp
);
6376 /* Finish by building the IF statement for value zero. */
6377 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
6378 build_real_from_int_cst (type
, integer_zero_node
));
6379 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
6380 gfc_finish_block (&block
));
6382 /* And deal with infinities and NaNs. */
6383 cond
= build_call_expr_loc (input_location
,
6384 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6386 nan
= gfc_build_nan (type
, "");
6387 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
6389 gfc_add_expr_to_block (&se
->pre
, tmp
);
6394 /* RRSPACING (s) is translated into
6403 x = scalbn (x, precision - e);
6410 where precision is gfc_real_kinds[k].digits. */
6413 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
6415 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
6419 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6420 prec
= gfc_real_kinds
[k
].digits
;
6422 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6423 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6424 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
6426 type
= gfc_typenode_for_spec (&expr
->ts
);
6427 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6428 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6430 e
= gfc_create_var (integer_type_node
, NULL
);
6431 x
= gfc_create_var (type
, NULL
);
6432 gfc_add_modify (&se
->pre
, x
,
6433 build_call_expr_loc (input_location
, fabs
, 1, arg
));
6436 gfc_start_block (&block
);
6437 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6438 gfc_build_addr_expr (NULL_TREE
, e
));
6439 gfc_add_expr_to_block (&block
, tmp
);
6441 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
6442 build_int_cst (integer_type_node
, prec
), e
);
6443 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
6444 gfc_add_modify (&block
, x
, tmp
);
6445 stmt
= gfc_finish_block (&block
);
6448 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
6449 build_real_from_int_cst (type
, integer_zero_node
));
6450 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
6452 /* And deal with infinities and NaNs. */
6453 cond
= build_call_expr_loc (input_location
,
6454 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6456 nan
= gfc_build_nan (type
, "");
6457 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
6459 gfc_add_expr_to_block (&se
->pre
, tmp
);
6460 se
->expr
= fold_convert (type
, x
);
6464 /* SCALE (s, i) is translated into scalbn (s, i). */
6466 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
6468 tree args
[2], type
, scalbn
;
6470 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6472 type
= gfc_typenode_for_spec (&expr
->ts
);
6473 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6474 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
6475 fold_convert (type
, args
[0]),
6476 fold_convert (integer_type_node
, args
[1]));
6477 se
->expr
= fold_convert (type
, se
->expr
);
6481 /* SET_EXPONENT (s, i) is translated into
6482 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6484 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
6486 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
6488 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6489 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6491 type
= gfc_typenode_for_spec (&expr
->ts
);
6492 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6493 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6495 tmp
= gfc_create_var (integer_type_node
, NULL
);
6496 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
6497 fold_convert (type
, args
[0]),
6498 gfc_build_addr_expr (NULL_TREE
, tmp
));
6499 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
6500 fold_convert (integer_type_node
, args
[1]));
6501 res
= fold_convert (type
, res
);
6503 /* Call to isfinite */
6504 cond
= build_call_expr_loc (input_location
,
6505 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6507 nan
= gfc_build_nan (type
, "");
6509 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6515 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
6517 gfc_actual_arglist
*actual
;
6524 gfc_init_se (&argse
, NULL
);
6525 actual
= expr
->value
.function
.actual
;
6527 if (actual
->expr
->ts
.type
== BT_CLASS
)
6528 gfc_add_class_array_ref (actual
->expr
);
6530 argse
.want_pointer
= 1;
6531 argse
.data_not_needed
= 1;
6532 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
6533 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6534 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6535 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
6537 /* Build the call to size0. */
6538 fncall0
= build_call_expr_loc (input_location
,
6539 gfor_fndecl_size0
, 1, arg1
);
6541 actual
= actual
->next
;
6545 gfc_init_se (&argse
, NULL
);
6546 gfc_conv_expr_type (&argse
, actual
->expr
,
6547 gfc_array_index_type
);
6548 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6550 /* Unusually, for an intrinsic, size does not exclude
6551 an optional arg2, so we must test for it. */
6552 if (actual
->expr
->expr_type
== EXPR_VARIABLE
6553 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
6554 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
6557 /* Build the call to size1. */
6558 fncall1
= build_call_expr_loc (input_location
,
6559 gfor_fndecl_size1
, 2,
6562 gfc_init_se (&argse
, NULL
);
6563 argse
.want_pointer
= 1;
6564 argse
.data_not_needed
= 1;
6565 gfc_conv_expr (&argse
, actual
->expr
);
6566 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6567 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6568 argse
.expr
, null_pointer_node
);
6569 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6570 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
6571 pvoid_type_node
, tmp
, fncall1
, fncall0
);
6575 se
->expr
= NULL_TREE
;
6576 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6577 gfc_array_index_type
,
6578 argse
.expr
, gfc_index_one_node
);
6581 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
6583 argse
.expr
= gfc_index_zero_node
;
6584 se
->expr
= NULL_TREE
;
6589 if (se
->expr
== NULL_TREE
)
6591 tree ubound
, lbound
;
6593 arg1
= build_fold_indirect_ref_loc (input_location
,
6595 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
6596 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
6597 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6598 gfc_array_index_type
, ubound
, lbound
);
6599 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
6600 gfc_array_index_type
,
6601 se
->expr
, gfc_index_one_node
);
6602 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6603 gfc_array_index_type
, se
->expr
,
6604 gfc_index_zero_node
);
6607 type
= gfc_typenode_for_spec (&expr
->ts
);
6608 se
->expr
= convert (type
, se
->expr
);
6612 /* Helper function to compute the size of a character variable,
6613 excluding the terminating null characters. The result has
6614 gfc_array_index_type type. */
6617 size_of_string_in_bytes (int kind
, tree string_length
)
6620 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
6622 bytesize
= build_int_cst (gfc_array_index_type
,
6623 gfc_character_kinds
[i
].bit_size
/ 8);
6625 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6627 fold_convert (gfc_array_index_type
, string_length
));
6632 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
6643 gfc_init_se (&argse
, NULL
);
6644 arg
= expr
->value
.function
.actual
->expr
;
6646 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
6647 gfc_conv_expr_descriptor (&argse
, arg
);
6649 gfc_conv_expr_reference (&argse
, arg
);
6651 if (arg
->ts
.type
== BT_ASSUMED
)
6653 /* This only works if an array descriptor has been passed; thus, extract
6654 the size from the descriptor. */
6655 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
6656 == TYPE_PRECISION (size_type_node
));
6657 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
6658 tmp
= DECL_LANG_SPECIFIC (tmp
)
6659 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
6660 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
6661 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
6662 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6663 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
6664 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
6665 build_int_cst (TREE_TYPE (tmp
),
6666 GFC_DTYPE_SIZE_SHIFT
));
6667 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
6669 else if (arg
->ts
.type
== BT_CLASS
)
6671 /* Conv_expr_descriptor returns a component_ref to _data component of the
6672 class object. The class object may be a non-pointer object, e.g.
6673 located on the stack, or a memory location pointed to, e.g. a
6674 parameter, i.e., an indirect_ref. */
6676 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
6677 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
6678 && GFC_DECL_CLASS (TREE_OPERAND (
6679 TREE_OPERAND (argse
.expr
, 0), 0)))
6680 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
6681 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6682 else if (arg
->rank
> 0)
6683 /* The scalarizer added an additional temp. To get the class' vptr
6684 one has to look at the original backend_decl. */
6685 byte_size
= gfc_class_vtab_size_get (
6686 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6688 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
6692 if (arg
->ts
.type
== BT_CHARACTER
)
6693 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6697 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6700 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6701 byte_size
= fold_convert (gfc_array_index_type
,
6702 size_in_bytes (byte_size
));
6707 se
->expr
= byte_size
;
6710 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
6711 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
6713 if (arg
->rank
== -1)
6715 tree cond
, loop_var
, exit_label
;
6718 tmp
= fold_convert (gfc_array_index_type
,
6719 gfc_conv_descriptor_rank (argse
.expr
));
6720 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
6721 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
6722 exit_label
= gfc_build_label_decl (NULL_TREE
);
6729 source_bytes = source_bytes * array.dim[i].extent;
6733 gfc_start_block (&body
);
6734 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6736 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6737 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6738 cond
, tmp
, build_empty_stmt (input_location
));
6739 gfc_add_expr_to_block (&body
, tmp
);
6741 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6742 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6743 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6744 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6745 gfc_array_index_type
, tmp
, source_bytes
);
6746 gfc_add_modify (&body
, source_bytes
, tmp
);
6748 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6749 gfc_array_index_type
, loop_var
,
6750 gfc_index_one_node
);
6751 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6753 tmp
= gfc_finish_block (&body
);
6755 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6757 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6759 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6760 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6764 /* Obtain the size of the array in bytes. */
6765 for (n
= 0; n
< arg
->rank
; n
++)
6768 idx
= gfc_rank_cst
[n
];
6769 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6770 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6771 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6772 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6773 gfc_array_index_type
, tmp
, source_bytes
);
6774 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6777 se
->expr
= source_bytes
;
6780 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6785 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6789 tree type
, result_type
, tmp
;
6791 arg
= expr
->value
.function
.actual
->expr
;
6793 gfc_init_se (&argse
, NULL
);
6794 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6798 if (arg
->ts
.type
== BT_CLASS
)
6800 gfc_add_vptr_component (arg
);
6801 gfc_add_size_component (arg
);
6802 gfc_conv_expr (&argse
, arg
);
6803 tmp
= fold_convert (result_type
, argse
.expr
);
6807 gfc_conv_expr_reference (&argse
, arg
);
6808 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6813 argse
.want_pointer
= 0;
6814 gfc_conv_expr_descriptor (&argse
, arg
);
6815 if (arg
->ts
.type
== BT_CLASS
)
6818 tmp
= gfc_class_vtab_size_get (
6819 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6821 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6822 tmp
= fold_convert (result_type
, tmp
);
6825 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6828 /* Obtain the argument's word length. */
6829 if (arg
->ts
.type
== BT_CHARACTER
)
6830 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6832 tmp
= size_in_bytes (type
);
6833 tmp
= fold_convert (result_type
, tmp
);
6836 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6837 build_int_cst (result_type
, BITS_PER_UNIT
));
6838 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6842 /* Intrinsic string comparison functions. */
6845 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6849 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6852 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6853 expr
->value
.function
.actual
->expr
->ts
.kind
,
6855 se
->expr
= fold_build2_loc (input_location
, op
,
6856 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6857 build_int_cst (TREE_TYPE (se
->expr
), 0));
6860 /* Generate a call to the adjustl/adjustr library function. */
6862 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6870 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6873 type
= TREE_TYPE (args
[2]);
6874 var
= gfc_conv_string_tmp (se
, type
, len
);
6877 tmp
= build_call_expr_loc (input_location
,
6878 fndecl
, 3, args
[0], args
[1], args
[2]);
6879 gfc_add_expr_to_block (&se
->pre
, tmp
);
6881 se
->string_length
= len
;
6885 /* Generate code for the TRANSFER intrinsic:
6887 DEST = TRANSFER (SOURCE, MOLD)
6889 typeof<DEST> = typeof<MOLD>
6894 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6896 typeof<DEST> = typeof<MOLD>
6898 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6899 sizeof (DEST(0) * SIZE). */
6901 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6917 gfc_actual_arglist
*arg
;
6919 gfc_array_info
*info
;
6923 gfc_expr
*source_expr
, *mold_expr
;
6927 info
= &se
->ss
->info
->data
.array
;
6929 /* Convert SOURCE. The output from this stage is:-
6930 source_bytes = length of the source in bytes
6931 source = pointer to the source data. */
6932 arg
= expr
->value
.function
.actual
;
6933 source_expr
= arg
->expr
;
6935 /* Ensure double transfer through LOGICAL preserves all
6937 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6938 && arg
->expr
->value
.function
.esym
== NULL
6939 && arg
->expr
->value
.function
.isym
!= NULL
6940 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6941 && arg
->expr
->ts
.type
== BT_LOGICAL
6942 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6943 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6945 gfc_init_se (&argse
, NULL
);
6947 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6949 /* Obtain the pointer to source and the length of source in bytes. */
6950 if (arg
->expr
->rank
== 0)
6952 gfc_conv_expr_reference (&argse
, arg
->expr
);
6953 if (arg
->expr
->ts
.type
== BT_CLASS
)
6954 source
= gfc_class_data_get (argse
.expr
);
6956 source
= argse
.expr
;
6958 /* Obtain the source word length. */
6959 switch (arg
->expr
->ts
.type
)
6962 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6963 argse
.string_length
);
6966 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6969 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6971 tmp
= fold_convert (gfc_array_index_type
,
6972 size_in_bytes (source_type
));
6978 argse
.want_pointer
= 0;
6979 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6980 source
= gfc_conv_descriptor_data_get (argse
.expr
);
6981 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6983 /* Repack the source if not simply contiguous. */
6984 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
6986 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
6988 if (warn_array_temporaries
)
6989 gfc_warning (OPT_Warray_temporaries
,
6990 "Creating array temporary at %L", &expr
->where
);
6992 source
= build_call_expr_loc (input_location
,
6993 gfor_fndecl_in_pack
, 1, tmp
);
6994 source
= gfc_evaluate_now (source
, &argse
.pre
);
6996 /* Free the temporary. */
6997 gfc_start_block (&block
);
6998 tmp
= gfc_call_free (source
);
6999 gfc_add_expr_to_block (&block
, tmp
);
7000 stmt
= gfc_finish_block (&block
);
7002 /* Clean up if it was repacked. */
7003 gfc_init_block (&block
);
7004 tmp
= gfc_conv_array_data (argse
.expr
);
7005 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7007 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7008 build_empty_stmt (input_location
));
7009 gfc_add_expr_to_block (&block
, tmp
);
7010 gfc_add_block_to_block (&block
, &se
->post
);
7011 gfc_init_block (&se
->post
);
7012 gfc_add_block_to_block (&se
->post
, &block
);
7015 /* Obtain the source word length. */
7016 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7017 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7018 argse
.string_length
);
7020 tmp
= fold_convert (gfc_array_index_type
,
7021 size_in_bytes (source_type
));
7023 /* Obtain the size of the array in bytes. */
7024 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7025 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7028 idx
= gfc_rank_cst
[n
];
7029 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7030 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7031 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7032 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7033 gfc_array_index_type
, upper
, lower
);
7034 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7035 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7036 gfc_array_index_type
, extent
,
7037 gfc_index_one_node
);
7038 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7039 gfc_array_index_type
, tmp
, source_bytes
);
7043 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7044 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7045 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7047 /* Now convert MOLD. The outputs are:
7048 mold_type = the TREE type of MOLD
7049 dest_word_len = destination word length in bytes. */
7051 mold_expr
= arg
->expr
;
7053 gfc_init_se (&argse
, NULL
);
7055 scalar_mold
= arg
->expr
->rank
== 0;
7057 if (arg
->expr
->rank
== 0)
7059 gfc_conv_expr_reference (&argse
, arg
->expr
);
7060 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7065 gfc_init_se (&argse
, NULL
);
7066 argse
.want_pointer
= 0;
7067 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7068 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7071 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7072 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7074 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7076 /* If this TRANSFER is nested in another TRANSFER, use a type
7077 that preserves all bits. */
7078 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7079 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7082 /* Obtain the destination word length. */
7083 switch (arg
->expr
->ts
.type
)
7086 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7087 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7090 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7093 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7096 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7097 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7099 /* Finally convert SIZE, if it is present. */
7101 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7105 gfc_init_se (&argse
, NULL
);
7106 gfc_conv_expr_reference (&argse
, arg
->expr
);
7107 tmp
= convert (gfc_array_index_type
,
7108 build_fold_indirect_ref_loc (input_location
,
7110 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7111 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7116 /* Separate array and scalar results. */
7117 if (scalar_mold
&& tmp
== NULL_TREE
)
7118 goto scalar_transfer
;
7120 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7121 if (tmp
!= NULL_TREE
)
7122 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7123 tmp
, dest_word_len
);
7127 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
7128 gfc_add_modify (&se
->pre
, size_words
,
7129 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
7130 gfc_array_index_type
,
7131 size_bytes
, dest_word_len
));
7133 /* Evaluate the bounds of the result. If the loop range exists, we have
7134 to check if it is too large. If so, we modify loop->to be consistent
7135 with min(size, size(source)). Otherwise, size is made consistent with
7136 the loop range, so that the right number of bytes is transferred.*/
7137 n
= se
->loop
->order
[0];
7138 if (se
->loop
->to
[n
] != NULL_TREE
)
7140 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7141 se
->loop
->to
[n
], se
->loop
->from
[n
]);
7142 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7143 tmp
, gfc_index_one_node
);
7144 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7146 gfc_add_modify (&se
->pre
, size_words
, tmp
);
7147 gfc_add_modify (&se
->pre
, size_bytes
,
7148 fold_build2_loc (input_location
, MULT_EXPR
,
7149 gfc_array_index_type
,
7150 size_words
, dest_word_len
));
7151 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7152 size_words
, se
->loop
->from
[n
]);
7153 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7154 upper
, gfc_index_one_node
);
7158 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7159 size_words
, gfc_index_one_node
);
7160 se
->loop
->from
[n
] = gfc_index_zero_node
;
7163 se
->loop
->to
[n
] = upper
;
7165 /* Build a destination descriptor, using the pointer, source, as the
7167 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
7168 NULL_TREE
, false, true, false, &expr
->where
);
7170 /* Cast the pointer to the result. */
7171 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7172 tmp
= fold_convert (pvoid_type_node
, tmp
);
7174 /* Use memcpy to do the transfer. */
7176 = build_call_expr_loc (input_location
,
7177 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
7178 fold_convert (pvoid_type_node
, source
),
7179 fold_convert (size_type_node
,
7180 fold_build2_loc (input_location
,
7182 gfc_array_index_type
,
7185 gfc_add_expr_to_block (&se
->pre
, tmp
);
7187 se
->expr
= info
->descriptor
;
7188 if (expr
->ts
.type
== BT_CHARACTER
)
7189 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7193 /* Deal with scalar results. */
7195 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7196 dest_word_len
, source_bytes
);
7197 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7198 extent
, gfc_index_zero_node
);
7200 if (expr
->ts
.type
== BT_CHARACTER
)
7202 tree direct
, indirect
, free
;
7204 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
7205 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
7208 /* If source is longer than the destination, use a pointer to
7209 the source directly. */
7210 gfc_init_block (&block
);
7211 gfc_add_modify (&block
, tmpdecl
, ptr
);
7212 direct
= gfc_finish_block (&block
);
7214 /* Otherwise, allocate a string with the length of the destination
7215 and copy the source into it. */
7216 gfc_init_block (&block
);
7217 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
7218 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
7219 gfc_add_modify (&block
, tmpdecl
,
7220 fold_convert (TREE_TYPE (ptr
), tmp
));
7221 tmp
= build_call_expr_loc (input_location
,
7222 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7223 fold_convert (pvoid_type_node
, tmpdecl
),
7224 fold_convert (pvoid_type_node
, ptr
),
7225 fold_convert (size_type_node
, extent
));
7226 gfc_add_expr_to_block (&block
, tmp
);
7227 indirect
= gfc_finish_block (&block
);
7229 /* Wrap it up with the condition. */
7230 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
7231 dest_word_len
, source_bytes
);
7232 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
7233 gfc_add_expr_to_block (&se
->pre
, tmp
);
7235 /* Free the temporary string, if necessary. */
7236 free
= gfc_call_free (tmpdecl
);
7237 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7238 dest_word_len
, source_bytes
);
7239 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
7240 gfc_add_expr_to_block (&se
->post
, tmp
);
7243 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7247 tmpdecl
= gfc_create_var (mold_type
, "transfer");
7249 ptr
= convert (build_pointer_type (mold_type
), source
);
7251 /* For CLASS results, allocate the needed memory first. */
7252 if (mold_expr
->ts
.type
== BT_CLASS
)
7255 cdata
= gfc_class_data_get (tmpdecl
);
7256 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
7257 gfc_add_modify (&se
->pre
, cdata
, tmp
);
7260 /* Use memcpy to do the transfer. */
7261 if (mold_expr
->ts
.type
== BT_CLASS
)
7262 tmp
= gfc_class_data_get (tmpdecl
);
7264 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
7266 tmp
= build_call_expr_loc (input_location
,
7267 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7268 fold_convert (pvoid_type_node
, tmp
),
7269 fold_convert (pvoid_type_node
, ptr
),
7270 fold_convert (size_type_node
, extent
));
7271 gfc_add_expr_to_block (&se
->pre
, tmp
);
7273 /* For CLASS results, set the _vptr. */
7274 if (mold_expr
->ts
.type
== BT_CLASS
)
7278 vptr
= gfc_class_vptr_get (tmpdecl
);
7279 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
7281 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7282 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
7290 /* Generate code for the ALLOCATED intrinsic.
7291 Generate inline code that directly check the address of the argument. */
7294 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
7296 gfc_actual_arglist
*arg1
;
7300 gfc_init_se (&arg1se
, NULL
);
7301 arg1
= expr
->value
.function
.actual
;
7303 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7305 /* Make sure that class array expressions have both a _data
7306 component reference and an array reference.... */
7307 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
7308 gfc_add_class_array_ref (arg1
->expr
);
7309 /* .... whilst scalars only need the _data component. */
7311 gfc_add_data_component (arg1
->expr
);
7314 if (arg1
->expr
->rank
== 0)
7316 /* Allocatable scalar. */
7317 arg1se
.want_pointer
= 1;
7318 gfc_conv_expr (&arg1se
, arg1
->expr
);
7323 /* Allocatable array. */
7324 arg1se
.descriptor_only
= 1;
7325 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7326 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7329 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
7330 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7331 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7335 /* Generate code for the ASSOCIATED intrinsic.
7336 If both POINTER and TARGET are arrays, generate a call to library function
7337 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7338 In other cases, generate inline code that directly compare the address of
7339 POINTER with the address of TARGET. */
7342 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
7344 gfc_actual_arglist
*arg1
;
7345 gfc_actual_arglist
*arg2
;
7350 tree nonzero_charlen
;
7351 tree nonzero_arraylen
;
7355 gfc_init_se (&arg1se
, NULL
);
7356 gfc_init_se (&arg2se
, NULL
);
7357 arg1
= expr
->value
.function
.actual
;
7360 /* Check whether the expression is a scalar or not; we cannot use
7361 arg1->expr->rank as it can be nonzero for proc pointers. */
7362 ss
= gfc_walk_expr (arg1
->expr
);
7363 scalar
= ss
== gfc_ss_terminator
;
7365 gfc_free_ss_chain (ss
);
7369 /* No optional target. */
7372 /* A pointer to a scalar. */
7373 arg1se
.want_pointer
= 1;
7374 gfc_conv_expr (&arg1se
, arg1
->expr
);
7375 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7376 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7377 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7379 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7381 tmp2
= gfc_class_data_get (arg1se
.expr
);
7382 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7383 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7390 /* A pointer to an array. */
7391 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7392 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7394 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7395 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7396 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
7397 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
7402 /* An optional target. */
7403 if (arg2
->expr
->ts
.type
== BT_CLASS
)
7404 gfc_add_data_component (arg2
->expr
);
7406 nonzero_charlen
= NULL_TREE
;
7407 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
7408 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
7410 arg1
->expr
->ts
.u
.cl
->backend_decl
,
7414 /* A pointer to a scalar. */
7415 arg1se
.want_pointer
= 1;
7416 gfc_conv_expr (&arg1se
, arg1
->expr
);
7417 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7418 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7419 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7421 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7422 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
7424 arg2se
.want_pointer
= 1;
7425 gfc_conv_expr (&arg2se
, arg2
->expr
);
7426 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7427 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
7428 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
7430 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7431 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7432 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7433 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7434 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7435 arg1se
.expr
, arg2se
.expr
);
7436 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7437 arg1se
.expr
, null_pointer_node
);
7438 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7439 boolean_type_node
, tmp
, tmp2
);
7443 /* An array pointer of zero length is not associated if target is
7445 arg1se
.descriptor_only
= 1;
7446 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
7447 if (arg1
->expr
->rank
== -1)
7449 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
7450 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7451 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
7454 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
7455 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
7456 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
7457 boolean_type_node
, tmp
,
7458 build_int_cst (TREE_TYPE (tmp
), 0));
7460 /* A pointer to an array, call library function _gfor_associated. */
7461 arg1se
.want_pointer
= 1;
7462 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7464 arg2se
.want_pointer
= 1;
7465 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
7466 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7467 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7468 se
->expr
= build_call_expr_loc (input_location
,
7469 gfor_fndecl_associated
, 2,
7470 arg1se
.expr
, arg2se
.expr
);
7471 se
->expr
= convert (boolean_type_node
, se
->expr
);
7472 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7473 boolean_type_node
, se
->expr
,
7477 /* If target is present zero character length pointers cannot
7479 if (nonzero_charlen
!= NULL_TREE
)
7480 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7482 se
->expr
, nonzero_charlen
);
7485 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7489 /* Generate code for the SAME_TYPE_AS intrinsic.
7490 Generate inline code that directly checks the vindices. */
7493 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
7498 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
7500 gfc_init_se (&se1
, NULL
);
7501 gfc_init_se (&se2
, NULL
);
7503 a
= expr
->value
.function
.actual
->expr
;
7504 b
= expr
->value
.function
.actual
->next
->expr
;
7506 if (UNLIMITED_POLY (a
))
7508 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
7509 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7510 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7513 if (UNLIMITED_POLY (b
))
7515 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
7516 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7517 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7520 if (a
->ts
.type
== BT_CLASS
)
7522 gfc_add_vptr_component (a
);
7523 gfc_add_hash_component (a
);
7525 else if (a
->ts
.type
== BT_DERIVED
)
7526 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7527 a
->ts
.u
.derived
->hash_value
);
7529 if (b
->ts
.type
== BT_CLASS
)
7531 gfc_add_vptr_component (b
);
7532 gfc_add_hash_component (b
);
7534 else if (b
->ts
.type
== BT_DERIVED
)
7535 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7536 b
->ts
.u
.derived
->hash_value
);
7538 gfc_conv_expr (&se1
, a
);
7539 gfc_conv_expr (&se2
, b
);
7541 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
7542 boolean_type_node
, se1
.expr
,
7543 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
7546 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7547 boolean_type_node
, conda
, tmp
);
7550 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7551 boolean_type_node
, condb
, tmp
);
7553 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7557 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
7560 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
7564 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7565 se
->expr
= build_call_expr_loc (input_location
,
7566 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
7567 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7571 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
7574 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
7578 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7580 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
7581 type
= gfc_get_int_type (4);
7582 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
7584 /* Convert it to the required type. */
7585 type
= gfc_typenode_for_spec (&expr
->ts
);
7586 se
->expr
= build_call_expr_loc (input_location
,
7587 gfor_fndecl_si_kind
, 1, arg
);
7588 se
->expr
= fold_convert (type
, se
->expr
);
7592 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
7595 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
7597 gfc_actual_arglist
*actual
;
7600 vec
<tree
, va_gc
> *args
= NULL
;
7602 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
7604 gfc_init_se (&argse
, se
);
7606 /* Pass a NULL pointer for an absent arg. */
7607 if (actual
->expr
== NULL
)
7608 argse
.expr
= null_pointer_node
;
7614 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
7616 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
7617 ts
.type
= BT_INTEGER
;
7618 ts
.kind
= gfc_c_int_kind
;
7619 gfc_convert_type (actual
->expr
, &ts
, 2);
7621 gfc_conv_expr_reference (&argse
, actual
->expr
);
7624 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7625 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7626 vec_safe_push (args
, argse
.expr
);
7629 /* Convert it to the required type. */
7630 type
= gfc_typenode_for_spec (&expr
->ts
);
7631 se
->expr
= build_call_expr_loc_vec (input_location
,
7632 gfor_fndecl_sr_kind
, args
);
7633 se
->expr
= fold_convert (type
, se
->expr
);
7637 /* Generate code for TRIM (A) intrinsic function. */
7640 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
7650 unsigned int num_args
;
7652 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
7653 args
= XALLOCAVEC (tree
, num_args
);
7655 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
7656 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
7657 len
= gfc_create_var (gfc_charlen_type_node
, "len");
7659 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
7660 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
7663 if (expr
->ts
.kind
== 1)
7664 function
= gfor_fndecl_string_trim
;
7665 else if (expr
->ts
.kind
== 4)
7666 function
= gfor_fndecl_string_trim_char4
;
7670 fndecl
= build_addr (function
);
7671 tmp
= build_call_array_loc (input_location
,
7672 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7674 gfc_add_expr_to_block (&se
->pre
, tmp
);
7676 /* Free the temporary afterwards, if necessary. */
7677 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7678 len
, build_int_cst (TREE_TYPE (len
), 0));
7679 tmp
= gfc_call_free (var
);
7680 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
7681 gfc_add_expr_to_block (&se
->post
, tmp
);
7684 se
->string_length
= len
;
7688 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
7691 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
7693 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
7694 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
7696 stmtblock_t block
, body
;
7699 /* We store in charsize the size of a character. */
7700 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
7701 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
7703 /* Get the arguments. */
7704 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7705 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
7707 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
7708 ncopies_type
= TREE_TYPE (ncopies
);
7710 /* Check that NCOPIES is not negative. */
7711 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
7712 build_int_cst (ncopies_type
, 0));
7713 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7714 "Argument NCOPIES of REPEAT intrinsic is negative "
7715 "(its value is %ld)",
7716 fold_convert (long_integer_type_node
, ncopies
));
7718 /* If the source length is zero, any non negative value of NCOPIES
7719 is valid, and nothing happens. */
7720 n
= gfc_create_var (ncopies_type
, "ncopies");
7721 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7722 build_int_cst (size_type_node
, 0));
7723 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
7724 build_int_cst (ncopies_type
, 0), ncopies
);
7725 gfc_add_modify (&se
->pre
, n
, tmp
);
7728 /* Check that ncopies is not too large: ncopies should be less than
7729 (or equal to) MAX / slen, where MAX is the maximal integer of
7730 the gfc_charlen_type_node type. If slen == 0, we need a special
7731 case to avoid the division by zero. */
7732 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
7733 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
7734 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
7735 fold_convert (size_type_node
, max
), slen
);
7736 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
7737 ? size_type_node
: ncopies_type
;
7738 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7739 fold_convert (largest
, ncopies
),
7740 fold_convert (largest
, max
));
7741 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7742 build_int_cst (size_type_node
, 0));
7743 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
7744 boolean_false_node
, cond
);
7745 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7746 "Argument NCOPIES of REPEAT intrinsic is too large");
7748 /* Compute the destination length. */
7749 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7750 fold_convert (gfc_charlen_type_node
, slen
),
7751 fold_convert (gfc_charlen_type_node
, ncopies
));
7752 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
7753 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
7755 /* Generate the code to do the repeat operation:
7756 for (i = 0; i < ncopies; i++)
7757 memmove (dest + (i * slen * size), src, slen*size); */
7758 gfc_start_block (&block
);
7759 count
= gfc_create_var (ncopies_type
, "count");
7760 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
7761 exit_label
= gfc_build_label_decl (NULL_TREE
);
7763 /* Start the loop body. */
7764 gfc_start_block (&body
);
7766 /* Exit the loop if count >= ncopies. */
7767 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
7769 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7770 TREE_USED (exit_label
) = 1;
7771 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7772 build_empty_stmt (input_location
));
7773 gfc_add_expr_to_block (&body
, tmp
);
7775 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7776 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7777 fold_convert (gfc_charlen_type_node
, slen
),
7778 fold_convert (gfc_charlen_type_node
, count
));
7779 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7780 tmp
, fold_convert (gfc_charlen_type_node
, size
));
7781 tmp
= fold_build_pointer_plus_loc (input_location
,
7782 fold_convert (pvoid_type_node
, dest
), tmp
);
7783 tmp
= build_call_expr_loc (input_location
,
7784 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7786 fold_build2_loc (input_location
, MULT_EXPR
,
7787 size_type_node
, slen
,
7788 fold_convert (size_type_node
,
7790 gfc_add_expr_to_block (&body
, tmp
);
7792 /* Increment count. */
7793 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
7794 count
, build_int_cst (TREE_TYPE (count
), 1));
7795 gfc_add_modify (&body
, count
, tmp
);
7797 /* Build the loop. */
7798 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7799 gfc_add_expr_to_block (&block
, tmp
);
7801 /* Add the exit label. */
7802 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7803 gfc_add_expr_to_block (&block
, tmp
);
7805 /* Finish the block. */
7806 tmp
= gfc_finish_block (&block
);
7807 gfc_add_expr_to_block (&se
->pre
, tmp
);
7809 /* Set the result value. */
7811 se
->string_length
= dlen
;
7815 /* Generate code for the IARGC intrinsic. */
7818 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
7824 /* Call the library function. This always returns an INTEGER(4). */
7825 fndecl
= gfor_fndecl_iargc
;
7826 tmp
= build_call_expr_loc (input_location
,
7829 /* Convert it to the required type. */
7830 type
= gfc_typenode_for_spec (&expr
->ts
);
7831 tmp
= fold_convert (type
, tmp
);
7837 /* The loc intrinsic returns the address of its argument as
7838 gfc_index_integer_kind integer. */
7841 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7846 gcc_assert (!se
->ss
);
7848 arg_expr
= expr
->value
.function
.actual
->expr
;
7849 if (arg_expr
->rank
== 0)
7851 if (arg_expr
->ts
.type
== BT_CLASS
)
7852 gfc_add_data_component (arg_expr
);
7853 gfc_conv_expr_reference (se
, arg_expr
);
7856 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7857 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7859 /* Create a temporary variable for loc return value. Without this,
7860 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7861 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7862 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7863 se
->expr
= temp_var
;
7867 /* The following routine generates code for the intrinsic
7868 functions from the ISO_C_BINDING module:
7874 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7876 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7878 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7880 if (arg
->expr
->rank
== 0)
7881 gfc_conv_expr_reference (se
, arg
->expr
);
7882 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
7883 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7886 gfc_conv_expr_descriptor (se
, arg
->expr
);
7887 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7890 /* TODO -- the following two lines shouldn't be necessary, but if
7891 they're removed, a bug is exposed later in the code path.
7892 This workaround was thus introduced, but will have to be
7893 removed; please see PR 35150 for details about the issue. */
7894 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7895 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7897 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7898 gfc_conv_expr_reference (se
, arg
->expr
);
7899 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7904 /* Build the addr_expr for the first argument. The argument is
7905 already an *address* so we don't need to set want_pointer in
7907 gfc_init_se (&arg1se
, NULL
);
7908 gfc_conv_expr (&arg1se
, arg
->expr
);
7909 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7910 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7912 /* See if we were given two arguments. */
7913 if (arg
->next
->expr
== NULL
)
7914 /* Only given one arg so generate a null and do a
7915 not-equal comparison against the first arg. */
7916 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7918 fold_convert (TREE_TYPE (arg1se
.expr
),
7919 null_pointer_node
));
7925 /* Given two arguments so build the arg2se from second arg. */
7926 gfc_init_se (&arg2se
, NULL
);
7927 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
7928 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7929 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7931 /* Generate test to compare that the two args are equal. */
7932 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7933 arg1se
.expr
, arg2se
.expr
);
7934 /* Generate test to ensure that the first arg is not null. */
7935 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
7937 arg1se
.expr
, null_pointer_node
);
7939 /* Finally, the generated test must check that both arg1 is not
7940 NULL and that it is equal to the second arg. */
7941 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7943 not_null_expr
, eq_expr
);
7951 /* The following routine generates code for the intrinsic
7952 subroutines from the ISO_C_BINDING module:
7954 * C_F_PROCPOINTER. */
7957 conv_isocbinding_subroutine (gfc_code
*code
)
7964 tree desc
, dim
, tmp
, stride
, offset
;
7965 stmtblock_t body
, block
;
7967 gfc_actual_arglist
*arg
= code
->ext
.actual
;
7969 gfc_init_se (&se
, NULL
);
7970 gfc_init_se (&cptrse
, NULL
);
7971 gfc_conv_expr (&cptrse
, arg
->expr
);
7972 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
7973 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
7975 gfc_init_se (&fptrse
, NULL
);
7976 if (arg
->next
->expr
->rank
== 0)
7978 fptrse
.want_pointer
= 1;
7979 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
7980 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
7981 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
7982 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7983 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
7984 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
7986 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7987 TREE_TYPE (fptrse
.expr
),
7989 fold_convert (TREE_TYPE (fptrse
.expr
),
7991 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
7992 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7993 return gfc_finish_block (&se
.pre
);
7996 gfc_start_block (&block
);
7998 /* Get the descriptor of the Fortran pointer. */
7999 fptrse
.descriptor_only
= 1;
8000 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
8001 gfc_add_block_to_block (&block
, &fptrse
.pre
);
8004 /* Set data value, dtype, and offset. */
8005 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
8006 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
8007 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
8008 gfc_get_dtype (TREE_TYPE (desc
)));
8010 /* Start scalarization of the bounds, using the shape argument. */
8012 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
8013 gcc_assert (shape_ss
!= gfc_ss_terminator
);
8014 gfc_init_se (&shapese
, NULL
);
8016 gfc_init_loopinfo (&loop
);
8017 gfc_add_ss_to_loop (&loop
, shape_ss
);
8018 gfc_conv_ss_startstride (&loop
);
8019 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
8020 gfc_mark_ss_chain_used (shape_ss
, 1);
8022 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
8023 shapese
.ss
= shape_ss
;
8025 stride
= gfc_create_var (gfc_array_index_type
, "stride");
8026 offset
= gfc_create_var (gfc_array_index_type
, "offset");
8027 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
8028 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8031 gfc_start_scalarized_body (&loop
, &body
);
8033 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8034 loop
.loopvar
[0], loop
.from
[0]);
8036 /* Set bounds and stride. */
8037 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
8038 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
8040 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
8041 gfc_add_block_to_block (&body
, &shapese
.pre
);
8042 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
8043 gfc_add_block_to_block (&body
, &shapese
.post
);
8045 /* Calculate offset. */
8046 gfc_add_modify (&body
, offset
,
8047 fold_build2_loc (input_location
, PLUS_EXPR
,
8048 gfc_array_index_type
, offset
, stride
));
8049 /* Update stride. */
8050 gfc_add_modify (&body
, stride
,
8051 fold_build2_loc (input_location
, MULT_EXPR
,
8052 gfc_array_index_type
, stride
,
8053 fold_convert (gfc_array_index_type
,
8055 /* Finish scalarization loop. */
8056 gfc_trans_scalarizing_loops (&loop
, &body
);
8057 gfc_add_block_to_block (&block
, &loop
.pre
);
8058 gfc_add_block_to_block (&block
, &loop
.post
);
8059 gfc_add_block_to_block (&block
, &fptrse
.post
);
8060 gfc_cleanup_loop (&loop
);
8062 gfc_add_modify (&block
, offset
,
8063 fold_build1_loc (input_location
, NEGATE_EXPR
,
8064 gfc_array_index_type
, offset
));
8065 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
8067 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
8068 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8069 return gfc_finish_block (&se
.pre
);
8073 /* Save and restore floating-point state. */
8076 gfc_save_fp_state (stmtblock_t
*block
)
8078 tree type
, fpstate
, tmp
;
8080 type
= build_array_type (char_type_node
,
8081 build_range_type (size_type_node
, size_zero_node
,
8082 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
8083 fpstate
= gfc_create_var (type
, "fpstate");
8084 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
8086 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
8088 gfc_add_expr_to_block (block
, tmp
);
8095 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
8099 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
8101 gfc_add_expr_to_block (block
, tmp
);
8105 /* Generate code for arguments of IEEE functions. */
8108 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
8111 gfc_actual_arglist
*actual
;
8116 actual
= expr
->value
.function
.actual
;
8117 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
8119 gcc_assert (actual
);
8122 gfc_init_se (&argse
, se
);
8123 gfc_conv_expr_val (&argse
, e
);
8125 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8126 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8127 argarray
[arg
] = argse
.expr
;
8132 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8133 and IEEE_UNORDERED, which translate directly to GCC type-generic
8137 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
8138 enum built_in_function code
, int nargs
)
8141 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
8143 conv_ieee_function_args (se
, expr
, args
, nargs
);
8144 se
->expr
= build_call_expr_loc_array (input_location
,
8145 builtin_decl_explicit (code
),
8147 STRIP_TYPE_NOPS (se
->expr
);
8148 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8152 /* Generate code for IEEE_IS_NORMAL intrinsic:
8153 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8156 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
8158 tree arg
, isnormal
, iszero
;
8160 /* Convert arg, evaluate it only once. */
8161 conv_ieee_function_args (se
, expr
, &arg
, 1);
8162 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8164 isnormal
= build_call_expr_loc (input_location
,
8165 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
8167 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
8168 build_real_from_int_cst (TREE_TYPE (arg
),
8169 integer_zero_node
));
8170 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8171 boolean_type_node
, isnormal
, iszero
);
8172 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8176 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8177 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8180 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
8182 tree arg
, signbit
, isnan
;
8184 /* Convert arg, evaluate it only once. */
8185 conv_ieee_function_args (se
, expr
, &arg
, 1);
8186 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8188 isnan
= build_call_expr_loc (input_location
,
8189 builtin_decl_explicit (BUILT_IN_ISNAN
),
8191 STRIP_TYPE_NOPS (isnan
);
8193 signbit
= build_call_expr_loc (input_location
,
8194 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8196 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8197 signbit
, integer_zero_node
);
8199 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8200 boolean_type_node
, signbit
,
8201 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
8202 TREE_TYPE(isnan
), isnan
));
8204 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8208 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8211 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
8212 enum built_in_function code
)
8214 tree arg
, decl
, call
, fpstate
;
8217 conv_ieee_function_args (se
, expr
, &arg
, 1);
8218 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
8219 decl
= builtin_decl_for_precision (code
, argprec
);
8221 /* Save floating-point state. */
8222 fpstate
= gfc_save_fp_state (&se
->pre
);
8224 /* Make the function call. */
8225 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
8226 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
8228 /* Restore floating-point state. */
8229 gfc_restore_fp_state (&se
->post
, fpstate
);
8233 /* Generate code for IEEE_REM. */
8236 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
8238 tree args
[2], decl
, call
, fpstate
;
8241 conv_ieee_function_args (se
, expr
, args
, 2);
8243 /* If arguments have unequal size, convert them to the larger. */
8244 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
8245 > TYPE_PRECISION (TREE_TYPE (args
[1])))
8246 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8247 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
8248 > TYPE_PRECISION (TREE_TYPE (args
[0])))
8249 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
8251 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8252 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
8254 /* Save floating-point state. */
8255 fpstate
= gfc_save_fp_state (&se
->pre
);
8257 /* Make the function call. */
8258 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8259 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8261 /* Restore floating-point state. */
8262 gfc_restore_fp_state (&se
->post
, fpstate
);
8266 /* Generate code for IEEE_NEXT_AFTER. */
8269 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
8271 tree args
[2], decl
, call
, fpstate
;
8274 conv_ieee_function_args (se
, expr
, args
, 2);
8276 /* Result has the characteristics of first argument. */
8277 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8278 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8279 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
8281 /* Save floating-point state. */
8282 fpstate
= gfc_save_fp_state (&se
->pre
);
8284 /* Make the function call. */
8285 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8286 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8288 /* Restore floating-point state. */
8289 gfc_restore_fp_state (&se
->post
, fpstate
);
8293 /* Generate code for IEEE_SCALB. */
8296 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
8298 tree args
[2], decl
, call
, huge
, type
;
8301 conv_ieee_function_args (se
, expr
, args
, 2);
8303 /* Result has the characteristics of first argument. */
8304 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8305 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
8307 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
8309 /* We need to fold the integer into the range of a C int. */
8310 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
8311 type
= TREE_TYPE (args
[1]);
8313 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
8314 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
8316 huge
= fold_convert (type
, huge
);
8317 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
8319 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
8320 fold_build1_loc (input_location
, NEGATE_EXPR
,
8324 args
[1] = fold_convert (integer_type_node
, args
[1]);
8326 /* Make the function call. */
8327 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8328 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8332 /* Generate code for IEEE_COPY_SIGN. */
8335 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
8337 tree args
[2], decl
, sign
;
8340 conv_ieee_function_args (se
, expr
, args
, 2);
8342 /* Get the sign of the second argument. */
8343 sign
= build_call_expr_loc (input_location
,
8344 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8346 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8347 sign
, integer_zero_node
);
8349 /* Create a value of one, with the right sign. */
8350 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
8352 fold_build1_loc (input_location
, NEGATE_EXPR
,
8356 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
8358 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8359 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
8361 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8365 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8369 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
8371 const char *name
= expr
->value
.function
.name
;
8373 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8375 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
8376 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
8377 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
8378 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
8379 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
8380 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
8381 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
8382 conv_intrinsic_ieee_is_normal (se
, expr
);
8383 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
8384 conv_intrinsic_ieee_is_negative (se
, expr
);
8385 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
8386 conv_intrinsic_ieee_copy_sign (se
, expr
);
8387 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
8388 conv_intrinsic_ieee_scalb (se
, expr
);
8389 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
8390 conv_intrinsic_ieee_next_after (se
, expr
);
8391 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
8392 conv_intrinsic_ieee_rem (se
, expr
);
8393 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
8394 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
8395 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
8396 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
8398 /* It is not among the functions we translate directly. We return
8399 false, so a library function call is emitted. */
8408 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8411 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
8413 tree arg
, res
, restype
;
8415 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8416 arg
= fold_convert (size_type_node
, arg
);
8417 res
= build_call_expr_loc (input_location
,
8418 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
8419 restype
= gfc_typenode_for_spec (&expr
->ts
);
8420 se
->expr
= fold_convert (restype
, res
);
8424 /* Generate code for an intrinsic function. Some map directly to library
8425 calls, others get special handling. In some cases the name of the function
8426 used depends on the type specifiers. */
8429 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
8435 name
= &expr
->value
.function
.name
[2];
8439 lib
= gfc_is_intrinsic_libcall (expr
);
8443 se
->ignore_optional
= 1;
8445 switch (expr
->value
.function
.isym
->id
)
8447 case GFC_ISYM_EOSHIFT
:
8449 case GFC_ISYM_RESHAPE
:
8450 /* For all of those the first argument specifies the type and the
8451 third is optional. */
8452 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
8456 gfc_conv_intrinsic_funcall (se
, expr
);
8464 switch (expr
->value
.function
.isym
->id
)
8469 case GFC_ISYM_REPEAT
:
8470 gfc_conv_intrinsic_repeat (se
, expr
);
8474 gfc_conv_intrinsic_trim (se
, expr
);
8477 case GFC_ISYM_SC_KIND
:
8478 gfc_conv_intrinsic_sc_kind (se
, expr
);
8481 case GFC_ISYM_SI_KIND
:
8482 gfc_conv_intrinsic_si_kind (se
, expr
);
8485 case GFC_ISYM_SR_KIND
:
8486 gfc_conv_intrinsic_sr_kind (se
, expr
);
8489 case GFC_ISYM_EXPONENT
:
8490 gfc_conv_intrinsic_exponent (se
, expr
);
8494 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8496 fndecl
= gfor_fndecl_string_scan
;
8498 fndecl
= gfor_fndecl_string_scan_char4
;
8502 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8505 case GFC_ISYM_VERIFY
:
8506 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8508 fndecl
= gfor_fndecl_string_verify
;
8510 fndecl
= gfor_fndecl_string_verify_char4
;
8514 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8517 case GFC_ISYM_ALLOCATED
:
8518 gfc_conv_allocated (se
, expr
);
8521 case GFC_ISYM_ASSOCIATED
:
8522 gfc_conv_associated(se
, expr
);
8525 case GFC_ISYM_SAME_TYPE_AS
:
8526 gfc_conv_same_type_as (se
, expr
);
8530 gfc_conv_intrinsic_abs (se
, expr
);
8533 case GFC_ISYM_ADJUSTL
:
8534 if (expr
->ts
.kind
== 1)
8535 fndecl
= gfor_fndecl_adjustl
;
8536 else if (expr
->ts
.kind
== 4)
8537 fndecl
= gfor_fndecl_adjustl_char4
;
8541 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8544 case GFC_ISYM_ADJUSTR
:
8545 if (expr
->ts
.kind
== 1)
8546 fndecl
= gfor_fndecl_adjustr
;
8547 else if (expr
->ts
.kind
== 4)
8548 fndecl
= gfor_fndecl_adjustr_char4
;
8552 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8555 case GFC_ISYM_AIMAG
:
8556 gfc_conv_intrinsic_imagpart (se
, expr
);
8560 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
8564 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
8567 case GFC_ISYM_ANINT
:
8568 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
8572 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8576 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
8579 case GFC_ISYM_BTEST
:
8580 gfc_conv_intrinsic_btest (se
, expr
);
8584 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
8588 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
8592 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
8596 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
8599 case GFC_ISYM_C_ASSOCIATED
:
8600 case GFC_ISYM_C_FUNLOC
:
8601 case GFC_ISYM_C_LOC
:
8602 conv_isocbinding_function (se
, expr
);
8605 case GFC_ISYM_ACHAR
:
8607 gfc_conv_intrinsic_char (se
, expr
);
8610 case GFC_ISYM_CONVERSION
:
8612 case GFC_ISYM_LOGICAL
:
8614 gfc_conv_intrinsic_conversion (se
, expr
);
8617 /* Integer conversions are handled separately to make sure we get the
8618 correct rounding mode. */
8623 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
8627 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
8630 case GFC_ISYM_CEILING
:
8631 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
8634 case GFC_ISYM_FLOOR
:
8635 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
8639 gfc_conv_intrinsic_mod (se
, expr
, 0);
8642 case GFC_ISYM_MODULO
:
8643 gfc_conv_intrinsic_mod (se
, expr
, 1);
8646 case GFC_ISYM_CAF_GET
:
8647 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
8651 case GFC_ISYM_CMPLX
:
8652 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
8655 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
8656 gfc_conv_intrinsic_iargc (se
, expr
);
8659 case GFC_ISYM_COMPLEX
:
8660 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
8663 case GFC_ISYM_CONJG
:
8664 gfc_conv_intrinsic_conjg (se
, expr
);
8667 case GFC_ISYM_COUNT
:
8668 gfc_conv_intrinsic_count (se
, expr
);
8671 case GFC_ISYM_CTIME
:
8672 gfc_conv_intrinsic_ctime (se
, expr
);
8676 gfc_conv_intrinsic_dim (se
, expr
);
8679 case GFC_ISYM_DOT_PRODUCT
:
8680 gfc_conv_intrinsic_dot_product (se
, expr
);
8683 case GFC_ISYM_DPROD
:
8684 gfc_conv_intrinsic_dprod (se
, expr
);
8687 case GFC_ISYM_DSHIFTL
:
8688 gfc_conv_intrinsic_dshift (se
, expr
, true);
8691 case GFC_ISYM_DSHIFTR
:
8692 gfc_conv_intrinsic_dshift (se
, expr
, false);
8695 case GFC_ISYM_FDATE
:
8696 gfc_conv_intrinsic_fdate (se
, expr
);
8699 case GFC_ISYM_FRACTION
:
8700 gfc_conv_intrinsic_fraction (se
, expr
);
8704 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
8708 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8712 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
8715 case GFC_ISYM_IBCLR
:
8716 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
8719 case GFC_ISYM_IBITS
:
8720 gfc_conv_intrinsic_ibits (se
, expr
);
8723 case GFC_ISYM_IBSET
:
8724 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
8727 case GFC_ISYM_IACHAR
:
8728 case GFC_ISYM_ICHAR
:
8729 /* We assume ASCII character sequence. */
8730 gfc_conv_intrinsic_ichar (se
, expr
);
8733 case GFC_ISYM_IARGC
:
8734 gfc_conv_intrinsic_iargc (se
, expr
);
8738 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8741 case GFC_ISYM_INDEX
:
8742 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8744 fndecl
= gfor_fndecl_string_index
;
8746 fndecl
= gfor_fndecl_string_index_char4
;
8750 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8754 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8757 case GFC_ISYM_IPARITY
:
8758 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
8761 case GFC_ISYM_IS_IOSTAT_END
:
8762 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
8765 case GFC_ISYM_IS_IOSTAT_EOR
:
8766 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
8769 case GFC_ISYM_ISNAN
:
8770 gfc_conv_intrinsic_isnan (se
, expr
);
8773 case GFC_ISYM_LSHIFT
:
8774 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8777 case GFC_ISYM_RSHIFT
:
8778 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8781 case GFC_ISYM_SHIFTA
:
8782 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8785 case GFC_ISYM_SHIFTL
:
8786 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8789 case GFC_ISYM_SHIFTR
:
8790 gfc_conv_intrinsic_shift (se
, expr
, true, false);
8793 case GFC_ISYM_ISHFT
:
8794 gfc_conv_intrinsic_ishft (se
, expr
);
8797 case GFC_ISYM_ISHFTC
:
8798 gfc_conv_intrinsic_ishftc (se
, expr
);
8801 case GFC_ISYM_LEADZ
:
8802 gfc_conv_intrinsic_leadz (se
, expr
);
8805 case GFC_ISYM_TRAILZ
:
8806 gfc_conv_intrinsic_trailz (se
, expr
);
8809 case GFC_ISYM_POPCNT
:
8810 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
8813 case GFC_ISYM_POPPAR
:
8814 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
8817 case GFC_ISYM_LBOUND
:
8818 gfc_conv_intrinsic_bound (se
, expr
, 0);
8821 case GFC_ISYM_LCOBOUND
:
8822 conv_intrinsic_cobound (se
, expr
);
8825 case GFC_ISYM_TRANSPOSE
:
8826 /* The scalarizer has already been set up for reversed dimension access
8827 order ; now we just get the argument value normally. */
8828 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
8832 gfc_conv_intrinsic_len (se
, expr
);
8835 case GFC_ISYM_LEN_TRIM
:
8836 gfc_conv_intrinsic_len_trim (se
, expr
);
8840 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
8844 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
8848 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
8852 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
8855 case GFC_ISYM_MALLOC
:
8856 gfc_conv_intrinsic_malloc (se
, expr
);
8859 case GFC_ISYM_MASKL
:
8860 gfc_conv_intrinsic_mask (se
, expr
, 1);
8863 case GFC_ISYM_MASKR
:
8864 gfc_conv_intrinsic_mask (se
, expr
, 0);
8868 if (expr
->ts
.type
== BT_CHARACTER
)
8869 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
8871 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
8874 case GFC_ISYM_MAXLOC
:
8875 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8878 case GFC_ISYM_MAXVAL
:
8879 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
8882 case GFC_ISYM_MERGE
:
8883 gfc_conv_intrinsic_merge (se
, expr
);
8886 case GFC_ISYM_MERGE_BITS
:
8887 gfc_conv_intrinsic_merge_bits (se
, expr
);
8891 if (expr
->ts
.type
== BT_CHARACTER
)
8892 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
8894 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
8897 case GFC_ISYM_MINLOC
:
8898 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8901 case GFC_ISYM_MINVAL
:
8902 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
8905 case GFC_ISYM_NEAREST
:
8906 gfc_conv_intrinsic_nearest (se
, expr
);
8909 case GFC_ISYM_NORM2
:
8910 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
8914 gfc_conv_intrinsic_not (se
, expr
);
8918 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8921 case GFC_ISYM_PARITY
:
8922 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
8925 case GFC_ISYM_PRESENT
:
8926 gfc_conv_intrinsic_present (se
, expr
);
8929 case GFC_ISYM_PRODUCT
:
8930 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
8934 gfc_conv_intrinsic_rank (se
, expr
);
8937 case GFC_ISYM_RRSPACING
:
8938 gfc_conv_intrinsic_rrspacing (se
, expr
);
8941 case GFC_ISYM_SET_EXPONENT
:
8942 gfc_conv_intrinsic_set_exponent (se
, expr
);
8945 case GFC_ISYM_SCALE
:
8946 gfc_conv_intrinsic_scale (se
, expr
);
8950 gfc_conv_intrinsic_sign (se
, expr
);
8954 gfc_conv_intrinsic_size (se
, expr
);
8957 case GFC_ISYM_SIZEOF
:
8958 case GFC_ISYM_C_SIZEOF
:
8959 gfc_conv_intrinsic_sizeof (se
, expr
);
8962 case GFC_ISYM_STORAGE_SIZE
:
8963 gfc_conv_intrinsic_storage_size (se
, expr
);
8966 case GFC_ISYM_SPACING
:
8967 gfc_conv_intrinsic_spacing (se
, expr
);
8970 case GFC_ISYM_STRIDE
:
8971 conv_intrinsic_stride (se
, expr
);
8975 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
8978 case GFC_ISYM_TRANSFER
:
8979 if (se
->ss
&& se
->ss
->info
->useflags
)
8980 /* Access the previously obtained result. */
8981 gfc_conv_tmp_array_ref (se
);
8983 gfc_conv_intrinsic_transfer (se
, expr
);
8986 case GFC_ISYM_TTYNAM
:
8987 gfc_conv_intrinsic_ttynam (se
, expr
);
8990 case GFC_ISYM_UBOUND
:
8991 gfc_conv_intrinsic_bound (se
, expr
, 1);
8994 case GFC_ISYM_UCOBOUND
:
8995 conv_intrinsic_cobound (se
, expr
);
8999 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9003 gfc_conv_intrinsic_loc (se
, expr
);
9006 case GFC_ISYM_THIS_IMAGE
:
9007 /* For num_images() == 1, handle as LCOBOUND. */
9008 if (expr
->value
.function
.actual
->expr
9009 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
9010 conv_intrinsic_cobound (se
, expr
);
9012 trans_this_image (se
, expr
);
9015 case GFC_ISYM_IMAGE_INDEX
:
9016 trans_image_index (se
, expr
);
9019 case GFC_ISYM_NUM_IMAGES
:
9020 trans_num_images (se
, expr
);
9023 case GFC_ISYM_ACCESS
:
9024 case GFC_ISYM_CHDIR
:
9025 case GFC_ISYM_CHMOD
:
9026 case GFC_ISYM_DTIME
:
9027 case GFC_ISYM_ETIME
:
9028 case GFC_ISYM_EXTENDS_TYPE_OF
:
9030 case GFC_ISYM_FGETC
:
9033 case GFC_ISYM_FPUTC
:
9034 case GFC_ISYM_FSTAT
:
9035 case GFC_ISYM_FTELL
:
9036 case GFC_ISYM_GETCWD
:
9037 case GFC_ISYM_GETGID
:
9038 case GFC_ISYM_GETPID
:
9039 case GFC_ISYM_GETUID
:
9040 case GFC_ISYM_HOSTNM
:
9042 case GFC_ISYM_IERRNO
:
9043 case GFC_ISYM_IRAND
:
9044 case GFC_ISYM_ISATTY
:
9047 case GFC_ISYM_LSTAT
:
9048 case GFC_ISYM_MATMUL
:
9049 case GFC_ISYM_MCLOCK
:
9050 case GFC_ISYM_MCLOCK8
:
9052 case GFC_ISYM_RENAME
:
9053 case GFC_ISYM_SECOND
:
9054 case GFC_ISYM_SECNDS
:
9055 case GFC_ISYM_SIGNAL
:
9057 case GFC_ISYM_SYMLNK
:
9058 case GFC_ISYM_SYSTEM
:
9060 case GFC_ISYM_TIME8
:
9061 case GFC_ISYM_UMASK
:
9062 case GFC_ISYM_UNLINK
:
9064 gfc_conv_intrinsic_funcall (se
, expr
);
9067 case GFC_ISYM_EOSHIFT
:
9069 case GFC_ISYM_RESHAPE
:
9070 /* For those, expr->rank should always be >0 and thus the if above the
9071 switch should have matched. */
9076 gfc_conv_intrinsic_lib_function (se
, expr
);
9083 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
9085 gfc_ss
*arg_ss
, *tmp_ss
;
9086 gfc_actual_arglist
*arg
;
9088 arg
= expr
->value
.function
.actual
;
9090 gcc_assert (arg
->expr
);
9092 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
9093 gcc_assert (arg_ss
!= gfc_ss_terminator
);
9095 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
9097 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
9098 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
9100 gcc_assert (tmp_ss
->dimen
== 2);
9102 /* We just invert dimensions. */
9103 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
9106 /* Stop when tmp_ss points to the last valid element of the chain... */
9107 if (tmp_ss
->next
== gfc_ss_terminator
)
9111 /* ... so that we can attach the rest of the chain to it. */
9118 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9119 This has the side effect of reversing the nested list, so there is no
9120 need to call gfc_reverse_ss on it (the given list is assumed not to be
9124 nest_loop_dimension (gfc_ss
*ss
, int dim
)
9127 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
9128 gfc_loopinfo
*new_loop
;
9130 gcc_assert (ss
!= gfc_ss_terminator
);
9132 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
9134 new_ss
= gfc_get_ss ();
9135 new_ss
->next
= prev_ss
;
9136 new_ss
->parent
= ss
;
9137 new_ss
->info
= ss
->info
;
9138 new_ss
->info
->refcount
++;
9141 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
9142 && ss
->info
->type
!= GFC_SS_REFERENCE
);
9145 new_ss
->dim
[0] = ss
->dim
[dim
];
9147 gcc_assert (dim
< ss
->dimen
);
9149 ss_dim
= --ss
->dimen
;
9150 for (i
= dim
; i
< ss_dim
; i
++)
9151 ss
->dim
[i
] = ss
->dim
[i
+ 1];
9153 ss
->dim
[ss_dim
] = 0;
9159 ss
->nested_ss
->parent
= new_ss
;
9160 new_ss
->nested_ss
= ss
->nested_ss
;
9162 ss
->nested_ss
= new_ss
;
9165 new_loop
= gfc_get_loopinfo ();
9166 gfc_init_loopinfo (new_loop
);
9168 gcc_assert (prev_ss
!= NULL
);
9169 gcc_assert (prev_ss
!= gfc_ss_terminator
);
9170 gfc_add_ss_to_loop (new_loop
, prev_ss
);
9171 return new_ss
->parent
;
9175 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9176 is to be inlined. */
9179 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
9181 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
9182 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
9184 bool scalar_mask
= false;
9186 /* The rank of the result will be determined later. */
9187 arg1
= expr
->value
.function
.actual
;
9190 gcc_assert (arg3
!= NULL
);
9192 if (expr
->rank
== 0)
9195 tmp_ss
= gfc_ss_terminator
;
9201 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
9202 if (mask_ss
== tmp_ss
)
9208 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
9209 gcc_assert (array_ss
!= tmp_ss
);
9211 /* Odd thing: If the mask is scalar, it is used by the frontend after
9212 the array (to make an if around the nested loop). Thus it shall
9213 be after array_ss once the gfc_ss list is reversed. */
9215 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
9219 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9221 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
9222 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
9230 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
9233 switch (expr
->value
.function
.isym
->id
)
9235 case GFC_ISYM_PRODUCT
:
9237 return walk_inline_intrinsic_arith (ss
, expr
);
9239 case GFC_ISYM_TRANSPOSE
:
9240 return walk_inline_intrinsic_transpose (ss
, expr
);
9249 /* This generates code to execute before entering the scalarization loop.
9250 Currently does nothing. */
9253 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
9255 switch (ss
->info
->expr
->value
.function
.isym
->id
)
9257 case GFC_ISYM_UBOUND
:
9258 case GFC_ISYM_LBOUND
:
9259 case GFC_ISYM_UCOBOUND
:
9260 case GFC_ISYM_LCOBOUND
:
9261 case GFC_ISYM_THIS_IMAGE
:
9270 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9271 are expanded into code inside the scalarization loop. */
9274 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
9276 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
9277 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
9279 /* The two argument version returns a scalar. */
9280 if (expr
->value
.function
.actual
->next
->expr
)
9283 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
9287 /* Walk an intrinsic array libcall. */
9290 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
9292 gcc_assert (expr
->rank
> 0);
9293 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9297 /* Return whether the function call expression EXPR will be expanded
9298 inline by gfc_conv_intrinsic_function. */
9301 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
9303 gfc_actual_arglist
*args
;
9305 if (!expr
->value
.function
.isym
)
9308 switch (expr
->value
.function
.isym
->id
)
9310 case GFC_ISYM_PRODUCT
:
9312 /* Disable inline expansion if code size matters. */
9316 args
= expr
->value
.function
.actual
;
9317 /* We need to be able to subset the SUM argument at compile-time. */
9318 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
9323 case GFC_ISYM_TRANSPOSE
:
9332 /* Returns nonzero if the specified intrinsic function call maps directly to
9333 an external library call. Should only be used for functions that return
9337 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
9339 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
9340 gcc_assert (expr
->rank
> 0);
9342 if (gfc_inline_intrinsic_function_p (expr
))
9345 switch (expr
->value
.function
.isym
->id
)
9349 case GFC_ISYM_COUNT
:
9353 case GFC_ISYM_IPARITY
:
9354 case GFC_ISYM_MATMUL
:
9355 case GFC_ISYM_MAXLOC
:
9356 case GFC_ISYM_MAXVAL
:
9357 case GFC_ISYM_MINLOC
:
9358 case GFC_ISYM_MINVAL
:
9359 case GFC_ISYM_NORM2
:
9360 case GFC_ISYM_PARITY
:
9361 case GFC_ISYM_PRODUCT
:
9363 case GFC_ISYM_SHAPE
:
9364 case GFC_ISYM_SPREAD
:
9366 /* Ignore absent optional parameters. */
9369 case GFC_ISYM_RESHAPE
:
9370 case GFC_ISYM_CSHIFT
:
9371 case GFC_ISYM_EOSHIFT
:
9373 case GFC_ISYM_UNPACK
:
9374 /* Pass absent optional parameters. */
9382 /* Walk an intrinsic function. */
9384 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
9385 gfc_intrinsic_sym
* isym
)
9389 if (isym
->elemental
)
9390 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9391 NULL
, GFC_SS_SCALAR
);
9393 if (expr
->rank
== 0)
9396 if (gfc_inline_intrinsic_function_p (expr
))
9397 return walk_inline_intrinsic_function (ss
, expr
);
9399 if (gfc_is_intrinsic_libcall (expr
))
9400 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9402 /* Special cases. */
9405 case GFC_ISYM_LBOUND
:
9406 case GFC_ISYM_LCOBOUND
:
9407 case GFC_ISYM_UBOUND
:
9408 case GFC_ISYM_UCOBOUND
:
9409 case GFC_ISYM_THIS_IMAGE
:
9410 return gfc_walk_intrinsic_bound (ss
, expr
);
9412 case GFC_ISYM_TRANSFER
:
9413 case GFC_ISYM_CAF_GET
:
9414 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9417 /* This probably meant someone forgot to add an intrinsic to the above
9418 list(s) when they implemented it, or something's gone horribly
9426 conv_co_collective (gfc_code
*code
)
9429 stmtblock_t block
, post_block
;
9430 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
9431 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
9433 gfc_start_block (&block
);
9434 gfc_init_block (&post_block
);
9436 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
9438 opr_expr
= code
->ext
.actual
->next
->expr
;
9439 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
9440 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9441 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
9446 image_idx_expr
= code
->ext
.actual
->next
->expr
;
9447 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9448 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9454 gfc_init_se (&argse
, NULL
);
9455 gfc_conv_expr (&argse
, stat_expr
);
9456 gfc_add_block_to_block (&block
, &argse
.pre
);
9457 gfc_add_block_to_block (&post_block
, &argse
.post
);
9459 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
9460 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
9462 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9465 stat
= null_pointer_node
;
9467 /* Early exit for GFC_FCOARRAY_SINGLE. */
9468 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9470 if (stat
!= NULL_TREE
)
9471 gfc_add_modify (&block
, stat
,
9472 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
9473 return gfc_finish_block (&block
);
9476 /* Handle the array. */
9477 gfc_init_se (&argse
, NULL
);
9478 if (code
->ext
.actual
->expr
->rank
== 0)
9480 symbol_attribute attr
;
9481 gfc_clear_attr (&attr
);
9482 gfc_init_se (&argse
, NULL
);
9483 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9484 gfc_add_block_to_block (&block
, &argse
.pre
);
9485 gfc_add_block_to_block (&post_block
, &argse
.post
);
9486 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
9487 array
= gfc_build_addr_expr (NULL_TREE
, array
);
9491 argse
.want_pointer
= 1;
9492 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
9495 gfc_add_block_to_block (&block
, &argse
.pre
);
9496 gfc_add_block_to_block (&post_block
, &argse
.post
);
9498 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
9499 strlen
= argse
.string_length
;
9501 strlen
= integer_zero_node
;
9506 gfc_init_se (&argse
, NULL
);
9507 gfc_conv_expr (&argse
, image_idx_expr
);
9508 gfc_add_block_to_block (&block
, &argse
.pre
);
9509 gfc_add_block_to_block (&post_block
, &argse
.post
);
9510 image_index
= fold_convert (integer_type_node
, argse
.expr
);
9513 image_index
= integer_zero_node
;
9518 gfc_init_se (&argse
, NULL
);
9519 gfc_conv_expr (&argse
, errmsg_expr
);
9520 gfc_add_block_to_block (&block
, &argse
.pre
);
9521 gfc_add_block_to_block (&post_block
, &argse
.post
);
9522 errmsg
= argse
.expr
;
9523 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
9527 errmsg
= null_pointer_node
;
9528 errmsg_len
= integer_zero_node
;
9531 /* Generate the function call. */
9532 switch (code
->resolved_isym
->id
)
9534 case GFC_ISYM_CO_BROADCAST
:
9535 fndecl
= gfor_fndecl_co_broadcast
;
9537 case GFC_ISYM_CO_MAX
:
9538 fndecl
= gfor_fndecl_co_max
;
9540 case GFC_ISYM_CO_MIN
:
9541 fndecl
= gfor_fndecl_co_min
;
9543 case GFC_ISYM_CO_REDUCE
:
9544 fndecl
= gfor_fndecl_co_reduce
;
9546 case GFC_ISYM_CO_SUM
:
9547 fndecl
= gfor_fndecl_co_sum
;
9553 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
9554 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
9555 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
9556 image_index
, stat
, errmsg
, errmsg_len
);
9557 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
9558 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
9559 stat
, errmsg
, strlen
, errmsg_len
);
9562 tree opr
, opr_flags
;
9564 // FIXME: Handle TS29113's bind(C) strings with descriptor.
9566 if (gfc_is_proc_ptr_comp (opr_expr
))
9568 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
9569 opr_flag_int
= sym
->attr
.dimension
9570 || (sym
->ts
.type
== BT_CHARACTER
9571 && !sym
->attr
.is_bind_c
)
9572 ? GFC_CAF_BYREF
: 0;
9573 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9574 && !sym
->attr
.is_bind_c
9575 ? GFC_CAF_HIDDENLEN
: 0;
9576 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
9580 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
9581 ? GFC_CAF_BYREF
: 0;
9582 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9583 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
9584 ? GFC_CAF_HIDDENLEN
: 0;
9585 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
9586 ? GFC_CAF_ARG_VALUE
: 0;
9588 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
9589 gfc_conv_expr (&argse
, opr_expr
);
9591 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
9592 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
9595 gfc_add_expr_to_block (&block
, fndecl
);
9596 gfc_add_block_to_block (&block
, &post_block
);
9598 return gfc_finish_block (&block
);
9603 conv_intrinsic_atomic_op (gfc_code
*code
)
9606 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
9607 stmtblock_t block
, post_block
;
9608 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9609 gfc_expr
*stat_expr
;
9610 built_in_function fn
;
9612 if (atom_expr
->expr_type
== EXPR_FUNCTION
9613 && atom_expr
->value
.function
.isym
9614 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9615 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9617 gfc_start_block (&block
);
9618 gfc_init_block (&post_block
);
9620 gfc_init_se (&argse
, NULL
);
9621 argse
.want_pointer
= 1;
9622 gfc_conv_expr (&argse
, atom_expr
);
9623 gfc_add_block_to_block (&block
, &argse
.pre
);
9624 gfc_add_block_to_block (&post_block
, &argse
.post
);
9627 gfc_init_se (&argse
, NULL
);
9628 if (flag_coarray
== GFC_FCOARRAY_LIB
9629 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9630 argse
.want_pointer
= 1;
9631 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9632 gfc_add_block_to_block (&block
, &argse
.pre
);
9633 gfc_add_block_to_block (&post_block
, &argse
.post
);
9636 switch (code
->resolved_isym
->id
)
9638 case GFC_ISYM_ATOMIC_ADD
:
9639 case GFC_ISYM_ATOMIC_AND
:
9640 case GFC_ISYM_ATOMIC_DEF
:
9641 case GFC_ISYM_ATOMIC_OR
:
9642 case GFC_ISYM_ATOMIC_XOR
:
9643 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9644 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9645 old
= null_pointer_node
;
9648 gfc_init_se (&argse
, NULL
);
9649 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9650 argse
.want_pointer
= 1;
9651 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9652 gfc_add_block_to_block (&block
, &argse
.pre
);
9653 gfc_add_block_to_block (&post_block
, &argse
.post
);
9655 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9659 if (stat_expr
!= NULL
)
9661 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
9662 gfc_init_se (&argse
, NULL
);
9663 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9664 argse
.want_pointer
= 1;
9665 gfc_conv_expr_val (&argse
, stat_expr
);
9666 gfc_add_block_to_block (&block
, &argse
.pre
);
9667 gfc_add_block_to_block (&post_block
, &argse
.post
);
9670 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9671 stat
= null_pointer_node
;
9673 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9675 tree image_index
, caf_decl
, offset
, token
;
9678 switch (code
->resolved_isym
->id
)
9680 case GFC_ISYM_ATOMIC_ADD
:
9681 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9682 op
= (int) GFC_CAF_ATOMIC_ADD
;
9684 case GFC_ISYM_ATOMIC_AND
:
9685 case GFC_ISYM_ATOMIC_FETCH_AND
:
9686 op
= (int) GFC_CAF_ATOMIC_AND
;
9688 case GFC_ISYM_ATOMIC_OR
:
9689 case GFC_ISYM_ATOMIC_FETCH_OR
:
9690 op
= (int) GFC_CAF_ATOMIC_OR
;
9692 case GFC_ISYM_ATOMIC_XOR
:
9693 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9694 op
= (int) GFC_CAF_ATOMIC_XOR
;
9696 case GFC_ISYM_ATOMIC_DEF
:
9697 op
= 0; /* Unused. */
9703 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9704 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9705 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9707 if (gfc_is_coindexed (atom_expr
))
9708 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9710 image_index
= integer_zero_node
;
9712 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9714 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9715 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
9716 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9719 gfc_init_se (&argse
, NULL
);
9720 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
9723 gfc_add_block_to_block (&block
, &argse
.pre
);
9724 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
9725 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
9726 token
, offset
, image_index
, value
, stat
,
9727 build_int_cst (integer_type_node
,
9728 (int) atom_expr
->ts
.type
),
9729 build_int_cst (integer_type_node
,
9730 (int) atom_expr
->ts
.kind
));
9732 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
9733 build_int_cst (integer_type_node
, op
),
9734 token
, offset
, image_index
, value
, old
, stat
,
9735 build_int_cst (integer_type_node
,
9736 (int) atom_expr
->ts
.type
),
9737 build_int_cst (integer_type_node
,
9738 (int) atom_expr
->ts
.kind
));
9740 gfc_add_expr_to_block (&block
, tmp
);
9741 gfc_add_block_to_block (&block
, &argse
.post
);
9742 gfc_add_block_to_block (&block
, &post_block
);
9743 return gfc_finish_block (&block
);
9747 switch (code
->resolved_isym
->id
)
9749 case GFC_ISYM_ATOMIC_ADD
:
9750 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9751 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
9753 case GFC_ISYM_ATOMIC_AND
:
9754 case GFC_ISYM_ATOMIC_FETCH_AND
:
9755 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
9757 case GFC_ISYM_ATOMIC_DEF
:
9758 fn
= BUILT_IN_ATOMIC_STORE_N
;
9760 case GFC_ISYM_ATOMIC_OR
:
9761 case GFC_ISYM_ATOMIC_FETCH_OR
:
9762 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
9764 case GFC_ISYM_ATOMIC_XOR
:
9765 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9766 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
9772 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9773 fn
= (built_in_function
) ((int) fn
9774 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9776 tmp
= builtin_decl_explicit (fn
);
9777 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
9778 tmp
= builtin_decl_explicit (fn
);
9780 switch (code
->resolved_isym
->id
)
9782 case GFC_ISYM_ATOMIC_ADD
:
9783 case GFC_ISYM_ATOMIC_AND
:
9784 case GFC_ISYM_ATOMIC_DEF
:
9785 case GFC_ISYM_ATOMIC_OR
:
9786 case GFC_ISYM_ATOMIC_XOR
:
9787 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9788 fold_convert (itype
, value
),
9789 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9790 gfc_add_expr_to_block (&block
, tmp
);
9793 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9794 fold_convert (itype
, value
),
9795 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9796 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
9800 if (stat
!= NULL_TREE
)
9801 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9802 gfc_add_block_to_block (&block
, &post_block
);
9803 return gfc_finish_block (&block
);
9808 conv_intrinsic_atomic_ref (gfc_code
*code
)
9811 tree tmp
, atom
, value
, stat
= NULL_TREE
;
9812 stmtblock_t block
, post_block
;
9813 built_in_function fn
;
9814 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
9816 if (atom_expr
->expr_type
== EXPR_FUNCTION
9817 && atom_expr
->value
.function
.isym
9818 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9819 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9821 gfc_start_block (&block
);
9822 gfc_init_block (&post_block
);
9823 gfc_init_se (&argse
, NULL
);
9824 argse
.want_pointer
= 1;
9825 gfc_conv_expr (&argse
, atom_expr
);
9826 gfc_add_block_to_block (&block
, &argse
.pre
);
9827 gfc_add_block_to_block (&post_block
, &argse
.post
);
9830 gfc_init_se (&argse
, NULL
);
9831 if (flag_coarray
== GFC_FCOARRAY_LIB
9832 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9833 argse
.want_pointer
= 1;
9834 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9835 gfc_add_block_to_block (&block
, &argse
.pre
);
9836 gfc_add_block_to_block (&post_block
, &argse
.post
);
9840 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
9842 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9844 gfc_init_se (&argse
, NULL
);
9845 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9846 argse
.want_pointer
= 1;
9847 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9848 gfc_add_block_to_block (&block
, &argse
.pre
);
9849 gfc_add_block_to_block (&post_block
, &argse
.post
);
9852 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9853 stat
= null_pointer_node
;
9855 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9857 tree image_index
, caf_decl
, offset
, token
;
9858 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
9860 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9861 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9862 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9864 if (gfc_is_coindexed (atom_expr
))
9865 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9867 image_index
= integer_zero_node
;
9869 gfc_init_se (&argse
, NULL
);
9870 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
9872 gfc_add_block_to_block (&block
, &argse
.pre
);
9874 /* Different type, need type conversion. */
9875 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9877 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9879 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
9882 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
9883 token
, offset
, image_index
, value
, stat
,
9884 build_int_cst (integer_type_node
,
9885 (int) atom_expr
->ts
.type
),
9886 build_int_cst (integer_type_node
,
9887 (int) atom_expr
->ts
.kind
));
9888 gfc_add_expr_to_block (&block
, tmp
);
9889 if (vardecl
!= NULL_TREE
)
9890 gfc_add_modify (&block
, orig_value
,
9891 fold_convert (TREE_TYPE (orig_value
), vardecl
));
9892 gfc_add_block_to_block (&block
, &argse
.post
);
9893 gfc_add_block_to_block (&block
, &post_block
);
9894 return gfc_finish_block (&block
);
9897 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9898 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
9899 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9901 tmp
= builtin_decl_explicit (fn
);
9902 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
9903 build_int_cst (integer_type_node
,
9905 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
9907 if (stat
!= NULL_TREE
)
9908 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9909 gfc_add_block_to_block (&block
, &post_block
);
9910 return gfc_finish_block (&block
);
9915 conv_intrinsic_atomic_cas (gfc_code
*code
)
9918 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
9919 stmtblock_t block
, post_block
;
9920 built_in_function fn
;
9921 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9923 if (atom_expr
->expr_type
== EXPR_FUNCTION
9924 && atom_expr
->value
.function
.isym
9925 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9926 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9928 gfc_init_block (&block
);
9929 gfc_init_block (&post_block
);
9930 gfc_init_se (&argse
, NULL
);
9931 argse
.want_pointer
= 1;
9932 gfc_conv_expr (&argse
, atom_expr
);
9935 gfc_init_se (&argse
, NULL
);
9936 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9937 argse
.want_pointer
= 1;
9938 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9939 gfc_add_block_to_block (&block
, &argse
.pre
);
9940 gfc_add_block_to_block (&post_block
, &argse
.post
);
9943 gfc_init_se (&argse
, NULL
);
9944 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9945 argse
.want_pointer
= 1;
9946 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9947 gfc_add_block_to_block (&block
, &argse
.pre
);
9948 gfc_add_block_to_block (&post_block
, &argse
.post
);
9951 gfc_init_se (&argse
, NULL
);
9952 if (flag_coarray
== GFC_FCOARRAY_LIB
9953 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
9954 == atom_expr
->ts
.kind
)
9955 argse
.want_pointer
= 1;
9956 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
9957 gfc_add_block_to_block (&block
, &argse
.pre
);
9958 gfc_add_block_to_block (&post_block
, &argse
.post
);
9959 new_val
= argse
.expr
;
9962 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
9964 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
9966 gfc_init_se (&argse
, NULL
);
9967 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9968 argse
.want_pointer
= 1;
9969 gfc_conv_expr_val (&argse
,
9970 code
->ext
.actual
->next
->next
->next
->next
->expr
);
9971 gfc_add_block_to_block (&block
, &argse
.pre
);
9972 gfc_add_block_to_block (&post_block
, &argse
.post
);
9975 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9976 stat
= null_pointer_node
;
9978 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9980 tree image_index
, caf_decl
, offset
, token
;
9982 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9983 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9984 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9986 if (gfc_is_coindexed (atom_expr
))
9987 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9989 image_index
= integer_zero_node
;
9991 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
9993 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
9994 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
9995 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9998 /* Convert a constant to a pointer. */
9999 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
10001 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
10002 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
10003 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10006 gfc_init_se (&argse
, NULL
);
10007 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10009 gfc_add_block_to_block (&block
, &argse
.pre
);
10011 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
10012 token
, offset
, image_index
, old
, comp
, new_val
,
10013 stat
, build_int_cst (integer_type_node
,
10014 (int) atom_expr
->ts
.type
),
10015 build_int_cst (integer_type_node
,
10016 (int) atom_expr
->ts
.kind
));
10017 gfc_add_expr_to_block (&block
, tmp
);
10018 gfc_add_block_to_block (&block
, &argse
.post
);
10019 gfc_add_block_to_block (&block
, &post_block
);
10020 return gfc_finish_block (&block
);
10023 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10024 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10025 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10027 tmp
= builtin_decl_explicit (fn
);
10029 gfc_add_modify (&block
, old
, comp
);
10030 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
10031 gfc_build_addr_expr (NULL
, old
),
10032 fold_convert (TREE_TYPE (old
), new_val
),
10033 boolean_false_node
,
10034 build_int_cst (NULL
, MEMMODEL_RELAXED
),
10035 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10036 gfc_add_expr_to_block (&block
, tmp
);
10038 if (stat
!= NULL_TREE
)
10039 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10040 gfc_add_block_to_block (&block
, &post_block
);
10041 return gfc_finish_block (&block
);
10045 conv_intrinsic_event_query (gfc_code
*code
)
10048 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
10049 tree count
= NULL_TREE
, count2
= NULL_TREE
;
10051 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
10053 if (code
->ext
.actual
->next
->next
->expr
)
10055 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10057 gfc_init_se (&argse
, NULL
);
10058 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10061 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10062 stat
= null_pointer_node
;
10064 if (code
->ext
.actual
->next
->expr
)
10066 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
10067 gfc_init_se (&argse
, NULL
);
10068 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
10069 count
= argse
.expr
;
10072 gfc_start_block (&se
.pre
);
10073 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10075 tree tmp
, token
, image_index
;
10076 tree index
= size_zero_node
;
10078 if (event_expr
->expr_type
== EXPR_FUNCTION
10079 && event_expr
->value
.function
.isym
10080 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10081 event_expr
= event_expr
->value
.function
.actual
->expr
;
10083 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
10085 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10086 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
10087 != INTMOD_ISO_FORTRAN_ENV
10088 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
10089 != ISOFORTRAN_EVENT_TYPE
)
10091 gfc_error ("Sorry, the event component of derived type at %L is not "
10092 "yet supported", &event_expr
->where
);
10096 if (gfc_is_coindexed (event_expr
))
10098 gfc_error ("The event variable at %L shall not be coindexed ",
10099 &event_expr
->where
);
10103 image_index
= integer_zero_node
;
10105 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10108 /* For arrays, obtain the array index. */
10109 if (gfc_expr_attr (event_expr
).dimension
)
10111 tree desc
, tmp
, extent
, lbound
, ubound
;
10112 gfc_array_ref
*ar
, ar2
;
10115 /* TODO: Extend this, once DT components are supported. */
10116 ar
= &event_expr
->ref
->u
.ar
;
10118 memset (ar
, '\0', sizeof (*ar
));
10120 ar
->type
= AR_FULL
;
10122 gfc_init_se (&argse
, NULL
);
10123 argse
.descriptor_only
= 1;
10124 gfc_conv_expr_descriptor (&argse
, event_expr
);
10125 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
10129 extent
= integer_one_node
;
10130 for (i
= 0; i
< ar
->dimen
; i
++)
10132 gfc_init_se (&argse
, NULL
);
10133 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
10134 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
10135 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
10136 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10137 integer_type_node
, argse
.expr
,
10138 fold_convert(integer_type_node
, lbound
));
10139 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10140 integer_type_node
, extent
, tmp
);
10141 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
10142 integer_type_node
, index
, tmp
);
10143 if (i
< ar
->dimen
- 1)
10145 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
10146 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10147 tmp
= fold_convert (integer_type_node
, tmp
);
10148 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
10149 integer_type_node
, extent
, tmp
);
10154 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
10157 count
= gfc_create_var (integer_type_node
, "count");
10160 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
10163 stat
= gfc_create_var (integer_type_node
, "stat");
10166 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
10167 token
, index
, image_index
, count
10168 ? gfc_build_addr_expr (NULL
, count
) : count
,
10169 stat
!= null_pointer_node
10170 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
10171 gfc_add_expr_to_block (&se
.pre
, tmp
);
10173 if (count2
!= NULL_TREE
)
10174 gfc_add_modify (&se
.pre
, count2
,
10175 fold_convert (TREE_TYPE (count2
), count
));
10177 if (stat2
!= NULL_TREE
)
10178 gfc_add_modify (&se
.pre
, stat2
,
10179 fold_convert (TREE_TYPE (stat2
), stat
));
10181 return gfc_finish_block (&se
.pre
);
10184 gfc_init_se (&argse
, NULL
);
10185 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
10186 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
10188 if (stat
!= NULL_TREE
)
10189 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10191 return gfc_finish_block (&se
.pre
);
10195 conv_intrinsic_move_alloc (gfc_code
*code
)
10198 gfc_expr
*from_expr
, *to_expr
;
10199 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
10200 gfc_se from_se
, to_se
;
10204 gfc_start_block (&block
);
10206 from_expr
= code
->ext
.actual
->expr
;
10207 to_expr
= code
->ext
.actual
->next
->expr
;
10209 gfc_init_se (&from_se
, NULL
);
10210 gfc_init_se (&to_se
, NULL
);
10212 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
10213 || to_expr
->ts
.type
== BT_CLASS
);
10214 coarray
= gfc_get_corank (from_expr
) != 0;
10216 if (from_expr
->rank
== 0 && !coarray
)
10218 if (from_expr
->ts
.type
!= BT_CLASS
)
10219 from_expr2
= from_expr
;
10222 from_expr2
= gfc_copy_expr (from_expr
);
10223 gfc_add_data_component (from_expr2
);
10226 if (to_expr
->ts
.type
!= BT_CLASS
)
10227 to_expr2
= to_expr
;
10230 to_expr2
= gfc_copy_expr (to_expr
);
10231 gfc_add_data_component (to_expr2
);
10234 from_se
.want_pointer
= 1;
10235 to_se
.want_pointer
= 1;
10236 gfc_conv_expr (&from_se
, from_expr2
);
10237 gfc_conv_expr (&to_se
, to_expr2
);
10238 gfc_add_block_to_block (&block
, &from_se
.pre
);
10239 gfc_add_block_to_block (&block
, &to_se
.pre
);
10241 /* Deallocate "to". */
10242 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
10243 to_expr
, to_expr
->ts
);
10244 gfc_add_expr_to_block (&block
, tmp
);
10246 /* Assign (_data) pointers. */
10247 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10248 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
10250 /* Set "from" to NULL. */
10251 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10252 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
10254 gfc_add_block_to_block (&block
, &from_se
.post
);
10255 gfc_add_block_to_block (&block
, &to_se
.post
);
10258 if (to_expr
->ts
.type
== BT_CLASS
)
10262 gfc_free_expr (to_expr2
);
10263 gfc_init_se (&to_se
, NULL
);
10264 to_se
.want_pointer
= 1;
10265 gfc_add_vptr_component (to_expr
);
10266 gfc_conv_expr (&to_se
, to_expr
);
10268 if (from_expr
->ts
.type
== BT_CLASS
)
10270 if (UNLIMITED_POLY (from_expr
))
10274 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10278 gfc_free_expr (from_expr2
);
10279 gfc_init_se (&from_se
, NULL
);
10280 from_se
.want_pointer
= 1;
10281 gfc_add_vptr_component (from_expr
);
10282 gfc_conv_expr (&from_se
, from_expr
);
10283 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10284 fold_convert (TREE_TYPE (to_se
.expr
),
10287 /* Reset _vptr component to declared type. */
10289 /* Unlimited polymorphic. */
10290 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10291 fold_convert (TREE_TYPE (from_se
.expr
),
10292 null_pointer_node
));
10295 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10296 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10297 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10302 vtab
= gfc_find_vtab (&from_expr
->ts
);
10304 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10305 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10306 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10310 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10312 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10313 fold_convert (TREE_TYPE (to_se
.string_length
),
10314 from_se
.string_length
));
10315 if (from_expr
->ts
.deferred
)
10316 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10317 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10320 return gfc_finish_block (&block
);
10323 /* Update _vptr component. */
10324 if (to_expr
->ts
.type
== BT_CLASS
)
10328 to_se
.want_pointer
= 1;
10329 to_expr2
= gfc_copy_expr (to_expr
);
10330 gfc_add_vptr_component (to_expr2
);
10331 gfc_conv_expr (&to_se
, to_expr2
);
10333 if (from_expr
->ts
.type
== BT_CLASS
)
10335 if (UNLIMITED_POLY (from_expr
))
10339 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10343 from_se
.want_pointer
= 1;
10344 from_expr2
= gfc_copy_expr (from_expr
);
10345 gfc_add_vptr_component (from_expr2
);
10346 gfc_conv_expr (&from_se
, from_expr2
);
10347 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10348 fold_convert (TREE_TYPE (to_se
.expr
),
10351 /* Reset _vptr component to declared type. */
10353 /* Unlimited polymorphic. */
10354 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10355 fold_convert (TREE_TYPE (from_se
.expr
),
10356 null_pointer_node
));
10359 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10360 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10361 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10366 vtab
= gfc_find_vtab (&from_expr
->ts
);
10368 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10369 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10370 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10373 gfc_free_expr (to_expr2
);
10374 gfc_init_se (&to_se
, NULL
);
10376 if (from_expr
->ts
.type
== BT_CLASS
)
10378 gfc_free_expr (from_expr2
);
10379 gfc_init_se (&from_se
, NULL
);
10384 /* Deallocate "to". */
10385 if (from_expr
->rank
== 0)
10387 to_se
.want_coarray
= 1;
10388 from_se
.want_coarray
= 1;
10390 gfc_conv_expr_descriptor (&to_se
, to_expr
);
10391 gfc_conv_expr_descriptor (&from_se
, from_expr
);
10393 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10394 is an image control "statement", cf. IR F08/0040 in 12-006A. */
10395 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10399 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10400 NULL_TREE
, NULL_TREE
, true, to_expr
,
10402 gfc_add_expr_to_block (&block
, tmp
);
10404 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10405 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10406 boolean_type_node
, tmp
,
10407 fold_convert (TREE_TYPE (tmp
),
10408 null_pointer_node
));
10409 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
10410 3, null_pointer_node
, null_pointer_node
,
10411 build_int_cst (integer_type_node
, 0));
10413 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
10414 tmp
, build_empty_stmt (input_location
));
10415 gfc_add_expr_to_block (&block
, tmp
);
10419 if (to_expr
->ts
.type
== BT_DERIVED
10420 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
10422 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
10423 to_se
.expr
, to_expr
->rank
);
10424 gfc_add_expr_to_block (&block
, tmp
);
10427 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10428 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10429 NULL_TREE
, true, to_expr
, false);
10430 gfc_add_expr_to_block (&block
, tmp
);
10433 /* Move the pointer and update the array descriptor data. */
10434 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
10436 /* Set "from" to NULL. */
10437 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
10438 gfc_add_modify_loc (input_location
, &block
, tmp
,
10439 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
10442 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10444 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10445 fold_convert (TREE_TYPE (to_se
.string_length
),
10446 from_se
.string_length
));
10447 if (from_expr
->ts
.deferred
)
10448 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10449 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10452 return gfc_finish_block (&block
);
10457 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
10461 gcc_assert (code
->resolved_isym
);
10463 switch (code
->resolved_isym
->id
)
10465 case GFC_ISYM_MOVE_ALLOC
:
10466 res
= conv_intrinsic_move_alloc (code
);
10469 case GFC_ISYM_ATOMIC_CAS
:
10470 res
= conv_intrinsic_atomic_cas (code
);
10473 case GFC_ISYM_ATOMIC_ADD
:
10474 case GFC_ISYM_ATOMIC_AND
:
10475 case GFC_ISYM_ATOMIC_DEF
:
10476 case GFC_ISYM_ATOMIC_OR
:
10477 case GFC_ISYM_ATOMIC_XOR
:
10478 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10479 case GFC_ISYM_ATOMIC_FETCH_AND
:
10480 case GFC_ISYM_ATOMIC_FETCH_OR
:
10481 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10482 res
= conv_intrinsic_atomic_op (code
);
10485 case GFC_ISYM_ATOMIC_REF
:
10486 res
= conv_intrinsic_atomic_ref (code
);
10489 case GFC_ISYM_EVENT_QUERY
:
10490 res
= conv_intrinsic_event_query (code
);
10493 case GFC_ISYM_C_F_POINTER
:
10494 case GFC_ISYM_C_F_PROCPOINTER
:
10495 res
= conv_isocbinding_subroutine (code
);
10498 case GFC_ISYM_CAF_SEND
:
10499 res
= conv_caf_send (code
);
10502 case GFC_ISYM_CO_BROADCAST
:
10503 case GFC_ISYM_CO_MIN
:
10504 case GFC_ISYM_CO_MAX
:
10505 case GFC_ISYM_CO_REDUCE
:
10506 case GFC_ISYM_CO_SUM
:
10507 res
= conv_co_collective (code
);
10510 case GFC_ISYM_FREE
:
10511 res
= conv_intrinsic_free (code
);
10514 case GFC_ISYM_SYSTEM_CLOCK
:
10515 res
= conv_intrinsic_system_clock (code
);
10526 #include "gt-fortran-trans-intrinsic.h"