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 minval or maxval intrinsic. There are many different cases
5181 we need to handle. For performance reasons we sometimes create two
5182 loops instead of one, where the second one is much simpler.
5183 Examples for minval intrinsic:
5184 1) Result is an array, a call is generated
5185 2) Array mask is used and NaNs need to be supported, rank 1:
5190 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
5193 limit = nonempty ? NaN : huge (limit);
5195 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
5196 3) NaNs need to be supported, but it is known at compile time or cheaply
5197 at runtime whether array is nonempty or not, rank 1:
5200 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
5201 limit = (from <= to) ? NaN : huge (limit);
5203 while (S <= to) { limit = min (a[S], limit); S++; }
5204 4) Array mask is used and NaNs need to be supported, rank > 1:
5213 if (fast) limit = min (a[S1][S2], limit);
5216 if (a[S1][S2] <= limit) {
5227 limit = nonempty ? NaN : huge (limit);
5228 5) NaNs need to be supported, but it is known at compile time or cheaply
5229 at runtime whether array is nonempty or not, rank > 1:
5236 if (fast) limit = min (a[S1][S2], limit);
5238 if (a[S1][S2] <= limit) {
5248 limit = (nonempty_array) ? NaN : huge (limit);
5249 6) NaNs aren't supported, but infinities are. Array mask is used:
5254 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
5257 limit = nonempty ? limit : huge (limit);
5258 7) Same without array mask:
5261 while (S <= to) { limit = min (a[S], limit); S++; }
5262 limit = (from <= to) ? limit : huge (limit);
5263 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
5264 limit = huge (limit);
5266 while (S <= to) { limit = min (a[S], limit); S++); }
5268 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
5269 with array mask instead).
5270 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
5271 setting limit = huge (limit); in the else branch. */
5274 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5284 tree huge_cst
= NULL
, nan_cst
= NULL
;
5286 stmtblock_t block
, block2
;
5288 gfc_actual_arglist
*actual
;
5293 gfc_expr
*arrayexpr
;
5299 gfc_conv_intrinsic_funcall (se
, expr
);
5303 actual
= expr
->value
.function
.actual
;
5304 arrayexpr
= actual
->expr
;
5306 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5308 gfc_actual_arglist
*a2
, *a3
;
5309 a2
= actual
->next
; /* dim */
5310 a3
= a2
->next
; /* mask */
5311 if (a2
->expr
== NULL
|| expr
->rank
== 0)
5313 if (a3
->expr
== NULL
)
5314 actual
->next
= NULL
;
5320 gfc_free_actual_arglist (a2
);
5323 if (a3
->expr
== NULL
)
5326 gfc_free_actual_arglist (a3
);
5328 gfc_conv_intrinsic_funcall (se
, expr
);
5331 type
= gfc_typenode_for_spec (&expr
->ts
);
5332 /* Initialize the result. */
5333 limit
= gfc_create_var (type
, "limit");
5334 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
5335 switch (expr
->ts
.type
)
5338 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
5340 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5342 REAL_VALUE_TYPE real
;
5344 tmp
= build_real (type
, real
);
5348 if (HONOR_NANS (DECL_MODE (limit
)))
5349 nan_cst
= gfc_build_nan (type
, "");
5353 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
5360 /* We start with the most negative possible value for MAXVAL, and the most
5361 positive possible value for MINVAL. The most negative possible value is
5362 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5363 possible value is HUGE in both cases. */
5366 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5368 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
5369 TREE_TYPE (huge_cst
), huge_cst
);
5372 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
5373 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5374 tmp
, build_int_cst (type
, 1));
5376 gfc_add_modify (&se
->pre
, limit
, tmp
);
5378 /* Walk the arguments. */
5379 arrayss
= gfc_walk_expr (arrayexpr
);
5380 gcc_assert (arrayss
!= gfc_ss_terminator
);
5382 actual
= actual
->next
->next
;
5383 gcc_assert (actual
);
5384 maskexpr
= actual
->expr
;
5386 if (maskexpr
&& maskexpr
->rank
!= 0)
5388 maskss
= gfc_walk_expr (maskexpr
);
5389 gcc_assert (maskss
!= gfc_ss_terminator
);
5394 if (gfc_array_size (arrayexpr
, &asize
))
5396 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5398 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5399 logical_type_node
, nonempty
,
5400 gfc_index_zero_node
);
5405 /* Initialize the scalarizer. */
5406 gfc_init_loopinfo (&loop
);
5407 gfc_add_ss_to_loop (&loop
, arrayss
);
5409 gfc_add_ss_to_loop (&loop
, maskss
);
5411 /* Initialize the loop. */
5412 gfc_conv_ss_startstride (&loop
);
5414 /* The code generated can have more than one loop in sequence (see the
5415 comment at the function header). This doesn't work well with the
5416 scalarizer, which changes arrays' offset when the scalarization loops
5417 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5418 are currently inlined in the scalar case only. As there is no dependency
5419 to care about in that case, there is no temporary, so that we can use the
5420 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5421 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5422 gfc_trans_scalarized_loop_boundary even later to restore offset.
5423 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5424 should eventually go away. We could either create two loops properly,
5425 or find another way to save/restore the array offsets between the two
5426 loops (without conflicting with temporary management), or use a single
5427 loop minmaxval implementation. See PR 31067. */
5428 loop
.temp_dim
= loop
.dimen
;
5429 gfc_conv_loop_setup (&loop
, &expr
->where
);
5431 if (nonempty
== NULL
&& maskss
== NULL
5432 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5433 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5434 loop
.from
[0], loop
.to
[0]);
5435 nonempty_var
= NULL
;
5436 if (nonempty
== NULL
5437 && (HONOR_INFINITIES (DECL_MODE (limit
))
5438 || HONOR_NANS (DECL_MODE (limit
))))
5440 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
5441 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
5442 nonempty
= nonempty_var
;
5446 if (HONOR_NANS (DECL_MODE (limit
)))
5448 if (loop
.dimen
== 1)
5450 lab
= gfc_build_label_decl (NULL_TREE
);
5451 TREE_USED (lab
) = 1;
5455 fast
= gfc_create_var (logical_type_node
, "fast");
5456 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
5460 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5462 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5463 /* Generate the loop body. */
5464 gfc_start_scalarized_body (&loop
, &body
);
5466 /* If we have a mask, only add this element if the mask is set. */
5469 gfc_init_se (&maskse
, NULL
);
5470 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5472 gfc_conv_expr_val (&maskse
, maskexpr
);
5473 gfc_add_block_to_block (&body
, &maskse
.pre
);
5475 gfc_start_block (&block
);
5478 gfc_init_block (&block
);
5480 /* Compare with the current limit. */
5481 gfc_init_se (&arrayse
, NULL
);
5482 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5483 arrayse
.ss
= arrayss
;
5484 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5485 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5487 gfc_init_block (&block2
);
5490 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
5492 if (HONOR_NANS (DECL_MODE (limit
)))
5494 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5495 logical_type_node
, arrayse
.expr
, limit
);
5497 ifbody
= build1_v (GOTO_EXPR
, lab
);
5500 stmtblock_t ifblock
;
5502 gfc_init_block (&ifblock
);
5503 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5504 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
5505 ifbody
= gfc_finish_block (&ifblock
);
5507 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5508 build_empty_stmt (input_location
));
5509 gfc_add_expr_to_block (&block2
, tmp
);
5513 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5515 tmp
= fold_build2_loc (input_location
,
5516 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5517 type
, arrayse
.expr
, limit
);
5518 gfc_add_modify (&block2
, limit
, tmp
);
5523 tree elsebody
= gfc_finish_block (&block2
);
5525 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5527 if (HONOR_NANS (DECL_MODE (limit
)))
5529 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5530 arrayse
.expr
, limit
);
5531 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5532 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5533 build_empty_stmt (input_location
));
5537 tmp
= fold_build2_loc (input_location
,
5538 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5539 type
, arrayse
.expr
, limit
);
5540 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5542 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5543 gfc_add_expr_to_block (&block
, tmp
);
5546 gfc_add_block_to_block (&block
, &block2
);
5548 gfc_add_block_to_block (&block
, &arrayse
.post
);
5550 tmp
= gfc_finish_block (&block
);
5552 /* We enclose the above in if (mask) {...}. */
5553 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5554 build_empty_stmt (input_location
));
5555 gfc_add_expr_to_block (&body
, tmp
);
5559 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5561 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5563 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
5564 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
5566 /* If we have a mask, only add this element if the mask is set. */
5569 gfc_init_se (&maskse
, NULL
);
5570 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5572 gfc_conv_expr_val (&maskse
, maskexpr
);
5573 gfc_add_block_to_block (&body
, &maskse
.pre
);
5575 gfc_start_block (&block
);
5578 gfc_init_block (&block
);
5580 /* Compare with the current limit. */
5581 gfc_init_se (&arrayse
, NULL
);
5582 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5583 arrayse
.ss
= arrayss
;
5584 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5585 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5587 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5589 if (HONOR_NANS (DECL_MODE (limit
)))
5591 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5592 arrayse
.expr
, limit
);
5593 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5594 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5595 build_empty_stmt (input_location
));
5596 gfc_add_expr_to_block (&block
, tmp
);
5600 tmp
= fold_build2_loc (input_location
,
5601 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5602 type
, arrayse
.expr
, limit
);
5603 gfc_add_modify (&block
, limit
, tmp
);
5606 gfc_add_block_to_block (&block
, &arrayse
.post
);
5608 tmp
= gfc_finish_block (&block
);
5610 /* We enclose the above in if (mask) {...}. */
5611 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5612 build_empty_stmt (input_location
));
5613 gfc_add_expr_to_block (&body
, tmp
);
5614 /* Avoid initializing loopvar[0] again, it should be left where
5615 it finished by the first loop. */
5616 loop
.from
[0] = loop
.loopvar
[0];
5618 gfc_trans_scalarizing_loops (&loop
, &body
);
5622 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5624 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5625 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
5627 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5629 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
5631 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
5633 gfc_add_modify (&loop
.pre
, limit
, tmp
);
5636 /* For a scalar mask, enclose the loop in an if statement. */
5637 if (maskexpr
&& maskss
== NULL
)
5641 gfc_init_se (&maskse
, NULL
);
5642 gfc_conv_expr_val (&maskse
, maskexpr
);
5643 gfc_init_block (&block
);
5644 gfc_add_block_to_block (&block
, &loop
.pre
);
5645 gfc_add_block_to_block (&block
, &loop
.post
);
5646 tmp
= gfc_finish_block (&block
);
5648 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5649 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
5651 else_stmt
= build_empty_stmt (input_location
);
5652 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
5653 gfc_add_expr_to_block (&block
, tmp
);
5654 gfc_add_block_to_block (&se
->pre
, &block
);
5658 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5659 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5662 gfc_cleanup_loop (&loop
);
5667 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5669 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
5675 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5676 type
= TREE_TYPE (args
[0]);
5678 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5679 build_int_cst (type
, 1), args
[1]);
5680 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
5681 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
5682 build_int_cst (type
, 0));
5683 type
= gfc_typenode_for_spec (&expr
->ts
);
5684 se
->expr
= convert (type
, tmp
);
5688 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5690 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5694 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5696 /* Convert both arguments to the unsigned type of the same size. */
5697 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
5698 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
5700 /* If they have unequal type size, convert to the larger one. */
5701 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
5702 > TYPE_PRECISION (TREE_TYPE (args
[1])))
5703 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
5704 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
5705 > TYPE_PRECISION (TREE_TYPE (args
[0])))
5706 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
5708 /* Now, we compare them. */
5709 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
5714 /* Generate code to perform the specified operation. */
5716 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5720 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5721 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
5727 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
5731 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5732 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5733 TREE_TYPE (arg
), arg
);
5736 /* Set or clear a single bit. */
5738 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
5745 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5746 type
= TREE_TYPE (args
[0]);
5748 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5749 build_int_cst (type
, 1), args
[1]);
5755 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
5757 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
5760 /* Extract a sequence of bits.
5761 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5763 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
5770 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5771 type
= TREE_TYPE (args
[0]);
5773 mask
= build_int_cst (type
, -1);
5774 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
5775 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
5777 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
5779 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
5783 gfc_conv_intrinsic_shape (gfc_se
*se
, gfc_expr
*expr
)
5785 gfc_actual_arglist
*s
, *k
;
5788 /* Remove the KIND argument, if present. */
5789 s
= expr
->value
.function
.actual
;
5795 gfc_conv_intrinsic_funcall (se
, expr
);
5799 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
5802 tree args
[2], type
, num_bits
, cond
;
5804 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5806 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5807 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5808 type
= TREE_TYPE (args
[0]);
5811 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
5813 gcc_assert (right_shift
);
5815 se
->expr
= fold_build2_loc (input_location
,
5816 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
5817 TREE_TYPE (args
[0]), args
[0], args
[1]);
5820 se
->expr
= fold_convert (type
, se
->expr
);
5822 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5823 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5825 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5826 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
5829 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5830 build_int_cst (type
, 0), se
->expr
);
5833 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5835 : ((shift >= 0) ? i << shift : i >> -shift)
5836 where all shifts are logical shifts. */
5838 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
5850 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5852 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5853 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5855 type
= TREE_TYPE (args
[0]);
5856 utype
= unsigned_type_for (type
);
5858 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
5861 /* Left shift if positive. */
5862 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
5864 /* Right shift if negative.
5865 We convert to an unsigned type because we want a logical shift.
5866 The standard doesn't define the case of shifting negative
5867 numbers, and we try to be compatible with other compilers, most
5868 notably g77, here. */
5869 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
5870 utype
, convert (utype
, args
[0]), width
));
5872 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
5873 build_int_cst (TREE_TYPE (args
[1]), 0));
5874 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
5876 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5877 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5879 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5880 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
5882 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5883 build_int_cst (type
, 0), tmp
);
5887 /* Circular shift. AKA rotate or barrel shift. */
5890 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
5898 unsigned int num_args
;
5900 num_args
= gfc_intrinsic_argument_list_length (expr
);
5901 args
= XALLOCAVEC (tree
, num_args
);
5903 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5907 /* Use a library function for the 3 parameter version. */
5908 tree int4type
= gfc_get_int_type (4);
5910 type
= TREE_TYPE (args
[0]);
5911 /* We convert the first argument to at least 4 bytes, and
5912 convert back afterwards. This removes the need for library
5913 functions for all argument sizes, and function will be
5914 aligned to at least 32 bits, so there's no loss. */
5915 if (expr
->ts
.kind
< 4)
5916 args
[0] = convert (int4type
, args
[0]);
5918 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5919 need loads of library functions. They cannot have values >
5920 BIT_SIZE (I) so the conversion is safe. */
5921 args
[1] = convert (int4type
, args
[1]);
5922 args
[2] = convert (int4type
, args
[2]);
5924 switch (expr
->ts
.kind
)
5929 tmp
= gfor_fndecl_math_ishftc4
;
5932 tmp
= gfor_fndecl_math_ishftc8
;
5935 tmp
= gfor_fndecl_math_ishftc16
;
5940 se
->expr
= build_call_expr_loc (input_location
,
5941 tmp
, 3, args
[0], args
[1], args
[2]);
5942 /* Convert the result back to the original type, if we extended
5943 the first argument's width above. */
5944 if (expr
->ts
.kind
< 4)
5945 se
->expr
= convert (type
, se
->expr
);
5949 type
= TREE_TYPE (args
[0]);
5951 /* Evaluate arguments only once. */
5952 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5953 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5955 /* Rotate left if positive. */
5956 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
5958 /* Rotate right if negative. */
5959 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
5961 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
5963 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
5964 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
5966 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
5968 /* Do nothing if shift == 0. */
5969 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
5971 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
5976 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5977 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5979 The conditional expression is necessary because the result of LEADZ(0)
5980 is defined, but the result of __builtin_clz(0) is undefined for most
5983 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5984 difference in bit size between the argument of LEADZ and the C int. */
5987 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
5999 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6000 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6002 /* Which variant of __builtin_clz* should we call? */
6003 if (argsize
<= INT_TYPE_SIZE
)
6005 arg_type
= unsigned_type_node
;
6006 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
6008 else if (argsize
<= LONG_TYPE_SIZE
)
6010 arg_type
= long_unsigned_type_node
;
6011 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
6013 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6015 arg_type
= long_long_unsigned_type_node
;
6016 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6020 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6021 arg_type
= gfc_build_uint_type (argsize
);
6025 /* Convert the actual argument twice: first, to the unsigned type of the
6026 same size; then, to the proper argument type for the built-in
6027 function. But the return type is of the default INTEGER kind. */
6028 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6029 arg
= fold_convert (arg_type
, arg
);
6030 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6031 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6033 /* Compute LEADZ for the case i .ne. 0. */
6036 s
= TYPE_PRECISION (arg_type
) - argsize
;
6037 tmp
= fold_convert (result_type
,
6038 build_call_expr_loc (input_location
, func
,
6040 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
6041 tmp
, build_int_cst (result_type
, s
));
6045 /* We end up here if the argument type is larger than 'long long'.
6046 We generate this code:
6048 if (x & (ULL_MAX << ULL_SIZE) != 0)
6049 return clzll ((unsigned long long) (x >> ULLSIZE));
6051 return ULL_SIZE + clzll ((unsigned long long) x);
6052 where ULL_MAX is the largest value that a ULL_MAX can hold
6053 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6054 is the bit-size of the long long type (64 in this example). */
6055 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
6057 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
6058 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6059 long_long_unsigned_type_node
,
6060 build_int_cst (long_long_unsigned_type_node
,
6063 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
6064 fold_convert (arg_type
, ullmax
), ullsize
);
6065 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
6067 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6068 cond
, build_int_cst (arg_type
, 0));
6070 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
6072 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
6073 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6074 tmp1
= fold_convert (result_type
,
6075 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
6077 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
6078 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6079 tmp2
= fold_convert (result_type
,
6080 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
6081 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6084 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
6088 /* Build BIT_SIZE. */
6089 bit_size
= build_int_cst (result_type
, argsize
);
6091 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6092 arg
, build_int_cst (arg_type
, 0));
6093 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
6098 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
6100 The conditional expression is necessary because the result of TRAILZ(0)
6101 is defined, but the result of __builtin_ctz(0) is undefined for most
6105 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
6116 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6117 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6119 /* Which variant of __builtin_ctz* should we call? */
6120 if (argsize
<= INT_TYPE_SIZE
)
6122 arg_type
= unsigned_type_node
;
6123 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
6125 else if (argsize
<= LONG_TYPE_SIZE
)
6127 arg_type
= long_unsigned_type_node
;
6128 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
6130 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6132 arg_type
= long_long_unsigned_type_node
;
6133 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6137 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6138 arg_type
= gfc_build_uint_type (argsize
);
6142 /* Convert the actual argument twice: first, to the unsigned type of the
6143 same size; then, to the proper argument type for the built-in
6144 function. But the return type is of the default INTEGER kind. */
6145 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6146 arg
= fold_convert (arg_type
, arg
);
6147 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6148 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6150 /* Compute TRAILZ for the case i .ne. 0. */
6152 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
6156 /* We end up here if the argument type is larger than 'long long'.
6157 We generate this code:
6159 if ((x & ULL_MAX) == 0)
6160 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
6162 return ctzll ((unsigned long long) x);
6164 where ULL_MAX is the largest value that a ULL_MAX can hold
6165 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6166 is the bit-size of the long long type (64 in this example). */
6167 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
6169 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
6170 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6171 long_long_unsigned_type_node
,
6172 build_int_cst (long_long_unsigned_type_node
, 0));
6174 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
6175 fold_convert (arg_type
, ullmax
));
6176 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
6177 build_int_cst (arg_type
, 0));
6179 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
6181 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
6182 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6183 tmp1
= fold_convert (result_type
,
6184 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
6185 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6188 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
6189 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6190 tmp2
= fold_convert (result_type
,
6191 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
6193 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
6197 /* Build BIT_SIZE. */
6198 bit_size
= build_int_cst (result_type
, argsize
);
6200 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6201 arg
, build_int_cst (arg_type
, 0));
6202 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
6206 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
6207 for types larger than "long long", we call the long long built-in for
6208 the lower and higher bits and combine the result. */
6211 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
6219 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6220 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6221 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6223 /* Which variant of the builtin should we call? */
6224 if (argsize
<= INT_TYPE_SIZE
)
6226 arg_type
= unsigned_type_node
;
6227 func
= builtin_decl_explicit (parity
6229 : BUILT_IN_POPCOUNT
);
6231 else if (argsize
<= LONG_TYPE_SIZE
)
6233 arg_type
= long_unsigned_type_node
;
6234 func
= builtin_decl_explicit (parity
6236 : BUILT_IN_POPCOUNTL
);
6238 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6240 arg_type
= long_long_unsigned_type_node
;
6241 func
= builtin_decl_explicit (parity
6243 : BUILT_IN_POPCOUNTLL
);
6247 /* Our argument type is larger than 'long long', which mean none
6248 of the POPCOUNT builtins covers it. We thus call the 'long long'
6249 variant multiple times, and add the results. */
6250 tree utype
, arg2
, call1
, call2
;
6252 /* For now, we only cover the case where argsize is twice as large
6254 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6256 func
= builtin_decl_explicit (parity
6258 : BUILT_IN_POPCOUNTLL
);
6260 /* Convert it to an integer, and store into a variable. */
6261 utype
= gfc_build_uint_type (argsize
);
6262 arg
= fold_convert (utype
, arg
);
6263 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6265 /* Call the builtin twice. */
6266 call1
= build_call_expr_loc (input_location
, func
, 1,
6267 fold_convert (long_long_unsigned_type_node
,
6270 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
6271 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
6272 call2
= build_call_expr_loc (input_location
, func
, 1,
6273 fold_convert (long_long_unsigned_type_node
,
6276 /* Combine the results. */
6278 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
6281 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6287 /* Convert the actual argument twice: first, to the unsigned type of the
6288 same size; then, to the proper argument type for the built-in
6290 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6291 arg
= fold_convert (arg_type
, arg
);
6293 se
->expr
= fold_convert (result_type
,
6294 build_call_expr_loc (input_location
, func
, 1, arg
));
6298 /* Process an intrinsic with unspecified argument-types that has an optional
6299 argument (which could be of type character), e.g. EOSHIFT. For those, we
6300 need to append the string length of the optional argument if it is not
6301 present and the type is really character.
6302 primary specifies the position (starting at 1) of the non-optional argument
6303 specifying the type and optional gives the position of the optional
6304 argument in the arglist. */
6307 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
6308 unsigned primary
, unsigned optional
)
6310 gfc_actual_arglist
* prim_arg
;
6311 gfc_actual_arglist
* opt_arg
;
6313 gfc_actual_arglist
* arg
;
6315 vec
<tree
, va_gc
> *append_args
;
6317 /* Find the two arguments given as position. */
6321 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
6325 if (cur_pos
== primary
)
6327 if (cur_pos
== optional
)
6330 if (cur_pos
>= primary
&& cur_pos
>= optional
)
6333 gcc_assert (prim_arg
);
6334 gcc_assert (prim_arg
->expr
);
6335 gcc_assert (opt_arg
);
6337 /* If we do have type CHARACTER and the optional argument is really absent,
6338 append a dummy 0 as string length. */
6340 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
6344 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
6345 vec_alloc (append_args
, 1);
6346 append_args
->quick_push (dummy
);
6349 /* Build the call itself. */
6350 gcc_assert (!se
->ignore_optional
);
6351 sym
= gfc_get_symbol_for_expr (expr
, false);
6352 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6354 gfc_free_symbol (sym
);
6357 /* The length of a character string. */
6359 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
6368 gcc_assert (!se
->ss
);
6370 arg
= expr
->value
.function
.actual
->expr
;
6372 type
= gfc_typenode_for_spec (&expr
->ts
);
6373 switch (arg
->expr_type
)
6376 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
6380 /* Obtain the string length from the function used by
6381 trans-array.c(gfc_trans_array_constructor). */
6383 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
6387 if (arg
->ref
== NULL
6388 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6390 /* This doesn't catch all cases.
6391 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6392 and the surrounding thread. */
6393 sym
= arg
->symtree
->n
.sym
;
6394 decl
= gfc_get_symbol_decl (sym
);
6395 if (decl
== current_function_decl
&& sym
->attr
.function
6396 && (sym
->result
== sym
))
6397 decl
= gfc_get_fake_result_decl (sym
, 0);
6399 len
= sym
->ts
.u
.cl
->backend_decl
;
6407 /* Anybody stupid enough to do this deserves inefficient code. */
6408 gfc_init_se (&argse
, se
);
6410 gfc_conv_expr (&argse
, arg
);
6412 gfc_conv_expr_descriptor (&argse
, arg
);
6413 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6414 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6415 len
= argse
.string_length
;
6418 se
->expr
= convert (type
, len
);
6421 /* The length of a character string not including trailing blanks. */
6423 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6425 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6426 tree args
[2], type
, fndecl
;
6428 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6429 type
= gfc_typenode_for_spec (&expr
->ts
);
6432 fndecl
= gfor_fndecl_string_len_trim
;
6434 fndecl
= gfor_fndecl_string_len_trim_char4
;
6438 se
->expr
= build_call_expr_loc (input_location
,
6439 fndecl
, 2, args
[0], args
[1]);
6440 se
->expr
= convert (type
, se
->expr
);
6444 /* Returns the starting position of a substring within a string. */
6447 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6450 tree logical4_type_node
= gfc_get_logical_type (4);
6454 unsigned int num_args
;
6456 args
= XALLOCAVEC (tree
, 5);
6458 /* Get number of arguments; characters count double due to the
6459 string length argument. Kind= is not passed to the library
6460 and thus ignored. */
6461 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6466 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6467 type
= gfc_typenode_for_spec (&expr
->ts
);
6470 args
[4] = build_int_cst (logical4_type_node
, 0);
6472 args
[4] = convert (logical4_type_node
, args
[4]);
6474 fndecl
= build_addr (function
);
6475 se
->expr
= build_call_array_loc (input_location
,
6476 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6478 se
->expr
= convert (type
, se
->expr
);
6482 /* The ascii value for a single character. */
6484 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6486 tree args
[3], type
, pchartype
;
6489 nargs
= gfc_intrinsic_argument_list_length (expr
);
6490 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6491 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6492 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6493 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6494 type
= gfc_typenode_for_spec (&expr
->ts
);
6496 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6498 se
->expr
= convert (type
, se
->expr
);
6502 /* Intrinsic ISNAN calls __builtin_isnan. */
6505 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6509 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6510 se
->expr
= build_call_expr_loc (input_location
,
6511 builtin_decl_explicit (BUILT_IN_ISNAN
),
6513 STRIP_TYPE_NOPS (se
->expr
);
6514 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6518 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6519 their argument against a constant integer value. */
6522 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6526 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6527 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6528 gfc_typenode_for_spec (&expr
->ts
),
6529 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6534 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6537 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
6545 unsigned int num_args
;
6547 num_args
= gfc_intrinsic_argument_list_length (expr
);
6548 args
= XALLOCAVEC (tree
, num_args
);
6550 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6551 if (expr
->ts
.type
!= BT_CHARACTER
)
6559 /* We do the same as in the non-character case, but the argument
6560 list is different because of the string length arguments. We
6561 also have to set the string length for the result. */
6568 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
6570 se
->string_length
= len
;
6572 type
= TREE_TYPE (tsource
);
6573 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
6574 fold_convert (type
, fsource
));
6578 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6581 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
6583 tree args
[3], mask
, type
;
6585 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6586 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
6588 type
= TREE_TYPE (args
[0]);
6589 gcc_assert (TREE_TYPE (args
[1]) == type
);
6590 gcc_assert (TREE_TYPE (mask
) == type
);
6592 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
6593 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
6594 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6596 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
6601 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6602 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6605 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
6607 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
6610 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6611 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6613 type
= gfc_get_int_type (expr
->ts
.kind
);
6614 utype
= unsigned_type_for (type
);
6616 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
6617 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
6619 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
6620 build_int_cst (utype
, 0));
6624 /* Left-justified mask. */
6625 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
6627 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6628 fold_convert (utype
, res
));
6630 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6631 smaller than type width. */
6632 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6633 build_int_cst (TREE_TYPE (arg
), 0));
6634 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
6635 build_int_cst (utype
, 0), res
);
6639 /* Right-justified mask. */
6640 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6641 fold_convert (utype
, arg
));
6642 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
6644 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6645 strictly smaller than type width. */
6646 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6648 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
6649 cond
, allones
, res
);
6652 se
->expr
= fold_convert (type
, res
);
6656 /* FRACTION (s) is translated into:
6657 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6659 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
6661 tree arg
, type
, tmp
, res
, frexp
, cond
;
6663 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6665 type
= gfc_typenode_for_spec (&expr
->ts
);
6666 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6667 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6669 cond
= build_call_expr_loc (input_location
,
6670 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6673 tmp
= gfc_create_var (integer_type_node
, NULL
);
6674 res
= build_call_expr_loc (input_location
, frexp
, 2,
6675 fold_convert (type
, arg
),
6676 gfc_build_addr_expr (NULL_TREE
, tmp
));
6677 res
= fold_convert (type
, res
);
6679 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
6680 cond
, res
, gfc_build_nan (type
, ""));
6684 /* NEAREST (s, dir) is translated into
6685 tmp = copysign (HUGE_VAL, dir);
6686 return nextafter (s, tmp);
6689 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
6691 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
6693 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
6694 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
6696 type
= gfc_typenode_for_spec (&expr
->ts
);
6697 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6699 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
6700 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
6701 fold_convert (type
, args
[1]));
6702 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
6703 fold_convert (type
, args
[0]), tmp
);
6704 se
->expr
= fold_convert (type
, se
->expr
);
6708 /* SPACING (s) is translated into
6718 e = MAX_EXPR (e, emin);
6719 res = scalbn (1., e);
6723 where prec is the precision of s, gfc_real_kinds[k].digits,
6724 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6725 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6728 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
6730 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
6731 tree cond
, nan
, tmp
, frexp
, scalbn
;
6735 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6736 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
6737 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
6738 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
6740 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6741 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6743 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6744 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6746 type
= gfc_typenode_for_spec (&expr
->ts
);
6747 e
= gfc_create_var (integer_type_node
, NULL
);
6748 res
= gfc_create_var (type
, NULL
);
6751 /* Build the block for s /= 0. */
6752 gfc_start_block (&block
);
6753 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6754 gfc_build_addr_expr (NULL_TREE
, e
));
6755 gfc_add_expr_to_block (&block
, tmp
);
6757 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
6759 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
6760 integer_type_node
, tmp
, emin
));
6762 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
6763 build_real_from_int_cst (type
, integer_one_node
), e
);
6764 gfc_add_modify (&block
, res
, tmp
);
6766 /* Finish by building the IF statement for value zero. */
6767 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6768 build_real_from_int_cst (type
, integer_zero_node
));
6769 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
6770 gfc_finish_block (&block
));
6772 /* And deal with infinities and NaNs. */
6773 cond
= build_call_expr_loc (input_location
,
6774 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6776 nan
= gfc_build_nan (type
, "");
6777 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
6779 gfc_add_expr_to_block (&se
->pre
, tmp
);
6784 /* RRSPACING (s) is translated into
6793 x = scalbn (x, precision - e);
6800 where precision is gfc_real_kinds[k].digits. */
6803 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
6805 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
6809 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6810 prec
= gfc_real_kinds
[k
].digits
;
6812 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6813 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6814 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
6816 type
= gfc_typenode_for_spec (&expr
->ts
);
6817 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6818 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6820 e
= gfc_create_var (integer_type_node
, NULL
);
6821 x
= gfc_create_var (type
, NULL
);
6822 gfc_add_modify (&se
->pre
, x
,
6823 build_call_expr_loc (input_location
, fabs
, 1, arg
));
6826 gfc_start_block (&block
);
6827 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6828 gfc_build_addr_expr (NULL_TREE
, e
));
6829 gfc_add_expr_to_block (&block
, tmp
);
6831 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
6832 build_int_cst (integer_type_node
, prec
), e
);
6833 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
6834 gfc_add_modify (&block
, x
, tmp
);
6835 stmt
= gfc_finish_block (&block
);
6838 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
6839 build_real_from_int_cst (type
, integer_zero_node
));
6840 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
6842 /* And deal with infinities and NaNs. */
6843 cond
= build_call_expr_loc (input_location
,
6844 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6846 nan
= gfc_build_nan (type
, "");
6847 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
6849 gfc_add_expr_to_block (&se
->pre
, tmp
);
6850 se
->expr
= fold_convert (type
, x
);
6854 /* SCALE (s, i) is translated into scalbn (s, i). */
6856 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
6858 tree args
[2], type
, scalbn
;
6860 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6862 type
= gfc_typenode_for_spec (&expr
->ts
);
6863 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6864 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
6865 fold_convert (type
, args
[0]),
6866 fold_convert (integer_type_node
, args
[1]));
6867 se
->expr
= fold_convert (type
, se
->expr
);
6871 /* SET_EXPONENT (s, i) is translated into
6872 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6874 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
6876 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
6878 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6879 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6881 type
= gfc_typenode_for_spec (&expr
->ts
);
6882 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6883 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6885 tmp
= gfc_create_var (integer_type_node
, NULL
);
6886 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
6887 fold_convert (type
, args
[0]),
6888 gfc_build_addr_expr (NULL_TREE
, tmp
));
6889 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
6890 fold_convert (integer_type_node
, args
[1]));
6891 res
= fold_convert (type
, res
);
6893 /* Call to isfinite */
6894 cond
= build_call_expr_loc (input_location
,
6895 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6897 nan
= gfc_build_nan (type
, "");
6899 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6905 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
6907 gfc_actual_arglist
*actual
;
6914 gfc_init_se (&argse
, NULL
);
6915 actual
= expr
->value
.function
.actual
;
6917 if (actual
->expr
->ts
.type
== BT_CLASS
)
6918 gfc_add_class_array_ref (actual
->expr
);
6920 argse
.data_not_needed
= 1;
6921 if (gfc_is_class_array_function (actual
->expr
))
6923 /* For functions that return a class array conv_expr_descriptor is not
6924 able to get the descriptor right. Therefore this special case. */
6925 gfc_conv_expr_reference (&argse
, actual
->expr
);
6926 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6927 gfc_class_data_get (argse
.expr
));
6931 argse
.want_pointer
= 1;
6932 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
6934 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6935 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6936 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
6938 /* Build the call to size0. */
6939 fncall0
= build_call_expr_loc (input_location
,
6940 gfor_fndecl_size0
, 1, arg1
);
6942 actual
= actual
->next
;
6946 gfc_init_se (&argse
, NULL
);
6947 gfc_conv_expr_type (&argse
, actual
->expr
,
6948 gfc_array_index_type
);
6949 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6951 /* Unusually, for an intrinsic, size does not exclude
6952 an optional arg2, so we must test for it. */
6953 if (actual
->expr
->expr_type
== EXPR_VARIABLE
6954 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
6955 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
6958 /* Build the call to size1. */
6959 fncall1
= build_call_expr_loc (input_location
,
6960 gfor_fndecl_size1
, 2,
6963 gfc_init_se (&argse
, NULL
);
6964 argse
.want_pointer
= 1;
6965 argse
.data_not_needed
= 1;
6966 gfc_conv_expr (&argse
, actual
->expr
);
6967 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6968 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6969 argse
.expr
, null_pointer_node
);
6970 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6971 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
6972 pvoid_type_node
, tmp
, fncall1
, fncall0
);
6976 se
->expr
= NULL_TREE
;
6977 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6978 gfc_array_index_type
,
6979 argse
.expr
, gfc_index_one_node
);
6982 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
6984 argse
.expr
= gfc_index_zero_node
;
6985 se
->expr
= NULL_TREE
;
6990 if (se
->expr
== NULL_TREE
)
6992 tree ubound
, lbound
;
6994 arg1
= build_fold_indirect_ref_loc (input_location
,
6996 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
6997 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
6998 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6999 gfc_array_index_type
, ubound
, lbound
);
7000 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
7001 gfc_array_index_type
,
7002 se
->expr
, gfc_index_one_node
);
7003 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7004 gfc_array_index_type
, se
->expr
,
7005 gfc_index_zero_node
);
7008 type
= gfc_typenode_for_spec (&expr
->ts
);
7009 se
->expr
= convert (type
, se
->expr
);
7013 /* Helper function to compute the size of a character variable,
7014 excluding the terminating null characters. The result has
7015 gfc_array_index_type type. */
7018 size_of_string_in_bytes (int kind
, tree string_length
)
7021 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
7023 bytesize
= build_int_cst (gfc_array_index_type
,
7024 gfc_character_kinds
[i
].bit_size
/ 8);
7026 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7028 fold_convert (gfc_array_index_type
, string_length
));
7033 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
7045 gfc_init_se (&argse
, NULL
);
7046 arg
= expr
->value
.function
.actual
->expr
;
7048 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
7049 gfc_conv_expr_descriptor (&argse
, arg
);
7051 gfc_conv_expr_reference (&argse
, arg
);
7053 if (arg
->ts
.type
== BT_ASSUMED
)
7055 /* This only works if an array descriptor has been passed; thus, extract
7056 the size from the descriptor. */
7057 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
7058 == TYPE_PRECISION (size_type_node
));
7059 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
7060 tmp
= DECL_LANG_SPECIFIC (tmp
)
7061 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
7062 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
7063 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
7064 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7066 tmp
= gfc_conv_descriptor_dtype (tmp
);
7067 field
= gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
7068 GFC_DTYPE_ELEM_LEN
);
7069 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7070 tmp
, field
, NULL_TREE
);
7072 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
7074 else if (arg
->ts
.type
== BT_CLASS
)
7076 /* Conv_expr_descriptor returns a component_ref to _data component of the
7077 class object. The class object may be a non-pointer object, e.g.
7078 located on the stack, or a memory location pointed to, e.g. a
7079 parameter, i.e., an indirect_ref. */
7081 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
7082 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
7083 && GFC_DECL_CLASS (TREE_OPERAND (
7084 TREE_OPERAND (argse
.expr
, 0), 0)))
7085 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
7086 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
7087 else if (arg
->rank
> 0
7089 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
7090 /* The scalarizer added an additional temp. To get the class' vptr
7091 one has to look at the original backend_decl. */
7092 byte_size
= gfc_class_vtab_size_get (
7093 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
7095 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
7099 if (arg
->ts
.type
== BT_CHARACTER
)
7100 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
7104 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7107 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7108 byte_size
= fold_convert (gfc_array_index_type
,
7109 size_in_bytes (byte_size
));
7114 se
->expr
= byte_size
;
7117 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
7118 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
7120 if (arg
->rank
== -1)
7122 tree cond
, loop_var
, exit_label
;
7125 tmp
= fold_convert (gfc_array_index_type
,
7126 gfc_conv_descriptor_rank (argse
.expr
));
7127 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
7128 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
7129 exit_label
= gfc_build_label_decl (NULL_TREE
);
7136 source_bytes = source_bytes * array.dim[i].extent;
7140 gfc_start_block (&body
);
7141 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
7143 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7144 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7145 cond
, tmp
, build_empty_stmt (input_location
));
7146 gfc_add_expr_to_block (&body
, tmp
);
7148 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
7149 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
7150 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
7151 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7152 gfc_array_index_type
, tmp
, source_bytes
);
7153 gfc_add_modify (&body
, source_bytes
, tmp
);
7155 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7156 gfc_array_index_type
, loop_var
,
7157 gfc_index_one_node
);
7158 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
7160 tmp
= gfc_finish_block (&body
);
7162 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
7164 gfc_add_expr_to_block (&argse
.pre
, tmp
);
7166 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7167 gfc_add_expr_to_block (&argse
.pre
, tmp
);
7171 /* Obtain the size of the array in bytes. */
7172 for (n
= 0; n
< arg
->rank
; n
++)
7175 idx
= gfc_rank_cst
[n
];
7176 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7177 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7178 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
7179 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7180 gfc_array_index_type
, tmp
, source_bytes
);
7181 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7184 se
->expr
= source_bytes
;
7187 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7192 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
7196 tree type
, result_type
, tmp
;
7198 arg
= expr
->value
.function
.actual
->expr
;
7200 gfc_init_se (&argse
, NULL
);
7201 result_type
= gfc_get_int_type (expr
->ts
.kind
);
7205 if (arg
->ts
.type
== BT_CLASS
)
7207 gfc_add_vptr_component (arg
);
7208 gfc_add_size_component (arg
);
7209 gfc_conv_expr (&argse
, arg
);
7210 tmp
= fold_convert (result_type
, argse
.expr
);
7214 gfc_conv_expr_reference (&argse
, arg
);
7215 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7220 argse
.want_pointer
= 0;
7221 gfc_conv_expr_descriptor (&argse
, arg
);
7222 if (arg
->ts
.type
== BT_CLASS
)
7225 tmp
= gfc_class_vtab_size_get (
7226 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
7228 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
7229 tmp
= fold_convert (result_type
, tmp
);
7232 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7235 /* Obtain the argument's word length. */
7236 if (arg
->ts
.type
== BT_CHARACTER
)
7237 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
7239 tmp
= size_in_bytes (type
);
7240 tmp
= fold_convert (result_type
, tmp
);
7243 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
7244 build_int_cst (result_type
, BITS_PER_UNIT
));
7245 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7249 /* Intrinsic string comparison functions. */
7252 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
7256 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
7259 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
7260 expr
->value
.function
.actual
->expr
->ts
.kind
,
7262 se
->expr
= fold_build2_loc (input_location
, op
,
7263 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
7264 build_int_cst (TREE_TYPE (se
->expr
), 0));
7267 /* Generate a call to the adjustl/adjustr library function. */
7269 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
7277 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
7280 type
= TREE_TYPE (args
[2]);
7281 var
= gfc_conv_string_tmp (se
, type
, len
);
7284 tmp
= build_call_expr_loc (input_location
,
7285 fndecl
, 3, args
[0], args
[1], args
[2]);
7286 gfc_add_expr_to_block (&se
->pre
, tmp
);
7288 se
->string_length
= len
;
7292 /* Generate code for the TRANSFER intrinsic:
7294 DEST = TRANSFER (SOURCE, MOLD)
7296 typeof<DEST> = typeof<MOLD>
7301 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
7303 typeof<DEST> = typeof<MOLD>
7305 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
7306 sizeof (DEST(0) * SIZE). */
7308 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
7324 tree class_ref
= NULL_TREE
;
7325 gfc_actual_arglist
*arg
;
7327 gfc_array_info
*info
;
7331 gfc_expr
*source_expr
, *mold_expr
, *class_expr
;
7335 info
= &se
->ss
->info
->data
.array
;
7337 /* Convert SOURCE. The output from this stage is:-
7338 source_bytes = length of the source in bytes
7339 source = pointer to the source data. */
7340 arg
= expr
->value
.function
.actual
;
7341 source_expr
= arg
->expr
;
7343 /* Ensure double transfer through LOGICAL preserves all
7345 if (arg
->expr
->expr_type
== EXPR_FUNCTION
7346 && arg
->expr
->value
.function
.esym
== NULL
7347 && arg
->expr
->value
.function
.isym
!= NULL
7348 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
7349 && arg
->expr
->ts
.type
== BT_LOGICAL
7350 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
7351 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
7353 gfc_init_se (&argse
, NULL
);
7355 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7357 /* Obtain the pointer to source and the length of source in bytes. */
7358 if (arg
->expr
->rank
== 0)
7360 gfc_conv_expr_reference (&argse
, arg
->expr
);
7361 if (arg
->expr
->ts
.type
== BT_CLASS
)
7363 tmp
= build_fold_indirect_ref_loc (input_location
, argse
.expr
);
7364 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
7365 source
= gfc_class_data_get (tmp
);
7368 /* Array elements are evaluated as a reference to the data.
7369 To obtain the vptr for the element size, the argument
7370 expression must be stripped to the class reference and
7371 re-evaluated. The pre and post blocks are not needed. */
7372 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
7373 source
= argse
.expr
;
7374 class_expr
= gfc_find_and_cut_at_last_class_ref (arg
->expr
);
7375 gfc_init_se (&argse
, NULL
);
7376 gfc_conv_expr (&argse
, class_expr
);
7377 class_ref
= argse
.expr
;
7381 source
= argse
.expr
;
7383 /* Obtain the source word length. */
7384 switch (arg
->expr
->ts
.type
)
7387 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7388 argse
.string_length
);
7391 if (class_ref
!= NULL_TREE
)
7392 tmp
= gfc_class_vtab_size_get (class_ref
);
7394 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7397 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7399 tmp
= fold_convert (gfc_array_index_type
,
7400 size_in_bytes (source_type
));
7406 argse
.want_pointer
= 0;
7407 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7408 source
= gfc_conv_descriptor_data_get (argse
.expr
);
7409 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7411 /* Repack the source if not simply contiguous. */
7412 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
7414 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
7416 if (warn_array_temporaries
)
7417 gfc_warning (OPT_Warray_temporaries
,
7418 "Creating array temporary at %L", &expr
->where
);
7420 source
= build_call_expr_loc (input_location
,
7421 gfor_fndecl_in_pack
, 1, tmp
);
7422 source
= gfc_evaluate_now (source
, &argse
.pre
);
7424 /* Free the temporary. */
7425 gfc_start_block (&block
);
7426 tmp
= gfc_call_free (source
);
7427 gfc_add_expr_to_block (&block
, tmp
);
7428 stmt
= gfc_finish_block (&block
);
7430 /* Clean up if it was repacked. */
7431 gfc_init_block (&block
);
7432 tmp
= gfc_conv_array_data (argse
.expr
);
7433 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7435 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7436 build_empty_stmt (input_location
));
7437 gfc_add_expr_to_block (&block
, tmp
);
7438 gfc_add_block_to_block (&block
, &se
->post
);
7439 gfc_init_block (&se
->post
);
7440 gfc_add_block_to_block (&se
->post
, &block
);
7443 /* Obtain the source word length. */
7444 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7445 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7446 argse
.string_length
);
7448 tmp
= fold_convert (gfc_array_index_type
,
7449 size_in_bytes (source_type
));
7451 /* Obtain the size of the array in bytes. */
7452 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7453 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7456 idx
= gfc_rank_cst
[n
];
7457 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7458 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7459 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7460 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7461 gfc_array_index_type
, upper
, lower
);
7462 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7463 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7464 gfc_array_index_type
, extent
,
7465 gfc_index_one_node
);
7466 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7467 gfc_array_index_type
, tmp
, source_bytes
);
7471 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7472 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7473 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7475 /* Now convert MOLD. The outputs are:
7476 mold_type = the TREE type of MOLD
7477 dest_word_len = destination word length in bytes. */
7479 mold_expr
= arg
->expr
;
7481 gfc_init_se (&argse
, NULL
);
7483 scalar_mold
= arg
->expr
->rank
== 0;
7485 if (arg
->expr
->rank
== 0)
7487 gfc_conv_expr_reference (&argse
, arg
->expr
);
7488 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7493 gfc_init_se (&argse
, NULL
);
7494 argse
.want_pointer
= 0;
7495 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7496 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7499 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7500 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7502 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7504 /* If this TRANSFER is nested in another TRANSFER, use a type
7505 that preserves all bits. */
7506 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7507 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7510 /* Obtain the destination word length. */
7511 switch (arg
->expr
->ts
.type
)
7514 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7515 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7518 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7521 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7524 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7525 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7527 /* Finally convert SIZE, if it is present. */
7529 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7533 gfc_init_se (&argse
, NULL
);
7534 gfc_conv_expr_reference (&argse
, arg
->expr
);
7535 tmp
= convert (gfc_array_index_type
,
7536 build_fold_indirect_ref_loc (input_location
,
7538 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7539 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7544 /* Separate array and scalar results. */
7545 if (scalar_mold
&& tmp
== NULL_TREE
)
7546 goto scalar_transfer
;
7548 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7549 if (tmp
!= NULL_TREE
)
7550 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7551 tmp
, dest_word_len
);
7555 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
7556 gfc_add_modify (&se
->pre
, size_words
,
7557 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
7558 gfc_array_index_type
,
7559 size_bytes
, dest_word_len
));
7561 /* Evaluate the bounds of the result. If the loop range exists, we have
7562 to check if it is too large. If so, we modify loop->to be consistent
7563 with min(size, size(source)). Otherwise, size is made consistent with
7564 the loop range, so that the right number of bytes is transferred.*/
7565 n
= se
->loop
->order
[0];
7566 if (se
->loop
->to
[n
] != NULL_TREE
)
7568 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7569 se
->loop
->to
[n
], se
->loop
->from
[n
]);
7570 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7571 tmp
, gfc_index_one_node
);
7572 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7574 gfc_add_modify (&se
->pre
, size_words
, tmp
);
7575 gfc_add_modify (&se
->pre
, size_bytes
,
7576 fold_build2_loc (input_location
, MULT_EXPR
,
7577 gfc_array_index_type
,
7578 size_words
, dest_word_len
));
7579 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7580 size_words
, se
->loop
->from
[n
]);
7581 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7582 upper
, gfc_index_one_node
);
7586 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7587 size_words
, gfc_index_one_node
);
7588 se
->loop
->from
[n
] = gfc_index_zero_node
;
7591 se
->loop
->to
[n
] = upper
;
7593 /* Build a destination descriptor, using the pointer, source, as the
7595 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
7596 NULL_TREE
, false, true, false, &expr
->where
);
7598 /* Cast the pointer to the result. */
7599 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7600 tmp
= fold_convert (pvoid_type_node
, tmp
);
7602 /* Use memcpy to do the transfer. */
7604 = build_call_expr_loc (input_location
,
7605 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
7606 fold_convert (pvoid_type_node
, source
),
7607 fold_convert (size_type_node
,
7608 fold_build2_loc (input_location
,
7610 gfc_array_index_type
,
7613 gfc_add_expr_to_block (&se
->pre
, tmp
);
7615 se
->expr
= info
->descriptor
;
7616 if (expr
->ts
.type
== BT_CHARACTER
)
7617 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7621 /* Deal with scalar results. */
7623 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7624 dest_word_len
, source_bytes
);
7625 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7626 extent
, gfc_index_zero_node
);
7628 if (expr
->ts
.type
== BT_CHARACTER
)
7630 tree direct
, indirect
, free
;
7632 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
7633 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
7636 /* If source is longer than the destination, use a pointer to
7637 the source directly. */
7638 gfc_init_block (&block
);
7639 gfc_add_modify (&block
, tmpdecl
, ptr
);
7640 direct
= gfc_finish_block (&block
);
7642 /* Otherwise, allocate a string with the length of the destination
7643 and copy the source into it. */
7644 gfc_init_block (&block
);
7645 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
7646 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
7647 gfc_add_modify (&block
, tmpdecl
,
7648 fold_convert (TREE_TYPE (ptr
), tmp
));
7649 tmp
= build_call_expr_loc (input_location
,
7650 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7651 fold_convert (pvoid_type_node
, tmpdecl
),
7652 fold_convert (pvoid_type_node
, ptr
),
7653 fold_convert (size_type_node
, extent
));
7654 gfc_add_expr_to_block (&block
, tmp
);
7655 indirect
= gfc_finish_block (&block
);
7657 /* Wrap it up with the condition. */
7658 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
7659 dest_word_len
, source_bytes
);
7660 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
7661 gfc_add_expr_to_block (&se
->pre
, tmp
);
7663 /* Free the temporary string, if necessary. */
7664 free
= gfc_call_free (tmpdecl
);
7665 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7666 dest_word_len
, source_bytes
);
7667 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
7668 gfc_add_expr_to_block (&se
->post
, tmp
);
7671 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7675 tmpdecl
= gfc_create_var (mold_type
, "transfer");
7677 ptr
= convert (build_pointer_type (mold_type
), source
);
7679 /* For CLASS results, allocate the needed memory first. */
7680 if (mold_expr
->ts
.type
== BT_CLASS
)
7683 cdata
= gfc_class_data_get (tmpdecl
);
7684 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
7685 gfc_add_modify (&se
->pre
, cdata
, tmp
);
7688 /* Use memcpy to do the transfer. */
7689 if (mold_expr
->ts
.type
== BT_CLASS
)
7690 tmp
= gfc_class_data_get (tmpdecl
);
7692 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
7694 tmp
= build_call_expr_loc (input_location
,
7695 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7696 fold_convert (pvoid_type_node
, tmp
),
7697 fold_convert (pvoid_type_node
, ptr
),
7698 fold_convert (size_type_node
, extent
));
7699 gfc_add_expr_to_block (&se
->pre
, tmp
);
7701 /* For CLASS results, set the _vptr. */
7702 if (mold_expr
->ts
.type
== BT_CLASS
)
7706 vptr
= gfc_class_vptr_get (tmpdecl
);
7707 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
7709 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7710 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
7718 /* Generate a call to caf_is_present. */
7721 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
7723 tree caf_reference
, caf_decl
, token
, image_index
;
7725 /* Compile the reference chain. */
7726 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
7727 gcc_assert (caf_reference
!= NULL_TREE
);
7729 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
7730 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
7731 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
7732 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
7733 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
7736 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
7737 3, token
, image_index
, caf_reference
);
7741 /* Test whether this ref-chain refs this image only. */
7744 caf_this_image_ref (gfc_ref
*ref
)
7746 for ( ; ref
; ref
= ref
->next
)
7747 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
7748 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
7754 /* Generate code for the ALLOCATED intrinsic.
7755 Generate inline code that directly check the address of the argument. */
7758 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
7760 gfc_actual_arglist
*arg1
;
7763 symbol_attribute caf_attr
;
7765 gfc_init_se (&arg1se
, NULL
);
7766 arg1
= expr
->value
.function
.actual
;
7768 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7770 /* Make sure that class array expressions have both a _data
7771 component reference and an array reference.... */
7772 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
7773 gfc_add_class_array_ref (arg1
->expr
);
7774 /* .... whilst scalars only need the _data component. */
7776 gfc_add_data_component (arg1
->expr
);
7779 /* When arg1 references an allocatable component in a coarray, then call
7780 the caf-library function caf_is_present (). */
7781 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
7782 && arg1
->expr
->value
.function
.isym
7783 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
7784 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
7786 gfc_clear_attr (&caf_attr
);
7787 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
7788 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
7789 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
7792 if (arg1
->expr
->rank
== 0)
7794 /* Allocatable scalar. */
7795 arg1se
.want_pointer
= 1;
7796 gfc_conv_expr (&arg1se
, arg1
->expr
);
7801 /* Allocatable array. */
7802 arg1se
.descriptor_only
= 1;
7803 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7804 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7807 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
7808 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7811 /* Components of pointer array references sometimes come back with a pre block. */
7812 if (arg1se
.pre
.head
)
7813 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7815 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7819 /* Generate code for the ASSOCIATED intrinsic.
7820 If both POINTER and TARGET are arrays, generate a call to library function
7821 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7822 In other cases, generate inline code that directly compare the address of
7823 POINTER with the address of TARGET. */
7826 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
7828 gfc_actual_arglist
*arg1
;
7829 gfc_actual_arglist
*arg2
;
7834 tree nonzero_charlen
;
7835 tree nonzero_arraylen
;
7839 gfc_init_se (&arg1se
, NULL
);
7840 gfc_init_se (&arg2se
, NULL
);
7841 arg1
= expr
->value
.function
.actual
;
7844 /* Check whether the expression is a scalar or not; we cannot use
7845 arg1->expr->rank as it can be nonzero for proc pointers. */
7846 ss
= gfc_walk_expr (arg1
->expr
);
7847 scalar
= ss
== gfc_ss_terminator
;
7849 gfc_free_ss_chain (ss
);
7853 /* No optional target. */
7856 /* A pointer to a scalar. */
7857 arg1se
.want_pointer
= 1;
7858 gfc_conv_expr (&arg1se
, arg1
->expr
);
7859 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7860 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7861 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7863 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7865 tmp2
= gfc_class_data_get (arg1se
.expr
);
7866 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7867 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7874 /* A pointer to an array. */
7875 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7876 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7878 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7879 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7880 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
7881 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
7886 /* An optional target. */
7887 if (arg2
->expr
->ts
.type
== BT_CLASS
)
7888 gfc_add_data_component (arg2
->expr
);
7890 nonzero_charlen
= NULL_TREE
;
7891 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
7892 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
7894 arg1
->expr
->ts
.u
.cl
->backend_decl
,
7896 (TREE_TYPE (arg1
->expr
->ts
.u
.cl
->backend_decl
)));
7899 /* A pointer to a scalar. */
7900 arg1se
.want_pointer
= 1;
7901 gfc_conv_expr (&arg1se
, arg1
->expr
);
7902 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7903 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7904 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7906 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7907 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
7909 arg2se
.want_pointer
= 1;
7910 gfc_conv_expr (&arg2se
, arg2
->expr
);
7911 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7912 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
7913 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
7915 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7916 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7917 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7918 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7919 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7920 arg1se
.expr
, arg2se
.expr
);
7921 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7922 arg1se
.expr
, null_pointer_node
);
7923 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7924 logical_type_node
, tmp
, tmp2
);
7928 /* An array pointer of zero length is not associated if target is
7930 arg1se
.descriptor_only
= 1;
7931 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
7932 if (arg1
->expr
->rank
== -1)
7934 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
7935 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7936 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
7939 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
7940 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
7941 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
7942 logical_type_node
, tmp
,
7943 build_int_cst (TREE_TYPE (tmp
), 0));
7945 /* A pointer to an array, call library function _gfor_associated. */
7946 arg1se
.want_pointer
= 1;
7947 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7948 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7949 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7951 arg2se
.want_pointer
= 1;
7952 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
7953 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7954 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7955 se
->expr
= build_call_expr_loc (input_location
,
7956 gfor_fndecl_associated
, 2,
7957 arg1se
.expr
, arg2se
.expr
);
7958 se
->expr
= convert (logical_type_node
, se
->expr
);
7959 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7960 logical_type_node
, se
->expr
,
7964 /* If target is present zero character length pointers cannot
7966 if (nonzero_charlen
!= NULL_TREE
)
7967 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7969 se
->expr
, nonzero_charlen
);
7972 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7976 /* Generate code for the SAME_TYPE_AS intrinsic.
7977 Generate inline code that directly checks the vindices. */
7980 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
7985 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
7987 gfc_init_se (&se1
, NULL
);
7988 gfc_init_se (&se2
, NULL
);
7990 a
= expr
->value
.function
.actual
->expr
;
7991 b
= expr
->value
.function
.actual
->next
->expr
;
7993 if (UNLIMITED_POLY (a
))
7995 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
7996 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7997 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
8000 if (UNLIMITED_POLY (b
))
8002 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
8003 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8004 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
8007 if (a
->ts
.type
== BT_CLASS
)
8009 gfc_add_vptr_component (a
);
8010 gfc_add_hash_component (a
);
8012 else if (a
->ts
.type
== BT_DERIVED
)
8013 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8014 a
->ts
.u
.derived
->hash_value
);
8016 if (b
->ts
.type
== BT_CLASS
)
8018 gfc_add_vptr_component (b
);
8019 gfc_add_hash_component (b
);
8021 else if (b
->ts
.type
== BT_DERIVED
)
8022 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8023 b
->ts
.u
.derived
->hash_value
);
8025 gfc_conv_expr (&se1
, a
);
8026 gfc_conv_expr (&se2
, b
);
8028 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
8029 logical_type_node
, se1
.expr
,
8030 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
8033 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
8034 logical_type_node
, conda
, tmp
);
8037 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
8038 logical_type_node
, condb
, tmp
);
8040 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
8044 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
8047 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
8051 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
8052 se
->expr
= build_call_expr_loc (input_location
,
8053 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
8054 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8058 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
8061 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
8065 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8067 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
8068 type
= gfc_get_int_type (4);
8069 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
8071 /* Convert it to the required type. */
8072 type
= gfc_typenode_for_spec (&expr
->ts
);
8073 se
->expr
= build_call_expr_loc (input_location
,
8074 gfor_fndecl_si_kind
, 1, arg
);
8075 se
->expr
= fold_convert (type
, se
->expr
);
8079 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
8082 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
8084 gfc_actual_arglist
*actual
;
8087 vec
<tree
, va_gc
> *args
= NULL
;
8089 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
8091 gfc_init_se (&argse
, se
);
8093 /* Pass a NULL pointer for an absent arg. */
8094 if (actual
->expr
== NULL
)
8095 argse
.expr
= null_pointer_node
;
8101 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
8103 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
8104 ts
.type
= BT_INTEGER
;
8105 ts
.kind
= gfc_c_int_kind
;
8106 gfc_convert_type (actual
->expr
, &ts
, 2);
8108 gfc_conv_expr_reference (&argse
, actual
->expr
);
8111 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8112 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8113 vec_safe_push (args
, argse
.expr
);
8116 /* Convert it to the required type. */
8117 type
= gfc_typenode_for_spec (&expr
->ts
);
8118 se
->expr
= build_call_expr_loc_vec (input_location
,
8119 gfor_fndecl_sr_kind
, args
);
8120 se
->expr
= fold_convert (type
, se
->expr
);
8124 /* Generate code for TRIM (A) intrinsic function. */
8127 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
8137 unsigned int num_args
;
8139 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
8140 args
= XALLOCAVEC (tree
, num_args
);
8142 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
8143 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
8144 len
= gfc_create_var (gfc_charlen_type_node
, "len");
8146 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
8147 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
8150 if (expr
->ts
.kind
== 1)
8151 function
= gfor_fndecl_string_trim
;
8152 else if (expr
->ts
.kind
== 4)
8153 function
= gfor_fndecl_string_trim_char4
;
8157 fndecl
= build_addr (function
);
8158 tmp
= build_call_array_loc (input_location
,
8159 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
8161 gfc_add_expr_to_block (&se
->pre
, tmp
);
8163 /* Free the temporary afterwards, if necessary. */
8164 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8165 len
, build_int_cst (TREE_TYPE (len
), 0));
8166 tmp
= gfc_call_free (var
);
8167 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
8168 gfc_add_expr_to_block (&se
->post
, tmp
);
8171 se
->string_length
= len
;
8175 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
8178 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
8180 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
8181 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
8183 stmtblock_t block
, body
;
8186 /* We store in charsize the size of a character. */
8187 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
8188 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
8190 /* Get the arguments. */
8191 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
8192 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
8194 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
8195 ncopies_type
= TREE_TYPE (ncopies
);
8197 /* Check that NCOPIES is not negative. */
8198 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
8199 build_int_cst (ncopies_type
, 0));
8200 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
8201 "Argument NCOPIES of REPEAT intrinsic is negative "
8202 "(its value is %ld)",
8203 fold_convert (long_integer_type_node
, ncopies
));
8205 /* If the source length is zero, any non negative value of NCOPIES
8206 is valid, and nothing happens. */
8207 n
= gfc_create_var (ncopies_type
, "ncopies");
8208 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
8210 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
8211 build_int_cst (ncopies_type
, 0), ncopies
);
8212 gfc_add_modify (&se
->pre
, n
, tmp
);
8215 /* Check that ncopies is not too large: ncopies should be less than
8216 (or equal to) MAX / slen, where MAX is the maximal integer of
8217 the gfc_charlen_type_node type. If slen == 0, we need a special
8218 case to avoid the division by zero. */
8219 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
8220 fold_convert (sizetype
,
8221 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
8223 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
8224 ? sizetype
: ncopies_type
;
8225 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8226 fold_convert (largest
, ncopies
),
8227 fold_convert (largest
, max
));
8228 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
8230 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
8231 logical_false_node
, cond
);
8232 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
8233 "Argument NCOPIES of REPEAT intrinsic is too large");
8235 /* Compute the destination length. */
8236 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
8237 fold_convert (gfc_charlen_type_node
, slen
),
8238 fold_convert (gfc_charlen_type_node
, ncopies
));
8239 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
8240 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
8242 /* Generate the code to do the repeat operation:
8243 for (i = 0; i < ncopies; i++)
8244 memmove (dest + (i * slen * size), src, slen*size); */
8245 gfc_start_block (&block
);
8246 count
= gfc_create_var (sizetype
, "count");
8247 gfc_add_modify (&block
, count
, size_zero_node
);
8248 exit_label
= gfc_build_label_decl (NULL_TREE
);
8250 /* Start the loop body. */
8251 gfc_start_block (&body
);
8253 /* Exit the loop if count >= ncopies. */
8254 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
8255 fold_convert (sizetype
, ncopies
));
8256 tmp
= build1_v (GOTO_EXPR
, exit_label
);
8257 TREE_USED (exit_label
) = 1;
8258 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
8259 build_empty_stmt (input_location
));
8260 gfc_add_expr_to_block (&body
, tmp
);
8262 /* Call memmove (dest + (i*slen*size), src, slen*size). */
8263 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
8265 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
8267 tmp
= fold_build_pointer_plus_loc (input_location
,
8268 fold_convert (pvoid_type_node
, dest
), tmp
);
8269 tmp
= build_call_expr_loc (input_location
,
8270 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
8272 fold_build2_loc (input_location
, MULT_EXPR
,
8273 size_type_node
, slen
, size
));
8274 gfc_add_expr_to_block (&body
, tmp
);
8276 /* Increment count. */
8277 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
8278 count
, size_one_node
);
8279 gfc_add_modify (&body
, count
, tmp
);
8281 /* Build the loop. */
8282 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
8283 gfc_add_expr_to_block (&block
, tmp
);
8285 /* Add the exit label. */
8286 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8287 gfc_add_expr_to_block (&block
, tmp
);
8289 /* Finish the block. */
8290 tmp
= gfc_finish_block (&block
);
8291 gfc_add_expr_to_block (&se
->pre
, tmp
);
8293 /* Set the result value. */
8295 se
->string_length
= dlen
;
8299 /* Generate code for the IARGC intrinsic. */
8302 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
8308 /* Call the library function. This always returns an INTEGER(4). */
8309 fndecl
= gfor_fndecl_iargc
;
8310 tmp
= build_call_expr_loc (input_location
,
8313 /* Convert it to the required type. */
8314 type
= gfc_typenode_for_spec (&expr
->ts
);
8315 tmp
= fold_convert (type
, tmp
);
8321 /* Generate code for the KILL intrinsic. */
8324 conv_intrinsic_kill (gfc_se
*se
, gfc_expr
*expr
)
8327 tree int4_type_node
= gfc_get_int_type (4);
8331 unsigned int num_args
;
8333 num_args
= gfc_intrinsic_argument_list_length (expr
);
8334 args
= XALLOCAVEC (tree
, num_args
);
8335 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
8337 /* Convert PID to a INTEGER(4) entity. */
8338 pid
= convert (int4_type_node
, args
[0]);
8340 /* Convert SIG to a INTEGER(4) entity. */
8341 sig
= convert (int4_type_node
, args
[1]);
8343 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill
, 2, pid
, sig
);
8345 se
->expr
= fold_convert (TREE_TYPE (args
[0]), tmp
);
8350 conv_intrinsic_kill_sub (gfc_code
*code
)
8354 tree int4_type_node
= gfc_get_int_type (4);
8360 /* Make the function call. */
8361 gfc_init_block (&block
);
8362 gfc_init_se (&se
, NULL
);
8364 /* Convert PID to a INTEGER(4) entity. */
8365 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
8366 gfc_add_block_to_block (&block
, &se
.pre
);
8367 pid
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
8368 gfc_add_block_to_block (&block
, &se
.post
);
8370 /* Convert SIG to a INTEGER(4) entity. */
8371 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
8372 gfc_add_block_to_block (&block
, &se
.pre
);
8373 sig
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
8374 gfc_add_block_to_block (&block
, &se
.post
);
8376 /* Deal with an optional STATUS. */
8377 if (code
->ext
.actual
->next
->next
->expr
)
8379 gfc_init_se (&se_stat
, NULL
);
8380 gfc_conv_expr (&se_stat
, code
->ext
.actual
->next
->next
->expr
);
8381 statp
= gfc_create_var (gfc_get_int_type (4), "_statp");
8386 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill_sub
, 3, pid
, sig
,
8387 statp
? gfc_build_addr_expr (NULL_TREE
, statp
) : null_pointer_node
);
8389 gfc_add_expr_to_block (&block
, tmp
);
8391 if (statp
&& statp
!= se_stat
.expr
)
8392 gfc_add_modify (&block
, se_stat
.expr
,
8393 fold_convert (TREE_TYPE (se_stat
.expr
), statp
));
8395 return gfc_finish_block (&block
);
8400 /* The loc intrinsic returns the address of its argument as
8401 gfc_index_integer_kind integer. */
8404 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
8409 gcc_assert (!se
->ss
);
8411 arg_expr
= expr
->value
.function
.actual
->expr
;
8412 if (arg_expr
->rank
== 0)
8414 if (arg_expr
->ts
.type
== BT_CLASS
)
8415 gfc_add_data_component (arg_expr
);
8416 gfc_conv_expr_reference (se
, arg_expr
);
8419 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
8420 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
8422 /* Create a temporary variable for loc return value. Without this,
8423 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
8424 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
8425 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
8426 se
->expr
= temp_var
;
8430 /* The following routine generates code for the intrinsic
8431 functions from the ISO_C_BINDING module:
8437 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
8439 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
8441 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
8443 if (arg
->expr
->rank
== 0)
8444 gfc_conv_expr_reference (se
, arg
->expr
);
8445 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
8446 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
8449 gfc_conv_expr_descriptor (se
, arg
->expr
);
8450 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
8453 /* TODO -- the following two lines shouldn't be necessary, but if
8454 they're removed, a bug is exposed later in the code path.
8455 This workaround was thus introduced, but will have to be
8456 removed; please see PR 35150 for details about the issue. */
8457 se
->expr
= convert (pvoid_type_node
, se
->expr
);
8458 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
8460 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
8461 gfc_conv_expr_reference (se
, arg
->expr
);
8462 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
8467 /* Build the addr_expr for the first argument. The argument is
8468 already an *address* so we don't need to set want_pointer in
8470 gfc_init_se (&arg1se
, NULL
);
8471 gfc_conv_expr (&arg1se
, arg
->expr
);
8472 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8473 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8475 /* See if we were given two arguments. */
8476 if (arg
->next
->expr
== NULL
)
8477 /* Only given one arg so generate a null and do a
8478 not-equal comparison against the first arg. */
8479 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8481 fold_convert (TREE_TYPE (arg1se
.expr
),
8482 null_pointer_node
));
8488 /* Given two arguments so build the arg2se from second arg. */
8489 gfc_init_se (&arg2se
, NULL
);
8490 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
8491 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8492 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8494 /* Generate test to compare that the two args are equal. */
8495 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8496 arg1se
.expr
, arg2se
.expr
);
8497 /* Generate test to ensure that the first arg is not null. */
8498 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
8500 arg1se
.expr
, null_pointer_node
);
8502 /* Finally, the generated test must check that both arg1 is not
8503 NULL and that it is equal to the second arg. */
8504 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8506 not_null_expr
, eq_expr
);
8514 /* The following routine generates code for the intrinsic
8515 subroutines from the ISO_C_BINDING module:
8517 * C_F_PROCPOINTER. */
8520 conv_isocbinding_subroutine (gfc_code
*code
)
8527 tree desc
, dim
, tmp
, stride
, offset
;
8528 stmtblock_t body
, block
;
8530 gfc_actual_arglist
*arg
= code
->ext
.actual
;
8532 gfc_init_se (&se
, NULL
);
8533 gfc_init_se (&cptrse
, NULL
);
8534 gfc_conv_expr (&cptrse
, arg
->expr
);
8535 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
8536 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
8538 gfc_init_se (&fptrse
, NULL
);
8539 if (arg
->next
->expr
->rank
== 0)
8541 fptrse
.want_pointer
= 1;
8542 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
8543 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
8544 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
8545 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8546 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
8547 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
8549 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8550 TREE_TYPE (fptrse
.expr
),
8552 fold_convert (TREE_TYPE (fptrse
.expr
),
8554 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
8555 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8556 return gfc_finish_block (&se
.pre
);
8559 gfc_start_block (&block
);
8561 /* Get the descriptor of the Fortran pointer. */
8562 fptrse
.descriptor_only
= 1;
8563 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
8564 gfc_add_block_to_block (&block
, &fptrse
.pre
);
8567 /* Set the span field. */
8568 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
8569 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8570 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
8572 /* Set data value, dtype, and offset. */
8573 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
8574 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
8575 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
8576 gfc_get_dtype (TREE_TYPE (desc
)));
8578 /* Start scalarization of the bounds, using the shape argument. */
8580 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
8581 gcc_assert (shape_ss
!= gfc_ss_terminator
);
8582 gfc_init_se (&shapese
, NULL
);
8584 gfc_init_loopinfo (&loop
);
8585 gfc_add_ss_to_loop (&loop
, shape_ss
);
8586 gfc_conv_ss_startstride (&loop
);
8587 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
8588 gfc_mark_ss_chain_used (shape_ss
, 1);
8590 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
8591 shapese
.ss
= shape_ss
;
8593 stride
= gfc_create_var (gfc_array_index_type
, "stride");
8594 offset
= gfc_create_var (gfc_array_index_type
, "offset");
8595 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
8596 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8599 gfc_start_scalarized_body (&loop
, &body
);
8601 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8602 loop
.loopvar
[0], loop
.from
[0]);
8604 /* Set bounds and stride. */
8605 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
8606 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
8608 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
8609 gfc_add_block_to_block (&body
, &shapese
.pre
);
8610 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
8611 gfc_add_block_to_block (&body
, &shapese
.post
);
8613 /* Calculate offset. */
8614 gfc_add_modify (&body
, offset
,
8615 fold_build2_loc (input_location
, PLUS_EXPR
,
8616 gfc_array_index_type
, offset
, stride
));
8617 /* Update stride. */
8618 gfc_add_modify (&body
, stride
,
8619 fold_build2_loc (input_location
, MULT_EXPR
,
8620 gfc_array_index_type
, stride
,
8621 fold_convert (gfc_array_index_type
,
8623 /* Finish scalarization loop. */
8624 gfc_trans_scalarizing_loops (&loop
, &body
);
8625 gfc_add_block_to_block (&block
, &loop
.pre
);
8626 gfc_add_block_to_block (&block
, &loop
.post
);
8627 gfc_add_block_to_block (&block
, &fptrse
.post
);
8628 gfc_cleanup_loop (&loop
);
8630 gfc_add_modify (&block
, offset
,
8631 fold_build1_loc (input_location
, NEGATE_EXPR
,
8632 gfc_array_index_type
, offset
));
8633 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
8635 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
8636 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8637 return gfc_finish_block (&se
.pre
);
8641 /* Save and restore floating-point state. */
8644 gfc_save_fp_state (stmtblock_t
*block
)
8646 tree type
, fpstate
, tmp
;
8648 type
= build_array_type (char_type_node
,
8649 build_range_type (size_type_node
, size_zero_node
,
8650 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
8651 fpstate
= gfc_create_var (type
, "fpstate");
8652 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
8654 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
8656 gfc_add_expr_to_block (block
, tmp
);
8663 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
8667 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
8669 gfc_add_expr_to_block (block
, tmp
);
8673 /* Generate code for arguments of IEEE functions. */
8676 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
8679 gfc_actual_arglist
*actual
;
8684 actual
= expr
->value
.function
.actual
;
8685 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
8687 gcc_assert (actual
);
8690 gfc_init_se (&argse
, se
);
8691 gfc_conv_expr_val (&argse
, e
);
8693 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8694 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8695 argarray
[arg
] = argse
.expr
;
8700 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8701 and IEEE_UNORDERED, which translate directly to GCC type-generic
8705 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
8706 enum built_in_function code
, int nargs
)
8709 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
8711 conv_ieee_function_args (se
, expr
, args
, nargs
);
8712 se
->expr
= build_call_expr_loc_array (input_location
,
8713 builtin_decl_explicit (code
),
8715 STRIP_TYPE_NOPS (se
->expr
);
8716 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8720 /* Generate code for IEEE_IS_NORMAL intrinsic:
8721 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8724 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
8726 tree arg
, isnormal
, iszero
;
8728 /* Convert arg, evaluate it only once. */
8729 conv_ieee_function_args (se
, expr
, &arg
, 1);
8730 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8732 isnormal
= build_call_expr_loc (input_location
,
8733 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
8735 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
8736 build_real_from_int_cst (TREE_TYPE (arg
),
8737 integer_zero_node
));
8738 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8739 logical_type_node
, isnormal
, iszero
);
8740 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8744 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8745 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8748 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
8750 tree arg
, signbit
, isnan
;
8752 /* Convert arg, evaluate it only once. */
8753 conv_ieee_function_args (se
, expr
, &arg
, 1);
8754 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8756 isnan
= build_call_expr_loc (input_location
,
8757 builtin_decl_explicit (BUILT_IN_ISNAN
),
8759 STRIP_TYPE_NOPS (isnan
);
8761 signbit
= build_call_expr_loc (input_location
,
8762 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8764 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8765 signbit
, integer_zero_node
);
8767 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8768 logical_type_node
, signbit
,
8769 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
8770 TREE_TYPE(isnan
), isnan
));
8772 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8776 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8779 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
8780 enum built_in_function code
)
8782 tree arg
, decl
, call
, fpstate
;
8785 conv_ieee_function_args (se
, expr
, &arg
, 1);
8786 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
8787 decl
= builtin_decl_for_precision (code
, argprec
);
8789 /* Save floating-point state. */
8790 fpstate
= gfc_save_fp_state (&se
->pre
);
8792 /* Make the function call. */
8793 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
8794 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
8796 /* Restore floating-point state. */
8797 gfc_restore_fp_state (&se
->post
, fpstate
);
8801 /* Generate code for IEEE_REM. */
8804 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
8806 tree args
[2], decl
, call
, fpstate
;
8809 conv_ieee_function_args (se
, expr
, args
, 2);
8811 /* If arguments have unequal size, convert them to the larger. */
8812 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
8813 > TYPE_PRECISION (TREE_TYPE (args
[1])))
8814 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8815 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
8816 > TYPE_PRECISION (TREE_TYPE (args
[0])))
8817 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
8819 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8820 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
8822 /* Save floating-point state. */
8823 fpstate
= gfc_save_fp_state (&se
->pre
);
8825 /* Make the function call. */
8826 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8827 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8829 /* Restore floating-point state. */
8830 gfc_restore_fp_state (&se
->post
, fpstate
);
8834 /* Generate code for IEEE_NEXT_AFTER. */
8837 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
8839 tree args
[2], decl
, call
, fpstate
;
8842 conv_ieee_function_args (se
, expr
, args
, 2);
8844 /* Result has the characteristics of first argument. */
8845 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8846 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8847 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
8849 /* Save floating-point state. */
8850 fpstate
= gfc_save_fp_state (&se
->pre
);
8852 /* Make the function call. */
8853 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8854 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8856 /* Restore floating-point state. */
8857 gfc_restore_fp_state (&se
->post
, fpstate
);
8861 /* Generate code for IEEE_SCALB. */
8864 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
8866 tree args
[2], decl
, call
, huge
, type
;
8869 conv_ieee_function_args (se
, expr
, args
, 2);
8871 /* Result has the characteristics of first argument. */
8872 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8873 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
8875 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
8877 /* We need to fold the integer into the range of a C int. */
8878 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
8879 type
= TREE_TYPE (args
[1]);
8881 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
8882 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
8884 huge
= fold_convert (type
, huge
);
8885 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
8887 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
8888 fold_build1_loc (input_location
, NEGATE_EXPR
,
8892 args
[1] = fold_convert (integer_type_node
, args
[1]);
8894 /* Make the function call. */
8895 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8896 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8900 /* Generate code for IEEE_COPY_SIGN. */
8903 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
8905 tree args
[2], decl
, sign
;
8908 conv_ieee_function_args (se
, expr
, args
, 2);
8910 /* Get the sign of the second argument. */
8911 sign
= build_call_expr_loc (input_location
,
8912 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8914 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8915 sign
, integer_zero_node
);
8917 /* Create a value of one, with the right sign. */
8918 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
8920 fold_build1_loc (input_location
, NEGATE_EXPR
,
8924 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
8926 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8927 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
8929 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8933 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8937 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
8939 const char *name
= expr
->value
.function
.name
;
8941 if (gfc_str_startswith (name
, "_gfortran_ieee_is_nan"))
8942 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
8943 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_finite"))
8944 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
8945 else if (gfc_str_startswith (name
, "_gfortran_ieee_unordered"))
8946 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
8947 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_normal"))
8948 conv_intrinsic_ieee_is_normal (se
, expr
);
8949 else if (gfc_str_startswith (name
, "_gfortran_ieee_is_negative"))
8950 conv_intrinsic_ieee_is_negative (se
, expr
);
8951 else if (gfc_str_startswith (name
, "_gfortran_ieee_copy_sign"))
8952 conv_intrinsic_ieee_copy_sign (se
, expr
);
8953 else if (gfc_str_startswith (name
, "_gfortran_ieee_scalb"))
8954 conv_intrinsic_ieee_scalb (se
, expr
);
8955 else if (gfc_str_startswith (name
, "_gfortran_ieee_next_after"))
8956 conv_intrinsic_ieee_next_after (se
, expr
);
8957 else if (gfc_str_startswith (name
, "_gfortran_ieee_rem"))
8958 conv_intrinsic_ieee_rem (se
, expr
);
8959 else if (gfc_str_startswith (name
, "_gfortran_ieee_logb"))
8960 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
8961 else if (gfc_str_startswith (name
, "_gfortran_ieee_rint"))
8962 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
8964 /* It is not among the functions we translate directly. We return
8965 false, so a library function call is emitted. */
8972 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8975 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
8977 tree arg
, res
, restype
;
8979 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8980 arg
= fold_convert (size_type_node
, arg
);
8981 res
= build_call_expr_loc (input_location
,
8982 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
8983 restype
= gfc_typenode_for_spec (&expr
->ts
);
8984 se
->expr
= fold_convert (restype
, res
);
8988 /* Generate code for an intrinsic function. Some map directly to library
8989 calls, others get special handling. In some cases the name of the function
8990 used depends on the type specifiers. */
8993 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
8999 name
= &expr
->value
.function
.name
[2];
9003 lib
= gfc_is_intrinsic_libcall (expr
);
9007 se
->ignore_optional
= 1;
9009 switch (expr
->value
.function
.isym
->id
)
9011 case GFC_ISYM_EOSHIFT
:
9013 case GFC_ISYM_RESHAPE
:
9014 /* For all of those the first argument specifies the type and the
9015 third is optional. */
9016 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
9019 case GFC_ISYM_MINLOC
:
9020 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9023 case GFC_ISYM_MAXLOC
:
9024 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9027 case GFC_ISYM_SHAPE
:
9028 gfc_conv_intrinsic_shape (se
, expr
);
9032 gfc_conv_intrinsic_funcall (se
, expr
);
9040 switch (expr
->value
.function
.isym
->id
)
9045 case GFC_ISYM_REPEAT
:
9046 gfc_conv_intrinsic_repeat (se
, expr
);
9050 gfc_conv_intrinsic_trim (se
, expr
);
9053 case GFC_ISYM_SC_KIND
:
9054 gfc_conv_intrinsic_sc_kind (se
, expr
);
9057 case GFC_ISYM_SI_KIND
:
9058 gfc_conv_intrinsic_si_kind (se
, expr
);
9061 case GFC_ISYM_SR_KIND
:
9062 gfc_conv_intrinsic_sr_kind (se
, expr
);
9065 case GFC_ISYM_EXPONENT
:
9066 gfc_conv_intrinsic_exponent (se
, expr
);
9070 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9072 fndecl
= gfor_fndecl_string_scan
;
9074 fndecl
= gfor_fndecl_string_scan_char4
;
9078 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9081 case GFC_ISYM_VERIFY
:
9082 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9084 fndecl
= gfor_fndecl_string_verify
;
9086 fndecl
= gfor_fndecl_string_verify_char4
;
9090 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9093 case GFC_ISYM_ALLOCATED
:
9094 gfc_conv_allocated (se
, expr
);
9097 case GFC_ISYM_ASSOCIATED
:
9098 gfc_conv_associated(se
, expr
);
9101 case GFC_ISYM_SAME_TYPE_AS
:
9102 gfc_conv_same_type_as (se
, expr
);
9106 gfc_conv_intrinsic_abs (se
, expr
);
9109 case GFC_ISYM_ADJUSTL
:
9110 if (expr
->ts
.kind
== 1)
9111 fndecl
= gfor_fndecl_adjustl
;
9112 else if (expr
->ts
.kind
== 4)
9113 fndecl
= gfor_fndecl_adjustl_char4
;
9117 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
9120 case GFC_ISYM_ADJUSTR
:
9121 if (expr
->ts
.kind
== 1)
9122 fndecl
= gfor_fndecl_adjustr
;
9123 else if (expr
->ts
.kind
== 4)
9124 fndecl
= gfor_fndecl_adjustr_char4
;
9128 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
9131 case GFC_ISYM_AIMAG
:
9132 gfc_conv_intrinsic_imagpart (se
, expr
);
9136 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
9140 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
9143 case GFC_ISYM_ANINT
:
9144 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
9148 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
9152 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
9155 case GFC_ISYM_BTEST
:
9156 gfc_conv_intrinsic_btest (se
, expr
);
9160 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
9164 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
9168 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
9172 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
9175 case GFC_ISYM_C_ASSOCIATED
:
9176 case GFC_ISYM_C_FUNLOC
:
9177 case GFC_ISYM_C_LOC
:
9178 conv_isocbinding_function (se
, expr
);
9181 case GFC_ISYM_ACHAR
:
9183 gfc_conv_intrinsic_char (se
, expr
);
9186 case GFC_ISYM_CONVERSION
:
9188 case GFC_ISYM_LOGICAL
:
9190 gfc_conv_intrinsic_conversion (se
, expr
);
9193 /* Integer conversions are handled separately to make sure we get the
9194 correct rounding mode. */
9199 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
9203 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
9206 case GFC_ISYM_CEILING
:
9207 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
9210 case GFC_ISYM_FLOOR
:
9211 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
9215 gfc_conv_intrinsic_mod (se
, expr
, 0);
9218 case GFC_ISYM_MODULO
:
9219 gfc_conv_intrinsic_mod (se
, expr
, 1);
9222 case GFC_ISYM_CAF_GET
:
9223 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9227 case GFC_ISYM_CMPLX
:
9228 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
9231 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
9232 gfc_conv_intrinsic_iargc (se
, expr
);
9235 case GFC_ISYM_COMPLEX
:
9236 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
9239 case GFC_ISYM_CONJG
:
9240 gfc_conv_intrinsic_conjg (se
, expr
);
9243 case GFC_ISYM_COUNT
:
9244 gfc_conv_intrinsic_count (se
, expr
);
9247 case GFC_ISYM_CTIME
:
9248 gfc_conv_intrinsic_ctime (se
, expr
);
9252 gfc_conv_intrinsic_dim (se
, expr
);
9255 case GFC_ISYM_DOT_PRODUCT
:
9256 gfc_conv_intrinsic_dot_product (se
, expr
);
9259 case GFC_ISYM_DPROD
:
9260 gfc_conv_intrinsic_dprod (se
, expr
);
9263 case GFC_ISYM_DSHIFTL
:
9264 gfc_conv_intrinsic_dshift (se
, expr
, true);
9267 case GFC_ISYM_DSHIFTR
:
9268 gfc_conv_intrinsic_dshift (se
, expr
, false);
9271 case GFC_ISYM_FDATE
:
9272 gfc_conv_intrinsic_fdate (se
, expr
);
9275 case GFC_ISYM_FRACTION
:
9276 gfc_conv_intrinsic_fraction (se
, expr
);
9280 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
9284 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
9288 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
9291 case GFC_ISYM_IBCLR
:
9292 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
9295 case GFC_ISYM_IBITS
:
9296 gfc_conv_intrinsic_ibits (se
, expr
);
9299 case GFC_ISYM_IBSET
:
9300 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
9303 case GFC_ISYM_IACHAR
:
9304 case GFC_ISYM_ICHAR
:
9305 /* We assume ASCII character sequence. */
9306 gfc_conv_intrinsic_ichar (se
, expr
);
9309 case GFC_ISYM_IARGC
:
9310 gfc_conv_intrinsic_iargc (se
, expr
);
9314 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9317 case GFC_ISYM_INDEX
:
9318 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9320 fndecl
= gfor_fndecl_string_index
;
9322 fndecl
= gfor_fndecl_string_index_char4
;
9326 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9330 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9333 case GFC_ISYM_IPARITY
:
9334 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
9337 case GFC_ISYM_IS_IOSTAT_END
:
9338 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
9341 case GFC_ISYM_IS_IOSTAT_EOR
:
9342 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
9345 case GFC_ISYM_ISNAN
:
9346 gfc_conv_intrinsic_isnan (se
, expr
);
9350 conv_intrinsic_kill (se
, expr
);
9353 case GFC_ISYM_LSHIFT
:
9354 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9357 case GFC_ISYM_RSHIFT
:
9358 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9361 case GFC_ISYM_SHIFTA
:
9362 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9365 case GFC_ISYM_SHIFTL
:
9366 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9369 case GFC_ISYM_SHIFTR
:
9370 gfc_conv_intrinsic_shift (se
, expr
, true, false);
9373 case GFC_ISYM_ISHFT
:
9374 gfc_conv_intrinsic_ishft (se
, expr
);
9377 case GFC_ISYM_ISHFTC
:
9378 gfc_conv_intrinsic_ishftc (se
, expr
);
9381 case GFC_ISYM_LEADZ
:
9382 gfc_conv_intrinsic_leadz (se
, expr
);
9385 case GFC_ISYM_TRAILZ
:
9386 gfc_conv_intrinsic_trailz (se
, expr
);
9389 case GFC_ISYM_POPCNT
:
9390 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
9393 case GFC_ISYM_POPPAR
:
9394 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
9397 case GFC_ISYM_LBOUND
:
9398 gfc_conv_intrinsic_bound (se
, expr
, 0);
9401 case GFC_ISYM_LCOBOUND
:
9402 conv_intrinsic_cobound (se
, expr
);
9405 case GFC_ISYM_TRANSPOSE
:
9406 /* The scalarizer has already been set up for reversed dimension access
9407 order ; now we just get the argument value normally. */
9408 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
9412 gfc_conv_intrinsic_len (se
, expr
);
9415 case GFC_ISYM_LEN_TRIM
:
9416 gfc_conv_intrinsic_len_trim (se
, expr
);
9420 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
9424 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
9428 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
9432 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
9435 case GFC_ISYM_MALLOC
:
9436 gfc_conv_intrinsic_malloc (se
, expr
);
9439 case GFC_ISYM_MASKL
:
9440 gfc_conv_intrinsic_mask (se
, expr
, 1);
9443 case GFC_ISYM_MASKR
:
9444 gfc_conv_intrinsic_mask (se
, expr
, 0);
9448 if (expr
->ts
.type
== BT_CHARACTER
)
9449 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
9451 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
9454 case GFC_ISYM_MAXLOC
:
9455 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9458 case GFC_ISYM_MAXVAL
:
9459 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
9462 case GFC_ISYM_MERGE
:
9463 gfc_conv_intrinsic_merge (se
, expr
);
9466 case GFC_ISYM_MERGE_BITS
:
9467 gfc_conv_intrinsic_merge_bits (se
, expr
);
9471 if (expr
->ts
.type
== BT_CHARACTER
)
9472 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
9474 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
9477 case GFC_ISYM_MINLOC
:
9478 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9481 case GFC_ISYM_MINVAL
:
9482 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
9485 case GFC_ISYM_NEAREST
:
9486 gfc_conv_intrinsic_nearest (se
, expr
);
9489 case GFC_ISYM_NORM2
:
9490 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
9494 gfc_conv_intrinsic_not (se
, expr
);
9498 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9501 case GFC_ISYM_PARITY
:
9502 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
9505 case GFC_ISYM_PRESENT
:
9506 gfc_conv_intrinsic_present (se
, expr
);
9509 case GFC_ISYM_PRODUCT
:
9510 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
9514 gfc_conv_intrinsic_rank (se
, expr
);
9517 case GFC_ISYM_RRSPACING
:
9518 gfc_conv_intrinsic_rrspacing (se
, expr
);
9521 case GFC_ISYM_SET_EXPONENT
:
9522 gfc_conv_intrinsic_set_exponent (se
, expr
);
9525 case GFC_ISYM_SCALE
:
9526 gfc_conv_intrinsic_scale (se
, expr
);
9530 gfc_conv_intrinsic_sign (se
, expr
);
9534 gfc_conv_intrinsic_size (se
, expr
);
9537 case GFC_ISYM_SIZEOF
:
9538 case GFC_ISYM_C_SIZEOF
:
9539 gfc_conv_intrinsic_sizeof (se
, expr
);
9542 case GFC_ISYM_STORAGE_SIZE
:
9543 gfc_conv_intrinsic_storage_size (se
, expr
);
9546 case GFC_ISYM_SPACING
:
9547 gfc_conv_intrinsic_spacing (se
, expr
);
9550 case GFC_ISYM_STRIDE
:
9551 conv_intrinsic_stride (se
, expr
);
9555 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
9558 case GFC_ISYM_TEAM_NUMBER
:
9559 conv_intrinsic_team_number (se
, expr
);
9562 case GFC_ISYM_TRANSFER
:
9563 if (se
->ss
&& se
->ss
->info
->useflags
)
9564 /* Access the previously obtained result. */
9565 gfc_conv_tmp_array_ref (se
);
9567 gfc_conv_intrinsic_transfer (se
, expr
);
9570 case GFC_ISYM_TTYNAM
:
9571 gfc_conv_intrinsic_ttynam (se
, expr
);
9574 case GFC_ISYM_UBOUND
:
9575 gfc_conv_intrinsic_bound (se
, expr
, 1);
9578 case GFC_ISYM_UCOBOUND
:
9579 conv_intrinsic_cobound (se
, expr
);
9583 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9587 gfc_conv_intrinsic_loc (se
, expr
);
9590 case GFC_ISYM_THIS_IMAGE
:
9591 /* For num_images() == 1, handle as LCOBOUND. */
9592 if (expr
->value
.function
.actual
->expr
9593 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
9594 conv_intrinsic_cobound (se
, expr
);
9596 trans_this_image (se
, expr
);
9599 case GFC_ISYM_IMAGE_INDEX
:
9600 trans_image_index (se
, expr
);
9603 case GFC_ISYM_IMAGE_STATUS
:
9604 conv_intrinsic_image_status (se
, expr
);
9607 case GFC_ISYM_NUM_IMAGES
:
9608 trans_num_images (se
, expr
);
9611 case GFC_ISYM_ACCESS
:
9612 case GFC_ISYM_CHDIR
:
9613 case GFC_ISYM_CHMOD
:
9614 case GFC_ISYM_DTIME
:
9615 case GFC_ISYM_ETIME
:
9616 case GFC_ISYM_EXTENDS_TYPE_OF
:
9618 case GFC_ISYM_FGETC
:
9621 case GFC_ISYM_FPUTC
:
9622 case GFC_ISYM_FSTAT
:
9623 case GFC_ISYM_FTELL
:
9624 case GFC_ISYM_GETCWD
:
9625 case GFC_ISYM_GETGID
:
9626 case GFC_ISYM_GETPID
:
9627 case GFC_ISYM_GETUID
:
9628 case GFC_ISYM_HOSTNM
:
9629 case GFC_ISYM_IERRNO
:
9630 case GFC_ISYM_IRAND
:
9631 case GFC_ISYM_ISATTY
:
9634 case GFC_ISYM_LSTAT
:
9635 case GFC_ISYM_MATMUL
:
9636 case GFC_ISYM_MCLOCK
:
9637 case GFC_ISYM_MCLOCK8
:
9639 case GFC_ISYM_RENAME
:
9640 case GFC_ISYM_SECOND
:
9641 case GFC_ISYM_SECNDS
:
9642 case GFC_ISYM_SIGNAL
:
9644 case GFC_ISYM_SYMLNK
:
9645 case GFC_ISYM_SYSTEM
:
9647 case GFC_ISYM_TIME8
:
9648 case GFC_ISYM_UMASK
:
9649 case GFC_ISYM_UNLINK
:
9651 gfc_conv_intrinsic_funcall (se
, expr
);
9654 case GFC_ISYM_EOSHIFT
:
9656 case GFC_ISYM_RESHAPE
:
9657 /* For those, expr->rank should always be >0 and thus the if above the
9658 switch should have matched. */
9663 gfc_conv_intrinsic_lib_function (se
, expr
);
9670 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
9672 gfc_ss
*arg_ss
, *tmp_ss
;
9673 gfc_actual_arglist
*arg
;
9675 arg
= expr
->value
.function
.actual
;
9677 gcc_assert (arg
->expr
);
9679 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
9680 gcc_assert (arg_ss
!= gfc_ss_terminator
);
9682 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
9684 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
9685 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
9687 gcc_assert (tmp_ss
->dimen
== 2);
9689 /* We just invert dimensions. */
9690 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
9693 /* Stop when tmp_ss points to the last valid element of the chain... */
9694 if (tmp_ss
->next
== gfc_ss_terminator
)
9698 /* ... so that we can attach the rest of the chain to it. */
9705 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9706 This has the side effect of reversing the nested list, so there is no
9707 need to call gfc_reverse_ss on it (the given list is assumed not to be
9711 nest_loop_dimension (gfc_ss
*ss
, int dim
)
9714 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
9715 gfc_loopinfo
*new_loop
;
9717 gcc_assert (ss
!= gfc_ss_terminator
);
9719 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
9721 new_ss
= gfc_get_ss ();
9722 new_ss
->next
= prev_ss
;
9723 new_ss
->parent
= ss
;
9724 new_ss
->info
= ss
->info
;
9725 new_ss
->info
->refcount
++;
9728 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
9729 && ss
->info
->type
!= GFC_SS_REFERENCE
);
9732 new_ss
->dim
[0] = ss
->dim
[dim
];
9734 gcc_assert (dim
< ss
->dimen
);
9736 ss_dim
= --ss
->dimen
;
9737 for (i
= dim
; i
< ss_dim
; i
++)
9738 ss
->dim
[i
] = ss
->dim
[i
+ 1];
9740 ss
->dim
[ss_dim
] = 0;
9746 ss
->nested_ss
->parent
= new_ss
;
9747 new_ss
->nested_ss
= ss
->nested_ss
;
9749 ss
->nested_ss
= new_ss
;
9752 new_loop
= gfc_get_loopinfo ();
9753 gfc_init_loopinfo (new_loop
);
9755 gcc_assert (prev_ss
!= NULL
);
9756 gcc_assert (prev_ss
!= gfc_ss_terminator
);
9757 gfc_add_ss_to_loop (new_loop
, prev_ss
);
9758 return new_ss
->parent
;
9762 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9763 is to be inlined. */
9766 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
9768 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
9769 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
9771 bool scalar_mask
= false;
9773 /* The rank of the result will be determined later. */
9774 arg1
= expr
->value
.function
.actual
;
9777 gcc_assert (arg3
!= NULL
);
9779 if (expr
->rank
== 0)
9782 tmp_ss
= gfc_ss_terminator
;
9788 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
9789 if (mask_ss
== tmp_ss
)
9795 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
9796 gcc_assert (array_ss
!= tmp_ss
);
9798 /* Odd thing: If the mask is scalar, it is used by the frontend after
9799 the array (to make an if around the nested loop). Thus it shall
9800 be after array_ss once the gfc_ss list is reversed. */
9802 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
9806 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9808 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
9809 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
9817 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
9820 switch (expr
->value
.function
.isym
->id
)
9822 case GFC_ISYM_PRODUCT
:
9824 return walk_inline_intrinsic_arith (ss
, expr
);
9826 case GFC_ISYM_TRANSPOSE
:
9827 return walk_inline_intrinsic_transpose (ss
, expr
);
9836 /* This generates code to execute before entering the scalarization loop.
9837 Currently does nothing. */
9840 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
9842 switch (ss
->info
->expr
->value
.function
.isym
->id
)
9844 case GFC_ISYM_UBOUND
:
9845 case GFC_ISYM_LBOUND
:
9846 case GFC_ISYM_UCOBOUND
:
9847 case GFC_ISYM_LCOBOUND
:
9848 case GFC_ISYM_THIS_IMAGE
:
9857 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9858 are expanded into code inside the scalarization loop. */
9861 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
9863 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
9864 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
9866 /* The two argument version returns a scalar. */
9867 if (expr
->value
.function
.actual
->next
->expr
)
9870 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
9874 /* Walk an intrinsic array libcall. */
9877 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
9879 gcc_assert (expr
->rank
> 0);
9880 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9884 /* Return whether the function call expression EXPR will be expanded
9885 inline by gfc_conv_intrinsic_function. */
9888 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
9890 gfc_actual_arglist
*args
;
9892 if (!expr
->value
.function
.isym
)
9895 switch (expr
->value
.function
.isym
->id
)
9897 case GFC_ISYM_PRODUCT
:
9899 /* Disable inline expansion if code size matters. */
9903 args
= expr
->value
.function
.actual
;
9904 /* We need to be able to subset the SUM argument at compile-time. */
9905 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
9910 case GFC_ISYM_TRANSPOSE
:
9919 /* Returns nonzero if the specified intrinsic function call maps directly to
9920 an external library call. Should only be used for functions that return
9924 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
9926 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
9927 gcc_assert (expr
->rank
> 0);
9929 if (gfc_inline_intrinsic_function_p (expr
))
9932 switch (expr
->value
.function
.isym
->id
)
9936 case GFC_ISYM_COUNT
:
9940 case GFC_ISYM_IPARITY
:
9941 case GFC_ISYM_MATMUL
:
9942 case GFC_ISYM_MAXLOC
:
9943 case GFC_ISYM_MAXVAL
:
9944 case GFC_ISYM_MINLOC
:
9945 case GFC_ISYM_MINVAL
:
9946 case GFC_ISYM_NORM2
:
9947 case GFC_ISYM_PARITY
:
9948 case GFC_ISYM_PRODUCT
:
9950 case GFC_ISYM_SHAPE
:
9951 case GFC_ISYM_SPREAD
:
9953 /* Ignore absent optional parameters. */
9956 case GFC_ISYM_CSHIFT
:
9957 case GFC_ISYM_EOSHIFT
:
9958 case GFC_ISYM_GET_TEAM
:
9959 case GFC_ISYM_FAILED_IMAGES
:
9960 case GFC_ISYM_STOPPED_IMAGES
:
9962 case GFC_ISYM_RESHAPE
:
9963 case GFC_ISYM_UNPACK
:
9964 /* Pass absent optional parameters. */
9972 /* Walk an intrinsic function. */
9974 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
9975 gfc_intrinsic_sym
* isym
)
9979 if (isym
->elemental
)
9980 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9981 NULL
, GFC_SS_SCALAR
);
9983 if (expr
->rank
== 0)
9986 if (gfc_inline_intrinsic_function_p (expr
))
9987 return walk_inline_intrinsic_function (ss
, expr
);
9989 if (gfc_is_intrinsic_libcall (expr
))
9990 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9992 /* Special cases. */
9995 case GFC_ISYM_LBOUND
:
9996 case GFC_ISYM_LCOBOUND
:
9997 case GFC_ISYM_UBOUND
:
9998 case GFC_ISYM_UCOBOUND
:
9999 case GFC_ISYM_THIS_IMAGE
:
10000 return gfc_walk_intrinsic_bound (ss
, expr
);
10002 case GFC_ISYM_TRANSFER
:
10003 case GFC_ISYM_CAF_GET
:
10004 return gfc_walk_intrinsic_libfunc (ss
, expr
);
10007 /* This probably meant someone forgot to add an intrinsic to the above
10008 list(s) when they implemented it, or something's gone horribly
10010 gcc_unreachable ();
10016 conv_co_collective (gfc_code
*code
)
10019 stmtblock_t block
, post_block
;
10020 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
10021 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
10023 gfc_start_block (&block
);
10024 gfc_init_block (&post_block
);
10026 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
10028 opr_expr
= code
->ext
.actual
->next
->expr
;
10029 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
10030 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10031 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
10036 image_idx_expr
= code
->ext
.actual
->next
->expr
;
10037 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
10038 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10044 gfc_init_se (&argse
, NULL
);
10045 gfc_conv_expr (&argse
, stat_expr
);
10046 gfc_add_block_to_block (&block
, &argse
.pre
);
10047 gfc_add_block_to_block (&post_block
, &argse
.post
);
10049 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
10050 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
10052 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
10055 stat
= null_pointer_node
;
10057 /* Early exit for GFC_FCOARRAY_SINGLE. */
10058 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
10060 if (stat
!= NULL_TREE
)
10061 gfc_add_modify (&block
, stat
,
10062 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
10063 return gfc_finish_block (&block
);
10066 /* Handle the array. */
10067 gfc_init_se (&argse
, NULL
);
10068 if (code
->ext
.actual
->expr
->rank
== 0)
10070 symbol_attribute attr
;
10071 gfc_clear_attr (&attr
);
10072 gfc_init_se (&argse
, NULL
);
10073 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10074 gfc_add_block_to_block (&block
, &argse
.pre
);
10075 gfc_add_block_to_block (&post_block
, &argse
.post
);
10076 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
10077 array
= gfc_build_addr_expr (NULL_TREE
, array
);
10081 argse
.want_pointer
= 1;
10082 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
10083 array
= argse
.expr
;
10085 gfc_add_block_to_block (&block
, &argse
.pre
);
10086 gfc_add_block_to_block (&post_block
, &argse
.post
);
10088 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
10089 strlen
= argse
.string_length
;
10091 strlen
= integer_zero_node
;
10094 if (image_idx_expr
)
10096 gfc_init_se (&argse
, NULL
);
10097 gfc_conv_expr (&argse
, image_idx_expr
);
10098 gfc_add_block_to_block (&block
, &argse
.pre
);
10099 gfc_add_block_to_block (&post_block
, &argse
.post
);
10100 image_index
= fold_convert (integer_type_node
, argse
.expr
);
10103 image_index
= integer_zero_node
;
10108 gfc_init_se (&argse
, NULL
);
10109 gfc_conv_expr (&argse
, errmsg_expr
);
10110 gfc_add_block_to_block (&block
, &argse
.pre
);
10111 gfc_add_block_to_block (&post_block
, &argse
.post
);
10112 errmsg
= argse
.expr
;
10113 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
10117 errmsg
= null_pointer_node
;
10118 errmsg_len
= build_zero_cst (size_type_node
);
10121 /* Generate the function call. */
10122 switch (code
->resolved_isym
->id
)
10124 case GFC_ISYM_CO_BROADCAST
:
10125 fndecl
= gfor_fndecl_co_broadcast
;
10127 case GFC_ISYM_CO_MAX
:
10128 fndecl
= gfor_fndecl_co_max
;
10130 case GFC_ISYM_CO_MIN
:
10131 fndecl
= gfor_fndecl_co_min
;
10133 case GFC_ISYM_CO_REDUCE
:
10134 fndecl
= gfor_fndecl_co_reduce
;
10136 case GFC_ISYM_CO_SUM
:
10137 fndecl
= gfor_fndecl_co_sum
;
10140 gcc_unreachable ();
10143 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
10144 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
10145 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
10146 image_index
, stat
, errmsg
, errmsg_len
);
10147 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
10148 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
10149 stat
, errmsg
, strlen
, errmsg_len
);
10152 tree opr
, opr_flags
;
10154 // FIXME: Handle TS29113's bind(C) strings with descriptor.
10156 if (gfc_is_proc_ptr_comp (opr_expr
))
10158 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
10159 opr_flag_int
= sym
->attr
.dimension
10160 || (sym
->ts
.type
== BT_CHARACTER
10161 && !sym
->attr
.is_bind_c
)
10162 ? GFC_CAF_BYREF
: 0;
10163 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
10164 && !sym
->attr
.is_bind_c
10165 ? GFC_CAF_HIDDENLEN
: 0;
10166 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
10170 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
10171 ? GFC_CAF_BYREF
: 0;
10172 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
10173 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
10174 ? GFC_CAF_HIDDENLEN
: 0;
10175 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
10176 ? GFC_CAF_ARG_VALUE
: 0;
10178 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
10179 gfc_conv_expr (&argse
, opr_expr
);
10181 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
10182 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
10185 gfc_add_expr_to_block (&block
, fndecl
);
10186 gfc_add_block_to_block (&block
, &post_block
);
10188 return gfc_finish_block (&block
);
10193 conv_intrinsic_atomic_op (gfc_code
*code
)
10196 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
10197 stmtblock_t block
, post_block
;
10198 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10199 gfc_expr
*stat_expr
;
10200 built_in_function fn
;
10202 if (atom_expr
->expr_type
== EXPR_FUNCTION
10203 && atom_expr
->value
.function
.isym
10204 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10205 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10207 gfc_start_block (&block
);
10208 gfc_init_block (&post_block
);
10210 gfc_init_se (&argse
, NULL
);
10211 argse
.want_pointer
= 1;
10212 gfc_conv_expr (&argse
, atom_expr
);
10213 gfc_add_block_to_block (&block
, &argse
.pre
);
10214 gfc_add_block_to_block (&post_block
, &argse
.post
);
10217 gfc_init_se (&argse
, NULL
);
10218 if (flag_coarray
== GFC_FCOARRAY_LIB
10219 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10220 argse
.want_pointer
= 1;
10221 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10222 gfc_add_block_to_block (&block
, &argse
.pre
);
10223 gfc_add_block_to_block (&post_block
, &argse
.post
);
10224 value
= argse
.expr
;
10226 switch (code
->resolved_isym
->id
)
10228 case GFC_ISYM_ATOMIC_ADD
:
10229 case GFC_ISYM_ATOMIC_AND
:
10230 case GFC_ISYM_ATOMIC_DEF
:
10231 case GFC_ISYM_ATOMIC_OR
:
10232 case GFC_ISYM_ATOMIC_XOR
:
10233 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
10234 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10235 old
= null_pointer_node
;
10238 gfc_init_se (&argse
, NULL
);
10239 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10240 argse
.want_pointer
= 1;
10241 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10242 gfc_add_block_to_block (&block
, &argse
.pre
);
10243 gfc_add_block_to_block (&post_block
, &argse
.post
);
10245 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10249 if (stat_expr
!= NULL
)
10251 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
10252 gfc_init_se (&argse
, NULL
);
10253 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10254 argse
.want_pointer
= 1;
10255 gfc_conv_expr_val (&argse
, stat_expr
);
10256 gfc_add_block_to_block (&block
, &argse
.pre
);
10257 gfc_add_block_to_block (&post_block
, &argse
.post
);
10260 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10261 stat
= null_pointer_node
;
10263 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10265 tree image_index
, caf_decl
, offset
, token
;
10268 switch (code
->resolved_isym
->id
)
10270 case GFC_ISYM_ATOMIC_ADD
:
10271 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10272 op
= (int) GFC_CAF_ATOMIC_ADD
;
10274 case GFC_ISYM_ATOMIC_AND
:
10275 case GFC_ISYM_ATOMIC_FETCH_AND
:
10276 op
= (int) GFC_CAF_ATOMIC_AND
;
10278 case GFC_ISYM_ATOMIC_OR
:
10279 case GFC_ISYM_ATOMIC_FETCH_OR
:
10280 op
= (int) GFC_CAF_ATOMIC_OR
;
10282 case GFC_ISYM_ATOMIC_XOR
:
10283 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10284 op
= (int) GFC_CAF_ATOMIC_XOR
;
10286 case GFC_ISYM_ATOMIC_DEF
:
10287 op
= 0; /* Unused. */
10290 gcc_unreachable ();
10293 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10294 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10295 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10297 if (gfc_is_coindexed (atom_expr
))
10298 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10300 image_index
= integer_zero_node
;
10302 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10304 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10305 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
10306 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10309 gfc_init_se (&argse
, NULL
);
10310 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10313 gfc_add_block_to_block (&block
, &argse
.pre
);
10314 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
10315 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
10316 token
, offset
, image_index
, value
, stat
,
10317 build_int_cst (integer_type_node
,
10318 (int) atom_expr
->ts
.type
),
10319 build_int_cst (integer_type_node
,
10320 (int) atom_expr
->ts
.kind
));
10322 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
10323 build_int_cst (integer_type_node
, op
),
10324 token
, offset
, image_index
, value
, old
, stat
,
10325 build_int_cst (integer_type_node
,
10326 (int) atom_expr
->ts
.type
),
10327 build_int_cst (integer_type_node
,
10328 (int) atom_expr
->ts
.kind
));
10330 gfc_add_expr_to_block (&block
, tmp
);
10331 gfc_add_block_to_block (&block
, &argse
.post
);
10332 gfc_add_block_to_block (&block
, &post_block
);
10333 return gfc_finish_block (&block
);
10337 switch (code
->resolved_isym
->id
)
10339 case GFC_ISYM_ATOMIC_ADD
:
10340 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10341 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
10343 case GFC_ISYM_ATOMIC_AND
:
10344 case GFC_ISYM_ATOMIC_FETCH_AND
:
10345 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
10347 case GFC_ISYM_ATOMIC_DEF
:
10348 fn
= BUILT_IN_ATOMIC_STORE_N
;
10350 case GFC_ISYM_ATOMIC_OR
:
10351 case GFC_ISYM_ATOMIC_FETCH_OR
:
10352 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
10354 case GFC_ISYM_ATOMIC_XOR
:
10355 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10356 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
10359 gcc_unreachable ();
10362 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10363 fn
= (built_in_function
) ((int) fn
10364 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10366 tmp
= builtin_decl_explicit (fn
);
10367 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
10368 tmp
= builtin_decl_explicit (fn
);
10370 switch (code
->resolved_isym
->id
)
10372 case GFC_ISYM_ATOMIC_ADD
:
10373 case GFC_ISYM_ATOMIC_AND
:
10374 case GFC_ISYM_ATOMIC_DEF
:
10375 case GFC_ISYM_ATOMIC_OR
:
10376 case GFC_ISYM_ATOMIC_XOR
:
10377 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10378 fold_convert (itype
, value
),
10379 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10380 gfc_add_expr_to_block (&block
, tmp
);
10383 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10384 fold_convert (itype
, value
),
10385 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10386 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
10390 if (stat
!= NULL_TREE
)
10391 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10392 gfc_add_block_to_block (&block
, &post_block
);
10393 return gfc_finish_block (&block
);
10398 conv_intrinsic_atomic_ref (gfc_code
*code
)
10401 tree tmp
, atom
, value
, stat
= NULL_TREE
;
10402 stmtblock_t block
, post_block
;
10403 built_in_function fn
;
10404 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
10406 if (atom_expr
->expr_type
== EXPR_FUNCTION
10407 && atom_expr
->value
.function
.isym
10408 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10409 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10411 gfc_start_block (&block
);
10412 gfc_init_block (&post_block
);
10413 gfc_init_se (&argse
, NULL
);
10414 argse
.want_pointer
= 1;
10415 gfc_conv_expr (&argse
, atom_expr
);
10416 gfc_add_block_to_block (&block
, &argse
.pre
);
10417 gfc_add_block_to_block (&post_block
, &argse
.post
);
10420 gfc_init_se (&argse
, NULL
);
10421 if (flag_coarray
== GFC_FCOARRAY_LIB
10422 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10423 argse
.want_pointer
= 1;
10424 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10425 gfc_add_block_to_block (&block
, &argse
.pre
);
10426 gfc_add_block_to_block (&post_block
, &argse
.post
);
10427 value
= argse
.expr
;
10430 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
10432 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10434 gfc_init_se (&argse
, NULL
);
10435 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10436 argse
.want_pointer
= 1;
10437 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10438 gfc_add_block_to_block (&block
, &argse
.pre
);
10439 gfc_add_block_to_block (&post_block
, &argse
.post
);
10442 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10443 stat
= null_pointer_node
;
10445 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10447 tree image_index
, caf_decl
, offset
, token
;
10448 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
10450 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10451 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10452 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10454 if (gfc_is_coindexed (atom_expr
))
10455 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10457 image_index
= integer_zero_node
;
10459 gfc_init_se (&argse
, NULL
);
10460 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10462 gfc_add_block_to_block (&block
, &argse
.pre
);
10464 /* Different type, need type conversion. */
10465 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10467 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10468 orig_value
= value
;
10469 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
10472 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
10473 token
, offset
, image_index
, value
, stat
,
10474 build_int_cst (integer_type_node
,
10475 (int) atom_expr
->ts
.type
),
10476 build_int_cst (integer_type_node
,
10477 (int) atom_expr
->ts
.kind
));
10478 gfc_add_expr_to_block (&block
, tmp
);
10479 if (vardecl
!= NULL_TREE
)
10480 gfc_add_modify (&block
, orig_value
,
10481 fold_convert (TREE_TYPE (orig_value
), vardecl
));
10482 gfc_add_block_to_block (&block
, &argse
.post
);
10483 gfc_add_block_to_block (&block
, &post_block
);
10484 return gfc_finish_block (&block
);
10487 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10488 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
10489 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10491 tmp
= builtin_decl_explicit (fn
);
10492 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
10493 build_int_cst (integer_type_node
,
10494 MEMMODEL_RELAXED
));
10495 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
10497 if (stat
!= NULL_TREE
)
10498 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10499 gfc_add_block_to_block (&block
, &post_block
);
10500 return gfc_finish_block (&block
);
10505 conv_intrinsic_atomic_cas (gfc_code
*code
)
10508 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
10509 stmtblock_t block
, post_block
;
10510 built_in_function fn
;
10511 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10513 if (atom_expr
->expr_type
== EXPR_FUNCTION
10514 && atom_expr
->value
.function
.isym
10515 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10516 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10518 gfc_init_block (&block
);
10519 gfc_init_block (&post_block
);
10520 gfc_init_se (&argse
, NULL
);
10521 argse
.want_pointer
= 1;
10522 gfc_conv_expr (&argse
, atom_expr
);
10525 gfc_init_se (&argse
, NULL
);
10526 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10527 argse
.want_pointer
= 1;
10528 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10529 gfc_add_block_to_block (&block
, &argse
.pre
);
10530 gfc_add_block_to_block (&post_block
, &argse
.post
);
10533 gfc_init_se (&argse
, NULL
);
10534 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10535 argse
.want_pointer
= 1;
10536 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10537 gfc_add_block_to_block (&block
, &argse
.pre
);
10538 gfc_add_block_to_block (&post_block
, &argse
.post
);
10541 gfc_init_se (&argse
, NULL
);
10542 if (flag_coarray
== GFC_FCOARRAY_LIB
10543 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
10544 == atom_expr
->ts
.kind
)
10545 argse
.want_pointer
= 1;
10546 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
10547 gfc_add_block_to_block (&block
, &argse
.pre
);
10548 gfc_add_block_to_block (&post_block
, &argse
.post
);
10549 new_val
= argse
.expr
;
10552 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
10554 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
10556 gfc_init_se (&argse
, NULL
);
10557 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10558 argse
.want_pointer
= 1;
10559 gfc_conv_expr_val (&argse
,
10560 code
->ext
.actual
->next
->next
->next
->next
->expr
);
10561 gfc_add_block_to_block (&block
, &argse
.pre
);
10562 gfc_add_block_to_block (&post_block
, &argse
.post
);
10565 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10566 stat
= null_pointer_node
;
10568 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10570 tree image_index
, caf_decl
, offset
, token
;
10572 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10573 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10574 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10576 if (gfc_is_coindexed (atom_expr
))
10577 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10579 image_index
= integer_zero_node
;
10581 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
10583 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
10584 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
10585 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10588 /* Convert a constant to a pointer. */
10589 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
10591 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
10592 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
10593 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10596 gfc_init_se (&argse
, NULL
);
10597 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10599 gfc_add_block_to_block (&block
, &argse
.pre
);
10601 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
10602 token
, offset
, image_index
, old
, comp
, new_val
,
10603 stat
, build_int_cst (integer_type_node
,
10604 (int) atom_expr
->ts
.type
),
10605 build_int_cst (integer_type_node
,
10606 (int) atom_expr
->ts
.kind
));
10607 gfc_add_expr_to_block (&block
, tmp
);
10608 gfc_add_block_to_block (&block
, &argse
.post
);
10609 gfc_add_block_to_block (&block
, &post_block
);
10610 return gfc_finish_block (&block
);
10613 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10614 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10615 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10617 tmp
= builtin_decl_explicit (fn
);
10619 gfc_add_modify (&block
, old
, comp
);
10620 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
10621 gfc_build_addr_expr (NULL
, old
),
10622 fold_convert (TREE_TYPE (old
), new_val
),
10623 boolean_false_node
,
10624 build_int_cst (NULL
, MEMMODEL_RELAXED
),
10625 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10626 gfc_add_expr_to_block (&block
, tmp
);
10628 if (stat
!= NULL_TREE
)
10629 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10630 gfc_add_block_to_block (&block
, &post_block
);
10631 return gfc_finish_block (&block
);
10635 conv_intrinsic_event_query (gfc_code
*code
)
10638 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
10639 tree count
= NULL_TREE
, count2
= NULL_TREE
;
10641 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
10643 if (code
->ext
.actual
->next
->next
->expr
)
10645 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10647 gfc_init_se (&argse
, NULL
);
10648 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10651 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10652 stat
= null_pointer_node
;
10654 if (code
->ext
.actual
->next
->expr
)
10656 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
10657 gfc_init_se (&argse
, NULL
);
10658 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
10659 count
= argse
.expr
;
10662 gfc_start_block (&se
.pre
);
10663 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10665 tree tmp
, token
, image_index
;
10666 tree index
= build_zero_cst (gfc_array_index_type
);
10668 if (event_expr
->expr_type
== EXPR_FUNCTION
10669 && event_expr
->value
.function
.isym
10670 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10671 event_expr
= event_expr
->value
.function
.actual
->expr
;
10673 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
10675 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10676 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
10677 != INTMOD_ISO_FORTRAN_ENV
10678 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
10679 != ISOFORTRAN_EVENT_TYPE
)
10681 gfc_error ("Sorry, the event component of derived type at %L is not "
10682 "yet supported", &event_expr
->where
);
10686 if (gfc_is_coindexed (event_expr
))
10688 gfc_error ("The event variable at %L shall not be coindexed",
10689 &event_expr
->where
);
10693 image_index
= integer_zero_node
;
10695 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10698 /* For arrays, obtain the array index. */
10699 if (gfc_expr_attr (event_expr
).dimension
)
10701 tree desc
, tmp
, extent
, lbound
, ubound
;
10702 gfc_array_ref
*ar
, ar2
;
10705 /* TODO: Extend this, once DT components are supported. */
10706 ar
= &event_expr
->ref
->u
.ar
;
10708 memset (ar
, '\0', sizeof (*ar
));
10710 ar
->type
= AR_FULL
;
10712 gfc_init_se (&argse
, NULL
);
10713 argse
.descriptor_only
= 1;
10714 gfc_conv_expr_descriptor (&argse
, event_expr
);
10715 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
10719 extent
= build_one_cst (gfc_array_index_type
);
10720 for (i
= 0; i
< ar
->dimen
; i
++)
10722 gfc_init_se (&argse
, NULL
);
10723 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
10724 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
10725 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
10726 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10727 TREE_TYPE (lbound
), argse
.expr
, lbound
);
10728 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10729 TREE_TYPE (tmp
), extent
, tmp
);
10730 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
10731 TREE_TYPE (tmp
), index
, tmp
);
10732 if (i
< ar
->dimen
- 1)
10734 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
10735 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10736 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
10737 TREE_TYPE (tmp
), extent
, tmp
);
10742 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
10745 count
= gfc_create_var (integer_type_node
, "count");
10748 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
10751 stat
= gfc_create_var (integer_type_node
, "stat");
10754 index
= fold_convert (size_type_node
, index
);
10755 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
10756 token
, index
, image_index
, count
10757 ? gfc_build_addr_expr (NULL
, count
) : count
,
10758 stat
!= null_pointer_node
10759 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
10760 gfc_add_expr_to_block (&se
.pre
, tmp
);
10762 if (count2
!= NULL_TREE
)
10763 gfc_add_modify (&se
.pre
, count2
,
10764 fold_convert (TREE_TYPE (count2
), count
));
10766 if (stat2
!= NULL_TREE
)
10767 gfc_add_modify (&se
.pre
, stat2
,
10768 fold_convert (TREE_TYPE (stat2
), stat
));
10770 return gfc_finish_block (&se
.pre
);
10773 gfc_init_se (&argse
, NULL
);
10774 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
10775 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
10777 if (stat
!= NULL_TREE
)
10778 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10780 return gfc_finish_block (&se
.pre
);
10784 conv_intrinsic_move_alloc (gfc_code
*code
)
10787 gfc_expr
*from_expr
, *to_expr
;
10788 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
10789 gfc_se from_se
, to_se
;
10793 gfc_start_block (&block
);
10795 from_expr
= code
->ext
.actual
->expr
;
10796 to_expr
= code
->ext
.actual
->next
->expr
;
10798 gfc_init_se (&from_se
, NULL
);
10799 gfc_init_se (&to_se
, NULL
);
10801 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
10802 || to_expr
->ts
.type
== BT_CLASS
);
10803 coarray
= gfc_get_corank (from_expr
) != 0;
10805 if (from_expr
->rank
== 0 && !coarray
)
10807 if (from_expr
->ts
.type
!= BT_CLASS
)
10808 from_expr2
= from_expr
;
10811 from_expr2
= gfc_copy_expr (from_expr
);
10812 gfc_add_data_component (from_expr2
);
10815 if (to_expr
->ts
.type
!= BT_CLASS
)
10816 to_expr2
= to_expr
;
10819 to_expr2
= gfc_copy_expr (to_expr
);
10820 gfc_add_data_component (to_expr2
);
10823 from_se
.want_pointer
= 1;
10824 to_se
.want_pointer
= 1;
10825 gfc_conv_expr (&from_se
, from_expr2
);
10826 gfc_conv_expr (&to_se
, to_expr2
);
10827 gfc_add_block_to_block (&block
, &from_se
.pre
);
10828 gfc_add_block_to_block (&block
, &to_se
.pre
);
10830 /* Deallocate "to". */
10831 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10832 true, to_expr
, to_expr
->ts
);
10833 gfc_add_expr_to_block (&block
, tmp
);
10835 /* Assign (_data) pointers. */
10836 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10837 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
10839 /* Set "from" to NULL. */
10840 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10841 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
10843 gfc_add_block_to_block (&block
, &from_se
.post
);
10844 gfc_add_block_to_block (&block
, &to_se
.post
);
10847 if (to_expr
->ts
.type
== BT_CLASS
)
10851 gfc_free_expr (to_expr2
);
10852 gfc_init_se (&to_se
, NULL
);
10853 to_se
.want_pointer
= 1;
10854 gfc_add_vptr_component (to_expr
);
10855 gfc_conv_expr (&to_se
, to_expr
);
10857 if (from_expr
->ts
.type
== BT_CLASS
)
10859 if (UNLIMITED_POLY (from_expr
))
10863 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10867 gfc_free_expr (from_expr2
);
10868 gfc_init_se (&from_se
, NULL
);
10869 from_se
.want_pointer
= 1;
10870 gfc_add_vptr_component (from_expr
);
10871 gfc_conv_expr (&from_se
, from_expr
);
10872 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10873 fold_convert (TREE_TYPE (to_se
.expr
),
10876 /* Reset _vptr component to declared type. */
10878 /* Unlimited polymorphic. */
10879 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10880 fold_convert (TREE_TYPE (from_se
.expr
),
10881 null_pointer_node
));
10884 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10885 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10886 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10891 vtab
= gfc_find_vtab (&from_expr
->ts
);
10893 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10894 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10895 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10899 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10901 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10902 fold_convert (TREE_TYPE (to_se
.string_length
),
10903 from_se
.string_length
));
10904 if (from_expr
->ts
.deferred
)
10905 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10906 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10909 return gfc_finish_block (&block
);
10912 /* Update _vptr component. */
10913 if (to_expr
->ts
.type
== BT_CLASS
)
10917 to_se
.want_pointer
= 1;
10918 to_expr2
= gfc_copy_expr (to_expr
);
10919 gfc_add_vptr_component (to_expr2
);
10920 gfc_conv_expr (&to_se
, to_expr2
);
10922 if (from_expr
->ts
.type
== BT_CLASS
)
10924 if (UNLIMITED_POLY (from_expr
))
10928 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10932 from_se
.want_pointer
= 1;
10933 from_expr2
= gfc_copy_expr (from_expr
);
10934 gfc_add_vptr_component (from_expr2
);
10935 gfc_conv_expr (&from_se
, from_expr2
);
10936 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10937 fold_convert (TREE_TYPE (to_se
.expr
),
10940 /* Reset _vptr component to declared type. */
10942 /* Unlimited polymorphic. */
10943 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10944 fold_convert (TREE_TYPE (from_se
.expr
),
10945 null_pointer_node
));
10948 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10949 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10950 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10955 vtab
= gfc_find_vtab (&from_expr
->ts
);
10957 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10958 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10959 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10962 gfc_free_expr (to_expr2
);
10963 gfc_init_se (&to_se
, NULL
);
10965 if (from_expr
->ts
.type
== BT_CLASS
)
10967 gfc_free_expr (from_expr2
);
10968 gfc_init_se (&from_se
, NULL
);
10973 /* Deallocate "to". */
10974 if (from_expr
->rank
== 0)
10976 to_se
.want_coarray
= 1;
10977 from_se
.want_coarray
= 1;
10979 gfc_conv_expr_descriptor (&to_se
, to_expr
);
10980 gfc_conv_expr_descriptor (&from_se
, from_expr
);
10982 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10983 is an image control "statement", cf. IR F08/0040 in 12-006A. */
10984 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10988 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10989 NULL_TREE
, NULL_TREE
, true, to_expr
,
10990 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
10991 gfc_add_expr_to_block (&block
, tmp
);
10993 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10994 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10995 logical_type_node
, tmp
,
10996 fold_convert (TREE_TYPE (tmp
),
10997 null_pointer_node
));
10998 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
10999 3, null_pointer_node
, null_pointer_node
,
11000 build_int_cst (integer_type_node
, 0));
11002 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
11003 tmp
, build_empty_stmt (input_location
));
11004 gfc_add_expr_to_block (&block
, tmp
);
11008 if (to_expr
->ts
.type
== BT_DERIVED
11009 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
11011 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
11012 to_se
.expr
, to_expr
->rank
);
11013 gfc_add_expr_to_block (&block
, tmp
);
11016 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
11017 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
11018 NULL_TREE
, true, to_expr
,
11019 GFC_CAF_COARRAY_NOCOARRAY
);
11020 gfc_add_expr_to_block (&block
, tmp
);
11023 /* Move the pointer and update the array descriptor data. */
11024 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
11026 /* Set "from" to NULL. */
11027 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
11028 gfc_add_modify_loc (input_location
, &block
, tmp
,
11029 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
11032 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
11034 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
11035 fold_convert (TREE_TYPE (to_se
.string_length
),
11036 from_se
.string_length
));
11037 if (from_expr
->ts
.deferred
)
11038 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
11039 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
11042 return gfc_finish_block (&block
);
11047 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
11051 gcc_assert (code
->resolved_isym
);
11053 switch (code
->resolved_isym
->id
)
11055 case GFC_ISYM_MOVE_ALLOC
:
11056 res
= conv_intrinsic_move_alloc (code
);
11059 case GFC_ISYM_ATOMIC_CAS
:
11060 res
= conv_intrinsic_atomic_cas (code
);
11063 case GFC_ISYM_ATOMIC_ADD
:
11064 case GFC_ISYM_ATOMIC_AND
:
11065 case GFC_ISYM_ATOMIC_DEF
:
11066 case GFC_ISYM_ATOMIC_OR
:
11067 case GFC_ISYM_ATOMIC_XOR
:
11068 case GFC_ISYM_ATOMIC_FETCH_ADD
:
11069 case GFC_ISYM_ATOMIC_FETCH_AND
:
11070 case GFC_ISYM_ATOMIC_FETCH_OR
:
11071 case GFC_ISYM_ATOMIC_FETCH_XOR
:
11072 res
= conv_intrinsic_atomic_op (code
);
11075 case GFC_ISYM_ATOMIC_REF
:
11076 res
= conv_intrinsic_atomic_ref (code
);
11079 case GFC_ISYM_EVENT_QUERY
:
11080 res
= conv_intrinsic_event_query (code
);
11083 case GFC_ISYM_C_F_POINTER
:
11084 case GFC_ISYM_C_F_PROCPOINTER
:
11085 res
= conv_isocbinding_subroutine (code
);
11088 case GFC_ISYM_CAF_SEND
:
11089 res
= conv_caf_send (code
);
11092 case GFC_ISYM_CO_BROADCAST
:
11093 case GFC_ISYM_CO_MIN
:
11094 case GFC_ISYM_CO_MAX
:
11095 case GFC_ISYM_CO_REDUCE
:
11096 case GFC_ISYM_CO_SUM
:
11097 res
= conv_co_collective (code
);
11100 case GFC_ISYM_FREE
:
11101 res
= conv_intrinsic_free (code
);
11104 case GFC_ISYM_RANDOM_INIT
:
11105 res
= conv_intrinsic_random_init (code
);
11108 case GFC_ISYM_KILL
:
11109 res
= conv_intrinsic_kill_sub (code
);
11112 case GFC_ISYM_SYSTEM_CLOCK
:
11113 res
= conv_intrinsic_system_clock (code
);
11124 #include "gt-fortran-trans-intrinsic.h"