1 /* Intrinsic translation
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "internal-fn.h"
35 #include "tree-nested.h"
36 #include "stor-layout.h"
37 #include "toplev.h" /* For rest_of_decl_compilation. */
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 #include "dependency.h" /* For CAF array alias analysis. */
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
45 /* This maps Fortran intrinsic math functions to external library or GCC
47 typedef struct GTY(()) gfc_intrinsic_map_t
{
48 /* The explicit enum is required to work around inadequacies in the
49 garbage collection/gengtype parsing mechanism. */
52 /* Enum value from the "language-independent", aka C-centric, part
53 of gcc, or END_BUILTINS of no such value set. */
54 enum built_in_function float_built_in
;
55 enum built_in_function double_built_in
;
56 enum built_in_function long_double_built_in
;
57 enum built_in_function complex_float_built_in
;
58 enum built_in_function complex_double_built_in
;
59 enum built_in_function complex_long_double_built_in
;
61 /* True if the naming pattern is to prepend "c" for complex and
62 append "f" for kind=4. False if the naming pattern is to
63 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 /* True if a complex version of the function exists. */
67 bool complex_available
;
69 /* True if the function should be marked const. */
72 /* The base library name of this function. */
75 /* Cache decls created for the various operand types. */
87 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
88 defines complex variants of all of the entries in mathbuiltins.def
90 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
91 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
92 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
93 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
94 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
96 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
97 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
98 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
99 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
100 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
102 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
108 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
109 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
110 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
116 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
117 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
118 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
119 #include "mathbuiltins.def"
121 /* Functions in libgfortran. */
122 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
125 LIB_FUNCTION (NONE
, NULL
, false)
130 #undef DEFINE_MATH_BUILTIN
131 #undef DEFINE_MATH_BUILTIN_C
134 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
137 /* Find the correct variant of a given builtin from its argument. */
139 builtin_decl_for_precision (enum built_in_function base_built_in
,
142 enum built_in_function i
= END_BUILTINS
;
144 gfc_intrinsic_map_t
*m
;
145 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
148 if (precision
== TYPE_PRECISION (float_type_node
))
149 i
= m
->float_built_in
;
150 else if (precision
== TYPE_PRECISION (double_type_node
))
151 i
= m
->double_built_in
;
152 else if (precision
== TYPE_PRECISION (long_double_type_node
))
153 i
= m
->long_double_built_in
;
154 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m
->real16_decl
;
161 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
169 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
171 if (gfc_real_kinds
[i
].c_float128
)
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t
*m
;
176 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
179 return m
->real16_decl
;
182 return builtin_decl_for_precision (double_built_in
,
183 gfc_real_kinds
[i
].mode_precision
);
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
193 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
194 tree
*argarray
, int nargs
)
196 gfc_actual_arglist
*actual
;
198 gfc_intrinsic_arg
*formal
;
202 formal
= expr
->value
.function
.isym
->formal
;
203 actual
= expr
->value
.function
.actual
;
205 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
206 actual
= actual
->next
,
207 formal
= formal
? formal
->next
: NULL
)
211 /* Skip omitted optional arguments. */
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse
, se
);
222 if (e
->ts
.type
== BT_CHARACTER
)
224 gfc_conv_expr (&argse
, e
);
225 gfc_conv_string_parameter (&argse
);
226 argarray
[curr_arg
++] = argse
.string_length
;
227 gcc_assert (curr_arg
< nargs
);
230 gfc_conv_expr_val (&argse
, e
);
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e
->expr_type
== EXPR_VARIABLE
235 && e
->symtree
->n
.sym
->attr
.optional
238 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
240 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
241 gfc_add_block_to_block (&se
->post
, &argse
.post
);
242 argarray
[curr_arg
] = argse
.expr
;
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
250 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
253 gfc_actual_arglist
*actual
;
255 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
260 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
274 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
280 nargs
= gfc_intrinsic_argument_list_length (expr
);
281 args
= XALLOCAVEC (tree
, nargs
);
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type
= gfc_typenode_for_spec (&expr
->ts
);
287 gcc_assert (expr
->value
.function
.actual
->expr
);
288 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
290 /* Conversion between character kinds involves a call to a library
292 if (expr
->ts
.type
== BT_CHARACTER
)
294 tree fndecl
, var
, addr
, tmp
;
296 if (expr
->ts
.kind
== 1
297 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
298 fndecl
= gfor_fndecl_convert_char4_to_char1
;
299 else if (expr
->ts
.kind
== 4
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
301 fndecl
= gfor_fndecl_convert_char1_to_char4
;
305 /* Create the variable storing the converted value. */
306 type
= gfc_get_pchar_type (expr
->ts
.kind
);
307 var
= gfc_create_var (type
, "str");
308 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs
>= 2);
312 tmp
= build_call_expr_loc (input_location
,
313 fndecl
, 3, addr
, args
[0], args
[1]);
314 gfc_add_expr_to_block (&se
->pre
, tmp
);
316 /* Free the temporary afterwards. */
317 tmp
= gfc_call_free (var
);
318 gfc_add_expr_to_block (&se
->post
, tmp
);
321 se
->string_length
= args
[0];
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
329 && expr
->ts
.type
!= BT_COMPLEX
)
333 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
334 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
338 se
->expr
= convert (type
, args
[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
354 argtype
= TREE_TYPE (arg
);
355 arg
= gfc_evaluate_now (arg
, pblock
);
357 intval
= convert (type
, arg
);
358 intval
= gfc_evaluate_now (intval
, pblock
);
360 tmp
= convert (argtype
, intval
);
361 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
362 logical_type_node
, tmp
, arg
);
364 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
365 intval
, build_int_cst (type
, 1));
366 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg
, tree restype
)
378 int argprec
, resprec
;
380 argtype
= TREE_TYPE (arg
);
381 argprec
= TYPE_PRECISION (argtype
);
382 resprec
= TYPE_PRECISION (restype
);
384 /* Depending on the type of the result, choose the int intrinsic
385 (iround, available only as a builtin, therefore cannot use it for
386 __float128), long int intrinsic (lround family) or long long
387 intrinsic (llround). We might also need to convert the result
389 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
390 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
391 else if (resprec
<= LONG_TYPE_SIZE
)
392 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
393 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
394 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
398 return fold_convert (restype
, build_call_expr_loc (input_location
,
403 /* Convert a real to an integer using a specific rounding mode.
404 Ideally we would just build the corresponding GENERIC node,
405 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
408 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
409 enum rounding_mode op
)
414 return build_fixbound_expr (pblock
, arg
, type
, 0);
417 return build_fixbound_expr (pblock
, arg
, type
, 1);
420 return build_round_expr (arg
, type
);
423 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
431 /* Round a real value using the specified rounding mode.
432 We use a temporary integer of that same kind size as the result.
433 Values larger than those that can be represented by this kind are
434 unchanged, as they will not be accurate enough to represent the
436 huge = HUGE (KIND (a))
437 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
441 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
453 kind
= expr
->ts
.kind
;
454 nargs
= gfc_intrinsic_argument_list_length (expr
);
457 /* We have builtin functions for some cases. */
461 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
465 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
472 /* Evaluate the argument. */
473 gcc_assert (expr
->value
.function
.actual
->expr
);
474 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
476 /* Use a builtin function if one exists. */
477 if (decl
!= NULL_TREE
)
479 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
483 /* This code is probably redundant, but we'll keep it lying around just
485 type
= gfc_typenode_for_spec (&expr
->ts
);
486 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
488 /* Test if the value is too large to handle sensibly. */
489 gfc_set_model_kind (kind
);
491 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
492 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
493 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
494 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, arg
[0],
497 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
498 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
499 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, arg
[0],
501 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, logical_type_node
,
503 itype
= gfc_get_int_type (kind
);
505 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
506 tmp
= convert (type
, tmp
);
507 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
513 /* Convert to an integer using the specified rounding mode. */
516 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
522 nargs
= gfc_intrinsic_argument_list_length (expr
);
523 args
= XALLOCAVEC (tree
, nargs
);
525 /* Evaluate the argument, we process all arguments even though we only
526 use the first one for code generation purposes. */
527 type
= gfc_typenode_for_spec (&expr
->ts
);
528 gcc_assert (expr
->value
.function
.actual
->expr
);
529 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
531 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
533 /* Conversion to a different integer kind. */
534 se
->expr
= convert (type
, args
[0]);
538 /* Conversion from complex to non-complex involves taking the real
539 component of the value. */
540 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
541 && expr
->ts
.type
!= BT_COMPLEX
)
545 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
546 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
550 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
555 /* Get the imaginary component of a value. */
558 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
562 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
563 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
564 TREE_TYPE (TREE_TYPE (arg
)), arg
);
568 /* Get the complex conjugate of a value. */
571 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
575 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
576 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
582 define_quad_builtin (const char *name
, tree type
, bool is_const
)
585 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
588 /* Mark the decl as external. */
589 DECL_EXTERNAL (fndecl
) = 1;
590 TREE_PUBLIC (fndecl
) = 1;
592 /* Mark it __attribute__((const)). */
593 TREE_READONLY (fndecl
) = is_const
;
595 rest_of_decl_compilation (fndecl
, 1, 0);
602 /* Initialize function decls for library functions. The external functions
603 are created as required. Builtin functions are added here. */
606 gfc_build_intrinsic_lib_fndecls (void)
608 gfc_intrinsic_map_t
*m
;
609 tree quad_decls
[END_BUILTINS
+ 1];
611 if (gfc_real16_is_float128
)
613 /* If we have soft-float types, we create the decls for their
614 C99-like library functions. For now, we only handle __float128
615 q-suffixed functions. */
617 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
618 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
620 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
622 type
= gfc_float128_type_node
;
623 complex_type
= gfc_complex_float128_type_node
;
624 /* type (*) (type) */
625 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
627 func_iround
= build_function_type_list (integer_type_node
,
629 /* long (*) (type) */
630 func_lround
= build_function_type_list (long_integer_type_node
,
632 /* long long (*) (type) */
633 func_llround
= build_function_type_list (long_long_integer_type_node
,
635 /* type (*) (type, type) */
636 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
637 /* type (*) (type, &int) */
639 = build_function_type_list (type
,
641 build_pointer_type (integer_type_node
),
643 /* type (*) (type, int) */
644 func_scalbn
= build_function_type_list (type
,
645 type
, integer_type_node
, NULL_TREE
);
646 /* type (*) (complex type) */
647 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
648 /* complex type (*) (complex type, complex type) */
650 = build_function_type_list (complex_type
,
651 complex_type
, complex_type
, NULL_TREE
);
653 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
654 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
655 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
657 /* Only these built-ins are actually needed here. These are used directly
658 from the code, when calling builtin_decl_for_precision() or
659 builtin_decl_for_float_type(). The others are all constructed by
660 gfc_get_intrinsic_lib_fndecl(). */
661 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
662 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
664 #include "mathbuiltins.def"
668 #undef DEFINE_MATH_BUILTIN
669 #undef DEFINE_MATH_BUILTIN_C
671 /* There is one built-in we defined manually, because it gets called
672 with builtin_decl_for_precision() or builtin_decl_for_float_type()
673 even though it is not an OTHER_BUILTIN: it is SQRT. */
674 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
678 /* Add GCC builtin functions. */
679 for (m
= gfc_intrinsic_map
;
680 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
682 if (m
->float_built_in
!= END_BUILTINS
)
683 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
684 if (m
->complex_float_built_in
!= END_BUILTINS
)
685 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
686 if (m
->double_built_in
!= END_BUILTINS
)
687 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
688 if (m
->complex_double_built_in
!= END_BUILTINS
)
689 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
691 /* If real(kind=10) exists, it is always long double. */
692 if (m
->long_double_built_in
!= END_BUILTINS
)
693 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
694 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
696 = builtin_decl_explicit (m
->complex_long_double_built_in
);
698 if (!gfc_real16_is_float128
)
700 if (m
->long_double_built_in
!= END_BUILTINS
)
701 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
702 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
704 = builtin_decl_explicit (m
->complex_long_double_built_in
);
706 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
708 /* Quad-precision function calls are constructed when first
709 needed by builtin_decl_for_precision(), except for those
710 that will be used directly (define by OTHER_BUILTIN). */
711 m
->real16_decl
= quad_decls
[m
->double_built_in
];
713 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
715 /* Same thing for the complex ones. */
716 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
722 /* Create a fndecl for a simple intrinsic library function. */
725 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
728 vec
<tree
, va_gc
> *argtypes
;
730 gfc_actual_arglist
*actual
;
733 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
736 if (ts
->type
== BT_REAL
)
741 pdecl
= &m
->real4_decl
;
744 pdecl
= &m
->real8_decl
;
747 pdecl
= &m
->real10_decl
;
750 pdecl
= &m
->real16_decl
;
756 else if (ts
->type
== BT_COMPLEX
)
758 gcc_assert (m
->complex_available
);
763 pdecl
= &m
->complex4_decl
;
766 pdecl
= &m
->complex8_decl
;
769 pdecl
= &m
->complex10_decl
;
772 pdecl
= &m
->complex16_decl
;
786 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
787 if (gfc_real_kinds
[n
].c_float
)
788 snprintf (name
, sizeof (name
), "%s%s%s",
789 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
790 else if (gfc_real_kinds
[n
].c_double
)
791 snprintf (name
, sizeof (name
), "%s%s",
792 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
793 else if (gfc_real_kinds
[n
].c_long_double
)
794 snprintf (name
, sizeof (name
), "%s%s%s",
795 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
796 else if (gfc_real_kinds
[n
].c_float128
)
797 snprintf (name
, sizeof (name
), "%s%s%s",
798 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
804 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
805 ts
->type
== BT_COMPLEX
? 'c' : 'r',
810 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
812 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
813 vec_safe_push (argtypes
, type
);
815 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
816 fndecl
= build_decl (input_location
,
817 FUNCTION_DECL
, get_identifier (name
), type
);
819 /* Mark the decl as external. */
820 DECL_EXTERNAL (fndecl
) = 1;
821 TREE_PUBLIC (fndecl
) = 1;
823 /* Mark it __attribute__((const)), if possible. */
824 TREE_READONLY (fndecl
) = m
->is_constant
;
826 rest_of_decl_compilation (fndecl
, 1, 0);
833 /* Convert an intrinsic function into an external or builtin call. */
836 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
838 gfc_intrinsic_map_t
*m
;
842 unsigned int num_args
;
845 id
= expr
->value
.function
.isym
->id
;
846 /* Find the entry for this function. */
847 for (m
= gfc_intrinsic_map
;
848 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
854 if (m
->id
== GFC_ISYM_NONE
)
856 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
857 expr
->value
.function
.name
, id
);
860 /* Get the decl and generate the call. */
861 num_args
= gfc_intrinsic_argument_list_length (expr
);
862 args
= XALLOCAVEC (tree
, num_args
);
864 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
865 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
866 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
868 fndecl
= build_addr (fndecl
);
869 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
873 /* If bounds-checking is enabled, create code to verify at runtime that the
874 string lengths for both expressions are the same (needed for e.g. MERGE).
875 If bounds-checking is not enabled, does nothing. */
878 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
879 tree a
, tree b
, stmtblock_t
* target
)
884 /* If bounds-checking is disabled, do nothing. */
885 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
888 /* Compare the two string lengths. */
889 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, a
, b
);
891 /* Output the runtime-check. */
892 name
= gfc_build_cstring_const (intr_name
);
893 name
= gfc_build_addr_expr (pchar_type_node
, name
);
894 gfc_trans_runtime_check (true, false, cond
, target
, where
,
895 "Unequal character lengths (%ld/%ld) in %s",
896 fold_convert (long_integer_type_node
, a
),
897 fold_convert (long_integer_type_node
, b
), name
);
901 /* The EXPONENT(X) intrinsic function is translated into
903 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
904 so that if X is a NaN or infinity, the result is HUGE(0).
908 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
910 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
913 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
914 expr
->value
.function
.actual
->expr
->ts
.kind
);
916 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
917 arg
= gfc_evaluate_now (arg
, &se
->pre
);
919 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
920 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
921 cond
= build_call_expr_loc (input_location
,
922 builtin_decl_explicit (BUILT_IN_ISFINITE
),
925 res
= gfc_create_var (integer_type_node
, NULL
);
926 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
927 gfc_build_addr_expr (NULL_TREE
, res
));
928 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
930 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
933 type
= gfc_typenode_for_spec (&expr
->ts
);
934 se
->expr
= fold_convert (type
, se
->expr
);
938 /* Fill in the following structure
939 struct caf_vector_t {
940 size_t nvec; // size of the vector
947 ptrdiff_t lower_bound;
948 ptrdiff_t upper_bound;
955 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
956 tree lower
, tree upper
, tree stride
,
957 tree vector
, int kind
, tree nvec
)
959 tree field
, type
, tmp
;
961 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
962 type
= TREE_TYPE (desc
);
964 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
965 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
966 desc
, field
, NULL_TREE
);
967 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
970 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
971 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
972 desc
, field
, NULL_TREE
);
973 type
= TREE_TYPE (desc
);
975 /* Access the inner struct. */
976 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
977 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
978 desc
, field
, NULL_TREE
);
979 type
= TREE_TYPE (desc
);
981 if (vector
!= NULL_TREE
)
983 /* Set vector and kind. */
984 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
985 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
986 desc
, field
, NULL_TREE
);
987 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
988 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
989 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
990 desc
, field
, NULL_TREE
);
991 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
995 /* Set dim.lower/upper/stride. */
996 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
997 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
998 desc
, field
, NULL_TREE
);
999 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1001 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1002 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1003 desc
, field
, NULL_TREE
);
1004 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1006 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1007 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1008 desc
, field
, NULL_TREE
);
1009 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1015 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1018 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1019 tree lbound
, ubound
, tmp
;
1022 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1024 for (i
= 0; i
< ar
->dimen
; i
++)
1025 switch (ar
->dimen_type
[i
])
1030 gfc_init_se (&argse
, NULL
);
1031 gfc_conv_expr (&argse
, ar
->end
[i
]);
1032 gfc_add_block_to_block (block
, &argse
.pre
);
1033 upper
= gfc_evaluate_now (argse
.expr
, block
);
1036 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1039 gfc_init_se (&argse
, NULL
);
1040 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1041 gfc_add_block_to_block (block
, &argse
.pre
);
1042 stride
= gfc_evaluate_now (argse
.expr
, block
);
1045 stride
= gfc_index_one_node
;
1051 gfc_init_se (&argse
, NULL
);
1052 gfc_conv_expr (&argse
, ar
->start
[i
]);
1053 gfc_add_block_to_block (block
, &argse
.pre
);
1054 lower
= gfc_evaluate_now (argse
.expr
, block
);
1057 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1058 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1061 stride
= gfc_index_one_node
;
1064 nvec
= size_zero_node
;
1065 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1070 gfc_init_se (&argse
, NULL
);
1071 argse
.descriptor_only
= 1;
1072 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1073 gfc_add_block_to_block (block
, &argse
.pre
);
1074 vector
= argse
.expr
;
1075 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1076 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1077 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1078 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1079 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1080 TREE_TYPE (nvec
), nvec
, tmp
);
1081 lower
= gfc_index_zero_node
;
1082 upper
= gfc_index_zero_node
;
1083 stride
= gfc_index_zero_node
;
1084 vector
= gfc_conv_descriptor_data_get (vector
);
1085 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1086 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1091 return gfc_build_addr_expr (NULL_TREE
, var
);
1096 compute_component_offset (tree field
, tree type
)
1099 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1100 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1102 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1103 DECL_FIELD_BIT_OFFSET (field
),
1105 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1108 return DECL_FIELD_OFFSET (field
);
1113 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1115 gfc_ref
*ref
= expr
->ref
, *last_comp_ref
;
1116 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1117 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1118 start
, end
, stride
, vector
, nvec
;
1120 bool ref_static_array
= false;
1121 tree last_component_ref_tree
= NULL_TREE
;
1126 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1127 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
1128 && !expr
->symtree
->n
.sym
->attr
.pointer
;
1131 /* Prevent uninit-warning. */
1132 reference_type
= NULL_TREE
;
1134 /* Skip refs upto the first coarray-ref. */
1135 last_comp_ref
= NULL
;
1136 while (ref
&& (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
== 0))
1138 /* Remember the type of components skipped. */
1139 if (ref
->type
== REF_COMPONENT
)
1140 last_comp_ref
= ref
;
1143 /* When a component was skipped, get the type information of the last
1144 component ref, else get the type from the symbol. */
1147 last_type
= gfc_typenode_for_spec (&last_comp_ref
->u
.c
.component
->ts
);
1148 last_type_n
= last_comp_ref
->u
.c
.component
->ts
.type
;
1152 last_type
= gfc_typenode_for_spec (&expr
->symtree
->n
.sym
->ts
);
1153 last_type_n
= expr
->symtree
->n
.sym
->ts
.type
;
1158 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0
1159 && ref
->u
.ar
.dimen
== 0)
1161 /* Skip pure coindexes. */
1165 tmp
= gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1166 reference_type
= TREE_TYPE (tmp
);
1168 if (caf_ref
== NULL_TREE
)
1171 /* Construct the chain of refs. */
1172 if (prev_caf_ref
!= NULL_TREE
)
1174 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1175 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1176 TREE_TYPE (field
), prev_caf_ref
, field
,
1178 gfc_add_modify (block
, tmp2
, gfc_build_addr_expr (TREE_TYPE (field
),
1186 last_type
= gfc_typenode_for_spec (&ref
->u
.c
.component
->ts
);
1187 last_type_n
= ref
->u
.c
.component
->ts
.type
;
1188 /* Set the type of the ref. */
1189 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1190 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1191 TREE_TYPE (field
), prev_caf_ref
, field
,
1193 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1194 GFC_CAF_REF_COMPONENT
));
1196 /* Ref the c in union u. */
1197 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1198 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1199 TREE_TYPE (field
), prev_caf_ref
, field
,
1201 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 0);
1202 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1203 TREE_TYPE (field
), tmp
, field
,
1206 /* Set the offset. */
1207 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1208 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1209 TREE_TYPE (field
), inner_struct
, field
,
1211 /* Computing the offset is somewhat harder. The bit_offset has to be
1212 taken into account. When the bit_offset in the field_decl is non-
1213 null, divide it by the bitsize_unit and add it to the regular
1215 tmp2
= compute_component_offset (ref
->u
.c
.component
->backend_decl
,
1217 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1219 /* Set caf_token_offset. */
1220 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 1);
1221 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1222 TREE_TYPE (field
), inner_struct
, field
,
1224 if ((ref
->u
.c
.component
->attr
.allocatable
1225 || ref
->u
.c
.component
->attr
.pointer
)
1226 && ref
->u
.c
.component
->attr
.dimension
)
1228 tree arr_desc_token_offset
;
1229 /* Get the token field from the descriptor. */
1230 arr_desc_token_offset
= TREE_OPERAND (
1231 gfc_conv_descriptor_token (ref
->u
.c
.component
->backend_decl
), 1);
1232 arr_desc_token_offset
1233 = compute_component_offset (arr_desc_token_offset
,
1235 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
,
1236 TREE_TYPE (tmp2
), tmp2
,
1237 arr_desc_token_offset
);
1239 else if (ref
->u
.c
.component
->caf_token
)
1240 tmp2
= compute_component_offset (ref
->u
.c
.component
->caf_token
,
1243 tmp2
= integer_zero_node
;
1244 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1246 /* Remember whether this ref was to a non-allocatable/non-pointer
1247 component so the next array ref can be tailored correctly. */
1248 ref_static_array
= !ref
->u
.c
.component
->attr
.allocatable
1249 && !ref
->u
.c
.component
->attr
.pointer
;
1250 last_component_ref_tree
= ref_static_array
1251 ? ref
->u
.c
.component
->backend_decl
: NULL_TREE
;
1254 if (ref_static_array
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
)
1255 ref_static_array
= false;
1256 /* Set the type of the ref. */
1257 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1258 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1259 TREE_TYPE (field
), prev_caf_ref
, field
,
1261 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1263 ? GFC_CAF_REF_STATIC_ARRAY
1264 : GFC_CAF_REF_ARRAY
));
1266 /* Ref the a in union u. */
1267 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1268 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1269 TREE_TYPE (field
), prev_caf_ref
, field
,
1271 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 1);
1272 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1273 TREE_TYPE (field
), tmp
, field
,
1276 /* Set the static_array_type in a for static arrays. */
1277 if (ref_static_array
)
1279 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)),
1281 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1282 TREE_TYPE (field
), inner_struct
, field
,
1284 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (tmp
),
1287 /* Ref the mode in the inner_struct. */
1288 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1289 mode
= fold_build3_loc (input_location
, COMPONENT_REF
,
1290 TREE_TYPE (field
), inner_struct
, field
,
1292 /* Ref the dim in the inner_struct. */
1293 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 2);
1294 dim_array
= fold_build3_loc (input_location
, COMPONENT_REF
,
1295 TREE_TYPE (field
), inner_struct
, field
,
1297 for (i
= 0; i
< ref
->u
.ar
.dimen
; ++i
)
1300 dim
= gfc_build_array_ref (dim_array
, gfc_rank_cst
[i
], NULL_TREE
);
1301 dim_type
= TREE_TYPE (dim
);
1302 mode_rhs
= start
= end
= stride
= NULL_TREE
;
1303 switch (ref
->u
.ar
.dimen_type
[i
])
1306 if (ref
->u
.ar
.end
[i
])
1308 gfc_init_se (&se
, NULL
);
1309 gfc_conv_expr (&se
, ref
->u
.ar
.end
[i
]);
1310 gfc_add_block_to_block (block
, &se
.pre
);
1311 if (ref_static_array
)
1313 /* Make the index zero-based, when reffing a static
1316 gfc_init_se (&se
, NULL
);
1317 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1318 gfc_add_block_to_block (block
, &se
.pre
);
1319 se
.expr
= fold_build2 (MINUS_EXPR
,
1320 gfc_array_index_type
,
1322 gfc_array_index_type
,
1325 end
= gfc_evaluate_now (fold_convert (
1326 gfc_array_index_type
,
1330 else if (ref_static_array
)
1331 end
= fold_build2 (MINUS_EXPR
,
1332 gfc_array_index_type
,
1333 gfc_conv_array_ubound (
1334 last_component_ref_tree
, i
),
1335 gfc_conv_array_lbound (
1336 last_component_ref_tree
, i
));
1340 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1341 GFC_CAF_ARR_REF_OPEN_END
);
1343 if (ref
->u
.ar
.stride
[i
])
1345 gfc_init_se (&se
, NULL
);
1346 gfc_conv_expr (&se
, ref
->u
.ar
.stride
[i
]);
1347 gfc_add_block_to_block (block
, &se
.pre
);
1348 stride
= gfc_evaluate_now (fold_convert (
1349 gfc_array_index_type
,
1352 if (ref_static_array
)
1354 /* Make the index zero-based, when reffing a static
1356 stride
= fold_build2 (MULT_EXPR
,
1357 gfc_array_index_type
,
1358 gfc_conv_array_stride (
1359 last_component_ref_tree
,
1362 gcc_assert (end
!= NULL_TREE
);
1363 /* Multiply with the product of array's stride and
1364 the step of the ref to a virtual upper bound.
1365 We can not compute the actual upper bound here or
1366 the caflib would compute the extend
1368 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1369 end
, gfc_conv_array_stride (
1370 last_component_ref_tree
,
1372 end
= gfc_evaluate_now (end
, block
);
1373 stride
= gfc_evaluate_now (stride
, block
);
1376 else if (ref_static_array
)
1378 stride
= gfc_conv_array_stride (last_component_ref_tree
,
1380 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1382 end
= gfc_evaluate_now (end
, block
);
1385 /* Always set a ref stride of one to make caflib's
1387 stride
= gfc_index_one_node
;
1391 if (ref
->u
.ar
.start
[i
])
1393 gfc_init_se (&se
, NULL
);
1394 gfc_conv_expr (&se
, ref
->u
.ar
.start
[i
]);
1395 gfc_add_block_to_block (block
, &se
.pre
);
1396 if (ref_static_array
)
1398 /* Make the index zero-based, when reffing a static
1400 start
= fold_convert (gfc_array_index_type
, se
.expr
);
1401 gfc_init_se (&se
, NULL
);
1402 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1403 gfc_add_block_to_block (block
, &se
.pre
);
1404 se
.expr
= fold_build2 (MINUS_EXPR
,
1405 gfc_array_index_type
,
1406 start
, fold_convert (
1407 gfc_array_index_type
,
1409 /* Multiply with the stride. */
1410 se
.expr
= fold_build2 (MULT_EXPR
,
1411 gfc_array_index_type
,
1413 gfc_conv_array_stride (
1414 last_component_ref_tree
,
1417 start
= gfc_evaluate_now (fold_convert (
1418 gfc_array_index_type
,
1421 if (mode_rhs
== NULL_TREE
)
1422 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1423 ref
->u
.ar
.dimen_type
[i
]
1425 ? GFC_CAF_ARR_REF_SINGLE
1426 : GFC_CAF_ARR_REF_RANGE
);
1428 else if (ref_static_array
)
1430 start
= integer_zero_node
;
1431 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1432 ref
->u
.ar
.start
[i
] == NULL
1433 ? GFC_CAF_ARR_REF_FULL
1434 : GFC_CAF_ARR_REF_RANGE
);
1436 else if (end
== NULL_TREE
)
1437 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1438 GFC_CAF_ARR_REF_FULL
);
1440 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1441 GFC_CAF_ARR_REF_OPEN_START
);
1443 /* Ref the s in dim. */
1444 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 0);
1445 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1446 TREE_TYPE (field
), dim
, field
,
1449 /* Set start in s. */
1450 if (start
!= NULL_TREE
)
1452 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1454 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1455 TREE_TYPE (field
), tmp
, field
,
1457 gfc_add_modify (block
, tmp2
,
1458 fold_convert (TREE_TYPE (tmp2
), start
));
1462 if (end
!= NULL_TREE
)
1464 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1466 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1467 TREE_TYPE (field
), tmp
, field
,
1469 gfc_add_modify (block
, tmp2
,
1470 fold_convert (TREE_TYPE (tmp2
), end
));
1474 if (stride
!= NULL_TREE
)
1476 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1478 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1479 TREE_TYPE (field
), tmp
, field
,
1481 gfc_add_modify (block
, tmp2
,
1482 fold_convert (TREE_TYPE (tmp2
), stride
));
1486 /* TODO: In case of static array. */
1487 gcc_assert (!ref_static_array
);
1488 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1489 GFC_CAF_ARR_REF_VECTOR
);
1490 gfc_init_se (&se
, NULL
);
1491 se
.descriptor_only
= 1;
1492 gfc_conv_expr_descriptor (&se
, ref
->u
.ar
.start
[i
]);
1493 gfc_add_block_to_block (block
, &se
.pre
);
1495 tmp
= gfc_conv_descriptor_lbound_get (vector
,
1497 tmp2
= gfc_conv_descriptor_ubound_get (vector
,
1499 nvec
= gfc_conv_array_extent_dim (tmp
, tmp2
, NULL
);
1500 tmp
= gfc_conv_descriptor_stride_get (vector
,
1502 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1503 TREE_TYPE (nvec
), nvec
, tmp
);
1504 vector
= gfc_conv_descriptor_data_get (vector
);
1506 /* Ref the v in dim. */
1507 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 1);
1508 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1509 TREE_TYPE (field
), dim
, field
,
1512 /* Set vector in v. */
1513 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 0);
1514 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1515 TREE_TYPE (field
), tmp
, field
,
1517 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1520 /* Set nvec in v. */
1521 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 1);
1522 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1523 TREE_TYPE (field
), tmp
, field
,
1525 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1528 /* Set kind in v. */
1529 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 2);
1530 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1531 TREE_TYPE (field
), tmp
, field
,
1533 gfc_add_modify (block
, tmp2
, build_int_cst (integer_type_node
,
1534 ref
->u
.ar
.start
[i
]->ts
.kind
));
1539 /* Set the mode for dim i. */
1540 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1541 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
),
1545 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1546 if (i
< GFC_MAX_DIMENSIONS
)
1548 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1549 gfc_add_modify (block
, tmp
,
1550 build_int_cst (unsigned_char_type_node
,
1551 GFC_CAF_ARR_REF_NONE
));
1558 /* Set the size of the current type. */
1559 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 2);
1560 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1561 prev_caf_ref
, field
, NULL_TREE
);
1562 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1563 TYPE_SIZE_UNIT (last_type
)));
1568 if (prev_caf_ref
!= NULL_TREE
)
1570 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1571 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1572 prev_caf_ref
, field
, NULL_TREE
);
1573 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1574 null_pointer_node
));
1576 return caf_ref
!= NULL_TREE
? gfc_build_addr_expr (NULL_TREE
, caf_ref
)
1580 /* Get data from a remote coarray. */
1583 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1584 tree may_require_tmp
, bool may_realloc
,
1585 symbol_attribute
*caf_attr
)
1587 gfc_expr
*array_expr
, *tmp_stat
;
1589 tree caf_decl
, token
, offset
, image_index
, tmp
;
1590 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
1592 symbol_attribute caf_attr_store
;
1594 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1596 if (se
->ss
&& se
->ss
->info
->useflags
)
1598 /* Access the previously obtained result. */
1599 gfc_conv_tmp_array_ref (se
);
1603 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1604 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1605 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1607 if (caf_attr
== NULL
)
1609 caf_attr_store
= gfc_caf_attr (array_expr
);
1610 caf_attr
= &caf_attr_store
;
1616 vec
= null_pointer_node
;
1617 tmp_stat
= gfc_find_stat_co (expr
);
1622 gfc_init_se (&stat_se
, NULL
);
1623 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1624 stat
= stat_se
.expr
;
1625 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1626 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1629 stat
= null_pointer_node
;
1631 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1632 is reallocatable or the right-hand side has allocatable components. */
1633 if (caf_attr
->alloc_comp
|| caf_attr
->pointer_comp
|| may_realloc
)
1635 /* Get using caf_get_by_ref. */
1636 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, array_expr
);
1638 if (caf_reference
!= NULL_TREE
)
1640 if (lhs
== NULL_TREE
)
1642 if (array_expr
->ts
.type
== BT_CHARACTER
)
1643 gfc_init_se (&argse
, NULL
);
1644 if (array_expr
->rank
== 0)
1646 symbol_attribute attr
;
1647 gfc_clear_attr (&attr
);
1648 if (array_expr
->ts
.type
== BT_CHARACTER
)
1650 res_var
= gfc_conv_string_tmp (se
,
1651 build_pointer_type (type
),
1652 array_expr
->ts
.u
.cl
->backend_decl
);
1653 argse
.string_length
= array_expr
->ts
.u
.cl
->backend_decl
;
1656 res_var
= gfc_create_var (type
, "caf_res");
1657 dst_var
= gfc_conv_scalar_to_descriptor (se
, res_var
, attr
);
1658 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1662 /* Create temporary. */
1663 if (array_expr
->ts
.type
== BT_CHARACTER
)
1664 gfc_conv_expr_descriptor (&argse
, array_expr
);
1665 may_realloc
= gfc_trans_create_temp_array (&se
->pre
,
1672 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1673 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1676 tmp
= gfc_conv_descriptor_data_get (res_var
);
1677 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
,
1678 NULL_TREE
, NULL_TREE
,
1681 GFC_CAF_COARRAY_NOCOARRAY
);
1682 gfc_add_expr_to_block (&se
->post
, tmp
);
1687 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1688 if (lhs_kind
== NULL_TREE
)
1691 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1692 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1693 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1694 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1696 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1699 /* No overlap possible as we have generated a temporary. */
1700 if (lhs
== NULL_TREE
)
1701 may_require_tmp
= boolean_false_node
;
1703 /* It guarantees memory consistency within the same segment. */
1704 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1705 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1706 gfc_build_string_const (1, ""), NULL_TREE
,
1707 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1709 ASM_VOLATILE_P (tmp
) = 1;
1710 gfc_add_expr_to_block (&se
->pre
, tmp
);
1712 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1713 10, token
, image_index
, dst_var
,
1714 caf_reference
, lhs_kind
, kind
,
1716 may_realloc
? boolean_true_node
:
1718 stat
, build_int_cst (integer_type_node
,
1719 array_expr
->ts
.type
));
1721 gfc_add_expr_to_block (&se
->pre
, tmp
);
1724 gfc_advance_se_ss_chain (se
);
1727 if (array_expr
->ts
.type
== BT_CHARACTER
)
1728 se
->string_length
= argse
.string_length
;
1734 gfc_init_se (&argse
, NULL
);
1735 if (array_expr
->rank
== 0)
1737 symbol_attribute attr
;
1739 gfc_clear_attr (&attr
);
1740 gfc_conv_expr (&argse
, array_expr
);
1742 if (lhs
== NULL_TREE
)
1744 gfc_clear_attr (&attr
);
1745 if (array_expr
->ts
.type
== BT_CHARACTER
)
1746 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1747 argse
.string_length
);
1749 res_var
= gfc_create_var (type
, "caf_res");
1750 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1751 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1753 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1754 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1758 /* If has_vector, pass descriptor for whole array and the
1759 vector bounds separately. */
1760 gfc_array_ref
*ar
, ar2
;
1761 bool has_vector
= false;
1763 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1766 ar
= gfc_find_array_ref (expr
);
1768 memset (ar
, '\0', sizeof (*ar
));
1772 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1773 gfc_conv_expr_descriptor (&argse
, array_expr
);
1774 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1775 has the wrong type if component references are done. */
1776 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1777 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1782 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1786 if (lhs
== NULL_TREE
)
1788 /* Create temporary. */
1789 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1790 if (se
->loop
->to
[n
] == NULL_TREE
)
1792 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1794 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1797 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1798 NULL_TREE
, false, true, false,
1799 &array_expr
->where
);
1800 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1801 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1803 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1806 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1807 if (lhs_kind
== NULL_TREE
)
1810 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1811 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1813 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1814 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1815 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1816 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1817 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1820 /* No overlap possible as we have generated a temporary. */
1821 if (lhs
== NULL_TREE
)
1822 may_require_tmp
= boolean_false_node
;
1824 /* It guarantees memory consistency within the same segment. */
1825 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1826 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1827 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1828 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1829 ASM_VOLATILE_P (tmp
) = 1;
1830 gfc_add_expr_to_block (&se
->pre
, tmp
);
1832 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1833 token
, offset
, image_index
, argse
.expr
, vec
,
1834 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1836 gfc_add_expr_to_block (&se
->pre
, tmp
);
1839 gfc_advance_se_ss_chain (se
);
1842 if (array_expr
->ts
.type
== BT_CHARACTER
)
1843 se
->string_length
= argse
.string_length
;
1847 /* Send data to a remote coarray. */
1850 conv_caf_send (gfc_code
*code
) {
1851 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
, *tmp_team
;
1852 gfc_se lhs_se
, rhs_se
;
1854 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1855 tree may_require_tmp
, src_stat
, dst_stat
, dst_team
;
1856 tree lhs_type
= NULL_TREE
;
1857 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1858 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1860 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1862 lhs_expr
= code
->ext
.actual
->expr
;
1863 rhs_expr
= code
->ext
.actual
->next
->expr
;
1864 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, true) == 0
1865 ? boolean_false_node
: boolean_true_node
;
1866 gfc_init_block (&block
);
1868 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1869 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1870 src_stat
= dst_stat
= null_pointer_node
;
1871 dst_team
= null_pointer_node
;
1874 gfc_init_se (&lhs_se
, NULL
);
1875 if (lhs_expr
->rank
== 0)
1877 if (lhs_expr
->ts
.type
== BT_CHARACTER
&& lhs_expr
->ts
.deferred
)
1879 lhs_se
.expr
= gfc_get_tree_for_caf_expr (lhs_expr
);
1880 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1884 symbol_attribute attr
;
1885 gfc_clear_attr (&attr
);
1886 gfc_conv_expr (&lhs_se
, lhs_expr
);
1887 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1888 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
,
1890 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1893 else if ((lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
1894 && lhs_caf_attr
.codimension
)
1896 lhs_se
.want_pointer
= 1;
1897 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1898 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1899 has the wrong type if component references are done. */
1900 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1901 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1902 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1903 gfc_get_dtype_rank_type (
1904 gfc_has_vector_subscript (lhs_expr
)
1905 ? gfc_find_array_ref (lhs_expr
)->dimen
1911 bool has_vector
= gfc_has_vector_subscript (lhs_expr
);
1913 if (gfc_is_coindexed (lhs_expr
) || !has_vector
)
1915 /* If has_vector, pass descriptor for whole array and the
1916 vector bounds separately. */
1917 gfc_array_ref
*ar
, ar2
;
1918 bool has_tmp_lhs_array
= false;
1921 has_tmp_lhs_array
= true;
1922 ar
= gfc_find_array_ref (lhs_expr
);
1924 memset (ar
, '\0', sizeof (*ar
));
1928 lhs_se
.want_pointer
= 1;
1929 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1930 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
1931 that has the wrong type if component references are done. */
1932 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1933 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1934 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1935 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1938 if (has_tmp_lhs_array
)
1940 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1946 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
1947 indexed array expression. This is rewritten to:
1949 tmp_array = arr2[...]
1950 arr1 ([...]) = tmp_array
1952 because using the standard gfc_conv_expr (lhs_expr) did the
1953 assignment with lhs and rhs exchanged. */
1955 gfc_ss
*lss_for_tmparray
, *lss_real
;
1959 tree tmparr_desc
, src
;
1960 tree index
= gfc_index_zero_node
;
1961 tree stride
= gfc_index_zero_node
;
1964 /* Walk both sides of the assignment, once to get the shape of the
1965 temporary array to create right. */
1966 lss_for_tmparray
= gfc_walk_expr (lhs_expr
);
1967 /* And a second time to be able to create an assignment of the
1968 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
1969 the tree in the descriptor with the one for the temporary
1971 lss_real
= gfc_walk_expr (lhs_expr
);
1972 gfc_init_loopinfo (&loop
);
1973 gfc_add_ss_to_loop (&loop
, lss_for_tmparray
);
1974 gfc_add_ss_to_loop (&loop
, lss_real
);
1975 gfc_conv_ss_startstride (&loop
);
1976 gfc_conv_loop_setup (&loop
, &lhs_expr
->where
);
1977 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1978 gfc_trans_create_temp_array (&lhs_se
.pre
, &lhs_se
.post
,
1979 lss_for_tmparray
, lhs_type
, NULL_TREE
,
1982 tmparr_desc
= lss_for_tmparray
->info
->data
.array
.descriptor
;
1983 gfc_start_scalarized_body (&loop
, &body
);
1984 gfc_init_se (&se
, NULL
);
1985 gfc_copy_loopinfo_to_se (&se
, &loop
);
1987 gfc_conv_expr (&se
, lhs_expr
);
1988 gfc_add_block_to_block (&body
, &se
.pre
);
1990 /* Walk over all indexes of the loop. */
1991 for (n
= loop
.dimen
- 1; n
> 0; --n
)
1993 tmp
= loop
.loopvar
[n
];
1994 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1995 gfc_array_index_type
, tmp
, loop
.from
[n
]);
1996 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1997 gfc_array_index_type
, tmp
, index
);
1999 stride
= fold_build2_loc (input_location
, MINUS_EXPR
,
2000 gfc_array_index_type
,
2001 loop
.to
[n
- 1], loop
.from
[n
- 1]);
2002 stride
= fold_build2_loc (input_location
, PLUS_EXPR
,
2003 gfc_array_index_type
,
2004 stride
, gfc_index_one_node
);
2006 index
= fold_build2_loc (input_location
, MULT_EXPR
,
2007 gfc_array_index_type
, tmp
, stride
);
2010 index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2011 gfc_array_index_type
,
2012 index
, loop
.from
[0]);
2014 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2015 gfc_array_index_type
,
2016 loop
.loopvar
[0], index
);
2018 src
= build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc
));
2019 src
= gfc_build_array_ref (src
, index
, NULL
);
2020 /* Now create the assignment of lhs_expr = tmp_array. */
2021 gfc_add_modify (&body
, se
.expr
, src
);
2022 gfc_add_block_to_block (&body
, &se
.post
);
2023 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, tmparr_desc
);
2024 gfc_trans_scalarizing_loops (&loop
, &body
);
2025 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2026 gfc_add_expr_to_block (&lhs_se
.post
, gfc_finish_block (&loop
.pre
));
2027 gfc_free_ss (lss_for_tmparray
);
2028 gfc_free_ss (lss_real
);
2032 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
2034 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2035 temporary and a loop. */
2036 if (!gfc_is_coindexed (lhs_expr
)
2037 && (!lhs_caf_attr
.codimension
2038 || !(lhs_expr
->rank
> 0
2039 && (lhs_caf_attr
.allocatable
|| lhs_caf_attr
.pointer
))))
2041 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
2042 gcc_assert (gfc_is_coindexed (rhs_expr
));
2043 gfc_init_se (&rhs_se
, NULL
);
2044 if (lhs_expr
->rank
== 0 && lhs_caf_attr
.allocatable
)
2047 gfc_init_se (&scal_se
, NULL
);
2048 scal_se
.want_pointer
= 1;
2049 gfc_conv_expr (&scal_se
, lhs_expr
);
2050 /* Ensure scalar on lhs is allocated. */
2051 gfc_add_block_to_block (&block
, &scal_se
.pre
);
2053 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
2055 gfc_typenode_for_spec (&lhs_expr
->ts
)),
2057 tmp
= fold_build2 (EQ_EXPR
, logical_type_node
, scal_se
.expr
,
2059 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2060 tmp
, gfc_finish_block (&scal_se
.pre
),
2061 build_empty_stmt (input_location
));
2062 gfc_add_expr_to_block (&block
, tmp
);
2065 lhs_may_realloc
= lhs_may_realloc
2066 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
2067 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2068 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
2069 may_require_tmp
, lhs_may_realloc
,
2071 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2072 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2073 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2074 return gfc_finish_block (&block
);
2077 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
2079 /* Obtain token, offset and image index for the LHS. */
2080 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
2081 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2082 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2083 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
2085 if (lhs_caf_attr
.alloc_comp
)
2086 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
2089 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
2094 gfc_init_se (&rhs_se
, NULL
);
2095 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
2096 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2097 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
2098 if (rhs_expr
->rank
== 0)
2100 symbol_attribute attr
;
2101 gfc_clear_attr (&attr
);
2102 gfc_conv_expr (&rhs_se
, rhs_expr
);
2103 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
2104 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2106 else if ((rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2107 && rhs_caf_attr
.codimension
)
2110 rhs_se
.want_pointer
= 1;
2111 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2112 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2113 has the wrong type if component references are done. */
2114 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2115 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2116 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2117 gfc_get_dtype_rank_type (
2118 gfc_has_vector_subscript (rhs_expr
)
2119 ? gfc_find_array_ref (rhs_expr
)->dimen
2125 /* If has_vector, pass descriptor for whole array and the
2126 vector bounds separately. */
2127 gfc_array_ref
*ar
, ar2
;
2128 bool has_vector
= false;
2131 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2134 ar
= gfc_find_array_ref (rhs_expr
);
2136 memset (ar
, '\0', sizeof (*ar
));
2140 rhs_se
.want_pointer
= 1;
2141 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2142 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2143 has the wrong type if component references are done. */
2144 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2145 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2146 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2147 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2152 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2157 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2159 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2161 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2166 gfc_init_se (&stat_se
, NULL
);
2167 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2168 dst_stat
= stat_se
.expr
;
2169 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2170 gfc_add_block_to_block (&block
, &stat_se
.post
);
2173 tmp_team
= gfc_find_team_co (lhs_expr
);
2178 gfc_init_se (&team_se
, NULL
);
2179 gfc_conv_expr_reference (&team_se
, tmp_team
);
2180 dst_team
= team_se
.expr
;
2181 gfc_add_block_to_block (&block
, &team_se
.pre
);
2182 gfc_add_block_to_block (&block
, &team_se
.post
);
2185 if (!gfc_is_coindexed (rhs_expr
))
2187 if (lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
2189 tree reference
, dst_realloc
;
2190 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2191 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2192 : boolean_false_node
;
2193 tmp
= build_call_expr_loc (input_location
,
2194 gfor_fndecl_caf_send_by_ref
,
2195 10, token
, image_index
, rhs_se
.expr
,
2196 reference
, lhs_kind
, rhs_kind
,
2197 may_require_tmp
, dst_realloc
, src_stat
,
2198 build_int_cst (integer_type_node
,
2199 lhs_expr
->ts
.type
));
2202 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 11,
2203 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2204 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2205 may_require_tmp
, src_stat
, dst_team
);
2209 tree rhs_token
, rhs_offset
, rhs_image_index
;
2211 /* It guarantees memory consistency within the same segment. */
2212 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2213 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2214 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2215 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2216 ASM_VOLATILE_P (tmp
) = 1;
2217 gfc_add_expr_to_block (&block
, tmp
);
2219 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2220 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2221 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2222 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2224 if (rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2226 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2231 gfc_init_se (&stat_se
, NULL
);
2232 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2233 src_stat
= stat_se
.expr
;
2234 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2235 gfc_add_block_to_block (&block
, &stat_se
.post
);
2238 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2240 tree lhs_reference
, rhs_reference
;
2241 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2242 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2243 tmp
= build_call_expr_loc (input_location
,
2244 gfor_fndecl_caf_sendget_by_ref
, 13,
2245 token
, image_index
, lhs_reference
,
2246 rhs_token
, rhs_image_index
, rhs_reference
,
2247 lhs_kind
, rhs_kind
, may_require_tmp
,
2249 build_int_cst (integer_type_node
,
2251 build_int_cst (integer_type_node
,
2252 rhs_expr
->ts
.type
));
2256 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2258 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2259 14, token
, offset
, image_index
,
2260 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2261 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2262 rhs_kind
, may_require_tmp
, src_stat
);
2265 gfc_add_expr_to_block (&block
, tmp
);
2266 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2267 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2269 /* It guarantees memory consistency within the same segment. */
2270 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2271 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2272 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2273 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2274 ASM_VOLATILE_P (tmp
) = 1;
2275 gfc_add_expr_to_block (&block
, tmp
);
2277 return gfc_finish_block (&block
);
2282 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2285 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2286 lbound
, ubound
, extent
, ml
;
2289 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2291 if (expr
->value
.function
.actual
->expr
2292 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2293 distance
= expr
->value
.function
.actual
->expr
;
2295 /* The case -fcoarray=single is handled elsewhere. */
2296 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2298 /* Argument-free version: THIS_IMAGE(). */
2299 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2303 gfc_init_se (&argse
, NULL
);
2304 gfc_conv_expr_val (&argse
, distance
);
2305 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2306 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2307 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2310 tmp
= integer_zero_node
;
2311 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2313 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2318 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2320 type
= gfc_get_int_type (gfc_default_integer_kind
);
2321 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2322 rank
= expr
->value
.function
.actual
->expr
->rank
;
2324 /* Obtain the descriptor of the COARRAY. */
2325 gfc_init_se (&argse
, NULL
);
2326 argse
.want_coarray
= 1;
2327 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2328 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2329 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2334 /* Create an implicit second parameter from the loop variable. */
2335 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2336 gcc_assert (corank
> 0);
2337 gcc_assert (se
->loop
->dimen
== 1);
2338 gcc_assert (se
->ss
->info
->expr
== expr
);
2340 dim_arg
= se
->loop
->loopvar
[0];
2341 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2342 gfc_array_index_type
, dim_arg
,
2343 build_int_cst (TREE_TYPE (dim_arg
), 1));
2344 gfc_advance_se_ss_chain (se
);
2348 /* Use the passed DIM= argument. */
2349 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2350 gfc_init_se (&argse
, NULL
);
2351 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2352 gfc_array_index_type
);
2353 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2354 dim_arg
= argse
.expr
;
2356 if (INTEGER_CST_P (dim_arg
))
2358 if (wi::ltu_p (wi::to_wide (dim_arg
), 1)
2359 || wi::gtu_p (wi::to_wide (dim_arg
),
2360 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2361 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2362 "dimension index", expr
->value
.function
.isym
->name
,
2365 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2367 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2368 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2370 build_int_cst (TREE_TYPE (dim_arg
), 1));
2371 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2372 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2374 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2375 logical_type_node
, cond
, tmp
);
2376 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2381 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2382 one always has a dim_arg argument.
2384 m = this_image() - 1
2387 sub(1) = m + lcobound(corank)
2391 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2394 extent = gfc_extent(i)
2402 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2403 : m + lcobound(corank)
2406 /* this_image () - 1. */
2407 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2409 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2410 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2413 /* sub(1) = m + lcobound(corank). */
2414 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2415 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2417 lbound
= fold_convert (type
, lbound
);
2418 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2424 m
= gfc_create_var (type
, NULL
);
2425 ml
= gfc_create_var (type
, NULL
);
2426 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2427 min_var
= gfc_create_var (integer_type_node
, NULL
);
2429 /* m = this_image () - 1. */
2430 gfc_add_modify (&se
->pre
, m
, tmp
);
2432 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2433 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2434 fold_convert (integer_type_node
, dim_arg
),
2435 build_int_cst (integer_type_node
, rank
- 1));
2436 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2437 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2439 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2442 tmp
= build_int_cst (integer_type_node
, rank
);
2443 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2445 exit_label
= gfc_build_label_decl (NULL_TREE
);
2446 TREE_USED (exit_label
) = 1;
2449 gfc_init_block (&loop
);
2452 gfc_add_modify (&loop
, ml
, m
);
2455 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2456 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2457 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2458 extent
= fold_convert (type
, extent
);
2461 gfc_add_modify (&loop
, m
,
2462 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2465 /* Exit condition: if (i >= min_var) goto exit_label. */
2466 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, loop_var
,
2468 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2469 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2470 build_empty_stmt (input_location
));
2471 gfc_add_expr_to_block (&loop
, tmp
);
2473 /* Increment loop variable: i++. */
2474 gfc_add_modify (&loop
, loop_var
,
2475 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2477 build_int_cst (integer_type_node
, 1)));
2479 /* Making the loop... actually loop! */
2480 tmp
= gfc_finish_block (&loop
);
2481 tmp
= build1_v (LOOP_EXPR
, tmp
);
2482 gfc_add_expr_to_block (&se
->pre
, tmp
);
2484 /* The exit label. */
2485 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2486 gfc_add_expr_to_block (&se
->pre
, tmp
);
2488 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2489 : m + lcobound(corank) */
2491 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, dim_arg
,
2492 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2494 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2495 fold_build2_loc (input_location
, PLUS_EXPR
,
2496 gfc_array_index_type
, dim_arg
,
2497 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2498 lbound
= fold_convert (type
, lbound
);
2500 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2501 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2503 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2505 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2506 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2511 /* Convert a call to image_status. */
2514 conv_intrinsic_image_status (gfc_se
*se
, gfc_expr
*expr
)
2516 unsigned int num_args
;
2519 num_args
= gfc_intrinsic_argument_list_length (expr
);
2520 args
= XALLOCAVEC (tree
, num_args
);
2521 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2522 /* In args[0] the number of the image the status is desired for has to be
2525 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2528 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2529 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2530 fold_convert (integer_type_node
, arg
),
2532 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2533 tmp
, integer_zero_node
,
2534 build_int_cst (integer_type_node
,
2535 GFC_STAT_STOPPED_IMAGE
));
2537 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2538 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_image_status
, 2,
2539 args
[0], build_int_cst (integer_type_node
, -1));
2547 conv_intrinsic_team_number (gfc_se
*se
, gfc_expr
*expr
)
2549 unsigned int num_args
;
2553 num_args
= gfc_intrinsic_argument_list_length (expr
);
2554 args
= XALLOCAVEC (tree
, num_args
);
2555 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2558 GFC_FCOARRAY_SINGLE
&& expr
->value
.function
.actual
->expr
)
2562 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2563 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2564 fold_convert (integer_type_node
, arg
),
2566 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2567 tmp
, integer_zero_node
,
2568 build_int_cst (integer_type_node
,
2569 GFC_STAT_STOPPED_IMAGE
));
2571 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2573 // the value -1 represents that no team has been created yet
2574 tmp
= build_int_cst (integer_type_node
, -1);
2576 else if (flag_coarray
== GFC_FCOARRAY_LIB
&& expr
->value
.function
.actual
->expr
)
2577 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2578 args
[0], build_int_cst (integer_type_node
, -1));
2579 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2580 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2581 integer_zero_node
, build_int_cst (integer_type_node
, -1));
2590 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2592 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2594 gfc_se argse
, subse
;
2595 int rank
, corank
, codim
;
2597 type
= gfc_get_int_type (gfc_default_integer_kind
);
2598 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2599 rank
= expr
->value
.function
.actual
->expr
->rank
;
2601 /* Obtain the descriptor of the COARRAY. */
2602 gfc_init_se (&argse
, NULL
);
2603 argse
.want_coarray
= 1;
2604 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2605 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2606 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2609 /* Obtain a handle to the SUB argument. */
2610 gfc_init_se (&subse
, NULL
);
2611 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2612 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2613 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2614 subdesc
= build_fold_indirect_ref_loc (input_location
,
2615 gfc_conv_descriptor_data_get (subse
.expr
));
2617 /* Fortran 2008 does not require that the values remain in the cobounds,
2618 thus we need explicitly check this - and return 0 if they are exceeded. */
2620 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2621 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2622 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2623 fold_convert (gfc_array_index_type
, tmp
),
2626 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2628 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2629 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2630 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2631 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2632 fold_convert (gfc_array_index_type
, tmp
),
2634 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2635 logical_type_node
, invalid_bound
, cond
);
2636 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2637 fold_convert (gfc_array_index_type
, tmp
),
2639 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2640 logical_type_node
, invalid_bound
, cond
);
2643 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2645 /* See Fortran 2008, C.10 for the following algorithm. */
2647 /* coindex = sub(corank) - lcobound(n). */
2648 coindex
= fold_convert (gfc_array_index_type
,
2649 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2651 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2652 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2653 fold_convert (gfc_array_index_type
, coindex
),
2656 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2658 tree extent
, ubound
;
2660 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2661 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2662 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2663 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2665 /* coindex *= extent. */
2666 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2667 gfc_array_index_type
, coindex
, extent
);
2669 /* coindex += sub(codim). */
2670 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2671 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2672 gfc_array_index_type
, coindex
,
2673 fold_convert (gfc_array_index_type
, tmp
));
2675 /* coindex -= lbound(codim). */
2676 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2677 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2678 gfc_array_index_type
, coindex
, lbound
);
2681 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2682 fold_convert(type
, coindex
),
2683 build_int_cst (type
, 1));
2685 /* Return 0 if "coindex" exceeds num_images(). */
2687 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2688 num_images
= build_int_cst (type
, 1);
2691 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2693 build_int_cst (integer_type_node
, -1));
2694 num_images
= fold_convert (type
, tmp
);
2697 tmp
= gfc_create_var (type
, NULL
);
2698 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2700 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, tmp
,
2702 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
2704 fold_convert (logical_type_node
, invalid_bound
));
2705 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2706 build_int_cst (type
, 0), tmp
);
2710 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2712 tree tmp
, distance
, failed
;
2715 if (expr
->value
.function
.actual
->expr
)
2717 gfc_init_se (&argse
, NULL
);
2718 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2719 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2720 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2721 distance
= fold_convert (integer_type_node
, argse
.expr
);
2724 distance
= integer_zero_node
;
2726 if (expr
->value
.function
.actual
->next
->expr
)
2728 gfc_init_se (&argse
, NULL
);
2729 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2730 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2731 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2732 failed
= fold_convert (integer_type_node
, argse
.expr
);
2735 failed
= build_int_cst (integer_type_node
, -1);
2736 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2738 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2743 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2747 gfc_init_se (&argse
, NULL
);
2748 argse
.data_not_needed
= 1;
2749 argse
.descriptor_only
= 1;
2751 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2752 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2753 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2755 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2756 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2761 /* Evaluate a single upper or lower bound. */
2762 /* TODO: bound intrinsic generates way too much unnecessary code. */
2765 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2767 gfc_actual_arglist
*arg
;
2768 gfc_actual_arglist
*arg2
;
2773 tree cond
, cond1
, cond3
, cond4
, size
;
2777 gfc_array_spec
* as
;
2778 bool assumed_rank_lb_one
;
2780 arg
= expr
->value
.function
.actual
;
2785 /* Create an implicit second parameter from the loop variable. */
2786 gcc_assert (!arg2
->expr
);
2787 gcc_assert (se
->loop
->dimen
== 1);
2788 gcc_assert (se
->ss
->info
->expr
== expr
);
2789 gfc_advance_se_ss_chain (se
);
2790 bound
= se
->loop
->loopvar
[0];
2791 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2792 gfc_array_index_type
, bound
,
2797 /* use the passed argument. */
2798 gcc_assert (arg2
->expr
);
2799 gfc_init_se (&argse
, NULL
);
2800 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2801 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2803 /* Convert from one based to zero based. */
2804 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2805 gfc_array_index_type
, bound
,
2806 gfc_index_one_node
);
2809 /* TODO: don't re-evaluate the descriptor on each iteration. */
2810 /* Get a descriptor for the first parameter. */
2811 gfc_init_se (&argse
, NULL
);
2812 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2813 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2814 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2818 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2820 if (INTEGER_CST_P (bound
))
2822 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2823 && wi::geu_p (wi::to_wide (bound
),
2824 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2825 || wi::gtu_p (wi::to_wide (bound
), GFC_MAX_DIMENSIONS
))
2826 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2827 "dimension index", upper
? "UBOUND" : "LBOUND",
2831 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
2833 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2835 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2836 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2837 bound
, build_int_cst (TREE_TYPE (bound
), 0));
2838 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2839 tmp
= gfc_conv_descriptor_rank (desc
);
2841 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
2842 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2843 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
2844 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2845 logical_type_node
, cond
, tmp
);
2846 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2851 /* Take care of the lbound shift for assumed-rank arrays, which are
2852 nonallocatable and nonpointers. Those has a lbound of 1. */
2853 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
2854 && ((arg
->expr
->ts
.type
!= BT_CLASS
2855 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
2856 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
2857 || (arg
->expr
->ts
.type
== BT_CLASS
2858 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
2859 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
2861 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2862 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2864 /* 13.14.53: Result value for LBOUND
2866 Case (i): For an array section or for an array expression other than a
2867 whole array or array structure component, LBOUND(ARRAY, DIM)
2868 has the value 1. For a whole array or array structure
2869 component, LBOUND(ARRAY, DIM) has the value:
2870 (a) equal to the lower bound for subscript DIM of ARRAY if
2871 dimension DIM of ARRAY does not have extent zero
2872 or if ARRAY is an assumed-size array of rank DIM,
2875 13.14.113: Result value for UBOUND
2877 Case (i): For an array section or for an array expression other than a
2878 whole array or array structure component, UBOUND(ARRAY, DIM)
2879 has the value equal to the number of elements in the given
2880 dimension; otherwise, it has a value equal to the upper bound
2881 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2882 not have size zero and has value zero if dimension DIM has
2885 if (!upper
&& assumed_rank_lb_one
)
2886 se
->expr
= gfc_index_one_node
;
2889 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
2891 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2893 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2894 stride
, gfc_index_zero_node
);
2895 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2896 logical_type_node
, cond3
, cond1
);
2897 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2898 stride
, gfc_index_zero_node
);
2903 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2904 logical_type_node
, cond3
, cond4
);
2905 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2906 gfc_index_one_node
, lbound
);
2907 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2908 logical_type_node
, cond4
, cond5
);
2910 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2911 logical_type_node
, cond
, cond5
);
2913 if (assumed_rank_lb_one
)
2915 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2916 gfc_array_index_type
, ubound
, lbound
);
2917 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2918 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2923 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2924 gfc_array_index_type
, cond
,
2925 tmp
, gfc_index_zero_node
);
2929 if (as
->type
== AS_ASSUMED_SIZE
)
2930 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2931 bound
, build_int_cst (TREE_TYPE (bound
),
2932 arg
->expr
->rank
- 1));
2934 cond
= logical_false_node
;
2936 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2937 logical_type_node
, cond3
, cond4
);
2938 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2939 logical_type_node
, cond
, cond1
);
2941 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2942 gfc_array_index_type
, cond
,
2943 lbound
, gfc_index_one_node
);
2950 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2951 gfc_array_index_type
, ubound
, lbound
);
2952 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2953 gfc_array_index_type
, size
,
2954 gfc_index_one_node
);
2955 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2956 gfc_array_index_type
, se
->expr
,
2957 gfc_index_zero_node
);
2960 se
->expr
= gfc_index_one_node
;
2963 type
= gfc_typenode_for_spec (&expr
->ts
);
2964 se
->expr
= convert (type
, se
->expr
);
2969 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2971 gfc_actual_arglist
*arg
;
2972 gfc_actual_arglist
*arg2
;
2974 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2978 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2979 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2980 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2982 arg
= expr
->value
.function
.actual
;
2985 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2986 corank
= gfc_get_corank (arg
->expr
);
2988 gfc_init_se (&argse
, NULL
);
2989 argse
.want_coarray
= 1;
2991 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2992 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2993 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2998 /* Create an implicit second parameter from the loop variable. */
2999 gcc_assert (!arg2
->expr
);
3000 gcc_assert (corank
> 0);
3001 gcc_assert (se
->loop
->dimen
== 1);
3002 gcc_assert (se
->ss
->info
->expr
== expr
);
3004 bound
= se
->loop
->loopvar
[0];
3005 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3006 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
3007 gfc_advance_se_ss_chain (se
);
3011 /* use the passed argument. */
3012 gcc_assert (arg2
->expr
);
3013 gfc_init_se (&argse
, NULL
);
3014 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
3015 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3018 if (INTEGER_CST_P (bound
))
3020 if (wi::ltu_p (wi::to_wide (bound
), 1)
3021 || wi::gtu_p (wi::to_wide (bound
),
3022 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
3023 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3024 "dimension index", expr
->value
.function
.isym
->name
,
3027 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3029 bound
= gfc_evaluate_now (bound
, &se
->pre
);
3030 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3031 bound
, build_int_cst (TREE_TYPE (bound
), 1));
3032 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
3033 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3035 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3036 logical_type_node
, cond
, tmp
);
3037 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
3042 /* Subtract 1 to get to zero based and add dimensions. */
3043 switch (arg
->expr
->rank
)
3046 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
3047 gfc_array_index_type
, bound
,
3048 gfc_index_one_node
);
3052 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3053 gfc_array_index_type
, bound
,
3054 gfc_rank_cst
[arg
->expr
->rank
- 1]);
3058 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
3060 /* Handle UCOBOUND with special handling of the last codimension. */
3061 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
3063 /* Last codimension: For -fcoarray=single just return
3064 the lcobound - otherwise add
3065 ceiling (real (num_images ()) / real (size)) - 1
3066 = (num_images () + size - 1) / size - 1
3067 = (num_images - 1) / size(),
3068 where size is the product of the extent of all but the last
3071 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
3075 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
3076 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3077 2, integer_zero_node
,
3078 build_int_cst (integer_type_node
, -1));
3079 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3080 gfc_array_index_type
,
3081 fold_convert (gfc_array_index_type
, tmp
),
3082 build_int_cst (gfc_array_index_type
, 1));
3083 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
3084 gfc_array_index_type
, tmp
,
3085 fold_convert (gfc_array_index_type
, cosize
));
3086 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3087 gfc_array_index_type
, resbound
, tmp
);
3089 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
3091 /* ubound = lbound + num_images() - 1. */
3092 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
3093 2, integer_zero_node
,
3094 build_int_cst (integer_type_node
, -1));
3095 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3096 gfc_array_index_type
,
3097 fold_convert (gfc_array_index_type
, tmp
),
3098 build_int_cst (gfc_array_index_type
, 1));
3099 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3100 gfc_array_index_type
, resbound
, tmp
);
3105 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3107 build_int_cst (TREE_TYPE (bound
),
3108 arg
->expr
->rank
+ corank
- 1));
3110 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3111 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3112 gfc_array_index_type
, cond
,
3113 resbound
, resbound2
);
3116 se
->expr
= resbound
;
3119 se
->expr
= resbound
;
3121 type
= gfc_typenode_for_spec (&expr
->ts
);
3122 se
->expr
= convert (type
, se
->expr
);
3127 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
3129 gfc_actual_arglist
*array_arg
;
3130 gfc_actual_arglist
*dim_arg
;
3134 array_arg
= expr
->value
.function
.actual
;
3135 dim_arg
= array_arg
->next
;
3137 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
3139 gfc_init_se (&argse
, NULL
);
3140 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
3141 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3142 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3145 gcc_assert (dim_arg
->expr
);
3146 gfc_init_se (&argse
, NULL
);
3147 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
3148 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3149 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3150 argse
.expr
, gfc_index_one_node
);
3151 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
3155 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
3159 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3161 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
3165 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
3170 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
3171 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
3180 /* Create a complex value from one or two real components. */
3183 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
3189 unsigned int num_args
;
3191 num_args
= gfc_intrinsic_argument_list_length (expr
);
3192 args
= XALLOCAVEC (tree
, num_args
);
3194 type
= gfc_typenode_for_spec (&expr
->ts
);
3195 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3196 real
= convert (TREE_TYPE (type
), args
[0]);
3198 imag
= convert (TREE_TYPE (type
), args
[1]);
3199 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
3201 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
3202 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
3203 imag
= convert (TREE_TYPE (type
), imag
);
3206 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3208 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3212 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3213 MODULO(A, P) = A - FLOOR (A / P) * P
3215 The obvious algorithms above are numerically instable for large
3216 arguments, hence these intrinsics are instead implemented via calls
3217 to the fmod family of functions. It is the responsibility of the
3218 user to ensure that the second argument is non-zero. */
3221 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3231 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3233 switch (expr
->ts
.type
)
3236 /* Integer case is easy, we've got a builtin op. */
3237 type
= TREE_TYPE (args
[0]);
3240 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3243 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3249 /* Check if we have a builtin fmod. */
3250 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3252 /* The builtin should always be available. */
3253 gcc_assert (fmod
!= NULL_TREE
);
3255 tmp
= build_addr (fmod
);
3256 se
->expr
= build_call_array_loc (input_location
,
3257 TREE_TYPE (TREE_TYPE (fmod
)),
3262 type
= TREE_TYPE (args
[0]);
3264 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3265 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3268 modulo = arg - floor (arg/arg2) * arg2
3270 In order to calculate the result accurately, we use the fmod
3271 function as follows.
3273 res = fmod (arg, arg2);
3276 if ((arg < 0) xor (arg2 < 0))
3280 res = copysign (0., arg2);
3282 => As two nested ternary exprs:
3284 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3285 : copysign (0., arg2);
3289 zero
= gfc_build_const (type
, integer_zero_node
);
3290 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3291 if (!flag_signed_zeros
)
3293 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3295 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3297 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3298 logical_type_node
, test
, test2
);
3299 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3301 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3302 logical_type_node
, test
, test2
);
3303 test
= gfc_evaluate_now (test
, &se
->pre
);
3304 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3305 fold_build2_loc (input_location
,
3307 type
, tmp
, args
[1]),
3312 tree expr1
, copysign
, cscall
;
3313 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3315 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3317 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3319 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3320 logical_type_node
, test
, test2
);
3321 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3322 fold_build2_loc (input_location
,
3324 type
, tmp
, args
[1]),
3326 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3328 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3330 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3340 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3341 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3342 where the right shifts are logical (i.e. 0's are shifted in).
3343 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3344 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3346 DSHIFTL(I,J,BITSIZE) = J
3348 DSHIFTR(I,J,BITSIZE) = I. */
3351 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3353 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3354 tree args
[3], cond
, tmp
;
3357 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3359 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3360 type
= TREE_TYPE (args
[0]);
3361 bitsize
= TYPE_PRECISION (type
);
3362 utype
= unsigned_type_for (type
);
3363 stype
= TREE_TYPE (args
[2]);
3365 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3366 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3367 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3369 /* The generic case. */
3370 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3371 build_int_cst (stype
, bitsize
), shift
);
3372 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3373 arg1
, dshiftl
? shift
: tmp
);
3375 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3376 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3377 right
= fold_convert (type
, right
);
3379 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3381 /* Special cases. */
3382 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3383 build_int_cst (stype
, 0));
3384 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3385 dshiftl
? arg1
: arg2
, res
);
3387 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3388 build_int_cst (stype
, bitsize
));
3389 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3390 dshiftl
? arg2
: arg1
, res
);
3396 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3399 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3407 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3408 type
= TREE_TYPE (args
[0]);
3410 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3411 val
= gfc_evaluate_now (val
, &se
->pre
);
3413 zero
= gfc_build_const (type
, integer_zero_node
);
3414 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, val
, zero
);
3415 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3419 /* SIGN(A, B) is absolute value of A times sign of B.
3420 The real value versions use library functions to ensure the correct
3421 handling of negative zero. Integer case implemented as:
3422 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3426 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3432 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3433 if (expr
->ts
.type
== BT_REAL
)
3437 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3438 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3440 /* We explicitly have to ignore the minus sign. We do so by using
3441 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3443 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3446 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3447 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3449 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3450 TREE_TYPE (args
[0]), cond
,
3451 build_call_expr_loc (input_location
, abs
, 1,
3453 build_call_expr_loc (input_location
, tmp
, 2,
3457 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3462 /* Having excluded floating point types, we know we are now dealing
3463 with signed integer types. */
3464 type
= TREE_TYPE (args
[0]);
3466 /* Args[0] is used multiple times below. */
3467 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3469 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3470 the signs of A and B are the same, and of all ones if they differ. */
3471 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3472 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3473 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3474 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3476 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3477 is all ones (i.e. -1). */
3478 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3479 fold_build2_loc (input_location
, PLUS_EXPR
,
3480 type
, args
[0], tmp
), tmp
);
3484 /* Test for the presence of an optional argument. */
3487 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3491 arg
= expr
->value
.function
.actual
->expr
;
3492 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3493 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3494 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3498 /* Calculate the double precision product of two single precision values. */
3501 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3506 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3508 /* Convert the args to double precision before multiplying. */
3509 type
= gfc_typenode_for_spec (&expr
->ts
);
3510 args
[0] = convert (type
, args
[0]);
3511 args
[1] = convert (type
, args
[1]);
3512 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3517 /* Return a length one character string containing an ascii character. */
3520 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3525 unsigned int num_args
;
3527 num_args
= gfc_intrinsic_argument_list_length (expr
);
3528 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3530 type
= gfc_get_char_type (expr
->ts
.kind
);
3531 var
= gfc_create_var (type
, "char");
3533 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3534 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3535 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3536 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3541 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3549 unsigned int num_args
;
3551 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3552 args
= XALLOCAVEC (tree
, num_args
);
3554 var
= gfc_create_var (pchar_type_node
, "pstr");
3555 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3557 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3558 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3559 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3561 fndecl
= build_addr (gfor_fndecl_ctime
);
3562 tmp
= build_call_array_loc (input_location
,
3563 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3564 fndecl
, num_args
, args
);
3565 gfc_add_expr_to_block (&se
->pre
, tmp
);
3567 /* Free the temporary afterwards, if necessary. */
3568 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3569 len
, build_int_cst (TREE_TYPE (len
), 0));
3570 tmp
= gfc_call_free (var
);
3571 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3572 gfc_add_expr_to_block (&se
->post
, tmp
);
3575 se
->string_length
= len
;
3580 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3588 unsigned int num_args
;
3590 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3591 args
= XALLOCAVEC (tree
, num_args
);
3593 var
= gfc_create_var (pchar_type_node
, "pstr");
3594 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3596 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3597 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3598 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3600 fndecl
= build_addr (gfor_fndecl_fdate
);
3601 tmp
= build_call_array_loc (input_location
,
3602 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3603 fndecl
, num_args
, args
);
3604 gfc_add_expr_to_block (&se
->pre
, tmp
);
3606 /* Free the temporary afterwards, if necessary. */
3607 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3608 len
, build_int_cst (TREE_TYPE (len
), 0));
3609 tmp
= gfc_call_free (var
);
3610 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3611 gfc_add_expr_to_block (&se
->post
, tmp
);
3614 se
->string_length
= len
;
3618 /* Generate a direct call to free() for the FREE subroutine. */
3621 conv_intrinsic_free (gfc_code
*code
)
3627 gfc_init_se (&argse
, NULL
);
3628 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3629 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3631 gfc_init_block (&block
);
3632 call
= build_call_expr_loc (input_location
,
3633 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3634 gfc_add_expr_to_block (&block
, call
);
3635 return gfc_finish_block (&block
);
3639 /* Call the RANDOM_INIT library subroutine with a hidden argument for
3640 handling seeding on coarray images. */
3643 conv_intrinsic_random_init (gfc_code
*code
)
3647 tree arg1
, arg2
, arg3
, tmp
;
3648 tree logical4_type_node
= gfc_get_logical_type (4);
3650 /* Make the function call. */
3651 gfc_init_block (&block
);
3652 gfc_init_se (&se
, NULL
);
3654 /* Convert REPEATABLE to a LOGICAL(4) entity. */
3655 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
3656 gfc_add_block_to_block (&block
, &se
.pre
);
3657 arg1
= fold_convert (logical4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3658 gfc_add_block_to_block (&block
, &se
.post
);
3660 /* Convert IMAGE_DISTINCT to a LOGICAL(4) entity. */
3661 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
3662 gfc_add_block_to_block (&block
, &se
.pre
);
3663 arg2
= fold_convert (logical4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
3664 gfc_add_block_to_block (&block
, &se
.post
);
3666 /* Create the hidden argument. For non-coarray codes and -fcoarray=single,
3667 simply set this to 0. For -fcoarray=lib, generate a call to
3668 THIS_IMAGE() without arguments. */
3669 arg3
= build_int_cst (gfc_get_int_type (4), 0);
3670 if (flag_coarray
== GFC_FCOARRAY_LIB
)
3672 arg3
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
,
3674 se
.expr
= fold_convert (gfc_get_int_type (4), arg3
);
3677 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_random_init
, 3,
3679 gfc_add_expr_to_block (&block
, tmp
);
3681 return gfc_finish_block (&block
);
3685 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3689 conv_intrinsic_system_clock (gfc_code
*code
)
3692 gfc_se count_se
, count_rate_se
, count_max_se
;
3693 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3697 gfc_expr
*count
= code
->ext
.actual
->expr
;
3698 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3699 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3701 /* Evaluate our arguments. */
3704 gfc_init_se (&count_se
, NULL
);
3705 gfc_conv_expr (&count_se
, count
);
3710 gfc_init_se (&count_rate_se
, NULL
);
3711 gfc_conv_expr (&count_rate_se
, count_rate
);
3716 gfc_init_se (&count_max_se
, NULL
);
3717 gfc_conv_expr (&count_max_se
, count_max
);
3720 /* Find the smallest kind found of the arguments. */
3722 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3723 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3725 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3728 /* Prepare temporary variables. */
3733 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3734 else if (least
== 4)
3735 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3736 else if (count
->ts
.kind
== 1)
3737 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3740 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3747 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3748 else if (least
== 4)
3749 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3751 arg2
= integer_zero_node
;
3757 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3758 else if (least
== 4)
3759 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3761 arg3
= integer_zero_node
;
3764 /* Make the function call. */
3765 gfc_init_block (&block
);
3771 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3772 : null_pointer_node
;
3773 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3774 : null_pointer_node
;
3775 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3776 : null_pointer_node
;
3781 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3782 : null_pointer_node
;
3783 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3784 : null_pointer_node
;
3785 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3786 : null_pointer_node
;
3793 tmp
= build_call_expr_loc (input_location
,
3794 gfor_fndecl_system_clock4
, 3,
3795 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3796 : null_pointer_node
,
3797 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3798 : null_pointer_node
,
3799 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3800 : null_pointer_node
);
3801 gfc_add_expr_to_block (&block
, tmp
);
3803 /* Handle kind>=8, 10, or 16 arguments */
3806 tmp
= build_call_expr_loc (input_location
,
3807 gfor_fndecl_system_clock8
, 3,
3808 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3809 : null_pointer_node
,
3810 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3811 : null_pointer_node
,
3812 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3813 : null_pointer_node
);
3814 gfc_add_expr_to_block (&block
, tmp
);
3818 /* And store values back if needed. */
3819 if (arg1
&& arg1
!= count_se
.expr
)
3820 gfc_add_modify (&block
, count_se
.expr
,
3821 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
3822 if (arg2
&& arg2
!= count_rate_se
.expr
)
3823 gfc_add_modify (&block
, count_rate_se
.expr
,
3824 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
3825 if (arg3
&& arg3
!= count_max_se
.expr
)
3826 gfc_add_modify (&block
, count_max_se
.expr
,
3827 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
3829 return gfc_finish_block (&block
);
3833 /* Return a character string containing the tty name. */
3836 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
3844 unsigned int num_args
;
3846 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3847 args
= XALLOCAVEC (tree
, num_args
);
3849 var
= gfc_create_var (pchar_type_node
, "pstr");
3850 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3852 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3853 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3854 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3856 fndecl
= build_addr (gfor_fndecl_ttynam
);
3857 tmp
= build_call_array_loc (input_location
,
3858 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
3859 fndecl
, num_args
, args
);
3860 gfc_add_expr_to_block (&se
->pre
, tmp
);
3862 /* Free the temporary afterwards, if necessary. */
3863 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3864 len
, build_int_cst (TREE_TYPE (len
), 0));
3865 tmp
= gfc_call_free (var
);
3866 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3867 gfc_add_expr_to_block (&se
->post
, tmp
);
3870 se
->string_length
= len
;
3874 /* Get the minimum/maximum value of all the parameters.
3875 minmax (a1, a2, a3, ...)
3878 mvar = COMP (mvar, a2)
3879 mvar = COMP (mvar, a3)
3883 Where COMP is MIN/MAX_EXPR for integral types or when we don't
3884 care about NaNs, or IFN_FMIN/MAX when the target has support for
3885 fast NaN-honouring min/max. When neither holds expand a sequence
3886 of explicit comparisons. */
3888 /* TODO: Mismatching types can occur when specific names are used.
3889 These should be handled during resolution. */
3891 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3898 gfc_actual_arglist
*argexpr
;
3899 unsigned int i
, nargs
;
3901 nargs
= gfc_intrinsic_argument_list_length (expr
);
3902 args
= XALLOCAVEC (tree
, nargs
);
3904 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
3905 type
= gfc_typenode_for_spec (&expr
->ts
);
3907 argexpr
= expr
->value
.function
.actual
;
3908 if (TREE_TYPE (args
[0]) != type
)
3909 args
[0] = convert (type
, args
[0]);
3910 /* Only evaluate the argument once. */
3911 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
3912 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3914 mvar
= gfc_create_var (type
, "M");
3915 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
3917 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++, argexpr
= argexpr
->next
)
3919 tree cond
= NULL_TREE
;
3922 /* Handle absent optional arguments by ignoring the comparison. */
3923 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
3924 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
3925 && TREE_CODE (val
) == INDIRECT_REF
)
3927 cond
= fold_build2_loc (input_location
,
3928 NE_EXPR
, logical_type_node
,
3929 TREE_OPERAND (val
, 0),
3930 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
3932 else if (!VAR_P (val
) && !TREE_CONSTANT (val
))
3933 /* Only evaluate the argument once. */
3934 val
= gfc_evaluate_now (val
, &se
->pre
);
3937 /* For floating point types, the question is what MAX(a, NaN) or
3938 MIN(a, NaN) should return (where "a" is a normal number).
3939 There are valid usecase for returning either one, but the
3940 Fortran standard doesn't specify which one should be chosen.
3941 Also, there is no consensus among other tested compilers. In
3942 short, it's a mess. So lets just do whatever is fastest. */
3943 tree_code code
= op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
;
3944 calc
= fold_build2_loc (input_location
, code
, type
,
3945 convert (type
, val
), mvar
);
3946 tmp
= build2_v (MODIFY_EXPR
, mvar
, calc
);
3948 if (cond
!= NULL_TREE
)
3949 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
3950 build_empty_stmt (input_location
));
3951 gfc_add_expr_to_block (&se
->pre
, tmp
);
3957 /* Generate library calls for MIN and MAX intrinsics for character
3960 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
3963 tree var
, len
, fndecl
, tmp
, cond
, function
;
3966 nargs
= gfc_intrinsic_argument_list_length (expr
);
3967 args
= XALLOCAVEC (tree
, nargs
+ 4);
3968 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
3970 /* Create the result variables. */
3971 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3972 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3973 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3974 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3975 args
[2] = build_int_cst (integer_type_node
, op
);
3976 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3978 if (expr
->ts
.kind
== 1)
3979 function
= gfor_fndecl_string_minmax
;
3980 else if (expr
->ts
.kind
== 4)
3981 function
= gfor_fndecl_string_minmax_char4
;
3985 /* Make the function call. */
3986 fndecl
= build_addr (function
);
3987 tmp
= build_call_array_loc (input_location
,
3988 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3990 gfc_add_expr_to_block (&se
->pre
, tmp
);
3992 /* Free the temporary afterwards, if necessary. */
3993 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3994 len
, build_int_cst (TREE_TYPE (len
), 0));
3995 tmp
= gfc_call_free (var
);
3996 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3997 gfc_add_expr_to_block (&se
->post
, tmp
);
4000 se
->string_length
= len
;
4004 /* Create a symbol node for this intrinsic. The symbol from the frontend
4005 has the generic name. */
4008 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
4012 /* TODO: Add symbols for intrinsic function to the global namespace. */
4013 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
4014 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
4017 sym
->attr
.external
= 1;
4018 sym
->attr
.function
= 1;
4019 sym
->attr
.always_explicit
= 1;
4020 sym
->attr
.proc
= PROC_INTRINSIC
;
4021 sym
->attr
.flavor
= FL_PROCEDURE
;
4025 sym
->attr
.dimension
= 1;
4026 sym
->as
= gfc_get_array_spec ();
4027 sym
->as
->type
= AS_ASSUMED_SHAPE
;
4028 sym
->as
->rank
= expr
->rank
;
4031 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
4032 ignore_optional
? expr
->value
.function
.actual
4038 /* Generate a call to an external intrinsic function. */
4040 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
4043 vec
<tree
, va_gc
> *append_args
;
4045 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
4048 gcc_assert (expr
->rank
> 0);
4050 gcc_assert (expr
->rank
== 0);
4052 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
4054 /* Calls to libgfortran_matmul need to be appended special arguments,
4055 to be able to call the BLAS ?gemm functions if required and possible. */
4057 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
4058 && !expr
->external_blas
4059 && sym
->ts
.type
!= BT_LOGICAL
)
4061 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
4063 if (flag_external_blas
4064 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
4065 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
4069 if (sym
->ts
.type
== BT_REAL
)
4071 if (sym
->ts
.kind
== 4)
4072 gemm_fndecl
= gfor_fndecl_sgemm
;
4074 gemm_fndecl
= gfor_fndecl_dgemm
;
4078 if (sym
->ts
.kind
== 4)
4079 gemm_fndecl
= gfor_fndecl_cgemm
;
4081 gemm_fndecl
= gfor_fndecl_zgemm
;
4084 vec_alloc (append_args
, 3);
4085 append_args
->quick_push (build_int_cst (cint
, 1));
4086 append_args
->quick_push (build_int_cst (cint
,
4087 flag_blas_matmul_limit
));
4088 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
4093 vec_alloc (append_args
, 3);
4094 append_args
->quick_push (build_int_cst (cint
, 0));
4095 append_args
->quick_push (build_int_cst (cint
, 0));
4096 append_args
->quick_push (null_pointer_node
);
4100 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4102 gfc_free_symbol (sym
);
4105 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4125 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4134 gfc_actual_arglist
*actual
;
4141 gfc_conv_intrinsic_funcall (se
, expr
);
4145 actual
= expr
->value
.function
.actual
;
4146 type
= gfc_typenode_for_spec (&expr
->ts
);
4147 /* Initialize the result. */
4148 resvar
= gfc_create_var (type
, "test");
4150 tmp
= convert (type
, boolean_true_node
);
4152 tmp
= convert (type
, boolean_false_node
);
4153 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4155 /* Walk the arguments. */
4156 arrayss
= gfc_walk_expr (actual
->expr
);
4157 gcc_assert (arrayss
!= gfc_ss_terminator
);
4159 /* Initialize the scalarizer. */
4160 gfc_init_loopinfo (&loop
);
4161 exit_label
= gfc_build_label_decl (NULL_TREE
);
4162 TREE_USED (exit_label
) = 1;
4163 gfc_add_ss_to_loop (&loop
, arrayss
);
4165 /* Initialize the loop. */
4166 gfc_conv_ss_startstride (&loop
);
4167 gfc_conv_loop_setup (&loop
, &expr
->where
);
4169 gfc_mark_ss_chain_used (arrayss
, 1);
4170 /* Generate the loop body. */
4171 gfc_start_scalarized_body (&loop
, &body
);
4173 /* If the condition matches then set the return value. */
4174 gfc_start_block (&block
);
4176 tmp
= convert (type
, boolean_false_node
);
4178 tmp
= convert (type
, boolean_true_node
);
4179 gfc_add_modify (&block
, resvar
, tmp
);
4181 /* And break out of the loop. */
4182 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4183 gfc_add_expr_to_block (&block
, tmp
);
4185 found
= gfc_finish_block (&block
);
4187 /* Check this element. */
4188 gfc_init_se (&arrayse
, NULL
);
4189 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4190 arrayse
.ss
= arrayss
;
4191 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4193 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4194 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
, arrayse
.expr
,
4195 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
4196 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
4197 gfc_add_expr_to_block (&body
, tmp
);
4198 gfc_add_block_to_block (&body
, &arrayse
.post
);
4200 gfc_trans_scalarizing_loops (&loop
, &body
);
4202 /* Add the exit label. */
4203 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4204 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4206 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4207 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4208 gfc_cleanup_loop (&loop
);
4213 /* COUNT(A) = Number of true elements in A. */
4215 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4222 gfc_actual_arglist
*actual
;
4228 gfc_conv_intrinsic_funcall (se
, expr
);
4232 actual
= expr
->value
.function
.actual
;
4234 type
= gfc_typenode_for_spec (&expr
->ts
);
4235 /* Initialize the result. */
4236 resvar
= gfc_create_var (type
, "count");
4237 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4239 /* Walk the arguments. */
4240 arrayss
= gfc_walk_expr (actual
->expr
);
4241 gcc_assert (arrayss
!= gfc_ss_terminator
);
4243 /* Initialize the scalarizer. */
4244 gfc_init_loopinfo (&loop
);
4245 gfc_add_ss_to_loop (&loop
, arrayss
);
4247 /* Initialize the loop. */
4248 gfc_conv_ss_startstride (&loop
);
4249 gfc_conv_loop_setup (&loop
, &expr
->where
);
4251 gfc_mark_ss_chain_used (arrayss
, 1);
4252 /* Generate the loop body. */
4253 gfc_start_scalarized_body (&loop
, &body
);
4255 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4256 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4257 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4259 gfc_init_se (&arrayse
, NULL
);
4260 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4261 arrayse
.ss
= arrayss
;
4262 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4263 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4264 build_empty_stmt (input_location
));
4266 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4267 gfc_add_expr_to_block (&body
, tmp
);
4268 gfc_add_block_to_block (&body
, &arrayse
.post
);
4270 gfc_trans_scalarizing_loops (&loop
, &body
);
4272 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4273 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4274 gfc_cleanup_loop (&loop
);
4280 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4281 struct and return the corresponding loopinfo. */
4283 static gfc_loopinfo
*
4284 enter_nested_loop (gfc_se
*se
)
4286 se
->ss
= se
->ss
->nested_ss
;
4287 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4289 return se
->ss
->loop
;
4293 /* Inline implementation of the sum and product intrinsics. */
4295 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4299 tree scale
= NULL_TREE
;
4304 gfc_loopinfo loop
, *ploop
;
4305 gfc_actual_arglist
*arg_array
, *arg_mask
;
4306 gfc_ss
*arrayss
= NULL
;
4307 gfc_ss
*maskss
= NULL
;
4311 gfc_expr
*arrayexpr
;
4316 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4322 type
= gfc_typenode_for_spec (&expr
->ts
);
4323 /* Initialize the result. */
4324 resvar
= gfc_create_var (type
, "val");
4329 scale
= gfc_create_var (type
, "scale");
4330 gfc_add_modify (&se
->pre
, scale
,
4331 gfc_build_const (type
, integer_one_node
));
4332 tmp
= gfc_build_const (type
, integer_zero_node
);
4334 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4335 tmp
= gfc_build_const (type
, integer_zero_node
);
4336 else if (op
== NE_EXPR
)
4338 tmp
= convert (type
, boolean_false_node
);
4339 else if (op
== BIT_AND_EXPR
)
4340 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4341 type
, integer_one_node
));
4343 tmp
= gfc_build_const (type
, integer_one_node
);
4345 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4347 arg_array
= expr
->value
.function
.actual
;
4349 arrayexpr
= arg_array
->expr
;
4351 if (op
== NE_EXPR
|| norm2
)
4352 /* PARITY and NORM2. */
4356 arg_mask
= arg_array
->next
->next
;
4357 gcc_assert (arg_mask
!= NULL
);
4358 maskexpr
= arg_mask
->expr
;
4361 if (expr
->rank
== 0)
4363 /* Walk the arguments. */
4364 arrayss
= gfc_walk_expr (arrayexpr
);
4365 gcc_assert (arrayss
!= gfc_ss_terminator
);
4367 if (maskexpr
&& maskexpr
->rank
> 0)
4369 maskss
= gfc_walk_expr (maskexpr
);
4370 gcc_assert (maskss
!= gfc_ss_terminator
);
4375 /* Initialize the scalarizer. */
4376 gfc_init_loopinfo (&loop
);
4377 gfc_add_ss_to_loop (&loop
, arrayss
);
4378 if (maskexpr
&& maskexpr
->rank
> 0)
4379 gfc_add_ss_to_loop (&loop
, maskss
);
4381 /* Initialize the loop. */
4382 gfc_conv_ss_startstride (&loop
);
4383 gfc_conv_loop_setup (&loop
, &expr
->where
);
4385 gfc_mark_ss_chain_used (arrayss
, 1);
4386 if (maskexpr
&& maskexpr
->rank
> 0)
4387 gfc_mark_ss_chain_used (maskss
, 1);
4392 /* All the work has been done in the parent loops. */
4393 ploop
= enter_nested_loop (se
);
4397 /* Generate the loop body. */
4398 gfc_start_scalarized_body (ploop
, &body
);
4400 /* If we have a mask, only add this element if the mask is set. */
4401 if (maskexpr
&& maskexpr
->rank
> 0)
4403 gfc_init_se (&maskse
, parent_se
);
4404 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4405 if (expr
->rank
== 0)
4407 gfc_conv_expr_val (&maskse
, maskexpr
);
4408 gfc_add_block_to_block (&body
, &maskse
.pre
);
4410 gfc_start_block (&block
);
4413 gfc_init_block (&block
);
4415 /* Do the actual summation/product. */
4416 gfc_init_se (&arrayse
, parent_se
);
4417 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4418 if (expr
->rank
== 0)
4419 arrayse
.ss
= arrayss
;
4420 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4421 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4425 /* if (x (i) != 0.0)
4431 result = 1.0 + result * val * val;
4437 result += val * val;
4440 tree res1
, res2
, cond
, absX
, val
;
4441 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4443 gfc_init_block (&ifblock1
);
4445 absX
= gfc_create_var (type
, "absX");
4446 gfc_add_modify (&ifblock1
, absX
,
4447 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4449 val
= gfc_create_var (type
, "val");
4450 gfc_add_expr_to_block (&ifblock1
, val
);
4452 gfc_init_block (&ifblock2
);
4453 gfc_add_modify (&ifblock2
, val
,
4454 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4456 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4457 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4458 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4459 gfc_build_const (type
, integer_one_node
));
4460 gfc_add_modify (&ifblock2
, resvar
, res1
);
4461 gfc_add_modify (&ifblock2
, scale
, absX
);
4462 res1
= gfc_finish_block (&ifblock2
);
4464 gfc_init_block (&ifblock3
);
4465 gfc_add_modify (&ifblock3
, val
,
4466 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4468 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4469 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4470 gfc_add_modify (&ifblock3
, resvar
, res2
);
4471 res2
= gfc_finish_block (&ifblock3
);
4473 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4475 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4476 gfc_add_expr_to_block (&ifblock1
, tmp
);
4477 tmp
= gfc_finish_block (&ifblock1
);
4479 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
4481 gfc_build_const (type
, integer_zero_node
));
4483 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4484 gfc_add_expr_to_block (&block
, tmp
);
4488 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4489 gfc_add_modify (&block
, resvar
, tmp
);
4492 gfc_add_block_to_block (&block
, &arrayse
.post
);
4494 if (maskexpr
&& maskexpr
->rank
> 0)
4496 /* We enclose the above in if (mask) {...} . */
4498 tmp
= gfc_finish_block (&block
);
4499 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4500 build_empty_stmt (input_location
));
4503 tmp
= gfc_finish_block (&block
);
4504 gfc_add_expr_to_block (&body
, tmp
);
4506 gfc_trans_scalarizing_loops (ploop
, &body
);
4508 /* For a scalar mask, enclose the loop in an if statement. */
4509 if (maskexpr
&& maskexpr
->rank
== 0)
4511 gfc_init_block (&block
);
4512 gfc_add_block_to_block (&block
, &ploop
->pre
);
4513 gfc_add_block_to_block (&block
, &ploop
->post
);
4514 tmp
= gfc_finish_block (&block
);
4518 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4519 build_empty_stmt (input_location
));
4520 gfc_advance_se_ss_chain (se
);
4524 gcc_assert (expr
->rank
== 0);
4525 gfc_init_se (&maskse
, NULL
);
4526 gfc_conv_expr_val (&maskse
, maskexpr
);
4527 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4528 build_empty_stmt (input_location
));
4531 gfc_add_expr_to_block (&block
, tmp
);
4532 gfc_add_block_to_block (&se
->pre
, &block
);
4533 gcc_assert (se
->post
.head
== NULL
);
4537 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4538 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4541 if (expr
->rank
== 0)
4542 gfc_cleanup_loop (ploop
);
4546 /* result = scale * sqrt(result). */
4548 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4549 resvar
= build_call_expr_loc (input_location
,
4551 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4558 /* Inline implementation of the dot_product intrinsic. This function
4559 is based on gfc_conv_intrinsic_arith (the previous function). */
4561 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4569 gfc_actual_arglist
*actual
;
4570 gfc_ss
*arrayss1
, *arrayss2
;
4571 gfc_se arrayse1
, arrayse2
;
4572 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4574 type
= gfc_typenode_for_spec (&expr
->ts
);
4576 /* Initialize the result. */
4577 resvar
= gfc_create_var (type
, "val");
4578 if (expr
->ts
.type
== BT_LOGICAL
)
4579 tmp
= build_int_cst (type
, 0);
4581 tmp
= gfc_build_const (type
, integer_zero_node
);
4583 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4585 /* Walk argument #1. */
4586 actual
= expr
->value
.function
.actual
;
4587 arrayexpr1
= actual
->expr
;
4588 arrayss1
= gfc_walk_expr (arrayexpr1
);
4589 gcc_assert (arrayss1
!= gfc_ss_terminator
);
4591 /* Walk argument #2. */
4592 actual
= actual
->next
;
4593 arrayexpr2
= actual
->expr
;
4594 arrayss2
= gfc_walk_expr (arrayexpr2
);
4595 gcc_assert (arrayss2
!= gfc_ss_terminator
);
4597 /* Initialize the scalarizer. */
4598 gfc_init_loopinfo (&loop
);
4599 gfc_add_ss_to_loop (&loop
, arrayss1
);
4600 gfc_add_ss_to_loop (&loop
, arrayss2
);
4602 /* Initialize the loop. */
4603 gfc_conv_ss_startstride (&loop
);
4604 gfc_conv_loop_setup (&loop
, &expr
->where
);
4606 gfc_mark_ss_chain_used (arrayss1
, 1);
4607 gfc_mark_ss_chain_used (arrayss2
, 1);
4609 /* Generate the loop body. */
4610 gfc_start_scalarized_body (&loop
, &body
);
4611 gfc_init_block (&block
);
4613 /* Make the tree expression for [conjg(]array1[)]. */
4614 gfc_init_se (&arrayse1
, NULL
);
4615 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
4616 arrayse1
.ss
= arrayss1
;
4617 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
4618 if (expr
->ts
.type
== BT_COMPLEX
)
4619 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
4621 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
4623 /* Make the tree expression for array2. */
4624 gfc_init_se (&arrayse2
, NULL
);
4625 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
4626 arrayse2
.ss
= arrayss2
;
4627 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
4628 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
4630 /* Do the actual product and sum. */
4631 if (expr
->ts
.type
== BT_LOGICAL
)
4633 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
4634 arrayse1
.expr
, arrayse2
.expr
);
4635 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
4639 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
4641 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
4643 gfc_add_modify (&block
, resvar
, tmp
);
4645 /* Finish up the loop block and the loop. */
4646 tmp
= gfc_finish_block (&block
);
4647 gfc_add_expr_to_block (&body
, tmp
);
4649 gfc_trans_scalarizing_loops (&loop
, &body
);
4650 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4651 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4652 gfc_cleanup_loop (&loop
);
4658 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4659 we need to handle. For performance reasons we sometimes create two
4660 loops instead of one, where the second one is much simpler.
4661 Examples for minloc intrinsic:
4662 1) Result is an array, a call is generated
4663 2) Array mask is used and NaNs need to be supported:
4669 if (pos == 0) pos = S + (1 - from);
4670 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4677 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4681 3) NaNs need to be supported, but it is known at compile time or cheaply
4682 at runtime whether array is nonempty or not:
4687 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4690 if (from <= to) pos = 1;
4694 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4698 4) NaNs aren't supported, array mask is used:
4699 limit = infinities_supported ? Infinity : huge (limit);
4703 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4709 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4713 5) Same without array mask:
4714 limit = infinities_supported ? Infinity : huge (limit);
4715 pos = (from <= to) ? 1 : 0;
4718 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4721 For 3) and 5), if mask is scalar, this all goes into a conditional,
4722 setting pos = 0; in the else branch.
4724 Since we now also support the BACK argument, instead of using
4725 if (a[S] < limit), we now use
4728 cond = a[S] <= limit;
4730 cond = a[S] < limit;
4734 The optimizer is smart enough to move the condition out of the loop.
4735 The are now marked as unlikely to for further speedup. */
4738 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4742 stmtblock_t ifblock
;
4743 stmtblock_t elseblock
;
4755 gfc_actual_arglist
*actual
;
4760 gfc_expr
*arrayexpr
;
4767 actual
= expr
->value
.function
.actual
;
4769 /* The last argument, BACK, is passed by value. Ensure that
4770 by setting its name to %VAL. */
4771 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
4773 if (a
->next
== NULL
)
4779 gfc_conv_intrinsic_funcall (se
, expr
);
4783 arrayexpr
= actual
->expr
;
4785 /* Special case for character maxloc. Remove unneeded actual
4786 arguments, then call a library function. */
4788 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
4790 gfc_actual_arglist
*a
, *b
;
4795 if (b
->expr
== NULL
|| strcmp (b
->name
, "dim") == 0)
4799 gfc_free_actual_arglist (b
);
4804 gfc_conv_intrinsic_funcall (se
, expr
);
4808 /* Initialize the result. */
4809 pos
= gfc_create_var (gfc_array_index_type
, "pos");
4810 offset
= gfc_create_var (gfc_array_index_type
, "offset");
4811 type
= gfc_typenode_for_spec (&expr
->ts
);
4813 /* Walk the arguments. */
4814 arrayss
= gfc_walk_expr (arrayexpr
);
4815 gcc_assert (arrayss
!= gfc_ss_terminator
);
4817 actual
= actual
->next
->next
;
4818 gcc_assert (actual
);
4819 maskexpr
= actual
->expr
;
4820 backexpr
= actual
->next
->next
->expr
;
4822 if (maskexpr
&& maskexpr
->rank
!= 0)
4824 maskss
= gfc_walk_expr (maskexpr
);
4825 gcc_assert (maskss
!= gfc_ss_terminator
);
4830 if (gfc_array_size (arrayexpr
, &asize
))
4832 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4834 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4835 logical_type_node
, nonempty
,
4836 gfc_index_zero_node
);
4841 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
4842 switch (arrayexpr
->ts
.type
)
4845 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
4849 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
4850 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
4851 arrayexpr
->ts
.kind
);
4858 /* We start with the most negative possible value for MAXLOC, and the most
4859 positive possible value for MINLOC. The most negative possible value is
4860 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4861 possible value is HUGE in both cases. */
4863 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4864 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
4865 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
4866 build_int_cst (TREE_TYPE (tmp
), 1));
4868 gfc_add_modify (&se
->pre
, limit
, tmp
);
4870 /* Initialize the scalarizer. */
4871 gfc_init_loopinfo (&loop
);
4872 gfc_add_ss_to_loop (&loop
, arrayss
);
4874 gfc_add_ss_to_loop (&loop
, maskss
);
4876 /* Initialize the loop. */
4877 gfc_conv_ss_startstride (&loop
);
4879 /* The code generated can have more than one loop in sequence (see the
4880 comment at the function header). This doesn't work well with the
4881 scalarizer, which changes arrays' offset when the scalarization loops
4882 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4883 are currently inlined in the scalar case only (for which loop is of rank
4884 one). As there is no dependency to care about in that case, there is no
4885 temporary, so that we can use the scalarizer temporary code to handle
4886 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4887 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4889 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4890 should eventually go away. We could either create two loops properly,
4891 or find another way to save/restore the array offsets between the two
4892 loops (without conflicting with temporary management), or use a single
4893 loop minmaxloc implementation. See PR 31067. */
4894 loop
.temp_dim
= loop
.dimen
;
4895 gfc_conv_loop_setup (&loop
, &expr
->where
);
4897 gcc_assert (loop
.dimen
== 1);
4898 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
4899 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4900 loop
.from
[0], loop
.to
[0]);
4904 /* Initialize the position to zero, following Fortran 2003. We are free
4905 to do this because Fortran 95 allows the result of an entirely false
4906 mask to be processor dependent. If we know at compile time the array
4907 is non-empty and no MASK is used, we can initialize to 1 to simplify
4909 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
4910 gfc_add_modify (&loop
.pre
, pos
,
4911 fold_build3_loc (input_location
, COND_EXPR
,
4912 gfc_array_index_type
,
4913 nonempty
, gfc_index_one_node
,
4914 gfc_index_zero_node
));
4917 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
4918 lab1
= gfc_build_label_decl (NULL_TREE
);
4919 TREE_USED (lab1
) = 1;
4920 lab2
= gfc_build_label_decl (NULL_TREE
);
4921 TREE_USED (lab2
) = 1;
4924 /* An offset must be added to the loop
4925 counter to obtain the required position. */
4926 gcc_assert (loop
.from
[0]);
4928 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4929 gfc_index_one_node
, loop
.from
[0]);
4930 gfc_add_modify (&loop
.pre
, offset
, tmp
);
4932 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
4934 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
4935 /* Generate the loop body. */
4936 gfc_start_scalarized_body (&loop
, &body
);
4938 /* If we have a mask, only check this element if the mask is set. */
4941 gfc_init_se (&maskse
, NULL
);
4942 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4944 gfc_conv_expr_val (&maskse
, maskexpr
);
4945 gfc_add_block_to_block (&body
, &maskse
.pre
);
4947 gfc_start_block (&block
);
4950 gfc_init_block (&block
);
4952 /* Compare with the current limit. */
4953 gfc_init_se (&arrayse
, NULL
);
4954 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4955 arrayse
.ss
= arrayss
;
4956 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4957 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4959 gfc_init_se (&backse
, NULL
);
4960 gfc_conv_expr_val (&backse
, backexpr
);
4961 gfc_add_block_to_block (&block
, &backse
.pre
);
4963 /* We do the following if this is a more extreme value. */
4964 gfc_start_block (&ifblock
);
4966 /* Assign the value to the limit... */
4967 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4969 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
4971 stmtblock_t ifblock2
;
4974 gfc_start_block (&ifblock2
);
4975 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4976 loop
.loopvar
[0], offset
);
4977 gfc_add_modify (&ifblock2
, pos
, tmp
);
4978 ifbody2
= gfc_finish_block (&ifblock2
);
4979 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pos
,
4980 gfc_index_zero_node
);
4981 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
4982 build_empty_stmt (input_location
));
4983 gfc_add_expr_to_block (&block
, tmp
);
4986 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4987 loop
.loopvar
[0], offset
);
4988 gfc_add_modify (&ifblock
, pos
, tmp
);
4991 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
4993 ifbody
= gfc_finish_block (&ifblock
);
4995 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
4998 cond
= fold_build2_loc (input_location
,
4999 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5000 logical_type_node
, arrayse
.expr
, limit
);
5003 tree ifbody2
, elsebody2
;
5005 /* We switch to > or >= depending on the value of the BACK argument. */
5006 cond
= gfc_create_var (logical_type_node
, "cond");
5008 gfc_start_block (&ifblock
);
5009 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5010 logical_type_node
, arrayse
.expr
, limit
);
5012 gfc_add_modify (&ifblock
, cond
, b_if
);
5013 ifbody2
= gfc_finish_block (&ifblock
);
5015 gfc_start_block (&elseblock
);
5016 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5017 arrayse
.expr
, limit
);
5019 gfc_add_modify (&elseblock
, cond
, b_else
);
5020 elsebody2
= gfc_finish_block (&elseblock
);
5022 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5023 backse
.expr
, ifbody2
, elsebody2
);
5025 gfc_add_expr_to_block (&block
, tmp
);
5028 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5029 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
5030 build_empty_stmt (input_location
));
5032 gfc_add_expr_to_block (&block
, ifbody
);
5036 /* We enclose the above in if (mask) {...}. */
5037 tmp
= gfc_finish_block (&block
);
5039 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5040 build_empty_stmt (input_location
));
5043 tmp
= gfc_finish_block (&block
);
5044 gfc_add_expr_to_block (&body
, tmp
);
5048 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5050 if (HONOR_NANS (DECL_MODE (limit
)))
5052 if (nonempty
!= NULL
)
5054 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
5055 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
5056 build_empty_stmt (input_location
));
5057 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
5061 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
5062 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
5064 /* If we have a mask, only check this element if the mask is set. */
5067 gfc_init_se (&maskse
, NULL
);
5068 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5070 gfc_conv_expr_val (&maskse
, maskexpr
);
5071 gfc_add_block_to_block (&body
, &maskse
.pre
);
5073 gfc_start_block (&block
);
5076 gfc_init_block (&block
);
5078 /* Compare with the current limit. */
5079 gfc_init_se (&arrayse
, NULL
);
5080 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5081 arrayse
.ss
= arrayss
;
5082 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5083 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5085 /* We do the following if this is a more extreme value. */
5086 gfc_start_block (&ifblock
);
5088 /* Assign the value to the limit... */
5089 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5091 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5092 loop
.loopvar
[0], offset
);
5093 gfc_add_modify (&ifblock
, pos
, tmp
);
5095 ifbody
= gfc_finish_block (&ifblock
);
5097 /* We switch to > or >= depending on the value of the BACK argument. */
5099 tree ifbody2
, elsebody2
;
5101 cond
= gfc_create_var (logical_type_node
, "cond");
5103 gfc_start_block (&ifblock
);
5104 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5105 logical_type_node
, arrayse
.expr
, limit
);
5107 gfc_add_modify (&ifblock
, cond
, b_if
);
5108 ifbody2
= gfc_finish_block (&ifblock
);
5110 gfc_start_block (&elseblock
);
5111 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5112 arrayse
.expr
, limit
);
5114 gfc_add_modify (&elseblock
, cond
, b_else
);
5115 elsebody2
= gfc_finish_block (&elseblock
);
5117 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5118 backse
.expr
, ifbody2
, elsebody2
);
5121 gfc_add_expr_to_block (&block
, tmp
);
5122 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5123 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
5124 build_empty_stmt (input_location
));
5126 gfc_add_expr_to_block (&block
, tmp
);
5130 /* We enclose the above in if (mask) {...}. */
5131 tmp
= gfc_finish_block (&block
);
5133 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5134 build_empty_stmt (input_location
));
5137 tmp
= gfc_finish_block (&block
);
5138 gfc_add_expr_to_block (&body
, tmp
);
5139 /* Avoid initializing loopvar[0] again, it should be left where
5140 it finished by the first loop. */
5141 loop
.from
[0] = loop
.loopvar
[0];
5144 gfc_trans_scalarizing_loops (&loop
, &body
);
5147 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
5149 /* For a scalar mask, enclose the loop in an if statement. */
5150 if (maskexpr
&& maskss
== NULL
)
5152 gfc_init_se (&maskse
, NULL
);
5153 gfc_conv_expr_val (&maskse
, maskexpr
);
5154 gfc_init_block (&block
);
5155 gfc_add_block_to_block (&block
, &loop
.pre
);
5156 gfc_add_block_to_block (&block
, &loop
.post
);
5157 tmp
= gfc_finish_block (&block
);
5159 /* For the else part of the scalar mask, just initialize
5160 the pos variable the same way as above. */
5162 gfc_init_block (&elseblock
);
5163 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
5164 elsetmp
= gfc_finish_block (&elseblock
);
5166 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
5167 gfc_add_expr_to_block (&block
, tmp
);
5168 gfc_add_block_to_block (&se
->pre
, &block
);
5172 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5173 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5175 gfc_cleanup_loop (&loop
);
5177 se
->expr
= convert (type
, pos
);
5180 /* Emit code for findloc. */
5183 gfc_conv_intrinsic_findloc (gfc_se
*se
, gfc_expr
*expr
)
5185 gfc_actual_arglist
*array_arg
, *value_arg
, *dim_arg
, *mask_arg
,
5186 *kind_arg
, *back_arg
;
5187 gfc_expr
*value_expr
;
5192 stmtblock_t loopblock
;
5196 tree forward_branch
;
5210 array_arg
= expr
->value
.function
.actual
;
5211 value_arg
= array_arg
->next
;
5212 dim_arg
= value_arg
->next
;
5213 mask_arg
= dim_arg
->next
;
5214 kind_arg
= mask_arg
->next
;
5215 back_arg
= kind_arg
->next
;
5217 /* Remove kind and set ikind. */
5220 ikind
= mpz_get_si (kind_arg
->expr
->value
.integer
);
5221 gfc_free_expr (kind_arg
->expr
);
5222 kind_arg
->expr
= NULL
;
5225 ikind
= gfc_default_integer_kind
;
5227 value_expr
= value_arg
->expr
;
5229 /* Unless it's a string, pass VALUE by value. */
5230 if (value_expr
->ts
.type
!= BT_CHARACTER
)
5231 value_arg
->name
= "%VAL";
5233 /* Pass BACK argument by value. */
5234 back_arg
->name
= "%VAL";
5236 /* Call the library if we have a character function or if
5238 if (se
->ss
|| array_arg
->expr
->ts
.type
== BT_CHARACTER
)
5240 se
->ignore_optional
= 1;
5241 if (expr
->rank
== 0)
5243 /* Remove dim argument. */
5244 gfc_free_expr (dim_arg
->expr
);
5245 dim_arg
->expr
= NULL
;
5247 gfc_conv_intrinsic_funcall (se
, expr
);
5251 type
= gfc_get_int_type (ikind
);
5253 /* Initialize the result. */
5254 resvar
= gfc_create_var (gfc_array_index_type
, "pos");
5255 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (gfc_array_index_type
, 0));
5256 offset
= gfc_create_var (gfc_array_index_type
, "offset");
5258 maskexpr
= mask_arg
->expr
;
5260 /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5262 for (i
= 0 ; i
< 2; i
++)
5264 /* Walk the arguments. */
5265 arrayss
= gfc_walk_expr (array_arg
->expr
);
5266 gcc_assert (arrayss
!= gfc_ss_terminator
);
5268 if (maskexpr
&& maskexpr
->rank
!= 0)
5270 maskss
= gfc_walk_expr (maskexpr
);
5271 gcc_assert (maskss
!= gfc_ss_terminator
);
5276 /* Initialize the scalarizer. */
5277 gfc_init_loopinfo (&loop
);
5278 exit_label
= gfc_build_label_decl (NULL_TREE
);
5279 TREE_USED (exit_label
) = 1;
5280 gfc_add_ss_to_loop (&loop
, arrayss
);
5282 gfc_add_ss_to_loop (&loop
, maskss
);
5284 /* Initialize the loop. */
5285 gfc_conv_ss_startstride (&loop
);
5286 gfc_conv_loop_setup (&loop
, &expr
->where
);
5288 /* Calculate the offset. */
5289 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5290 gfc_index_one_node
, loop
.from
[0]);
5291 gfc_add_modify (&loop
.pre
, offset
, tmp
);
5293 gfc_mark_ss_chain_used (arrayss
, 1);
5295 gfc_mark_ss_chain_used (maskss
, 1);
5297 /* The first loop is for BACK=.true. */
5299 loop
.reverse
[0] = GFC_REVERSE_SET
;
5301 /* Generate the loop body. */
5302 gfc_start_scalarized_body (&loop
, &body
);
5304 /* If we have an array mask, only add the element if it is
5308 gfc_init_se (&maskse
, NULL
);
5309 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5311 gfc_conv_expr_val (&maskse
, maskexpr
);
5312 gfc_add_block_to_block (&body
, &maskse
.pre
);
5315 /* If the condition matches then set the return value. */
5316 gfc_start_block (&block
);
5318 /* Add the offset. */
5319 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5321 loop
.loopvar
[0], offset
);
5322 gfc_add_modify (&block
, resvar
, tmp
);
5323 /* And break out of the loop. */
5324 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5325 gfc_add_expr_to_block (&block
, tmp
);
5327 found
= gfc_finish_block (&block
);
5329 /* Check this element. */
5330 gfc_init_se (&arrayse
, NULL
);
5331 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5332 arrayse
.ss
= arrayss
;
5333 gfc_conv_expr_val (&arrayse
, array_arg
->expr
);
5334 gfc_add_block_to_block (&body
, &arrayse
.pre
);
5336 gfc_init_se (&valuese
, NULL
);
5337 gfc_conv_expr_val (&valuese
, value_arg
->expr
);
5338 gfc_add_block_to_block (&body
, &valuese
.pre
);
5340 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5341 arrayse
.expr
, valuese
.expr
);
5343 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
5345 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5346 build_empty_stmt (input_location
));
5348 gfc_add_expr_to_block (&body
, tmp
);
5349 gfc_add_block_to_block (&body
, &arrayse
.post
);
5351 gfc_trans_scalarizing_loops (&loop
, &body
);
5353 /* Add the exit label. */
5354 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5355 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5356 gfc_start_block (&loopblock
);
5357 gfc_add_block_to_block (&loopblock
, &loop
.pre
);
5358 gfc_add_block_to_block (&loopblock
, &loop
.post
);
5360 forward_branch
= gfc_finish_block (&loopblock
);
5362 back_branch
= gfc_finish_block (&loopblock
);
5364 gfc_cleanup_loop (&loop
);
5367 /* Enclose the two loops in an IF statement. */
5369 gfc_init_se (&backse
, NULL
);
5370 gfc_conv_expr_val (&backse
, back_arg
->expr
);
5371 gfc_add_block_to_block (&se
->pre
, &backse
.pre
);
5372 tmp
= build3_v (COND_EXPR
, backse
.expr
, forward_branch
, back_branch
);
5374 /* For a scalar mask, enclose the loop in an if statement. */
5375 if (maskexpr
&& maskss
== NULL
)
5378 gfc_init_se (&maskse
, NULL
);
5379 gfc_conv_expr_val (&maskse
, maskexpr
);
5380 gfc_init_block (&block
);
5381 gfc_add_expr_to_block (&block
, maskse
.expr
);
5382 if_stmt
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5383 build_empty_stmt (input_location
));
5384 gfc_add_expr_to_block (&block
, if_stmt
);
5385 tmp
= gfc_finish_block (&block
);
5388 gfc_add_expr_to_block (&se
->pre
, tmp
);
5389 se
->expr
= convert (type
, resvar
);
5393 /* Emit code for minval or maxval intrinsic. There are many different cases
5394 we need to handle. For performance reasons we sometimes create two
5395 loops instead of one, where the second one is much simpler.
5396 Examples for minval intrinsic:
5397 1) Result is an array, a call is generated
5398 2) Array mask is used and NaNs need to be supported, rank 1:
5403 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
5406 limit = nonempty ? NaN : huge (limit);
5408 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
5409 3) NaNs need to be supported, but it is known at compile time or cheaply
5410 at runtime whether array is nonempty or not, rank 1:
5413 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
5414 limit = (from <= to) ? NaN : huge (limit);
5416 while (S <= to) { limit = min (a[S], limit); S++; }
5417 4) Array mask is used and NaNs need to be supported, rank > 1:
5426 if (fast) limit = min (a[S1][S2], limit);
5429 if (a[S1][S2] <= limit) {
5440 limit = nonempty ? NaN : huge (limit);
5441 5) NaNs need to be supported, but it is known at compile time or cheaply
5442 at runtime whether array is nonempty or not, rank > 1:
5449 if (fast) limit = min (a[S1][S2], limit);
5451 if (a[S1][S2] <= limit) {
5461 limit = (nonempty_array) ? NaN : huge (limit);
5462 6) NaNs aren't supported, but infinities are. Array mask is used:
5467 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
5470 limit = nonempty ? limit : huge (limit);
5471 7) Same without array mask:
5474 while (S <= to) { limit = min (a[S], limit); S++; }
5475 limit = (from <= to) ? limit : huge (limit);
5476 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
5477 limit = huge (limit);
5479 while (S <= to) { limit = min (a[S], limit); S++); }
5481 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
5482 with array mask instead).
5483 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
5484 setting limit = huge (limit); in the else branch. */
5487 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5497 tree huge_cst
= NULL
, nan_cst
= NULL
;
5499 stmtblock_t block
, block2
;
5501 gfc_actual_arglist
*actual
;
5506 gfc_expr
*arrayexpr
;
5512 gfc_conv_intrinsic_funcall (se
, expr
);
5516 actual
= expr
->value
.function
.actual
;
5517 arrayexpr
= actual
->expr
;
5519 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5521 gfc_actual_arglist
*a2
, *a3
;
5522 a2
= actual
->next
; /* dim */
5523 a3
= a2
->next
; /* mask */
5524 if (a2
->expr
== NULL
|| expr
->rank
== 0)
5526 if (a3
->expr
== NULL
)
5527 actual
->next
= NULL
;
5533 gfc_free_actual_arglist (a2
);
5536 if (a3
->expr
== NULL
)
5539 gfc_free_actual_arglist (a3
);
5541 gfc_conv_intrinsic_funcall (se
, expr
);
5544 type
= gfc_typenode_for_spec (&expr
->ts
);
5545 /* Initialize the result. */
5546 limit
= gfc_create_var (type
, "limit");
5547 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
5548 switch (expr
->ts
.type
)
5551 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
5553 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5555 REAL_VALUE_TYPE real
;
5557 tmp
= build_real (type
, real
);
5561 if (HONOR_NANS (DECL_MODE (limit
)))
5562 nan_cst
= gfc_build_nan (type
, "");
5566 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
5573 /* We start with the most negative possible value for MAXVAL, and the most
5574 positive possible value for MINVAL. The most negative possible value is
5575 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5576 possible value is HUGE in both cases. */
5579 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5581 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
5582 TREE_TYPE (huge_cst
), huge_cst
);
5585 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
5586 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5587 tmp
, build_int_cst (type
, 1));
5589 gfc_add_modify (&se
->pre
, limit
, tmp
);
5591 /* Walk the arguments. */
5592 arrayss
= gfc_walk_expr (arrayexpr
);
5593 gcc_assert (arrayss
!= gfc_ss_terminator
);
5595 actual
= actual
->next
->next
;
5596 gcc_assert (actual
);
5597 maskexpr
= actual
->expr
;
5599 if (maskexpr
&& maskexpr
->rank
!= 0)
5601 maskss
= gfc_walk_expr (maskexpr
);
5602 gcc_assert (maskss
!= gfc_ss_terminator
);
5607 if (gfc_array_size (arrayexpr
, &asize
))
5609 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5611 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5612 logical_type_node
, nonempty
,
5613 gfc_index_zero_node
);
5618 /* Initialize the scalarizer. */
5619 gfc_init_loopinfo (&loop
);
5620 gfc_add_ss_to_loop (&loop
, arrayss
);
5622 gfc_add_ss_to_loop (&loop
, maskss
);
5624 /* Initialize the loop. */
5625 gfc_conv_ss_startstride (&loop
);
5627 /* The code generated can have more than one loop in sequence (see the
5628 comment at the function header). This doesn't work well with the
5629 scalarizer, which changes arrays' offset when the scalarization loops
5630 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5631 are currently inlined in the scalar case only. As there is no dependency
5632 to care about in that case, there is no temporary, so that we can use the
5633 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5634 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5635 gfc_trans_scalarized_loop_boundary even later to restore offset.
5636 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5637 should eventually go away. We could either create two loops properly,
5638 or find another way to save/restore the array offsets between the two
5639 loops (without conflicting with temporary management), or use a single
5640 loop minmaxval implementation. See PR 31067. */
5641 loop
.temp_dim
= loop
.dimen
;
5642 gfc_conv_loop_setup (&loop
, &expr
->where
);
5644 if (nonempty
== NULL
&& maskss
== NULL
5645 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5646 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5647 loop
.from
[0], loop
.to
[0]);
5648 nonempty_var
= NULL
;
5649 if (nonempty
== NULL
5650 && (HONOR_INFINITIES (DECL_MODE (limit
))
5651 || HONOR_NANS (DECL_MODE (limit
))))
5653 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
5654 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
5655 nonempty
= nonempty_var
;
5659 if (HONOR_NANS (DECL_MODE (limit
)))
5661 if (loop
.dimen
== 1)
5663 lab
= gfc_build_label_decl (NULL_TREE
);
5664 TREE_USED (lab
) = 1;
5668 fast
= gfc_create_var (logical_type_node
, "fast");
5669 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
5673 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5675 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5676 /* Generate the loop body. */
5677 gfc_start_scalarized_body (&loop
, &body
);
5679 /* If we have a mask, only add this element if the mask is set. */
5682 gfc_init_se (&maskse
, NULL
);
5683 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5685 gfc_conv_expr_val (&maskse
, maskexpr
);
5686 gfc_add_block_to_block (&body
, &maskse
.pre
);
5688 gfc_start_block (&block
);
5691 gfc_init_block (&block
);
5693 /* Compare with the current limit. */
5694 gfc_init_se (&arrayse
, NULL
);
5695 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5696 arrayse
.ss
= arrayss
;
5697 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5698 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5700 gfc_init_block (&block2
);
5703 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
5705 if (HONOR_NANS (DECL_MODE (limit
)))
5707 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5708 logical_type_node
, arrayse
.expr
, limit
);
5710 ifbody
= build1_v (GOTO_EXPR
, lab
);
5713 stmtblock_t ifblock
;
5715 gfc_init_block (&ifblock
);
5716 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5717 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
5718 ifbody
= gfc_finish_block (&ifblock
);
5720 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5721 build_empty_stmt (input_location
));
5722 gfc_add_expr_to_block (&block2
, tmp
);
5726 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5728 tmp
= fold_build2_loc (input_location
,
5729 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5730 type
, arrayse
.expr
, limit
);
5731 gfc_add_modify (&block2
, limit
, tmp
);
5736 tree elsebody
= gfc_finish_block (&block2
);
5738 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5740 if (HONOR_NANS (DECL_MODE (limit
)))
5742 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5743 arrayse
.expr
, limit
);
5744 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5745 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5746 build_empty_stmt (input_location
));
5750 tmp
= fold_build2_loc (input_location
,
5751 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5752 type
, arrayse
.expr
, limit
);
5753 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5755 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5756 gfc_add_expr_to_block (&block
, tmp
);
5759 gfc_add_block_to_block (&block
, &block2
);
5761 gfc_add_block_to_block (&block
, &arrayse
.post
);
5763 tmp
= gfc_finish_block (&block
);
5765 /* We enclose the above in if (mask) {...}. */
5766 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5767 build_empty_stmt (input_location
));
5768 gfc_add_expr_to_block (&body
, tmp
);
5772 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5774 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5776 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
5777 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
5779 /* If we have a mask, only add this element if the mask is set. */
5782 gfc_init_se (&maskse
, NULL
);
5783 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5785 gfc_conv_expr_val (&maskse
, maskexpr
);
5786 gfc_add_block_to_block (&body
, &maskse
.pre
);
5788 gfc_start_block (&block
);
5791 gfc_init_block (&block
);
5793 /* Compare with the current limit. */
5794 gfc_init_se (&arrayse
, NULL
);
5795 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5796 arrayse
.ss
= arrayss
;
5797 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5798 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5800 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5802 if (HONOR_NANS (DECL_MODE (limit
)))
5804 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5805 arrayse
.expr
, limit
);
5806 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5807 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5808 build_empty_stmt (input_location
));
5809 gfc_add_expr_to_block (&block
, tmp
);
5813 tmp
= fold_build2_loc (input_location
,
5814 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5815 type
, arrayse
.expr
, limit
);
5816 gfc_add_modify (&block
, limit
, tmp
);
5819 gfc_add_block_to_block (&block
, &arrayse
.post
);
5821 tmp
= gfc_finish_block (&block
);
5823 /* We enclose the above in if (mask) {...}. */
5824 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5825 build_empty_stmt (input_location
));
5826 gfc_add_expr_to_block (&body
, tmp
);
5827 /* Avoid initializing loopvar[0] again, it should be left where
5828 it finished by the first loop. */
5829 loop
.from
[0] = loop
.loopvar
[0];
5831 gfc_trans_scalarizing_loops (&loop
, &body
);
5835 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5837 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5838 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
5840 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5842 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
5844 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
5846 gfc_add_modify (&loop
.pre
, limit
, tmp
);
5849 /* For a scalar mask, enclose the loop in an if statement. */
5850 if (maskexpr
&& maskss
== NULL
)
5854 gfc_init_se (&maskse
, NULL
);
5855 gfc_conv_expr_val (&maskse
, maskexpr
);
5856 gfc_init_block (&block
);
5857 gfc_add_block_to_block (&block
, &loop
.pre
);
5858 gfc_add_block_to_block (&block
, &loop
.post
);
5859 tmp
= gfc_finish_block (&block
);
5861 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5862 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
5864 else_stmt
= build_empty_stmt (input_location
);
5865 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
5866 gfc_add_expr_to_block (&block
, tmp
);
5867 gfc_add_block_to_block (&se
->pre
, &block
);
5871 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5872 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5875 gfc_cleanup_loop (&loop
);
5880 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5882 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
5888 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5889 type
= TREE_TYPE (args
[0]);
5891 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5892 build_int_cst (type
, 1), args
[1]);
5893 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
5894 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
5895 build_int_cst (type
, 0));
5896 type
= gfc_typenode_for_spec (&expr
->ts
);
5897 se
->expr
= convert (type
, tmp
);
5901 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5903 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5907 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5909 /* Convert both arguments to the unsigned type of the same size. */
5910 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
5911 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
5913 /* If they have unequal type size, convert to the larger one. */
5914 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
5915 > TYPE_PRECISION (TREE_TYPE (args
[1])))
5916 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
5917 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
5918 > TYPE_PRECISION (TREE_TYPE (args
[0])))
5919 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
5921 /* Now, we compare them. */
5922 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
5927 /* Generate code to perform the specified operation. */
5929 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5933 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5934 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
5940 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
5944 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5945 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5946 TREE_TYPE (arg
), arg
);
5949 /* Set or clear a single bit. */
5951 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
5958 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5959 type
= TREE_TYPE (args
[0]);
5961 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5962 build_int_cst (type
, 1), args
[1]);
5968 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
5970 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
5973 /* Extract a sequence of bits.
5974 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5976 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
5983 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5984 type
= TREE_TYPE (args
[0]);
5986 mask
= build_int_cst (type
, -1);
5987 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
5988 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
5990 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
5992 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
5996 gfc_conv_intrinsic_shape (gfc_se
*se
, gfc_expr
*expr
)
5998 gfc_actual_arglist
*s
, *k
;
6001 /* Remove the KIND argument, if present. */
6002 s
= expr
->value
.function
.actual
;
6008 gfc_conv_intrinsic_funcall (se
, expr
);
6012 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
6015 tree args
[2], type
, num_bits
, cond
;
6017 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6019 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6020 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6021 type
= TREE_TYPE (args
[0]);
6024 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
6026 gcc_assert (right_shift
);
6028 se
->expr
= fold_build2_loc (input_location
,
6029 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
6030 TREE_TYPE (args
[0]), args
[0], args
[1]);
6033 se
->expr
= fold_convert (type
, se
->expr
);
6035 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6036 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6038 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6039 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6042 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6043 build_int_cst (type
, 0), se
->expr
);
6046 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
6048 : ((shift >= 0) ? i << shift : i >> -shift)
6049 where all shifts are logical shifts. */
6051 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
6063 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6065 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6066 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6068 type
= TREE_TYPE (args
[0]);
6069 utype
= unsigned_type_for (type
);
6071 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
6074 /* Left shift if positive. */
6075 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
6077 /* Right shift if negative.
6078 We convert to an unsigned type because we want a logical shift.
6079 The standard doesn't define the case of shifting negative
6080 numbers, and we try to be compatible with other compilers, most
6081 notably g77, here. */
6082 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
6083 utype
, convert (utype
, args
[0]), width
));
6085 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
6086 build_int_cst (TREE_TYPE (args
[1]), 0));
6087 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
6089 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6090 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6092 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
6093 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
6095 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6096 build_int_cst (type
, 0), tmp
);
6100 /* Circular shift. AKA rotate or barrel shift. */
6103 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
6111 unsigned int num_args
;
6113 num_args
= gfc_intrinsic_argument_list_length (expr
);
6114 args
= XALLOCAVEC (tree
, num_args
);
6116 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6120 /* Use a library function for the 3 parameter version. */
6121 tree int4type
= gfc_get_int_type (4);
6123 type
= TREE_TYPE (args
[0]);
6124 /* We convert the first argument to at least 4 bytes, and
6125 convert back afterwards. This removes the need for library
6126 functions for all argument sizes, and function will be
6127 aligned to at least 32 bits, so there's no loss. */
6128 if (expr
->ts
.kind
< 4)
6129 args
[0] = convert (int4type
, args
[0]);
6131 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
6132 need loads of library functions. They cannot have values >
6133 BIT_SIZE (I) so the conversion is safe. */
6134 args
[1] = convert (int4type
, args
[1]);
6135 args
[2] = convert (int4type
, args
[2]);
6137 switch (expr
->ts
.kind
)
6142 tmp
= gfor_fndecl_math_ishftc4
;
6145 tmp
= gfor_fndecl_math_ishftc8
;
6148 tmp
= gfor_fndecl_math_ishftc16
;
6153 se
->expr
= build_call_expr_loc (input_location
,
6154 tmp
, 3, args
[0], args
[1], args
[2]);
6155 /* Convert the result back to the original type, if we extended
6156 the first argument's width above. */
6157 if (expr
->ts
.kind
< 4)
6158 se
->expr
= convert (type
, se
->expr
);
6162 type
= TREE_TYPE (args
[0]);
6164 /* Evaluate arguments only once. */
6165 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6166 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
6168 /* Rotate left if positive. */
6169 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
6171 /* Rotate right if negative. */
6172 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
6174 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
6176 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
6177 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
6179 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
6181 /* Do nothing if shift == 0. */
6182 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
6184 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
6189 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
6190 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
6192 The conditional expression is necessary because the result of LEADZ(0)
6193 is defined, but the result of __builtin_clz(0) is undefined for most
6196 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
6197 difference in bit size between the argument of LEADZ and the C int. */
6200 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
6212 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6213 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6215 /* Which variant of __builtin_clz* should we call? */
6216 if (argsize
<= INT_TYPE_SIZE
)
6218 arg_type
= unsigned_type_node
;
6219 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
6221 else if (argsize
<= LONG_TYPE_SIZE
)
6223 arg_type
= long_unsigned_type_node
;
6224 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
6226 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6228 arg_type
= long_long_unsigned_type_node
;
6229 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6233 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6234 arg_type
= gfc_build_uint_type (argsize
);
6238 /* Convert the actual argument twice: first, to the unsigned type of the
6239 same size; then, to the proper argument type for the built-in
6240 function. But the return type is of the default INTEGER kind. */
6241 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6242 arg
= fold_convert (arg_type
, arg
);
6243 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6244 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6246 /* Compute LEADZ for the case i .ne. 0. */
6249 s
= TYPE_PRECISION (arg_type
) - argsize
;
6250 tmp
= fold_convert (result_type
,
6251 build_call_expr_loc (input_location
, func
,
6253 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
6254 tmp
, build_int_cst (result_type
, s
));
6258 /* We end up here if the argument type is larger than 'long long'.
6259 We generate this code:
6261 if (x & (ULL_MAX << ULL_SIZE) != 0)
6262 return clzll ((unsigned long long) (x >> ULLSIZE));
6264 return ULL_SIZE + clzll ((unsigned long long) x);
6265 where ULL_MAX is the largest value that a ULL_MAX can hold
6266 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6267 is the bit-size of the long long type (64 in this example). */
6268 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
6270 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
6271 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6272 long_long_unsigned_type_node
,
6273 build_int_cst (long_long_unsigned_type_node
,
6276 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
6277 fold_convert (arg_type
, ullmax
), ullsize
);
6278 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
6280 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6281 cond
, build_int_cst (arg_type
, 0));
6283 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
6285 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
6286 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6287 tmp1
= fold_convert (result_type
,
6288 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
6290 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
6291 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6292 tmp2
= fold_convert (result_type
,
6293 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
6294 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6297 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
6301 /* Build BIT_SIZE. */
6302 bit_size
= build_int_cst (result_type
, argsize
);
6304 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6305 arg
, build_int_cst (arg_type
, 0));
6306 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
6311 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
6313 The conditional expression is necessary because the result of TRAILZ(0)
6314 is defined, but the result of __builtin_ctz(0) is undefined for most
6318 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
6329 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6330 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6332 /* Which variant of __builtin_ctz* should we call? */
6333 if (argsize
<= INT_TYPE_SIZE
)
6335 arg_type
= unsigned_type_node
;
6336 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
6338 else if (argsize
<= LONG_TYPE_SIZE
)
6340 arg_type
= long_unsigned_type_node
;
6341 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
6343 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6345 arg_type
= long_long_unsigned_type_node
;
6346 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6350 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6351 arg_type
= gfc_build_uint_type (argsize
);
6355 /* Convert the actual argument twice: first, to the unsigned type of the
6356 same size; then, to the proper argument type for the built-in
6357 function. But the return type is of the default INTEGER kind. */
6358 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6359 arg
= fold_convert (arg_type
, arg
);
6360 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6361 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6363 /* Compute TRAILZ for the case i .ne. 0. */
6365 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
6369 /* We end up here if the argument type is larger than 'long long'.
6370 We generate this code:
6372 if ((x & ULL_MAX) == 0)
6373 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
6375 return ctzll ((unsigned long long) x);
6377 where ULL_MAX is the largest value that a ULL_MAX can hold
6378 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6379 is the bit-size of the long long type (64 in this example). */
6380 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
6382 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
6383 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6384 long_long_unsigned_type_node
,
6385 build_int_cst (long_long_unsigned_type_node
, 0));
6387 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
6388 fold_convert (arg_type
, ullmax
));
6389 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
6390 build_int_cst (arg_type
, 0));
6392 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
6394 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
6395 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6396 tmp1
= fold_convert (result_type
,
6397 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
6398 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6401 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
6402 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6403 tmp2
= fold_convert (result_type
,
6404 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
6406 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
6410 /* Build BIT_SIZE. */
6411 bit_size
= build_int_cst (result_type
, argsize
);
6413 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6414 arg
, build_int_cst (arg_type
, 0));
6415 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
6419 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
6420 for types larger than "long long", we call the long long built-in for
6421 the lower and higher bits and combine the result. */
6424 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
6432 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6433 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6434 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6436 /* Which variant of the builtin should we call? */
6437 if (argsize
<= INT_TYPE_SIZE
)
6439 arg_type
= unsigned_type_node
;
6440 func
= builtin_decl_explicit (parity
6442 : BUILT_IN_POPCOUNT
);
6444 else if (argsize
<= LONG_TYPE_SIZE
)
6446 arg_type
= long_unsigned_type_node
;
6447 func
= builtin_decl_explicit (parity
6449 : BUILT_IN_POPCOUNTL
);
6451 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6453 arg_type
= long_long_unsigned_type_node
;
6454 func
= builtin_decl_explicit (parity
6456 : BUILT_IN_POPCOUNTLL
);
6460 /* Our argument type is larger than 'long long', which mean none
6461 of the POPCOUNT builtins covers it. We thus call the 'long long'
6462 variant multiple times, and add the results. */
6463 tree utype
, arg2
, call1
, call2
;
6465 /* For now, we only cover the case where argsize is twice as large
6467 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6469 func
= builtin_decl_explicit (parity
6471 : BUILT_IN_POPCOUNTLL
);
6473 /* Convert it to an integer, and store into a variable. */
6474 utype
= gfc_build_uint_type (argsize
);
6475 arg
= fold_convert (utype
, arg
);
6476 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6478 /* Call the builtin twice. */
6479 call1
= build_call_expr_loc (input_location
, func
, 1,
6480 fold_convert (long_long_unsigned_type_node
,
6483 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
6484 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
6485 call2
= build_call_expr_loc (input_location
, func
, 1,
6486 fold_convert (long_long_unsigned_type_node
,
6489 /* Combine the results. */
6491 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
6494 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6500 /* Convert the actual argument twice: first, to the unsigned type of the
6501 same size; then, to the proper argument type for the built-in
6503 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6504 arg
= fold_convert (arg_type
, arg
);
6506 se
->expr
= fold_convert (result_type
,
6507 build_call_expr_loc (input_location
, func
, 1, arg
));
6511 /* Process an intrinsic with unspecified argument-types that has an optional
6512 argument (which could be of type character), e.g. EOSHIFT. For those, we
6513 need to append the string length of the optional argument if it is not
6514 present and the type is really character.
6515 primary specifies the position (starting at 1) of the non-optional argument
6516 specifying the type and optional gives the position of the optional
6517 argument in the arglist. */
6520 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
6521 unsigned primary
, unsigned optional
)
6523 gfc_actual_arglist
* prim_arg
;
6524 gfc_actual_arglist
* opt_arg
;
6526 gfc_actual_arglist
* arg
;
6528 vec
<tree
, va_gc
> *append_args
;
6530 /* Find the two arguments given as position. */
6534 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
6538 if (cur_pos
== primary
)
6540 if (cur_pos
== optional
)
6543 if (cur_pos
>= primary
&& cur_pos
>= optional
)
6546 gcc_assert (prim_arg
);
6547 gcc_assert (prim_arg
->expr
);
6548 gcc_assert (opt_arg
);
6550 /* If we do have type CHARACTER and the optional argument is really absent,
6551 append a dummy 0 as string length. */
6553 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
6557 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
6558 vec_alloc (append_args
, 1);
6559 append_args
->quick_push (dummy
);
6562 /* Build the call itself. */
6563 gcc_assert (!se
->ignore_optional
);
6564 sym
= gfc_get_symbol_for_expr (expr
, false);
6565 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6567 gfc_free_symbol (sym
);
6570 /* The length of a character string. */
6572 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
6581 gcc_assert (!se
->ss
);
6583 arg
= expr
->value
.function
.actual
->expr
;
6585 type
= gfc_typenode_for_spec (&expr
->ts
);
6586 switch (arg
->expr_type
)
6589 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
6593 /* Obtain the string length from the function used by
6594 trans-array.c(gfc_trans_array_constructor). */
6596 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
6600 if (arg
->ref
== NULL
6601 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6603 /* This doesn't catch all cases.
6604 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6605 and the surrounding thread. */
6606 sym
= arg
->symtree
->n
.sym
;
6607 decl
= gfc_get_symbol_decl (sym
);
6608 if (decl
== current_function_decl
&& sym
->attr
.function
6609 && (sym
->result
== sym
))
6610 decl
= gfc_get_fake_result_decl (sym
, 0);
6612 len
= sym
->ts
.u
.cl
->backend_decl
;
6620 gfc_init_se (&argse
, se
);
6622 gfc_conv_expr (&argse
, arg
);
6624 gfc_conv_expr_descriptor (&argse
, arg
);
6625 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6626 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6627 len
= argse
.string_length
;
6630 se
->expr
= convert (type
, len
);
6633 /* The length of a character string not including trailing blanks. */
6635 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6637 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6638 tree args
[2], type
, fndecl
;
6640 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6641 type
= gfc_typenode_for_spec (&expr
->ts
);
6644 fndecl
= gfor_fndecl_string_len_trim
;
6646 fndecl
= gfor_fndecl_string_len_trim_char4
;
6650 se
->expr
= build_call_expr_loc (input_location
,
6651 fndecl
, 2, args
[0], args
[1]);
6652 se
->expr
= convert (type
, se
->expr
);
6656 /* Returns the starting position of a substring within a string. */
6659 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6662 tree logical4_type_node
= gfc_get_logical_type (4);
6666 unsigned int num_args
;
6668 args
= XALLOCAVEC (tree
, 5);
6670 /* Get number of arguments; characters count double due to the
6671 string length argument. Kind= is not passed to the library
6672 and thus ignored. */
6673 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6678 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6679 type
= gfc_typenode_for_spec (&expr
->ts
);
6682 args
[4] = build_int_cst (logical4_type_node
, 0);
6684 args
[4] = convert (logical4_type_node
, args
[4]);
6686 fndecl
= build_addr (function
);
6687 se
->expr
= build_call_array_loc (input_location
,
6688 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6690 se
->expr
= convert (type
, se
->expr
);
6694 /* The ascii value for a single character. */
6696 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6698 tree args
[3], type
, pchartype
;
6701 nargs
= gfc_intrinsic_argument_list_length (expr
);
6702 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6703 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6704 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6705 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6706 type
= gfc_typenode_for_spec (&expr
->ts
);
6708 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6710 se
->expr
= convert (type
, se
->expr
);
6714 /* Intrinsic ISNAN calls __builtin_isnan. */
6717 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6721 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6722 se
->expr
= build_call_expr_loc (input_location
,
6723 builtin_decl_explicit (BUILT_IN_ISNAN
),
6725 STRIP_TYPE_NOPS (se
->expr
);
6726 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6730 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6731 their argument against a constant integer value. */
6734 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6738 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6739 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6740 gfc_typenode_for_spec (&expr
->ts
),
6741 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6746 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6749 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
6757 unsigned int num_args
;
6759 num_args
= gfc_intrinsic_argument_list_length (expr
);
6760 args
= XALLOCAVEC (tree
, num_args
);
6762 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6763 if (expr
->ts
.type
!= BT_CHARACTER
)
6771 /* We do the same as in the non-character case, but the argument
6772 list is different because of the string length arguments. We
6773 also have to set the string length for the result. */
6780 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
6782 se
->string_length
= len
;
6784 type
= TREE_TYPE (tsource
);
6785 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
6786 fold_convert (type
, fsource
));
6790 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6793 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
6795 tree args
[3], mask
, type
;
6797 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6798 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
6800 type
= TREE_TYPE (args
[0]);
6801 gcc_assert (TREE_TYPE (args
[1]) == type
);
6802 gcc_assert (TREE_TYPE (mask
) == type
);
6804 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
6805 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
6806 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6808 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
6813 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6814 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6817 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
6819 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
6822 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6823 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6825 type
= gfc_get_int_type (expr
->ts
.kind
);
6826 utype
= unsigned_type_for (type
);
6828 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
6829 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
6831 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
6832 build_int_cst (utype
, 0));
6836 /* Left-justified mask. */
6837 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
6839 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6840 fold_convert (utype
, res
));
6842 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6843 smaller than type width. */
6844 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6845 build_int_cst (TREE_TYPE (arg
), 0));
6846 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
6847 build_int_cst (utype
, 0), res
);
6851 /* Right-justified mask. */
6852 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6853 fold_convert (utype
, arg
));
6854 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
6856 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6857 strictly smaller than type width. */
6858 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6860 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
6861 cond
, allones
, res
);
6864 se
->expr
= fold_convert (type
, res
);
6868 /* FRACTION (s) is translated into:
6869 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6871 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
6873 tree arg
, type
, tmp
, res
, frexp
, cond
;
6875 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6877 type
= gfc_typenode_for_spec (&expr
->ts
);
6878 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6879 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6881 cond
= build_call_expr_loc (input_location
,
6882 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6885 tmp
= gfc_create_var (integer_type_node
, NULL
);
6886 res
= build_call_expr_loc (input_location
, frexp
, 2,
6887 fold_convert (type
, arg
),
6888 gfc_build_addr_expr (NULL_TREE
, tmp
));
6889 res
= fold_convert (type
, res
);
6891 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
6892 cond
, res
, gfc_build_nan (type
, ""));
6896 /* NEAREST (s, dir) is translated into
6897 tmp = copysign (HUGE_VAL, dir);
6898 return nextafter (s, tmp);
6901 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
6903 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
6905 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
6906 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
6908 type
= gfc_typenode_for_spec (&expr
->ts
);
6909 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6911 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
6912 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
6913 fold_convert (type
, args
[1]));
6914 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
6915 fold_convert (type
, args
[0]), tmp
);
6916 se
->expr
= fold_convert (type
, se
->expr
);
6920 /* SPACING (s) is translated into
6930 e = MAX_EXPR (e, emin);
6931 res = scalbn (1., e);
6935 where prec is the precision of s, gfc_real_kinds[k].digits,
6936 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6937 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6940 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
6942 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
6943 tree cond
, nan
, tmp
, frexp
, scalbn
;
6947 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6948 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
6949 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
6950 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
6952 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6953 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6955 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6956 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6958 type
= gfc_typenode_for_spec (&expr
->ts
);
6959 e
= gfc_create_var (integer_type_node
, NULL
);
6960 res
= gfc_create_var (type
, NULL
);
6963 /* Build the block for s /= 0. */
6964 gfc_start_block (&block
);
6965 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6966 gfc_build_addr_expr (NULL_TREE
, e
));
6967 gfc_add_expr_to_block (&block
, tmp
);
6969 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
6971 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
6972 integer_type_node
, tmp
, emin
));
6974 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
6975 build_real_from_int_cst (type
, integer_one_node
), e
);
6976 gfc_add_modify (&block
, res
, tmp
);
6978 /* Finish by building the IF statement for value zero. */
6979 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6980 build_real_from_int_cst (type
, integer_zero_node
));
6981 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
6982 gfc_finish_block (&block
));
6984 /* And deal with infinities and NaNs. */
6985 cond
= build_call_expr_loc (input_location
,
6986 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6988 nan
= gfc_build_nan (type
, "");
6989 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
6991 gfc_add_expr_to_block (&se
->pre
, tmp
);
6996 /* RRSPACING (s) is translated into
7005 x = scalbn (x, precision - e);
7012 where precision is gfc_real_kinds[k].digits. */
7015 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
7017 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
7021 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
7022 prec
= gfc_real_kinds
[k
].digits
;
7024 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7025 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7026 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
7028 type
= gfc_typenode_for_spec (&expr
->ts
);
7029 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7030 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7032 e
= gfc_create_var (integer_type_node
, NULL
);
7033 x
= gfc_create_var (type
, NULL
);
7034 gfc_add_modify (&se
->pre
, x
,
7035 build_call_expr_loc (input_location
, fabs
, 1, arg
));
7038 gfc_start_block (&block
);
7039 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
7040 gfc_build_addr_expr (NULL_TREE
, e
));
7041 gfc_add_expr_to_block (&block
, tmp
);
7043 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
7044 build_int_cst (integer_type_node
, prec
), e
);
7045 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
7046 gfc_add_modify (&block
, x
, tmp
);
7047 stmt
= gfc_finish_block (&block
);
7050 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
7051 build_real_from_int_cst (type
, integer_zero_node
));
7052 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
7054 /* And deal with infinities and NaNs. */
7055 cond
= build_call_expr_loc (input_location
,
7056 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7058 nan
= gfc_build_nan (type
, "");
7059 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
7061 gfc_add_expr_to_block (&se
->pre
, tmp
);
7062 se
->expr
= fold_convert (type
, x
);
7066 /* SCALE (s, i) is translated into scalbn (s, i). */
7068 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
7070 tree args
[2], type
, scalbn
;
7072 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7074 type
= gfc_typenode_for_spec (&expr
->ts
);
7075 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7076 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
7077 fold_convert (type
, args
[0]),
7078 fold_convert (integer_type_node
, args
[1]));
7079 se
->expr
= fold_convert (type
, se
->expr
);
7083 /* SET_EXPONENT (s, i) is translated into
7084 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
7086 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
7088 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
7090 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
7091 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
7093 type
= gfc_typenode_for_spec (&expr
->ts
);
7094 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7095 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
7097 tmp
= gfc_create_var (integer_type_node
, NULL
);
7098 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
7099 fold_convert (type
, args
[0]),
7100 gfc_build_addr_expr (NULL_TREE
, tmp
));
7101 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
7102 fold_convert (integer_type_node
, args
[1]));
7103 res
= fold_convert (type
, res
);
7105 /* Call to isfinite */
7106 cond
= build_call_expr_loc (input_location
,
7107 builtin_decl_explicit (BUILT_IN_ISFINITE
),
7109 nan
= gfc_build_nan (type
, "");
7111 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
7117 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
7119 gfc_actual_arglist
*actual
;
7126 gfc_init_se (&argse
, NULL
);
7127 actual
= expr
->value
.function
.actual
;
7129 if (actual
->expr
->ts
.type
== BT_CLASS
)
7130 gfc_add_class_array_ref (actual
->expr
);
7132 argse
.data_not_needed
= 1;
7133 if (gfc_is_class_array_function (actual
->expr
))
7135 /* For functions that return a class array conv_expr_descriptor is not
7136 able to get the descriptor right. Therefore this special case. */
7137 gfc_conv_expr_reference (&argse
, actual
->expr
);
7138 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
7139 gfc_class_data_get (argse
.expr
));
7143 argse
.want_pointer
= 1;
7144 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
7146 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7147 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7148 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
7150 /* Build the call to size0. */
7151 fncall0
= build_call_expr_loc (input_location
,
7152 gfor_fndecl_size0
, 1, arg1
);
7154 actual
= actual
->next
;
7158 gfc_init_se (&argse
, NULL
);
7159 gfc_conv_expr_type (&argse
, actual
->expr
,
7160 gfc_array_index_type
);
7161 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7163 /* Unusually, for an intrinsic, size does not exclude
7164 an optional arg2, so we must test for it. */
7165 if (actual
->expr
->expr_type
== EXPR_VARIABLE
7166 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
7167 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
7170 /* Build the call to size1. */
7171 fncall1
= build_call_expr_loc (input_location
,
7172 gfor_fndecl_size1
, 2,
7175 gfc_init_se (&argse
, NULL
);
7176 argse
.want_pointer
= 1;
7177 argse
.data_not_needed
= 1;
7178 gfc_conv_expr (&argse
, actual
->expr
);
7179 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7180 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7181 argse
.expr
, null_pointer_node
);
7182 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
7183 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
7184 pvoid_type_node
, tmp
, fncall1
, fncall0
);
7188 se
->expr
= NULL_TREE
;
7189 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
7190 gfc_array_index_type
,
7191 argse
.expr
, gfc_index_one_node
);
7194 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
7196 argse
.expr
= gfc_index_zero_node
;
7197 se
->expr
= NULL_TREE
;
7202 if (se
->expr
== NULL_TREE
)
7204 tree ubound
, lbound
;
7206 arg1
= build_fold_indirect_ref_loc (input_location
,
7208 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
7209 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
7210 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
7211 gfc_array_index_type
, ubound
, lbound
);
7212 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
7213 gfc_array_index_type
,
7214 se
->expr
, gfc_index_one_node
);
7215 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7216 gfc_array_index_type
, se
->expr
,
7217 gfc_index_zero_node
);
7220 type
= gfc_typenode_for_spec (&expr
->ts
);
7221 se
->expr
= convert (type
, se
->expr
);
7225 /* Helper function to compute the size of a character variable,
7226 excluding the terminating null characters. The result has
7227 gfc_array_index_type type. */
7230 size_of_string_in_bytes (int kind
, tree string_length
)
7233 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
7235 bytesize
= build_int_cst (gfc_array_index_type
,
7236 gfc_character_kinds
[i
].bit_size
/ 8);
7238 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7240 fold_convert (gfc_array_index_type
, string_length
));
7245 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
7257 gfc_init_se (&argse
, NULL
);
7258 arg
= expr
->value
.function
.actual
->expr
;
7260 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
7261 gfc_conv_expr_descriptor (&argse
, arg
);
7263 gfc_conv_expr_reference (&argse
, arg
);
7265 if (arg
->ts
.type
== BT_ASSUMED
)
7267 /* This only works if an array descriptor has been passed; thus, extract
7268 the size from the descriptor. */
7269 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
7270 == TYPE_PRECISION (size_type_node
));
7271 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
7272 tmp
= DECL_LANG_SPECIFIC (tmp
)
7273 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
7274 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
7275 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
7276 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7278 tmp
= gfc_conv_descriptor_dtype (tmp
);
7279 field
= gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
7280 GFC_DTYPE_ELEM_LEN
);
7281 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7282 tmp
, field
, NULL_TREE
);
7284 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
7286 else if (arg
->ts
.type
== BT_CLASS
)
7288 /* Conv_expr_descriptor returns a component_ref to _data component of the
7289 class object. The class object may be a non-pointer object, e.g.
7290 located on the stack, or a memory location pointed to, e.g. a
7291 parameter, i.e., an indirect_ref. */
7293 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
7294 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
7295 && GFC_DECL_CLASS (TREE_OPERAND (
7296 TREE_OPERAND (argse
.expr
, 0), 0)))
7297 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
7298 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
7299 else if (arg
->rank
> 0
7301 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
7302 /* The scalarizer added an additional temp. To get the class' vptr
7303 one has to look at the original backend_decl. */
7304 byte_size
= gfc_class_vtab_size_get (
7305 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
7307 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
7311 if (arg
->ts
.type
== BT_CHARACTER
)
7312 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
7316 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7319 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7320 byte_size
= fold_convert (gfc_array_index_type
,
7321 size_in_bytes (byte_size
));
7326 se
->expr
= byte_size
;
7329 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
7330 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
7332 if (arg
->rank
== -1)
7334 tree cond
, loop_var
, exit_label
;
7337 tmp
= fold_convert (gfc_array_index_type
,
7338 gfc_conv_descriptor_rank (argse
.expr
));
7339 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
7340 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
7341 exit_label
= gfc_build_label_decl (NULL_TREE
);
7348 source_bytes = source_bytes * array.dim[i].extent;
7352 gfc_start_block (&body
);
7353 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
7355 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7356 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7357 cond
, tmp
, build_empty_stmt (input_location
));
7358 gfc_add_expr_to_block (&body
, tmp
);
7360 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
7361 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
7362 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
7363 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7364 gfc_array_index_type
, tmp
, source_bytes
);
7365 gfc_add_modify (&body
, source_bytes
, tmp
);
7367 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7368 gfc_array_index_type
, loop_var
,
7369 gfc_index_one_node
);
7370 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
7372 tmp
= gfc_finish_block (&body
);
7374 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
7376 gfc_add_expr_to_block (&argse
.pre
, tmp
);
7378 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7379 gfc_add_expr_to_block (&argse
.pre
, tmp
);
7383 /* Obtain the size of the array in bytes. */
7384 for (n
= 0; n
< arg
->rank
; n
++)
7387 idx
= gfc_rank_cst
[n
];
7388 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7389 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7390 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
7391 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7392 gfc_array_index_type
, tmp
, source_bytes
);
7393 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7396 se
->expr
= source_bytes
;
7399 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7404 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
7408 tree type
, result_type
, tmp
;
7410 arg
= expr
->value
.function
.actual
->expr
;
7412 gfc_init_se (&argse
, NULL
);
7413 result_type
= gfc_get_int_type (expr
->ts
.kind
);
7417 if (arg
->ts
.type
== BT_CLASS
)
7419 gfc_add_vptr_component (arg
);
7420 gfc_add_size_component (arg
);
7421 gfc_conv_expr (&argse
, arg
);
7422 tmp
= fold_convert (result_type
, argse
.expr
);
7426 gfc_conv_expr_reference (&argse
, arg
);
7427 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7432 argse
.want_pointer
= 0;
7433 gfc_conv_expr_descriptor (&argse
, arg
);
7434 if (arg
->ts
.type
== BT_CLASS
)
7437 tmp
= gfc_class_vtab_size_get (
7438 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
7440 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
7441 tmp
= fold_convert (result_type
, tmp
);
7444 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7447 /* Obtain the argument's word length. */
7448 if (arg
->ts
.type
== BT_CHARACTER
)
7449 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
7451 tmp
= size_in_bytes (type
);
7452 tmp
= fold_convert (result_type
, tmp
);
7455 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
7456 build_int_cst (result_type
, BITS_PER_UNIT
));
7457 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7461 /* Intrinsic string comparison functions. */
7464 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
7468 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
7471 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
7472 expr
->value
.function
.actual
->expr
->ts
.kind
,
7474 se
->expr
= fold_build2_loc (input_location
, op
,
7475 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
7476 build_int_cst (TREE_TYPE (se
->expr
), 0));
7479 /* Generate a call to the adjustl/adjustr library function. */
7481 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
7489 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
7492 type
= TREE_TYPE (args
[2]);
7493 var
= gfc_conv_string_tmp (se
, type
, len
);
7496 tmp
= build_call_expr_loc (input_location
,
7497 fndecl
, 3, args
[0], args
[1], args
[2]);
7498 gfc_add_expr_to_block (&se
->pre
, tmp
);
7500 se
->string_length
= len
;
7504 /* Generate code for the TRANSFER intrinsic:
7506 DEST = TRANSFER (SOURCE, MOLD)
7508 typeof<DEST> = typeof<MOLD>
7513 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
7515 typeof<DEST> = typeof<MOLD>
7517 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
7518 sizeof (DEST(0) * SIZE). */
7520 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
7536 tree class_ref
= NULL_TREE
;
7537 gfc_actual_arglist
*arg
;
7539 gfc_array_info
*info
;
7543 gfc_expr
*source_expr
, *mold_expr
, *class_expr
;
7547 info
= &se
->ss
->info
->data
.array
;
7549 /* Convert SOURCE. The output from this stage is:-
7550 source_bytes = length of the source in bytes
7551 source = pointer to the source data. */
7552 arg
= expr
->value
.function
.actual
;
7553 source_expr
= arg
->expr
;
7555 /* Ensure double transfer through LOGICAL preserves all
7557 if (arg
->expr
->expr_type
== EXPR_FUNCTION
7558 && arg
->expr
->value
.function
.esym
== NULL
7559 && arg
->expr
->value
.function
.isym
!= NULL
7560 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
7561 && arg
->expr
->ts
.type
== BT_LOGICAL
7562 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
7563 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
7565 gfc_init_se (&argse
, NULL
);
7567 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7569 /* Obtain the pointer to source and the length of source in bytes. */
7570 if (arg
->expr
->rank
== 0)
7572 gfc_conv_expr_reference (&argse
, arg
->expr
);
7573 if (arg
->expr
->ts
.type
== BT_CLASS
)
7575 tmp
= build_fold_indirect_ref_loc (input_location
, argse
.expr
);
7576 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
7577 source
= gfc_class_data_get (tmp
);
7580 /* Array elements are evaluated as a reference to the data.
7581 To obtain the vptr for the element size, the argument
7582 expression must be stripped to the class reference and
7583 re-evaluated. The pre and post blocks are not needed. */
7584 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
7585 source
= argse
.expr
;
7586 class_expr
= gfc_find_and_cut_at_last_class_ref (arg
->expr
);
7587 gfc_init_se (&argse
, NULL
);
7588 gfc_conv_expr (&argse
, class_expr
);
7589 class_ref
= argse
.expr
;
7593 source
= argse
.expr
;
7595 /* Obtain the source word length. */
7596 switch (arg
->expr
->ts
.type
)
7599 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7600 argse
.string_length
);
7603 if (class_ref
!= NULL_TREE
)
7604 tmp
= gfc_class_vtab_size_get (class_ref
);
7606 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7609 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7611 tmp
= fold_convert (gfc_array_index_type
,
7612 size_in_bytes (source_type
));
7618 argse
.want_pointer
= 0;
7619 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7620 source
= gfc_conv_descriptor_data_get (argse
.expr
);
7621 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7623 /* Repack the source if not simply contiguous. */
7624 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
7626 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
7628 if (warn_array_temporaries
)
7629 gfc_warning (OPT_Warray_temporaries
,
7630 "Creating array temporary at %L", &expr
->where
);
7632 source
= build_call_expr_loc (input_location
,
7633 gfor_fndecl_in_pack
, 1, tmp
);
7634 source
= gfc_evaluate_now (source
, &argse
.pre
);
7636 /* Free the temporary. */
7637 gfc_start_block (&block
);
7638 tmp
= gfc_call_free (source
);
7639 gfc_add_expr_to_block (&block
, tmp
);
7640 stmt
= gfc_finish_block (&block
);
7642 /* Clean up if it was repacked. */
7643 gfc_init_block (&block
);
7644 tmp
= gfc_conv_array_data (argse
.expr
);
7645 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7647 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7648 build_empty_stmt (input_location
));
7649 gfc_add_expr_to_block (&block
, tmp
);
7650 gfc_add_block_to_block (&block
, &se
->post
);
7651 gfc_init_block (&se
->post
);
7652 gfc_add_block_to_block (&se
->post
, &block
);
7655 /* Obtain the source word length. */
7656 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7657 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7658 argse
.string_length
);
7660 tmp
= fold_convert (gfc_array_index_type
,
7661 size_in_bytes (source_type
));
7663 /* Obtain the size of the array in bytes. */
7664 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7665 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7668 idx
= gfc_rank_cst
[n
];
7669 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7670 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7671 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7672 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7673 gfc_array_index_type
, upper
, lower
);
7674 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7675 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7676 gfc_array_index_type
, extent
,
7677 gfc_index_one_node
);
7678 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7679 gfc_array_index_type
, tmp
, source_bytes
);
7683 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7684 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7685 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7687 /* Now convert MOLD. The outputs are:
7688 mold_type = the TREE type of MOLD
7689 dest_word_len = destination word length in bytes. */
7691 mold_expr
= arg
->expr
;
7693 gfc_init_se (&argse
, NULL
);
7695 scalar_mold
= arg
->expr
->rank
== 0;
7697 if (arg
->expr
->rank
== 0)
7699 gfc_conv_expr_reference (&argse
, arg
->expr
);
7700 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7705 gfc_init_se (&argse
, NULL
);
7706 argse
.want_pointer
= 0;
7707 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7708 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7711 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7712 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7714 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7716 /* If this TRANSFER is nested in another TRANSFER, use a type
7717 that preserves all bits. */
7718 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7719 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7722 /* Obtain the destination word length. */
7723 switch (arg
->expr
->ts
.type
)
7726 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7727 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7730 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7733 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7736 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7737 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7739 /* Finally convert SIZE, if it is present. */
7741 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7745 gfc_init_se (&argse
, NULL
);
7746 gfc_conv_expr_reference (&argse
, arg
->expr
);
7747 tmp
= convert (gfc_array_index_type
,
7748 build_fold_indirect_ref_loc (input_location
,
7750 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7751 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7756 /* Separate array and scalar results. */
7757 if (scalar_mold
&& tmp
== NULL_TREE
)
7758 goto scalar_transfer
;
7760 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7761 if (tmp
!= NULL_TREE
)
7762 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7763 tmp
, dest_word_len
);
7767 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
7768 gfc_add_modify (&se
->pre
, size_words
,
7769 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
7770 gfc_array_index_type
,
7771 size_bytes
, dest_word_len
));
7773 /* Evaluate the bounds of the result. If the loop range exists, we have
7774 to check if it is too large. If so, we modify loop->to be consistent
7775 with min(size, size(source)). Otherwise, size is made consistent with
7776 the loop range, so that the right number of bytes is transferred.*/
7777 n
= se
->loop
->order
[0];
7778 if (se
->loop
->to
[n
] != NULL_TREE
)
7780 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7781 se
->loop
->to
[n
], se
->loop
->from
[n
]);
7782 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7783 tmp
, gfc_index_one_node
);
7784 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7786 gfc_add_modify (&se
->pre
, size_words
, tmp
);
7787 gfc_add_modify (&se
->pre
, size_bytes
,
7788 fold_build2_loc (input_location
, MULT_EXPR
,
7789 gfc_array_index_type
,
7790 size_words
, dest_word_len
));
7791 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7792 size_words
, se
->loop
->from
[n
]);
7793 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7794 upper
, gfc_index_one_node
);
7798 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7799 size_words
, gfc_index_one_node
);
7800 se
->loop
->from
[n
] = gfc_index_zero_node
;
7803 se
->loop
->to
[n
] = upper
;
7805 /* Build a destination descriptor, using the pointer, source, as the
7807 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
7808 NULL_TREE
, false, true, false, &expr
->where
);
7810 /* Cast the pointer to the result. */
7811 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7812 tmp
= fold_convert (pvoid_type_node
, tmp
);
7814 /* Use memcpy to do the transfer. */
7816 = build_call_expr_loc (input_location
,
7817 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
7818 fold_convert (pvoid_type_node
, source
),
7819 fold_convert (size_type_node
,
7820 fold_build2_loc (input_location
,
7822 gfc_array_index_type
,
7825 gfc_add_expr_to_block (&se
->pre
, tmp
);
7827 se
->expr
= info
->descriptor
;
7828 if (expr
->ts
.type
== BT_CHARACTER
)
7829 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7833 /* Deal with scalar results. */
7835 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7836 dest_word_len
, source_bytes
);
7837 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7838 extent
, gfc_index_zero_node
);
7840 if (expr
->ts
.type
== BT_CHARACTER
)
7842 tree direct
, indirect
, free
;
7844 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
7845 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
7848 /* If source is longer than the destination, use a pointer to
7849 the source directly. */
7850 gfc_init_block (&block
);
7851 gfc_add_modify (&block
, tmpdecl
, ptr
);
7852 direct
= gfc_finish_block (&block
);
7854 /* Otherwise, allocate a string with the length of the destination
7855 and copy the source into it. */
7856 gfc_init_block (&block
);
7857 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
7858 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
7859 gfc_add_modify (&block
, tmpdecl
,
7860 fold_convert (TREE_TYPE (ptr
), tmp
));
7861 tmp
= build_call_expr_loc (input_location
,
7862 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7863 fold_convert (pvoid_type_node
, tmpdecl
),
7864 fold_convert (pvoid_type_node
, ptr
),
7865 fold_convert (size_type_node
, extent
));
7866 gfc_add_expr_to_block (&block
, tmp
);
7867 indirect
= gfc_finish_block (&block
);
7869 /* Wrap it up with the condition. */
7870 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
7871 dest_word_len
, source_bytes
);
7872 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
7873 gfc_add_expr_to_block (&se
->pre
, tmp
);
7875 /* Free the temporary string, if necessary. */
7876 free
= gfc_call_free (tmpdecl
);
7877 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7878 dest_word_len
, source_bytes
);
7879 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
7880 gfc_add_expr_to_block (&se
->post
, tmp
);
7883 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7887 tmpdecl
= gfc_create_var (mold_type
, "transfer");
7889 ptr
= convert (build_pointer_type (mold_type
), source
);
7891 /* For CLASS results, allocate the needed memory first. */
7892 if (mold_expr
->ts
.type
== BT_CLASS
)
7895 cdata
= gfc_class_data_get (tmpdecl
);
7896 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
7897 gfc_add_modify (&se
->pre
, cdata
, tmp
);
7900 /* Use memcpy to do the transfer. */
7901 if (mold_expr
->ts
.type
== BT_CLASS
)
7902 tmp
= gfc_class_data_get (tmpdecl
);
7904 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
7906 tmp
= build_call_expr_loc (input_location
,
7907 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7908 fold_convert (pvoid_type_node
, tmp
),
7909 fold_convert (pvoid_type_node
, ptr
),
7910 fold_convert (size_type_node
, extent
));
7911 gfc_add_expr_to_block (&se
->pre
, tmp
);
7913 /* For CLASS results, set the _vptr. */
7914 if (mold_expr
->ts
.type
== BT_CLASS
)
7918 vptr
= gfc_class_vptr_get (tmpdecl
);
7919 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
7921 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7922 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
7930 /* Generate a call to caf_is_present. */
7933 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
7935 tree caf_reference
, caf_decl
, token
, image_index
;
7937 /* Compile the reference chain. */
7938 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
7939 gcc_assert (caf_reference
!= NULL_TREE
);
7941 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
7942 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
7943 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
7944 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
7945 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
7948 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
7949 3, token
, image_index
, caf_reference
);
7953 /* Test whether this ref-chain refs this image only. */
7956 caf_this_image_ref (gfc_ref
*ref
)
7958 for ( ; ref
; ref
= ref
->next
)
7959 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
7960 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
7966 /* Generate code for the ALLOCATED intrinsic.
7967 Generate inline code that directly check the address of the argument. */
7970 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
7972 gfc_actual_arglist
*arg1
;
7975 symbol_attribute caf_attr
;
7977 gfc_init_se (&arg1se
, NULL
);
7978 arg1
= expr
->value
.function
.actual
;
7980 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7982 /* Make sure that class array expressions have both a _data
7983 component reference and an array reference.... */
7984 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
7985 gfc_add_class_array_ref (arg1
->expr
);
7986 /* .... whilst scalars only need the _data component. */
7988 gfc_add_data_component (arg1
->expr
);
7991 /* When arg1 references an allocatable component in a coarray, then call
7992 the caf-library function caf_is_present (). */
7993 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
7994 && arg1
->expr
->value
.function
.isym
7995 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
7996 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
7998 gfc_clear_attr (&caf_attr
);
7999 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
8000 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
8001 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
8004 if (arg1
->expr
->rank
== 0)
8006 /* Allocatable scalar. */
8007 arg1se
.want_pointer
= 1;
8008 gfc_conv_expr (&arg1se
, arg1
->expr
);
8013 /* Allocatable array. */
8014 arg1se
.descriptor_only
= 1;
8015 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8016 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8019 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
8020 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
8023 /* Components of pointer array references sometimes come back with a pre block. */
8024 if (arg1se
.pre
.head
)
8025 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8027 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
8031 /* Generate code for the ASSOCIATED intrinsic.
8032 If both POINTER and TARGET are arrays, generate a call to library function
8033 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
8034 In other cases, generate inline code that directly compare the address of
8035 POINTER with the address of TARGET. */
8038 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
8040 gfc_actual_arglist
*arg1
;
8041 gfc_actual_arglist
*arg2
;
8046 tree nonzero_charlen
;
8047 tree nonzero_arraylen
;
8051 gfc_init_se (&arg1se
, NULL
);
8052 gfc_init_se (&arg2se
, NULL
);
8053 arg1
= expr
->value
.function
.actual
;
8056 /* Check whether the expression is a scalar or not; we cannot use
8057 arg1->expr->rank as it can be nonzero for proc pointers. */
8058 ss
= gfc_walk_expr (arg1
->expr
);
8059 scalar
= ss
== gfc_ss_terminator
;
8061 gfc_free_ss_chain (ss
);
8065 /* No optional target. */
8068 /* A pointer to a scalar. */
8069 arg1se
.want_pointer
= 1;
8070 gfc_conv_expr (&arg1se
, arg1
->expr
);
8071 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8072 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
8073 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
8075 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8077 tmp2
= gfc_class_data_get (arg1se
.expr
);
8078 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
8079 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
8086 /* A pointer to an array. */
8087 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8088 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
8090 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8091 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8092 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
8093 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
8098 /* An optional target. */
8099 if (arg2
->expr
->ts
.type
== BT_CLASS
)
8100 gfc_add_data_component (arg2
->expr
);
8102 nonzero_charlen
= NULL_TREE
;
8103 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
8104 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
8106 arg1
->expr
->ts
.u
.cl
->backend_decl
,
8108 (TREE_TYPE (arg1
->expr
->ts
.u
.cl
->backend_decl
)));
8111 /* A pointer to a scalar. */
8112 arg1se
.want_pointer
= 1;
8113 gfc_conv_expr (&arg1se
, arg1
->expr
);
8114 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8115 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
8116 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
8118 if (arg1
->expr
->ts
.type
== BT_CLASS
)
8119 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
8121 arg2se
.want_pointer
= 1;
8122 gfc_conv_expr (&arg2se
, arg2
->expr
);
8123 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8124 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
8125 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
8127 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8128 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8129 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8130 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8131 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8132 arg1se
.expr
, arg2se
.expr
);
8133 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8134 arg1se
.expr
, null_pointer_node
);
8135 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8136 logical_type_node
, tmp
, tmp2
);
8140 /* An array pointer of zero length is not associated if target is
8142 arg1se
.descriptor_only
= 1;
8143 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
8144 if (arg1
->expr
->rank
== -1)
8146 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
8147 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8148 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
8151 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
8152 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
8153 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
8154 logical_type_node
, tmp
,
8155 build_int_cst (TREE_TYPE (tmp
), 0));
8157 /* A pointer to an array, call library function _gfor_associated. */
8158 arg1se
.want_pointer
= 1;
8159 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
8160 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8161 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8163 arg2se
.want_pointer
= 1;
8164 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
8165 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8166 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8167 se
->expr
= build_call_expr_loc (input_location
,
8168 gfor_fndecl_associated
, 2,
8169 arg1se
.expr
, arg2se
.expr
);
8170 se
->expr
= convert (logical_type_node
, se
->expr
);
8171 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8172 logical_type_node
, se
->expr
,
8176 /* If target is present zero character length pointers cannot
8178 if (nonzero_charlen
!= NULL_TREE
)
8179 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8181 se
->expr
, nonzero_charlen
);
8184 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8188 /* Generate code for the SAME_TYPE_AS intrinsic.
8189 Generate inline code that directly checks the vindices. */
8192 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
8197 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
8199 gfc_init_se (&se1
, NULL
);
8200 gfc_init_se (&se2
, NULL
);
8202 a
= expr
->value
.function
.actual
->expr
;
8203 b
= expr
->value
.function
.actual
->next
->expr
;
8205 if (UNLIMITED_POLY (a
))
8207 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
8208 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8209 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
8212 if (UNLIMITED_POLY (b
))
8214 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
8215 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8216 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
8219 if (a
->ts
.type
== BT_CLASS
)
8221 gfc_add_vptr_component (a
);
8222 gfc_add_hash_component (a
);
8224 else if (a
->ts
.type
== BT_DERIVED
)
8225 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8226 a
->ts
.u
.derived
->hash_value
);
8228 if (b
->ts
.type
== BT_CLASS
)
8230 gfc_add_vptr_component (b
);
8231 gfc_add_hash_component (b
);
8233 else if (b
->ts
.type
== BT_DERIVED
)
8234 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8235 b
->ts
.u
.derived
->hash_value
);
8237 gfc_conv_expr (&se1
, a
);
8238 gfc_conv_expr (&se2
, b
);
8240 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
8241 logical_type_node
, se1
.expr
,
8242 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
8245 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
8246 logical_type_node
, conda
, tmp
);
8249 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
8250 logical_type_node
, condb
, tmp
);
8252 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
8256 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
8259 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
8263 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
8264 se
->expr
= build_call_expr_loc (input_location
,
8265 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
8266 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8270 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
8273 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
8277 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8279 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
8280 type
= gfc_get_int_type (4);
8281 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
8283 /* Convert it to the required type. */
8284 type
= gfc_typenode_for_spec (&expr
->ts
);
8285 se
->expr
= build_call_expr_loc (input_location
,
8286 gfor_fndecl_si_kind
, 1, arg
);
8287 se
->expr
= fold_convert (type
, se
->expr
);
8291 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
8294 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
8296 gfc_actual_arglist
*actual
;
8299 vec
<tree
, va_gc
> *args
= NULL
;
8301 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
8303 gfc_init_se (&argse
, se
);
8305 /* Pass a NULL pointer for an absent arg. */
8306 if (actual
->expr
== NULL
)
8307 argse
.expr
= null_pointer_node
;
8313 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
8315 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
8316 ts
.type
= BT_INTEGER
;
8317 ts
.kind
= gfc_c_int_kind
;
8318 gfc_convert_type (actual
->expr
, &ts
, 2);
8320 gfc_conv_expr_reference (&argse
, actual
->expr
);
8323 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8324 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8325 vec_safe_push (args
, argse
.expr
);
8328 /* Convert it to the required type. */
8329 type
= gfc_typenode_for_spec (&expr
->ts
);
8330 se
->expr
= build_call_expr_loc_vec (input_location
,
8331 gfor_fndecl_sr_kind
, args
);
8332 se
->expr
= fold_convert (type
, se
->expr
);
8336 /* Generate code for TRIM (A) intrinsic function. */
8339 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
8349 unsigned int num_args
;
8351 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
8352 args
= XALLOCAVEC (tree
, num_args
);
8354 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
8355 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
8356 len
= gfc_create_var (gfc_charlen_type_node
, "len");
8358 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
8359 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
8362 if (expr
->ts
.kind
== 1)
8363 function
= gfor_fndecl_string_trim
;
8364 else if (expr
->ts
.kind
== 4)
8365 function
= gfor_fndecl_string_trim_char4
;
8369 fndecl
= build_addr (function
);
8370 tmp
= build_call_array_loc (input_location
,
8371 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
8373 gfc_add_expr_to_block (&se
->pre
, tmp
);
8375 /* Free the temporary afterwards, if necessary. */
8376 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8377 len
, build_int_cst (TREE_TYPE (len
), 0));
8378 tmp
= gfc_call_free (var
);
8379 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
8380 gfc_add_expr_to_block (&se
->post
, tmp
);
8383 se
->string_length
= len
;
8387 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
8390 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
8392 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
8393 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
8395 stmtblock_t block
, body
;
8398 /* We store in charsize the size of a character. */
8399 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
8400 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
8402 /* Get the arguments. */
8403 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
8404 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
8406 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
8407 ncopies_type
= TREE_TYPE (ncopies
);
8409 /* Check that NCOPIES is not negative. */
8410 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
8411 build_int_cst (ncopies_type
, 0));
8412 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
8413 "Argument NCOPIES of REPEAT intrinsic is negative "
8414 "(its value is %ld)",
8415 fold_convert (long_integer_type_node
, ncopies
));
8417 /* If the source length is zero, any non negative value of NCOPIES
8418 is valid, and nothing happens. */
8419 n
= gfc_create_var (ncopies_type
, "ncopies");
8420 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
8422 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
8423 build_int_cst (ncopies_type
, 0), ncopies
);
8424 gfc_add_modify (&se
->pre
, n
, tmp
);
8427 /* Check that ncopies is not too large: ncopies should be less than
8428 (or equal to) MAX / slen, where MAX is the maximal integer of
8429 the gfc_charlen_type_node type. If slen == 0, we need a special
8430 case to avoid the division by zero. */
8431 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
8432 fold_convert (sizetype
,
8433 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
8435 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
8436 ? sizetype
: ncopies_type
;
8437 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8438 fold_convert (largest
, ncopies
),
8439 fold_convert (largest
, max
));
8440 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
8442 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
8443 logical_false_node
, cond
);
8444 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
8445 "Argument NCOPIES of REPEAT intrinsic is too large");
8447 /* Compute the destination length. */
8448 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
8449 fold_convert (gfc_charlen_type_node
, slen
),
8450 fold_convert (gfc_charlen_type_node
, ncopies
));
8451 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
8452 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
8454 /* Generate the code to do the repeat operation:
8455 for (i = 0; i < ncopies; i++)
8456 memmove (dest + (i * slen * size), src, slen*size); */
8457 gfc_start_block (&block
);
8458 count
= gfc_create_var (sizetype
, "count");
8459 gfc_add_modify (&block
, count
, size_zero_node
);
8460 exit_label
= gfc_build_label_decl (NULL_TREE
);
8462 /* Start the loop body. */
8463 gfc_start_block (&body
);
8465 /* Exit the loop if count >= ncopies. */
8466 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
8467 fold_convert (sizetype
, ncopies
));
8468 tmp
= build1_v (GOTO_EXPR
, exit_label
);
8469 TREE_USED (exit_label
) = 1;
8470 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
8471 build_empty_stmt (input_location
));
8472 gfc_add_expr_to_block (&body
, tmp
);
8474 /* Call memmove (dest + (i*slen*size), src, slen*size). */
8475 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
8477 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
8479 tmp
= fold_build_pointer_plus_loc (input_location
,
8480 fold_convert (pvoid_type_node
, dest
), tmp
);
8481 tmp
= build_call_expr_loc (input_location
,
8482 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
8484 fold_build2_loc (input_location
, MULT_EXPR
,
8485 size_type_node
, slen
, size
));
8486 gfc_add_expr_to_block (&body
, tmp
);
8488 /* Increment count. */
8489 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
8490 count
, size_one_node
);
8491 gfc_add_modify (&body
, count
, tmp
);
8493 /* Build the loop. */
8494 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
8495 gfc_add_expr_to_block (&block
, tmp
);
8497 /* Add the exit label. */
8498 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8499 gfc_add_expr_to_block (&block
, tmp
);
8501 /* Finish the block. */
8502 tmp
= gfc_finish_block (&block
);
8503 gfc_add_expr_to_block (&se
->pre
, tmp
);
8505 /* Set the result value. */
8507 se
->string_length
= dlen
;
8511 /* Generate code for the IARGC intrinsic. */
8514 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
8520 /* Call the library function. This always returns an INTEGER(4). */
8521 fndecl
= gfor_fndecl_iargc
;
8522 tmp
= build_call_expr_loc (input_location
,
8525 /* Convert it to the required type. */
8526 type
= gfc_typenode_for_spec (&expr
->ts
);
8527 tmp
= fold_convert (type
, tmp
);
8533 /* Generate code for the KILL intrinsic. */
8536 conv_intrinsic_kill (gfc_se
*se
, gfc_expr
*expr
)
8539 tree int4_type_node
= gfc_get_int_type (4);
8543 unsigned int num_args
;
8545 num_args
= gfc_intrinsic_argument_list_length (expr
);
8546 args
= XALLOCAVEC (tree
, num_args
);
8547 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
8549 /* Convert PID to a INTEGER(4) entity. */
8550 pid
= convert (int4_type_node
, args
[0]);
8552 /* Convert SIG to a INTEGER(4) entity. */
8553 sig
= convert (int4_type_node
, args
[1]);
8555 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill
, 2, pid
, sig
);
8557 se
->expr
= fold_convert (TREE_TYPE (args
[0]), tmp
);
8562 conv_intrinsic_kill_sub (gfc_code
*code
)
8566 tree int4_type_node
= gfc_get_int_type (4);
8572 /* Make the function call. */
8573 gfc_init_block (&block
);
8574 gfc_init_se (&se
, NULL
);
8576 /* Convert PID to a INTEGER(4) entity. */
8577 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
8578 gfc_add_block_to_block (&block
, &se
.pre
);
8579 pid
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
8580 gfc_add_block_to_block (&block
, &se
.post
);
8582 /* Convert SIG to a INTEGER(4) entity. */
8583 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
8584 gfc_add_block_to_block (&block
, &se
.pre
);
8585 sig
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
8586 gfc_add_block_to_block (&block
, &se
.post
);
8588 /* Deal with an optional STATUS. */
8589 if (code
->ext
.actual
->next
->next
->expr
)
8591 gfc_init_se (&se_stat
, NULL
);
8592 gfc_conv_expr (&se_stat
, code
->ext
.actual
->next
->next
->expr
);
8593 statp
= gfc_create_var (gfc_get_int_type (4), "_statp");
8598 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill_sub
, 3, pid
, sig
,
8599 statp
? gfc_build_addr_expr (NULL_TREE
, statp
) : null_pointer_node
);
8601 gfc_add_expr_to_block (&block
, tmp
);
8603 if (statp
&& statp
!= se_stat
.expr
)
8604 gfc_add_modify (&block
, se_stat
.expr
,
8605 fold_convert (TREE_TYPE (se_stat
.expr
), statp
));
8607 return gfc_finish_block (&block
);
8612 /* The loc intrinsic returns the address of its argument as
8613 gfc_index_integer_kind integer. */
8616 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
8621 gcc_assert (!se
->ss
);
8623 arg_expr
= expr
->value
.function
.actual
->expr
;
8624 if (arg_expr
->rank
== 0)
8626 if (arg_expr
->ts
.type
== BT_CLASS
)
8627 gfc_add_data_component (arg_expr
);
8628 gfc_conv_expr_reference (se
, arg_expr
);
8631 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
8632 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
8634 /* Create a temporary variable for loc return value. Without this,
8635 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
8636 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
8637 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
8638 se
->expr
= temp_var
;
8642 /* The following routine generates code for the intrinsic
8643 functions from the ISO_C_BINDING module:
8649 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
8651 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
8653 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
8655 if (arg
->expr
->rank
== 0)
8656 gfc_conv_expr_reference (se
, arg
->expr
);
8657 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
8658 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
8661 gfc_conv_expr_descriptor (se
, arg
->expr
);
8662 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
8665 /* TODO -- the following two lines shouldn't be necessary, but if
8666 they're removed, a bug is exposed later in the code path.
8667 This workaround was thus introduced, but will have to be
8668 removed; please see PR 35150 for details about the issue. */
8669 se
->expr
= convert (pvoid_type_node
, se
->expr
);
8670 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
8672 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
8673 gfc_conv_expr_reference (se
, arg
->expr
);
8674 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
8679 /* Build the addr_expr for the first argument. The argument is
8680 already an *address* so we don't need to set want_pointer in
8682 gfc_init_se (&arg1se
, NULL
);
8683 gfc_conv_expr (&arg1se
, arg
->expr
);
8684 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8685 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8687 /* See if we were given two arguments. */
8688 if (arg
->next
->expr
== NULL
)
8689 /* Only given one arg so generate a null and do a
8690 not-equal comparison against the first arg. */
8691 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8693 fold_convert (TREE_TYPE (arg1se
.expr
),
8694 null_pointer_node
));
8700 /* Given two arguments so build the arg2se from second arg. */
8701 gfc_init_se (&arg2se
, NULL
);
8702 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
8703 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8704 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8706 /* Generate test to compare that the two args are equal. */
8707 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8708 arg1se
.expr
, arg2se
.expr
);
8709 /* Generate test to ensure that the first arg is not null. */
8710 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
8712 arg1se
.expr
, null_pointer_node
);
8714 /* Finally, the generated test must check that both arg1 is not
8715 NULL and that it is equal to the second arg. */
8716 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8718 not_null_expr
, eq_expr
);
8726 /* The following routine generates code for the intrinsic
8727 subroutines from the ISO_C_BINDING module:
8729 * C_F_PROCPOINTER. */
8732 conv_isocbinding_subroutine (gfc_code
*code
)
8739 tree desc
, dim
, tmp
, stride
, offset
;
8740 stmtblock_t body
, block
;
8742 gfc_actual_arglist
*arg
= code
->ext
.actual
;
8744 gfc_init_se (&se
, NULL
);
8745 gfc_init_se (&cptrse
, NULL
);
8746 gfc_conv_expr (&cptrse
, arg
->expr
);
8747 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
8748 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
8750 gfc_init_se (&fptrse
, NULL
);
8751 if (arg
->next
->expr
->rank
== 0)
8753 fptrse
.want_pointer
= 1;
8754 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
8755 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
8756 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
8757 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8758 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
8759 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
8761 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8762 TREE_TYPE (fptrse
.expr
),
8764 fold_convert (TREE_TYPE (fptrse
.expr
),
8766 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
8767 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8768 return gfc_finish_block (&se
.pre
);
8771 gfc_start_block (&block
);
8773 /* Get the descriptor of the Fortran pointer. */
8774 fptrse
.descriptor_only
= 1;
8775 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
8776 gfc_add_block_to_block (&block
, &fptrse
.pre
);
8779 /* Set the span field. */
8780 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
8781 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8782 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
8784 /* Set data value, dtype, and offset. */
8785 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
8786 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
8787 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
8788 gfc_get_dtype (TREE_TYPE (desc
)));
8790 /* Start scalarization of the bounds, using the shape argument. */
8792 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
8793 gcc_assert (shape_ss
!= gfc_ss_terminator
);
8794 gfc_init_se (&shapese
, NULL
);
8796 gfc_init_loopinfo (&loop
);
8797 gfc_add_ss_to_loop (&loop
, shape_ss
);
8798 gfc_conv_ss_startstride (&loop
);
8799 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
8800 gfc_mark_ss_chain_used (shape_ss
, 1);
8802 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
8803 shapese
.ss
= shape_ss
;
8805 stride
= gfc_create_var (gfc_array_index_type
, "stride");
8806 offset
= gfc_create_var (gfc_array_index_type
, "offset");
8807 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
8808 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8811 gfc_start_scalarized_body (&loop
, &body
);
8813 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8814 loop
.loopvar
[0], loop
.from
[0]);
8816 /* Set bounds and stride. */
8817 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
8818 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
8820 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
8821 gfc_add_block_to_block (&body
, &shapese
.pre
);
8822 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
8823 gfc_add_block_to_block (&body
, &shapese
.post
);
8825 /* Calculate offset. */
8826 gfc_add_modify (&body
, offset
,
8827 fold_build2_loc (input_location
, PLUS_EXPR
,
8828 gfc_array_index_type
, offset
, stride
));
8829 /* Update stride. */
8830 gfc_add_modify (&body
, stride
,
8831 fold_build2_loc (input_location
, MULT_EXPR
,
8832 gfc_array_index_type
, stride
,
8833 fold_convert (gfc_array_index_type
,
8835 /* Finish scalarization loop. */
8836 gfc_trans_scalarizing_loops (&loop
, &body
);
8837 gfc_add_block_to_block (&block
, &loop
.pre
);
8838 gfc_add_block_to_block (&block
, &loop
.post
);
8839 gfc_add_block_to_block (&block
, &fptrse
.post
);
8840 gfc_cleanup_loop (&loop
);
8842 gfc_add_modify (&block
, offset
,
8843 fold_build1_loc (input_location
, NEGATE_EXPR
,
8844 gfc_array_index_type
, offset
));
8845 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
8847 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
8848 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8849 return gfc_finish_block (&se
.pre
);
8853 /* Save and restore floating-point state. */
8856 gfc_save_fp_state (stmtblock_t
*block
)
8858 tree type
, fpstate
, tmp
;
8860 type
= build_array_type (char_type_node
,
8861 build_range_type (size_type_node
, size_zero_node
,
8862 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
8863 fpstate
= gfc_create_var (type
, "fpstate");
8864 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
8866 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
8868 gfc_add_expr_to_block (block
, tmp
);
8875 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
8879 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
8881 gfc_add_expr_to_block (block
, tmp
);
8885 /* Generate code for arguments of IEEE functions. */
8888 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
8891 gfc_actual_arglist
*actual
;
8896 actual
= expr
->value
.function
.actual
;
8897 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
8899 gcc_assert (actual
);
8902 gfc_init_se (&argse
, se
);
8903 gfc_conv_expr_val (&argse
, e
);
8905 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8906 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8907 argarray
[arg
] = argse
.expr
;
8912 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8913 and IEEE_UNORDERED, which translate directly to GCC type-generic
8917 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
8918 enum built_in_function code
, int nargs
)
8921 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
8923 conv_ieee_function_args (se
, expr
, args
, nargs
);
8924 se
->expr
= build_call_expr_loc_array (input_location
,
8925 builtin_decl_explicit (code
),
8927 STRIP_TYPE_NOPS (se
->expr
);
8928 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8932 /* Generate code for IEEE_IS_NORMAL intrinsic:
8933 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8936 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
8938 tree arg
, isnormal
, iszero
;
8940 /* Convert arg, evaluate it only once. */
8941 conv_ieee_function_args (se
, expr
, &arg
, 1);
8942 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8944 isnormal
= build_call_expr_loc (input_location
,
8945 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
8947 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
8948 build_real_from_int_cst (TREE_TYPE (arg
),
8949 integer_zero_node
));
8950 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8951 logical_type_node
, isnormal
, iszero
);
8952 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8956 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8957 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8960 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
8962 tree arg
, signbit
, isnan
;
8964 /* Convert arg, evaluate it only once. */
8965 conv_ieee_function_args (se
, expr
, &arg
, 1);
8966 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8968 isnan
= build_call_expr_loc (input_location
,
8969 builtin_decl_explicit (BUILT_IN_ISNAN
),
8971 STRIP_TYPE_NOPS (isnan
);
8973 signbit
= build_call_expr_loc (input_location
,
8974 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8976 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8977 signbit
, integer_zero_node
);
8979 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8980 logical_type_node
, signbit
,
8981 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
8982 TREE_TYPE(isnan
), isnan
));
8984 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8988 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8991 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
8992 enum built_in_function code
)
8994 tree arg
, decl
, call
, fpstate
;
8997 conv_ieee_function_args (se
, expr
, &arg
, 1);
8998 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
8999 decl
= builtin_decl_for_precision (code
, argprec
);
9001 /* Save floating-point state. */
9002 fpstate
= gfc_save_fp_state (&se
->pre
);
9004 /* Make the function call. */
9005 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
9006 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
9008 /* Restore floating-point state. */
9009 gfc_restore_fp_state (&se
->post
, fpstate
);
9013 /* Generate code for IEEE_REM. */
9016 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
9018 tree args
[2], decl
, call
, fpstate
;
9021 conv_ieee_function_args (se
, expr
, args
, 2);
9023 /* If arguments have unequal size, convert them to the larger. */
9024 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
9025 > TYPE_PRECISION (TREE_TYPE (args
[1])))
9026 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
9027 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
9028 > TYPE_PRECISION (TREE_TYPE (args
[0])))
9029 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
9031 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9032 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
9034 /* Save floating-point state. */
9035 fpstate
= gfc_save_fp_state (&se
->pre
);
9037 /* Make the function call. */
9038 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9039 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9041 /* Restore floating-point state. */
9042 gfc_restore_fp_state (&se
->post
, fpstate
);
9046 /* Generate code for IEEE_NEXT_AFTER. */
9049 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
9051 tree args
[2], decl
, call
, fpstate
;
9054 conv_ieee_function_args (se
, expr
, args
, 2);
9056 /* Result has the characteristics of first argument. */
9057 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
9058 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9059 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
9061 /* Save floating-point state. */
9062 fpstate
= gfc_save_fp_state (&se
->pre
);
9064 /* Make the function call. */
9065 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9066 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9068 /* Restore floating-point state. */
9069 gfc_restore_fp_state (&se
->post
, fpstate
);
9073 /* Generate code for IEEE_SCALB. */
9076 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
9078 tree args
[2], decl
, call
, huge
, type
;
9081 conv_ieee_function_args (se
, expr
, args
, 2);
9083 /* Result has the characteristics of first argument. */
9084 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9085 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
9087 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
9089 /* We need to fold the integer into the range of a C int. */
9090 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
9091 type
= TREE_TYPE (args
[1]);
9093 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
9094 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
9096 huge
= fold_convert (type
, huge
);
9097 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
9099 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
9100 fold_build1_loc (input_location
, NEGATE_EXPR
,
9104 args
[1] = fold_convert (integer_type_node
, args
[1]);
9106 /* Make the function call. */
9107 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9108 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
9112 /* Generate code for IEEE_COPY_SIGN. */
9115 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
9117 tree args
[2], decl
, sign
;
9120 conv_ieee_function_args (se
, expr
, args
, 2);
9122 /* Get the sign of the second argument. */
9123 sign
= build_call_expr_loc (input_location
,
9124 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
9126 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9127 sign
, integer_zero_node
);
9129 /* Create a value of one, with the right sign. */
9130 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
9132 fold_build1_loc (input_location
, NEGATE_EXPR
,
9136 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
9138 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
9139 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
9141 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
9145 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
9149 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
9151 const char *name
= expr
->value
.function
.name
;
9153 if (gfc_str_startswith (name
, "_gfortran_ieee_is_nan"))
9154 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
9155 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_finite"))
9156 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
9157 else if (gfc_str_startswith (name
, "_gfortran_ieee_unordered"))
9158 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
9159 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_normal"))
9160 conv_intrinsic_ieee_is_normal (se
, expr
);
9161 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_negative"))
9162 conv_intrinsic_ieee_is_negative (se
, expr
);
9163 else if (gfc_str_startswith (name
, "_gfortran_ieee_copy_sign"))
9164 conv_intrinsic_ieee_copy_sign (se
, expr
);
9165 else if (gfc_str_startswith (name
, "_gfortran_ieee_scalb"))
9166 conv_intrinsic_ieee_scalb (se
, expr
);
9167 else if (gfc_str_startswith (name
, "_gfortran_ieee_next_after"))
9168 conv_intrinsic_ieee_next_after (se
, expr
);
9169 else if (gfc_str_startswith (name
, "_gfortran_ieee_rem"))
9170 conv_intrinsic_ieee_rem (se
, expr
);
9171 else if (gfc_str_startswith (name
, "_gfortran_ieee_logb"))
9172 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
9173 else if (gfc_str_startswith (name
, "_gfortran_ieee_rint"))
9174 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
9176 /* It is not among the functions we translate directly. We return
9177 false, so a library function call is emitted. */
9184 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
9187 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
9189 tree arg
, res
, restype
;
9191 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
9192 arg
= fold_convert (size_type_node
, arg
);
9193 res
= build_call_expr_loc (input_location
,
9194 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
9195 restype
= gfc_typenode_for_spec (&expr
->ts
);
9196 se
->expr
= fold_convert (restype
, res
);
9200 /* Generate code for an intrinsic function. Some map directly to library
9201 calls, others get special handling. In some cases the name of the function
9202 used depends on the type specifiers. */
9205 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
9211 name
= &expr
->value
.function
.name
[2];
9215 lib
= gfc_is_intrinsic_libcall (expr
);
9219 se
->ignore_optional
= 1;
9221 switch (expr
->value
.function
.isym
->id
)
9223 case GFC_ISYM_EOSHIFT
:
9225 case GFC_ISYM_RESHAPE
:
9226 /* For all of those the first argument specifies the type and the
9227 third is optional. */
9228 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
9231 case GFC_ISYM_FINDLOC
:
9232 gfc_conv_intrinsic_findloc (se
, expr
);
9235 case GFC_ISYM_MINLOC
:
9236 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9239 case GFC_ISYM_MAXLOC
:
9240 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9243 case GFC_ISYM_SHAPE
:
9244 gfc_conv_intrinsic_shape (se
, expr
);
9248 gfc_conv_intrinsic_funcall (se
, expr
);
9256 switch (expr
->value
.function
.isym
->id
)
9261 case GFC_ISYM_REPEAT
:
9262 gfc_conv_intrinsic_repeat (se
, expr
);
9266 gfc_conv_intrinsic_trim (se
, expr
);
9269 case GFC_ISYM_SC_KIND
:
9270 gfc_conv_intrinsic_sc_kind (se
, expr
);
9273 case GFC_ISYM_SI_KIND
:
9274 gfc_conv_intrinsic_si_kind (se
, expr
);
9277 case GFC_ISYM_SR_KIND
:
9278 gfc_conv_intrinsic_sr_kind (se
, expr
);
9281 case GFC_ISYM_EXPONENT
:
9282 gfc_conv_intrinsic_exponent (se
, expr
);
9286 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9288 fndecl
= gfor_fndecl_string_scan
;
9290 fndecl
= gfor_fndecl_string_scan_char4
;
9294 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9297 case GFC_ISYM_VERIFY
:
9298 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9300 fndecl
= gfor_fndecl_string_verify
;
9302 fndecl
= gfor_fndecl_string_verify_char4
;
9306 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9309 case GFC_ISYM_ALLOCATED
:
9310 gfc_conv_allocated (se
, expr
);
9313 case GFC_ISYM_ASSOCIATED
:
9314 gfc_conv_associated(se
, expr
);
9317 case GFC_ISYM_SAME_TYPE_AS
:
9318 gfc_conv_same_type_as (se
, expr
);
9322 gfc_conv_intrinsic_abs (se
, expr
);
9325 case GFC_ISYM_ADJUSTL
:
9326 if (expr
->ts
.kind
== 1)
9327 fndecl
= gfor_fndecl_adjustl
;
9328 else if (expr
->ts
.kind
== 4)
9329 fndecl
= gfor_fndecl_adjustl_char4
;
9333 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
9336 case GFC_ISYM_ADJUSTR
:
9337 if (expr
->ts
.kind
== 1)
9338 fndecl
= gfor_fndecl_adjustr
;
9339 else if (expr
->ts
.kind
== 4)
9340 fndecl
= gfor_fndecl_adjustr_char4
;
9344 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
9347 case GFC_ISYM_AIMAG
:
9348 gfc_conv_intrinsic_imagpart (se
, expr
);
9352 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
9356 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
9359 case GFC_ISYM_ANINT
:
9360 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
9364 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
9368 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
9371 case GFC_ISYM_BTEST
:
9372 gfc_conv_intrinsic_btest (se
, expr
);
9376 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
9380 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
9384 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
9388 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
9391 case GFC_ISYM_C_ASSOCIATED
:
9392 case GFC_ISYM_C_FUNLOC
:
9393 case GFC_ISYM_C_LOC
:
9394 conv_isocbinding_function (se
, expr
);
9397 case GFC_ISYM_ACHAR
:
9399 gfc_conv_intrinsic_char (se
, expr
);
9402 case GFC_ISYM_CONVERSION
:
9404 case GFC_ISYM_LOGICAL
:
9406 gfc_conv_intrinsic_conversion (se
, expr
);
9409 /* Integer conversions are handled separately to make sure we get the
9410 correct rounding mode. */
9415 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
9419 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
9422 case GFC_ISYM_CEILING
:
9423 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
9426 case GFC_ISYM_FLOOR
:
9427 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
9431 gfc_conv_intrinsic_mod (se
, expr
, 0);
9434 case GFC_ISYM_MODULO
:
9435 gfc_conv_intrinsic_mod (se
, expr
, 1);
9438 case GFC_ISYM_CAF_GET
:
9439 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9443 case GFC_ISYM_CMPLX
:
9444 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
9447 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
9448 gfc_conv_intrinsic_iargc (se
, expr
);
9451 case GFC_ISYM_COMPLEX
:
9452 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
9455 case GFC_ISYM_CONJG
:
9456 gfc_conv_intrinsic_conjg (se
, expr
);
9459 case GFC_ISYM_COUNT
:
9460 gfc_conv_intrinsic_count (se
, expr
);
9463 case GFC_ISYM_CTIME
:
9464 gfc_conv_intrinsic_ctime (se
, expr
);
9468 gfc_conv_intrinsic_dim (se
, expr
);
9471 case GFC_ISYM_DOT_PRODUCT
:
9472 gfc_conv_intrinsic_dot_product (se
, expr
);
9475 case GFC_ISYM_DPROD
:
9476 gfc_conv_intrinsic_dprod (se
, expr
);
9479 case GFC_ISYM_DSHIFTL
:
9480 gfc_conv_intrinsic_dshift (se
, expr
, true);
9483 case GFC_ISYM_DSHIFTR
:
9484 gfc_conv_intrinsic_dshift (se
, expr
, false);
9487 case GFC_ISYM_FDATE
:
9488 gfc_conv_intrinsic_fdate (se
, expr
);
9491 case GFC_ISYM_FRACTION
:
9492 gfc_conv_intrinsic_fraction (se
, expr
);
9496 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
9500 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
9504 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
9507 case GFC_ISYM_IBCLR
:
9508 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
9511 case GFC_ISYM_IBITS
:
9512 gfc_conv_intrinsic_ibits (se
, expr
);
9515 case GFC_ISYM_IBSET
:
9516 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
9519 case GFC_ISYM_IACHAR
:
9520 case GFC_ISYM_ICHAR
:
9521 /* We assume ASCII character sequence. */
9522 gfc_conv_intrinsic_ichar (se
, expr
);
9525 case GFC_ISYM_IARGC
:
9526 gfc_conv_intrinsic_iargc (se
, expr
);
9530 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9533 case GFC_ISYM_INDEX
:
9534 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9536 fndecl
= gfor_fndecl_string_index
;
9538 fndecl
= gfor_fndecl_string_index_char4
;
9542 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9546 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9549 case GFC_ISYM_IPARITY
:
9550 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
9553 case GFC_ISYM_IS_IOSTAT_END
:
9554 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
9557 case GFC_ISYM_IS_IOSTAT_EOR
:
9558 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
9561 case GFC_ISYM_ISNAN
:
9562 gfc_conv_intrinsic_isnan (se
, expr
);
9566 conv_intrinsic_kill (se
, expr
);
9569 case GFC_ISYM_LSHIFT
:
9570 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9573 case GFC_ISYM_RSHIFT
:
9574 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9577 case GFC_ISYM_SHIFTA
:
9578 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9581 case GFC_ISYM_SHIFTL
:
9582 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9585 case GFC_ISYM_SHIFTR
:
9586 gfc_conv_intrinsic_shift (se
, expr
, true, false);
9589 case GFC_ISYM_ISHFT
:
9590 gfc_conv_intrinsic_ishft (se
, expr
);
9593 case GFC_ISYM_ISHFTC
:
9594 gfc_conv_intrinsic_ishftc (se
, expr
);
9597 case GFC_ISYM_LEADZ
:
9598 gfc_conv_intrinsic_leadz (se
, expr
);
9601 case GFC_ISYM_TRAILZ
:
9602 gfc_conv_intrinsic_trailz (se
, expr
);
9605 case GFC_ISYM_POPCNT
:
9606 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
9609 case GFC_ISYM_POPPAR
:
9610 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
9613 case GFC_ISYM_LBOUND
:
9614 gfc_conv_intrinsic_bound (se
, expr
, 0);
9617 case GFC_ISYM_LCOBOUND
:
9618 conv_intrinsic_cobound (se
, expr
);
9621 case GFC_ISYM_TRANSPOSE
:
9622 /* The scalarizer has already been set up for reversed dimension access
9623 order ; now we just get the argument value normally. */
9624 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
9628 gfc_conv_intrinsic_len (se
, expr
);
9631 case GFC_ISYM_LEN_TRIM
:
9632 gfc_conv_intrinsic_len_trim (se
, expr
);
9636 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
9640 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
9644 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
9648 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
9651 case GFC_ISYM_MALLOC
:
9652 gfc_conv_intrinsic_malloc (se
, expr
);
9655 case GFC_ISYM_MASKL
:
9656 gfc_conv_intrinsic_mask (se
, expr
, 1);
9659 case GFC_ISYM_MASKR
:
9660 gfc_conv_intrinsic_mask (se
, expr
, 0);
9664 if (expr
->ts
.type
== BT_CHARACTER
)
9665 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
9667 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
9670 case GFC_ISYM_MAXLOC
:
9671 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9674 case GFC_ISYM_FINDLOC
:
9675 gfc_conv_intrinsic_findloc (se
, expr
);
9678 case GFC_ISYM_MAXVAL
:
9679 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
9682 case GFC_ISYM_MERGE
:
9683 gfc_conv_intrinsic_merge (se
, expr
);
9686 case GFC_ISYM_MERGE_BITS
:
9687 gfc_conv_intrinsic_merge_bits (se
, expr
);
9691 if (expr
->ts
.type
== BT_CHARACTER
)
9692 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
9694 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
9697 case GFC_ISYM_MINLOC
:
9698 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9701 case GFC_ISYM_MINVAL
:
9702 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
9705 case GFC_ISYM_NEAREST
:
9706 gfc_conv_intrinsic_nearest (se
, expr
);
9709 case GFC_ISYM_NORM2
:
9710 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
9714 gfc_conv_intrinsic_not (se
, expr
);
9718 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9721 case GFC_ISYM_PARITY
:
9722 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
9725 case GFC_ISYM_PRESENT
:
9726 gfc_conv_intrinsic_present (se
, expr
);
9729 case GFC_ISYM_PRODUCT
:
9730 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
9734 gfc_conv_intrinsic_rank (se
, expr
);
9737 case GFC_ISYM_RRSPACING
:
9738 gfc_conv_intrinsic_rrspacing (se
, expr
);
9741 case GFC_ISYM_SET_EXPONENT
:
9742 gfc_conv_intrinsic_set_exponent (se
, expr
);
9745 case GFC_ISYM_SCALE
:
9746 gfc_conv_intrinsic_scale (se
, expr
);
9750 gfc_conv_intrinsic_sign (se
, expr
);
9754 gfc_conv_intrinsic_size (se
, expr
);
9757 case GFC_ISYM_SIZEOF
:
9758 case GFC_ISYM_C_SIZEOF
:
9759 gfc_conv_intrinsic_sizeof (se
, expr
);
9762 case GFC_ISYM_STORAGE_SIZE
:
9763 gfc_conv_intrinsic_storage_size (se
, expr
);
9766 case GFC_ISYM_SPACING
:
9767 gfc_conv_intrinsic_spacing (se
, expr
);
9770 case GFC_ISYM_STRIDE
:
9771 conv_intrinsic_stride (se
, expr
);
9775 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
9778 case GFC_ISYM_TEAM_NUMBER
:
9779 conv_intrinsic_team_number (se
, expr
);
9782 case GFC_ISYM_TRANSFER
:
9783 if (se
->ss
&& se
->ss
->info
->useflags
)
9784 /* Access the previously obtained result. */
9785 gfc_conv_tmp_array_ref (se
);
9787 gfc_conv_intrinsic_transfer (se
, expr
);
9790 case GFC_ISYM_TTYNAM
:
9791 gfc_conv_intrinsic_ttynam (se
, expr
);
9794 case GFC_ISYM_UBOUND
:
9795 gfc_conv_intrinsic_bound (se
, expr
, 1);
9798 case GFC_ISYM_UCOBOUND
:
9799 conv_intrinsic_cobound (se
, expr
);
9803 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9807 gfc_conv_intrinsic_loc (se
, expr
);
9810 case GFC_ISYM_THIS_IMAGE
:
9811 /* For num_images() == 1, handle as LCOBOUND. */
9812 if (expr
->value
.function
.actual
->expr
9813 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
9814 conv_intrinsic_cobound (se
, expr
);
9816 trans_this_image (se
, expr
);
9819 case GFC_ISYM_IMAGE_INDEX
:
9820 trans_image_index (se
, expr
);
9823 case GFC_ISYM_IMAGE_STATUS
:
9824 conv_intrinsic_image_status (se
, expr
);
9827 case GFC_ISYM_NUM_IMAGES
:
9828 trans_num_images (se
, expr
);
9831 case GFC_ISYM_ACCESS
:
9832 case GFC_ISYM_CHDIR
:
9833 case GFC_ISYM_CHMOD
:
9834 case GFC_ISYM_DTIME
:
9835 case GFC_ISYM_ETIME
:
9836 case GFC_ISYM_EXTENDS_TYPE_OF
:
9838 case GFC_ISYM_FGETC
:
9841 case GFC_ISYM_FPUTC
:
9842 case GFC_ISYM_FSTAT
:
9843 case GFC_ISYM_FTELL
:
9844 case GFC_ISYM_GETCWD
:
9845 case GFC_ISYM_GETGID
:
9846 case GFC_ISYM_GETPID
:
9847 case GFC_ISYM_GETUID
:
9848 case GFC_ISYM_HOSTNM
:
9849 case GFC_ISYM_IERRNO
:
9850 case GFC_ISYM_IRAND
:
9851 case GFC_ISYM_ISATTY
:
9854 case GFC_ISYM_LSTAT
:
9855 case GFC_ISYM_MATMUL
:
9856 case GFC_ISYM_MCLOCK
:
9857 case GFC_ISYM_MCLOCK8
:
9859 case GFC_ISYM_RENAME
:
9860 case GFC_ISYM_SECOND
:
9861 case GFC_ISYM_SECNDS
:
9862 case GFC_ISYM_SIGNAL
:
9864 case GFC_ISYM_SYMLNK
:
9865 case GFC_ISYM_SYSTEM
:
9867 case GFC_ISYM_TIME8
:
9868 case GFC_ISYM_UMASK
:
9869 case GFC_ISYM_UNLINK
:
9871 gfc_conv_intrinsic_funcall (se
, expr
);
9874 case GFC_ISYM_EOSHIFT
:
9876 case GFC_ISYM_RESHAPE
:
9877 /* For those, expr->rank should always be >0 and thus the if above the
9878 switch should have matched. */
9883 gfc_conv_intrinsic_lib_function (se
, expr
);
9890 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
9892 gfc_ss
*arg_ss
, *tmp_ss
;
9893 gfc_actual_arglist
*arg
;
9895 arg
= expr
->value
.function
.actual
;
9897 gcc_assert (arg
->expr
);
9899 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
9900 gcc_assert (arg_ss
!= gfc_ss_terminator
);
9902 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
9904 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
9905 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
9907 gcc_assert (tmp_ss
->dimen
== 2);
9909 /* We just invert dimensions. */
9910 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
9913 /* Stop when tmp_ss points to the last valid element of the chain... */
9914 if (tmp_ss
->next
== gfc_ss_terminator
)
9918 /* ... so that we can attach the rest of the chain to it. */
9925 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9926 This has the side effect of reversing the nested list, so there is no
9927 need to call gfc_reverse_ss on it (the given list is assumed not to be
9931 nest_loop_dimension (gfc_ss
*ss
, int dim
)
9934 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
9935 gfc_loopinfo
*new_loop
;
9937 gcc_assert (ss
!= gfc_ss_terminator
);
9939 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
9941 new_ss
= gfc_get_ss ();
9942 new_ss
->next
= prev_ss
;
9943 new_ss
->parent
= ss
;
9944 new_ss
->info
= ss
->info
;
9945 new_ss
->info
->refcount
++;
9948 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
9949 && ss
->info
->type
!= GFC_SS_REFERENCE
);
9952 new_ss
->dim
[0] = ss
->dim
[dim
];
9954 gcc_assert (dim
< ss
->dimen
);
9956 ss_dim
= --ss
->dimen
;
9957 for (i
= dim
; i
< ss_dim
; i
++)
9958 ss
->dim
[i
] = ss
->dim
[i
+ 1];
9960 ss
->dim
[ss_dim
] = 0;
9966 ss
->nested_ss
->parent
= new_ss
;
9967 new_ss
->nested_ss
= ss
->nested_ss
;
9969 ss
->nested_ss
= new_ss
;
9972 new_loop
= gfc_get_loopinfo ();
9973 gfc_init_loopinfo (new_loop
);
9975 gcc_assert (prev_ss
!= NULL
);
9976 gcc_assert (prev_ss
!= gfc_ss_terminator
);
9977 gfc_add_ss_to_loop (new_loop
, prev_ss
);
9978 return new_ss
->parent
;
9982 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9983 is to be inlined. */
9986 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
9988 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
9989 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
9991 bool scalar_mask
= false;
9993 /* The rank of the result will be determined later. */
9994 arg1
= expr
->value
.function
.actual
;
9997 gcc_assert (arg3
!= NULL
);
9999 if (expr
->rank
== 0)
10002 tmp_ss
= gfc_ss_terminator
;
10008 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
10009 if (mask_ss
== tmp_ss
)
10015 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
10016 gcc_assert (array_ss
!= tmp_ss
);
10018 /* Odd thing: If the mask is scalar, it is used by the frontend after
10019 the array (to make an if around the nested loop). Thus it shall
10020 be after array_ss once the gfc_ss list is reversed. */
10022 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
10026 /* "Hide" the dimension on which we will sum in the first arg's scalarization
10028 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
10029 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
10037 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
10040 switch (expr
->value
.function
.isym
->id
)
10042 case GFC_ISYM_PRODUCT
:
10044 return walk_inline_intrinsic_arith (ss
, expr
);
10046 case GFC_ISYM_TRANSPOSE
:
10047 return walk_inline_intrinsic_transpose (ss
, expr
);
10050 gcc_unreachable ();
10052 gcc_unreachable ();
10056 /* This generates code to execute before entering the scalarization loop.
10057 Currently does nothing. */
10060 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
10062 switch (ss
->info
->expr
->value
.function
.isym
->id
)
10064 case GFC_ISYM_UBOUND
:
10065 case GFC_ISYM_LBOUND
:
10066 case GFC_ISYM_UCOBOUND
:
10067 case GFC_ISYM_LCOBOUND
:
10068 case GFC_ISYM_THIS_IMAGE
:
10072 gcc_unreachable ();
10077 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
10078 are expanded into code inside the scalarization loop. */
10081 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
10083 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
10084 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
10086 /* The two argument version returns a scalar. */
10087 if (expr
->value
.function
.actual
->next
->expr
)
10090 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
10094 /* Walk an intrinsic array libcall. */
10097 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
10099 gcc_assert (expr
->rank
> 0);
10100 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
10104 /* Return whether the function call expression EXPR will be expanded
10105 inline by gfc_conv_intrinsic_function. */
10108 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
10110 gfc_actual_arglist
*args
;
10112 if (!expr
->value
.function
.isym
)
10115 switch (expr
->value
.function
.isym
->id
)
10117 case GFC_ISYM_PRODUCT
:
10119 /* Disable inline expansion if code size matters. */
10123 args
= expr
->value
.function
.actual
;
10124 /* We need to be able to subset the SUM argument at compile-time. */
10125 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
10130 case GFC_ISYM_TRANSPOSE
:
10139 /* Returns nonzero if the specified intrinsic function call maps directly to
10140 an external library call. Should only be used for functions that return
10144 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
10146 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
10147 gcc_assert (expr
->rank
> 0);
10149 if (gfc_inline_intrinsic_function_p (expr
))
10152 switch (expr
->value
.function
.isym
->id
)
10156 case GFC_ISYM_COUNT
:
10157 case GFC_ISYM_FINDLOC
:
10159 case GFC_ISYM_IANY
:
10160 case GFC_ISYM_IALL
:
10161 case GFC_ISYM_IPARITY
:
10162 case GFC_ISYM_MATMUL
:
10163 case GFC_ISYM_MAXLOC
:
10164 case GFC_ISYM_MAXVAL
:
10165 case GFC_ISYM_MINLOC
:
10166 case GFC_ISYM_MINVAL
:
10167 case GFC_ISYM_NORM2
:
10168 case GFC_ISYM_PARITY
:
10169 case GFC_ISYM_PRODUCT
:
10171 case GFC_ISYM_SHAPE
:
10172 case GFC_ISYM_SPREAD
:
10174 /* Ignore absent optional parameters. */
10177 case GFC_ISYM_CSHIFT
:
10178 case GFC_ISYM_EOSHIFT
:
10179 case GFC_ISYM_GET_TEAM
:
10180 case GFC_ISYM_FAILED_IMAGES
:
10181 case GFC_ISYM_STOPPED_IMAGES
:
10182 case GFC_ISYM_PACK
:
10183 case GFC_ISYM_RESHAPE
:
10184 case GFC_ISYM_UNPACK
:
10185 /* Pass absent optional parameters. */
10193 /* Walk an intrinsic function. */
10195 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
10196 gfc_intrinsic_sym
* isym
)
10200 if (isym
->elemental
)
10201 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
10202 NULL
, GFC_SS_SCALAR
);
10204 if (expr
->rank
== 0)
10207 if (gfc_inline_intrinsic_function_p (expr
))
10208 return walk_inline_intrinsic_function (ss
, expr
);
10210 if (gfc_is_intrinsic_libcall (expr
))
10211 return gfc_walk_intrinsic_libfunc (ss
, expr
);
10213 /* Special cases. */
10216 case GFC_ISYM_LBOUND
:
10217 case GFC_ISYM_LCOBOUND
:
10218 case GFC_ISYM_UBOUND
:
10219 case GFC_ISYM_UCOBOUND
:
10220 case GFC_ISYM_THIS_IMAGE
:
10221 return gfc_walk_intrinsic_bound (ss
, expr
);
10223 case GFC_ISYM_TRANSFER
:
10224 case GFC_ISYM_CAF_GET
:
10225 return gfc_walk_intrinsic_libfunc (ss
, expr
);
10228 /* This probably meant someone forgot to add an intrinsic to the above
10229 list(s) when they implemented it, or something's gone horribly
10231 gcc_unreachable ();
10237 conv_co_collective (gfc_code
*code
)
10240 stmtblock_t block
, post_block
;
10241 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
10242 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
10244 gfc_start_block (&block
);
10245 gfc_init_block (&post_block
);
10247 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
10249 opr_expr
= code
->ext
.actual
->next
->expr
;
10250 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
10251 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10252 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
10257 image_idx_expr
= code
->ext
.actual
->next
->expr
;
10258 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
10259 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10265 gfc_init_se (&argse
, NULL
);
10266 gfc_conv_expr (&argse
, stat_expr
);
10267 gfc_add_block_to_block (&block
, &argse
.pre
);
10268 gfc_add_block_to_block (&post_block
, &argse
.post
);
10270 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
10271 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
10273 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
10276 stat
= null_pointer_node
;
10278 /* Early exit for GFC_FCOARRAY_SINGLE. */
10279 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
10281 if (stat
!= NULL_TREE
)
10282 gfc_add_modify (&block
, stat
,
10283 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
10284 return gfc_finish_block (&block
);
10287 /* Handle the array. */
10288 gfc_init_se (&argse
, NULL
);
10289 if (code
->ext
.actual
->expr
->rank
== 0)
10291 symbol_attribute attr
;
10292 gfc_clear_attr (&attr
);
10293 gfc_init_se (&argse
, NULL
);
10294 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10295 gfc_add_block_to_block (&block
, &argse
.pre
);
10296 gfc_add_block_to_block (&post_block
, &argse
.post
);
10297 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
10298 array
= gfc_build_addr_expr (NULL_TREE
, array
);
10302 argse
.want_pointer
= 1;
10303 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
10304 array
= argse
.expr
;
10306 gfc_add_block_to_block (&block
, &argse
.pre
);
10307 gfc_add_block_to_block (&post_block
, &argse
.post
);
10309 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
10310 strlen
= argse
.string_length
;
10312 strlen
= integer_zero_node
;
10315 if (image_idx_expr
)
10317 gfc_init_se (&argse
, NULL
);
10318 gfc_conv_expr (&argse
, image_idx_expr
);
10319 gfc_add_block_to_block (&block
, &argse
.pre
);
10320 gfc_add_block_to_block (&post_block
, &argse
.post
);
10321 image_index
= fold_convert (integer_type_node
, argse
.expr
);
10324 image_index
= integer_zero_node
;
10329 gfc_init_se (&argse
, NULL
);
10330 gfc_conv_expr (&argse
, errmsg_expr
);
10331 gfc_add_block_to_block (&block
, &argse
.pre
);
10332 gfc_add_block_to_block (&post_block
, &argse
.post
);
10333 errmsg
= argse
.expr
;
10334 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
10338 errmsg
= null_pointer_node
;
10339 errmsg_len
= build_zero_cst (size_type_node
);
10342 /* Generate the function call. */
10343 switch (code
->resolved_isym
->id
)
10345 case GFC_ISYM_CO_BROADCAST
:
10346 fndecl
= gfor_fndecl_co_broadcast
;
10348 case GFC_ISYM_CO_MAX
:
10349 fndecl
= gfor_fndecl_co_max
;
10351 case GFC_ISYM_CO_MIN
:
10352 fndecl
= gfor_fndecl_co_min
;
10354 case GFC_ISYM_CO_REDUCE
:
10355 fndecl
= gfor_fndecl_co_reduce
;
10357 case GFC_ISYM_CO_SUM
:
10358 fndecl
= gfor_fndecl_co_sum
;
10361 gcc_unreachable ();
10364 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
10365 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
10366 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
10367 image_index
, stat
, errmsg
, errmsg_len
);
10368 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
10369 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
10370 stat
, errmsg
, strlen
, errmsg_len
);
10373 tree opr
, opr_flags
;
10375 // FIXME: Handle TS29113's bind(C) strings with descriptor.
10377 if (gfc_is_proc_ptr_comp (opr_expr
))
10379 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
10380 opr_flag_int
= sym
->attr
.dimension
10381 || (sym
->ts
.type
== BT_CHARACTER
10382 && !sym
->attr
.is_bind_c
)
10383 ? GFC_CAF_BYREF
: 0;
10384 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
10385 && !sym
->attr
.is_bind_c
10386 ? GFC_CAF_HIDDENLEN
: 0;
10387 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
10391 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
10392 ? GFC_CAF_BYREF
: 0;
10393 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
10394 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
10395 ? GFC_CAF_HIDDENLEN
: 0;
10396 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
10397 ? GFC_CAF_ARG_VALUE
: 0;
10399 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
10400 gfc_conv_expr (&argse
, opr_expr
);
10402 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
10403 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
10406 gfc_add_expr_to_block (&block
, fndecl
);
10407 gfc_add_block_to_block (&block
, &post_block
);
10409 return gfc_finish_block (&block
);
10414 conv_intrinsic_atomic_op (gfc_code
*code
)
10417 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
10418 stmtblock_t block
, post_block
;
10419 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10420 gfc_expr
*stat_expr
;
10421 built_in_function fn
;
10423 if (atom_expr
->expr_type
== EXPR_FUNCTION
10424 && atom_expr
->value
.function
.isym
10425 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10426 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10428 gfc_start_block (&block
);
10429 gfc_init_block (&post_block
);
10431 gfc_init_se (&argse
, NULL
);
10432 argse
.want_pointer
= 1;
10433 gfc_conv_expr (&argse
, atom_expr
);
10434 gfc_add_block_to_block (&block
, &argse
.pre
);
10435 gfc_add_block_to_block (&post_block
, &argse
.post
);
10438 gfc_init_se (&argse
, NULL
);
10439 if (flag_coarray
== GFC_FCOARRAY_LIB
10440 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10441 argse
.want_pointer
= 1;
10442 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10443 gfc_add_block_to_block (&block
, &argse
.pre
);
10444 gfc_add_block_to_block (&post_block
, &argse
.post
);
10445 value
= argse
.expr
;
10447 switch (code
->resolved_isym
->id
)
10449 case GFC_ISYM_ATOMIC_ADD
:
10450 case GFC_ISYM_ATOMIC_AND
:
10451 case GFC_ISYM_ATOMIC_DEF
:
10452 case GFC_ISYM_ATOMIC_OR
:
10453 case GFC_ISYM_ATOMIC_XOR
:
10454 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
10455 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10456 old
= null_pointer_node
;
10459 gfc_init_se (&argse
, NULL
);
10460 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10461 argse
.want_pointer
= 1;
10462 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10463 gfc_add_block_to_block (&block
, &argse
.pre
);
10464 gfc_add_block_to_block (&post_block
, &argse
.post
);
10466 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10470 if (stat_expr
!= NULL
)
10472 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
10473 gfc_init_se (&argse
, NULL
);
10474 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10475 argse
.want_pointer
= 1;
10476 gfc_conv_expr_val (&argse
, stat_expr
);
10477 gfc_add_block_to_block (&block
, &argse
.pre
);
10478 gfc_add_block_to_block (&post_block
, &argse
.post
);
10481 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10482 stat
= null_pointer_node
;
10484 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10486 tree image_index
, caf_decl
, offset
, token
;
10489 switch (code
->resolved_isym
->id
)
10491 case GFC_ISYM_ATOMIC_ADD
:
10492 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10493 op
= (int) GFC_CAF_ATOMIC_ADD
;
10495 case GFC_ISYM_ATOMIC_AND
:
10496 case GFC_ISYM_ATOMIC_FETCH_AND
:
10497 op
= (int) GFC_CAF_ATOMIC_AND
;
10499 case GFC_ISYM_ATOMIC_OR
:
10500 case GFC_ISYM_ATOMIC_FETCH_OR
:
10501 op
= (int) GFC_CAF_ATOMIC_OR
;
10503 case GFC_ISYM_ATOMIC_XOR
:
10504 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10505 op
= (int) GFC_CAF_ATOMIC_XOR
;
10507 case GFC_ISYM_ATOMIC_DEF
:
10508 op
= 0; /* Unused. */
10511 gcc_unreachable ();
10514 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10515 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10516 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10518 if (gfc_is_coindexed (atom_expr
))
10519 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10521 image_index
= integer_zero_node
;
10523 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10525 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10526 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
10527 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10530 gfc_init_se (&argse
, NULL
);
10531 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10534 gfc_add_block_to_block (&block
, &argse
.pre
);
10535 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
10536 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
10537 token
, offset
, image_index
, value
, stat
,
10538 build_int_cst (integer_type_node
,
10539 (int) atom_expr
->ts
.type
),
10540 build_int_cst (integer_type_node
,
10541 (int) atom_expr
->ts
.kind
));
10543 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
10544 build_int_cst (integer_type_node
, op
),
10545 token
, offset
, image_index
, value
, old
, stat
,
10546 build_int_cst (integer_type_node
,
10547 (int) atom_expr
->ts
.type
),
10548 build_int_cst (integer_type_node
,
10549 (int) atom_expr
->ts
.kind
));
10551 gfc_add_expr_to_block (&block
, tmp
);
10552 gfc_add_block_to_block (&block
, &argse
.post
);
10553 gfc_add_block_to_block (&block
, &post_block
);
10554 return gfc_finish_block (&block
);
10558 switch (code
->resolved_isym
->id
)
10560 case GFC_ISYM_ATOMIC_ADD
:
10561 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10562 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
10564 case GFC_ISYM_ATOMIC_AND
:
10565 case GFC_ISYM_ATOMIC_FETCH_AND
:
10566 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
10568 case GFC_ISYM_ATOMIC_DEF
:
10569 fn
= BUILT_IN_ATOMIC_STORE_N
;
10571 case GFC_ISYM_ATOMIC_OR
:
10572 case GFC_ISYM_ATOMIC_FETCH_OR
:
10573 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
10575 case GFC_ISYM_ATOMIC_XOR
:
10576 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10577 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
10580 gcc_unreachable ();
10583 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10584 fn
= (built_in_function
) ((int) fn
10585 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10587 tmp
= builtin_decl_explicit (fn
);
10588 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
10589 tmp
= builtin_decl_explicit (fn
);
10591 switch (code
->resolved_isym
->id
)
10593 case GFC_ISYM_ATOMIC_ADD
:
10594 case GFC_ISYM_ATOMIC_AND
:
10595 case GFC_ISYM_ATOMIC_DEF
:
10596 case GFC_ISYM_ATOMIC_OR
:
10597 case GFC_ISYM_ATOMIC_XOR
:
10598 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10599 fold_convert (itype
, value
),
10600 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10601 gfc_add_expr_to_block (&block
, tmp
);
10604 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10605 fold_convert (itype
, value
),
10606 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10607 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
10611 if (stat
!= NULL_TREE
)
10612 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10613 gfc_add_block_to_block (&block
, &post_block
);
10614 return gfc_finish_block (&block
);
10619 conv_intrinsic_atomic_ref (gfc_code
*code
)
10622 tree tmp
, atom
, value
, stat
= NULL_TREE
;
10623 stmtblock_t block
, post_block
;
10624 built_in_function fn
;
10625 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
10627 if (atom_expr
->expr_type
== EXPR_FUNCTION
10628 && atom_expr
->value
.function
.isym
10629 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10630 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10632 gfc_start_block (&block
);
10633 gfc_init_block (&post_block
);
10634 gfc_init_se (&argse
, NULL
);
10635 argse
.want_pointer
= 1;
10636 gfc_conv_expr (&argse
, atom_expr
);
10637 gfc_add_block_to_block (&block
, &argse
.pre
);
10638 gfc_add_block_to_block (&post_block
, &argse
.post
);
10641 gfc_init_se (&argse
, NULL
);
10642 if (flag_coarray
== GFC_FCOARRAY_LIB
10643 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10644 argse
.want_pointer
= 1;
10645 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10646 gfc_add_block_to_block (&block
, &argse
.pre
);
10647 gfc_add_block_to_block (&post_block
, &argse
.post
);
10648 value
= argse
.expr
;
10651 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
10653 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10655 gfc_init_se (&argse
, NULL
);
10656 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10657 argse
.want_pointer
= 1;
10658 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10659 gfc_add_block_to_block (&block
, &argse
.pre
);
10660 gfc_add_block_to_block (&post_block
, &argse
.post
);
10663 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10664 stat
= null_pointer_node
;
10666 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10668 tree image_index
, caf_decl
, offset
, token
;
10669 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
10671 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10672 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10673 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10675 if (gfc_is_coindexed (atom_expr
))
10676 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10678 image_index
= integer_zero_node
;
10680 gfc_init_se (&argse
, NULL
);
10681 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10683 gfc_add_block_to_block (&block
, &argse
.pre
);
10685 /* Different type, need type conversion. */
10686 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10688 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10689 orig_value
= value
;
10690 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
10693 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
10694 token
, offset
, image_index
, value
, stat
,
10695 build_int_cst (integer_type_node
,
10696 (int) atom_expr
->ts
.type
),
10697 build_int_cst (integer_type_node
,
10698 (int) atom_expr
->ts
.kind
));
10699 gfc_add_expr_to_block (&block
, tmp
);
10700 if (vardecl
!= NULL_TREE
)
10701 gfc_add_modify (&block
, orig_value
,
10702 fold_convert (TREE_TYPE (orig_value
), vardecl
));
10703 gfc_add_block_to_block (&block
, &argse
.post
);
10704 gfc_add_block_to_block (&block
, &post_block
);
10705 return gfc_finish_block (&block
);
10708 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10709 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
10710 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10712 tmp
= builtin_decl_explicit (fn
);
10713 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
10714 build_int_cst (integer_type_node
,
10715 MEMMODEL_RELAXED
));
10716 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
10718 if (stat
!= NULL_TREE
)
10719 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10720 gfc_add_block_to_block (&block
, &post_block
);
10721 return gfc_finish_block (&block
);
10726 conv_intrinsic_atomic_cas (gfc_code
*code
)
10729 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
10730 stmtblock_t block
, post_block
;
10731 built_in_function fn
;
10732 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10734 if (atom_expr
->expr_type
== EXPR_FUNCTION
10735 && atom_expr
->value
.function
.isym
10736 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10737 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10739 gfc_init_block (&block
);
10740 gfc_init_block (&post_block
);
10741 gfc_init_se (&argse
, NULL
);
10742 argse
.want_pointer
= 1;
10743 gfc_conv_expr (&argse
, atom_expr
);
10746 gfc_init_se (&argse
, NULL
);
10747 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10748 argse
.want_pointer
= 1;
10749 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10750 gfc_add_block_to_block (&block
, &argse
.pre
);
10751 gfc_add_block_to_block (&post_block
, &argse
.post
);
10754 gfc_init_se (&argse
, NULL
);
10755 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10756 argse
.want_pointer
= 1;
10757 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10758 gfc_add_block_to_block (&block
, &argse
.pre
);
10759 gfc_add_block_to_block (&post_block
, &argse
.post
);
10762 gfc_init_se (&argse
, NULL
);
10763 if (flag_coarray
== GFC_FCOARRAY_LIB
10764 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
10765 == atom_expr
->ts
.kind
)
10766 argse
.want_pointer
= 1;
10767 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
10768 gfc_add_block_to_block (&block
, &argse
.pre
);
10769 gfc_add_block_to_block (&post_block
, &argse
.post
);
10770 new_val
= argse
.expr
;
10773 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
10775 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
10777 gfc_init_se (&argse
, NULL
);
10778 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10779 argse
.want_pointer
= 1;
10780 gfc_conv_expr_val (&argse
,
10781 code
->ext
.actual
->next
->next
->next
->next
->expr
);
10782 gfc_add_block_to_block (&block
, &argse
.pre
);
10783 gfc_add_block_to_block (&post_block
, &argse
.post
);
10786 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10787 stat
= null_pointer_node
;
10789 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10791 tree image_index
, caf_decl
, offset
, token
;
10793 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10794 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10795 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10797 if (gfc_is_coindexed (atom_expr
))
10798 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10800 image_index
= integer_zero_node
;
10802 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
10804 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
10805 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
10806 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10809 /* Convert a constant to a pointer. */
10810 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
10812 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
10813 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
10814 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10817 gfc_init_se (&argse
, NULL
);
10818 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10820 gfc_add_block_to_block (&block
, &argse
.pre
);
10822 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
10823 token
, offset
, image_index
, old
, comp
, new_val
,
10824 stat
, build_int_cst (integer_type_node
,
10825 (int) atom_expr
->ts
.type
),
10826 build_int_cst (integer_type_node
,
10827 (int) atom_expr
->ts
.kind
));
10828 gfc_add_expr_to_block (&block
, tmp
);
10829 gfc_add_block_to_block (&block
, &argse
.post
);
10830 gfc_add_block_to_block (&block
, &post_block
);
10831 return gfc_finish_block (&block
);
10834 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10835 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10836 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10838 tmp
= builtin_decl_explicit (fn
);
10840 gfc_add_modify (&block
, old
, comp
);
10841 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
10842 gfc_build_addr_expr (NULL
, old
),
10843 fold_convert (TREE_TYPE (old
), new_val
),
10844 boolean_false_node
,
10845 build_int_cst (NULL
, MEMMODEL_RELAXED
),
10846 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10847 gfc_add_expr_to_block (&block
, tmp
);
10849 if (stat
!= NULL_TREE
)
10850 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10851 gfc_add_block_to_block (&block
, &post_block
);
10852 return gfc_finish_block (&block
);
10856 conv_intrinsic_event_query (gfc_code
*code
)
10859 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
10860 tree count
= NULL_TREE
, count2
= NULL_TREE
;
10862 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
10864 if (code
->ext
.actual
->next
->next
->expr
)
10866 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10868 gfc_init_se (&argse
, NULL
);
10869 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10872 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10873 stat
= null_pointer_node
;
10875 if (code
->ext
.actual
->next
->expr
)
10877 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
10878 gfc_init_se (&argse
, NULL
);
10879 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
10880 count
= argse
.expr
;
10883 gfc_start_block (&se
.pre
);
10884 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10886 tree tmp
, token
, image_index
;
10887 tree index
= build_zero_cst (gfc_array_index_type
);
10889 if (event_expr
->expr_type
== EXPR_FUNCTION
10890 && event_expr
->value
.function
.isym
10891 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10892 event_expr
= event_expr
->value
.function
.actual
->expr
;
10894 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
10896 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10897 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
10898 != INTMOD_ISO_FORTRAN_ENV
10899 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
10900 != ISOFORTRAN_EVENT_TYPE
)
10902 gfc_error ("Sorry, the event component of derived type at %L is not "
10903 "yet supported", &event_expr
->where
);
10907 if (gfc_is_coindexed (event_expr
))
10909 gfc_error ("The event variable at %L shall not be coindexed",
10910 &event_expr
->where
);
10914 image_index
= integer_zero_node
;
10916 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10919 /* For arrays, obtain the array index. */
10920 if (gfc_expr_attr (event_expr
).dimension
)
10922 tree desc
, tmp
, extent
, lbound
, ubound
;
10923 gfc_array_ref
*ar
, ar2
;
10926 /* TODO: Extend this, once DT components are supported. */
10927 ar
= &event_expr
->ref
->u
.ar
;
10929 memset (ar
, '\0', sizeof (*ar
));
10931 ar
->type
= AR_FULL
;
10933 gfc_init_se (&argse
, NULL
);
10934 argse
.descriptor_only
= 1;
10935 gfc_conv_expr_descriptor (&argse
, event_expr
);
10936 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
10940 extent
= build_one_cst (gfc_array_index_type
);
10941 for (i
= 0; i
< ar
->dimen
; i
++)
10943 gfc_init_se (&argse
, NULL
);
10944 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
10945 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
10946 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
10947 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10948 TREE_TYPE (lbound
), argse
.expr
, lbound
);
10949 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10950 TREE_TYPE (tmp
), extent
, tmp
);
10951 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
10952 TREE_TYPE (tmp
), index
, tmp
);
10953 if (i
< ar
->dimen
- 1)
10955 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
10956 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10957 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
10958 TREE_TYPE (tmp
), extent
, tmp
);
10963 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
10966 count
= gfc_create_var (integer_type_node
, "count");
10969 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
10972 stat
= gfc_create_var (integer_type_node
, "stat");
10975 index
= fold_convert (size_type_node
, index
);
10976 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
10977 token
, index
, image_index
, count
10978 ? gfc_build_addr_expr (NULL
, count
) : count
,
10979 stat
!= null_pointer_node
10980 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
10981 gfc_add_expr_to_block (&se
.pre
, tmp
);
10983 if (count2
!= NULL_TREE
)
10984 gfc_add_modify (&se
.pre
, count2
,
10985 fold_convert (TREE_TYPE (count2
), count
));
10987 if (stat2
!= NULL_TREE
)
10988 gfc_add_modify (&se
.pre
, stat2
,
10989 fold_convert (TREE_TYPE (stat2
), stat
));
10991 return gfc_finish_block (&se
.pre
);
10994 gfc_init_se (&argse
, NULL
);
10995 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
10996 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
10998 if (stat
!= NULL_TREE
)
10999 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
11001 return gfc_finish_block (&se
.pre
);
11005 conv_intrinsic_move_alloc (gfc_code
*code
)
11008 gfc_expr
*from_expr
, *to_expr
;
11009 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
11010 gfc_se from_se
, to_se
;
11014 gfc_start_block (&block
);
11016 from_expr
= code
->ext
.actual
->expr
;
11017 to_expr
= code
->ext
.actual
->next
->expr
;
11019 gfc_init_se (&from_se
, NULL
);
11020 gfc_init_se (&to_se
, NULL
);
11022 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
11023 || to_expr
->ts
.type
== BT_CLASS
);
11024 coarray
= gfc_get_corank (from_expr
) != 0;
11026 if (from_expr
->rank
== 0 && !coarray
)
11028 if (from_expr
->ts
.type
!= BT_CLASS
)
11029 from_expr2
= from_expr
;
11032 from_expr2
= gfc_copy_expr (from_expr
);
11033 gfc_add_data_component (from_expr2
);
11036 if (to_expr
->ts
.type
!= BT_CLASS
)
11037 to_expr2
= to_expr
;
11040 to_expr2
= gfc_copy_expr (to_expr
);
11041 gfc_add_data_component (to_expr2
);
11044 from_se
.want_pointer
= 1;
11045 to_se
.want_pointer
= 1;
11046 gfc_conv_expr (&from_se
, from_expr2
);
11047 gfc_conv_expr (&to_se
, to_expr2
);
11048 gfc_add_block_to_block (&block
, &from_se
.pre
);
11049 gfc_add_block_to_block (&block
, &to_se
.pre
);
11051 /* Deallocate "to". */
11052 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
11053 true, to_expr
, to_expr
->ts
);
11054 gfc_add_expr_to_block (&block
, tmp
);
11056 /* Assign (_data) pointers. */
11057 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11058 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
11060 /* Set "from" to NULL. */
11061 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11062 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
11064 gfc_add_block_to_block (&block
, &from_se
.post
);
11065 gfc_add_block_to_block (&block
, &to_se
.post
);
11068 if (to_expr
->ts
.type
== BT_CLASS
)
11072 gfc_free_expr (to_expr2
);
11073 gfc_init_se (&to_se
, NULL
);
11074 to_se
.want_pointer
= 1;
11075 gfc_add_vptr_component (to_expr
);
11076 gfc_conv_expr (&to_se
, to_expr
);
11078 if (from_expr
->ts
.type
== BT_CLASS
)
11080 if (UNLIMITED_POLY (from_expr
))
11084 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
11088 gfc_free_expr (from_expr2
);
11089 gfc_init_se (&from_se
, NULL
);
11090 from_se
.want_pointer
= 1;
11091 gfc_add_vptr_component (from_expr
);
11092 gfc_conv_expr (&from_se
, from_expr
);
11093 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11094 fold_convert (TREE_TYPE (to_se
.expr
),
11097 /* Reset _vptr component to declared type. */
11099 /* Unlimited polymorphic. */
11100 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11101 fold_convert (TREE_TYPE (from_se
.expr
),
11102 null_pointer_node
));
11105 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11106 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11107 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
11112 vtab
= gfc_find_vtab (&from_expr
->ts
);
11114 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11115 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11116 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
11120 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
11122 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
11123 fold_convert (TREE_TYPE (to_se
.string_length
),
11124 from_se
.string_length
));
11125 if (from_expr
->ts
.deferred
)
11126 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
11127 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
11130 return gfc_finish_block (&block
);
11133 /* Update _vptr component. */
11134 if (to_expr
->ts
.type
== BT_CLASS
)
11138 to_se
.want_pointer
= 1;
11139 to_expr2
= gfc_copy_expr (to_expr
);
11140 gfc_add_vptr_component (to_expr2
);
11141 gfc_conv_expr (&to_se
, to_expr2
);
11143 if (from_expr
->ts
.type
== BT_CLASS
)
11145 if (UNLIMITED_POLY (from_expr
))
11149 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
11153 from_se
.want_pointer
= 1;
11154 from_expr2
= gfc_copy_expr (from_expr
);
11155 gfc_add_vptr_component (from_expr2
);
11156 gfc_conv_expr (&from_se
, from_expr2
);
11157 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11158 fold_convert (TREE_TYPE (to_se
.expr
),
11161 /* Reset _vptr component to declared type. */
11163 /* Unlimited polymorphic. */
11164 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11165 fold_convert (TREE_TYPE (from_se
.expr
),
11166 null_pointer_node
));
11169 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11170 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
11171 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
11176 vtab
= gfc_find_vtab (&from_expr
->ts
);
11178 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
11179 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
11180 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
11183 gfc_free_expr (to_expr2
);
11184 gfc_init_se (&to_se
, NULL
);
11186 if (from_expr
->ts
.type
== BT_CLASS
)
11188 gfc_free_expr (from_expr2
);
11189 gfc_init_se (&from_se
, NULL
);
11194 /* Deallocate "to". */
11195 if (from_expr
->rank
== 0)
11197 to_se
.want_coarray
= 1;
11198 from_se
.want_coarray
= 1;
11200 gfc_conv_expr_descriptor (&to_se
, to_expr
);
11201 gfc_conv_expr_descriptor (&from_se
, from_expr
);
11203 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
11204 is an image control "statement", cf. IR F08/0040 in 12-006A. */
11205 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
11209 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
11210 NULL_TREE
, NULL_TREE
, true, to_expr
,
11211 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
11212 gfc_add_expr_to_block (&block
, tmp
);
11214 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
11215 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
11216 logical_type_node
, tmp
,
11217 fold_convert (TREE_TYPE (tmp
),
11218 null_pointer_node
));
11219 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
11220 3, null_pointer_node
, null_pointer_node
,
11221 build_int_cst (integer_type_node
, 0));
11223 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
11224 tmp
, build_empty_stmt (input_location
));
11225 gfc_add_expr_to_block (&block
, tmp
);
11229 if (to_expr
->ts
.type
== BT_DERIVED
11230 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
11232 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
11233 to_se
.expr
, to_expr
->rank
);
11234 gfc_add_expr_to_block (&block
, tmp
);
11237 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
11238 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
11239 NULL_TREE
, true, to_expr
,
11240 GFC_CAF_COARRAY_NOCOARRAY
);
11241 gfc_add_expr_to_block (&block
, tmp
);
11244 /* Move the pointer and update the array descriptor data. */
11245 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
11247 /* Set "from" to NULL. */
11248 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
11249 gfc_add_modify_loc (input_location
, &block
, tmp
,
11250 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
11253 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
11255 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
11256 fold_convert (TREE_TYPE (to_se
.string_length
),
11257 from_se
.string_length
));
11258 if (from_expr
->ts
.deferred
)
11259 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
11260 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
11263 return gfc_finish_block (&block
);
11268 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
11272 gcc_assert (code
->resolved_isym
);
11274 switch (code
->resolved_isym
->id
)
11276 case GFC_ISYM_MOVE_ALLOC
:
11277 res
= conv_intrinsic_move_alloc (code
);
11280 case GFC_ISYM_ATOMIC_CAS
:
11281 res
= conv_intrinsic_atomic_cas (code
);
11284 case GFC_ISYM_ATOMIC_ADD
:
11285 case GFC_ISYM_ATOMIC_AND
:
11286 case GFC_ISYM_ATOMIC_DEF
:
11287 case GFC_ISYM_ATOMIC_OR
:
11288 case GFC_ISYM_ATOMIC_XOR
:
11289 case GFC_ISYM_ATOMIC_FETCH_ADD
:
11290 case GFC_ISYM_ATOMIC_FETCH_AND
:
11291 case GFC_ISYM_ATOMIC_FETCH_OR
:
11292 case GFC_ISYM_ATOMIC_FETCH_XOR
:
11293 res
= conv_intrinsic_atomic_op (code
);
11296 case GFC_ISYM_ATOMIC_REF
:
11297 res
= conv_intrinsic_atomic_ref (code
);
11300 case GFC_ISYM_EVENT_QUERY
:
11301 res
= conv_intrinsic_event_query (code
);
11304 case GFC_ISYM_C_F_POINTER
:
11305 case GFC_ISYM_C_F_PROCPOINTER
:
11306 res
= conv_isocbinding_subroutine (code
);
11309 case GFC_ISYM_CAF_SEND
:
11310 res
= conv_caf_send (code
);
11313 case GFC_ISYM_CO_BROADCAST
:
11314 case GFC_ISYM_CO_MIN
:
11315 case GFC_ISYM_CO_MAX
:
11316 case GFC_ISYM_CO_REDUCE
:
11317 case GFC_ISYM_CO_SUM
:
11318 res
= conv_co_collective (code
);
11321 case GFC_ISYM_FREE
:
11322 res
= conv_intrinsic_free (code
);
11325 case GFC_ISYM_RANDOM_INIT
:
11326 res
= conv_intrinsic_random_init (code
);
11329 case GFC_ISYM_KILL
:
11330 res
= conv_intrinsic_kill_sub (code
);
11333 case GFC_ISYM_SYSTEM_CLOCK
:
11334 res
= conv_intrinsic_system_clock (code
);
11345 #include "gt-fortran-trans-intrinsic.h"