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 && sym
->ts
.type
!= BT_LOGICAL
)
4060 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
4062 if (flag_external_blas
4063 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
4064 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
4068 if (sym
->ts
.type
== BT_REAL
)
4070 if (sym
->ts
.kind
== 4)
4071 gemm_fndecl
= gfor_fndecl_sgemm
;
4073 gemm_fndecl
= gfor_fndecl_dgemm
;
4077 if (sym
->ts
.kind
== 4)
4078 gemm_fndecl
= gfor_fndecl_cgemm
;
4080 gemm_fndecl
= gfor_fndecl_zgemm
;
4083 vec_alloc (append_args
, 3);
4084 append_args
->quick_push (build_int_cst (cint
, 1));
4085 append_args
->quick_push (build_int_cst (cint
,
4086 flag_blas_matmul_limit
));
4087 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
4092 vec_alloc (append_args
, 3);
4093 append_args
->quick_push (build_int_cst (cint
, 0));
4094 append_args
->quick_push (build_int_cst (cint
, 0));
4095 append_args
->quick_push (null_pointer_node
);
4099 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4101 gfc_free_symbol (sym
);
4104 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4124 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4133 gfc_actual_arglist
*actual
;
4140 gfc_conv_intrinsic_funcall (se
, expr
);
4144 actual
= expr
->value
.function
.actual
;
4145 type
= gfc_typenode_for_spec (&expr
->ts
);
4146 /* Initialize the result. */
4147 resvar
= gfc_create_var (type
, "test");
4149 tmp
= convert (type
, boolean_true_node
);
4151 tmp
= convert (type
, boolean_false_node
);
4152 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4154 /* Walk the arguments. */
4155 arrayss
= gfc_walk_expr (actual
->expr
);
4156 gcc_assert (arrayss
!= gfc_ss_terminator
);
4158 /* Initialize the scalarizer. */
4159 gfc_init_loopinfo (&loop
);
4160 exit_label
= gfc_build_label_decl (NULL_TREE
);
4161 TREE_USED (exit_label
) = 1;
4162 gfc_add_ss_to_loop (&loop
, arrayss
);
4164 /* Initialize the loop. */
4165 gfc_conv_ss_startstride (&loop
);
4166 gfc_conv_loop_setup (&loop
, &expr
->where
);
4168 gfc_mark_ss_chain_used (arrayss
, 1);
4169 /* Generate the loop body. */
4170 gfc_start_scalarized_body (&loop
, &body
);
4172 /* If the condition matches then set the return value. */
4173 gfc_start_block (&block
);
4175 tmp
= convert (type
, boolean_false_node
);
4177 tmp
= convert (type
, boolean_true_node
);
4178 gfc_add_modify (&block
, resvar
, tmp
);
4180 /* And break out of the loop. */
4181 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4182 gfc_add_expr_to_block (&block
, tmp
);
4184 found
= gfc_finish_block (&block
);
4186 /* Check this element. */
4187 gfc_init_se (&arrayse
, NULL
);
4188 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4189 arrayse
.ss
= arrayss
;
4190 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4192 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4193 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
, arrayse
.expr
,
4194 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
4195 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
4196 gfc_add_expr_to_block (&body
, tmp
);
4197 gfc_add_block_to_block (&body
, &arrayse
.post
);
4199 gfc_trans_scalarizing_loops (&loop
, &body
);
4201 /* Add the exit label. */
4202 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4203 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4205 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4206 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4207 gfc_cleanup_loop (&loop
);
4212 /* COUNT(A) = Number of true elements in A. */
4214 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4221 gfc_actual_arglist
*actual
;
4227 gfc_conv_intrinsic_funcall (se
, expr
);
4231 actual
= expr
->value
.function
.actual
;
4233 type
= gfc_typenode_for_spec (&expr
->ts
);
4234 /* Initialize the result. */
4235 resvar
= gfc_create_var (type
, "count");
4236 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4238 /* Walk the arguments. */
4239 arrayss
= gfc_walk_expr (actual
->expr
);
4240 gcc_assert (arrayss
!= gfc_ss_terminator
);
4242 /* Initialize the scalarizer. */
4243 gfc_init_loopinfo (&loop
);
4244 gfc_add_ss_to_loop (&loop
, arrayss
);
4246 /* Initialize the loop. */
4247 gfc_conv_ss_startstride (&loop
);
4248 gfc_conv_loop_setup (&loop
, &expr
->where
);
4250 gfc_mark_ss_chain_used (arrayss
, 1);
4251 /* Generate the loop body. */
4252 gfc_start_scalarized_body (&loop
, &body
);
4254 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4255 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4256 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4258 gfc_init_se (&arrayse
, NULL
);
4259 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4260 arrayse
.ss
= arrayss
;
4261 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4262 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4263 build_empty_stmt (input_location
));
4265 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4266 gfc_add_expr_to_block (&body
, tmp
);
4267 gfc_add_block_to_block (&body
, &arrayse
.post
);
4269 gfc_trans_scalarizing_loops (&loop
, &body
);
4271 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4272 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4273 gfc_cleanup_loop (&loop
);
4279 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4280 struct and return the corresponding loopinfo. */
4282 static gfc_loopinfo
*
4283 enter_nested_loop (gfc_se
*se
)
4285 se
->ss
= se
->ss
->nested_ss
;
4286 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4288 return se
->ss
->loop
;
4292 /* Inline implementation of the sum and product intrinsics. */
4294 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4298 tree scale
= NULL_TREE
;
4303 gfc_loopinfo loop
, *ploop
;
4304 gfc_actual_arglist
*arg_array
, *arg_mask
;
4305 gfc_ss
*arrayss
= NULL
;
4306 gfc_ss
*maskss
= NULL
;
4310 gfc_expr
*arrayexpr
;
4315 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4321 type
= gfc_typenode_for_spec (&expr
->ts
);
4322 /* Initialize the result. */
4323 resvar
= gfc_create_var (type
, "val");
4328 scale
= gfc_create_var (type
, "scale");
4329 gfc_add_modify (&se
->pre
, scale
,
4330 gfc_build_const (type
, integer_one_node
));
4331 tmp
= gfc_build_const (type
, integer_zero_node
);
4333 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4334 tmp
= gfc_build_const (type
, integer_zero_node
);
4335 else if (op
== NE_EXPR
)
4337 tmp
= convert (type
, boolean_false_node
);
4338 else if (op
== BIT_AND_EXPR
)
4339 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4340 type
, integer_one_node
));
4342 tmp
= gfc_build_const (type
, integer_one_node
);
4344 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4346 arg_array
= expr
->value
.function
.actual
;
4348 arrayexpr
= arg_array
->expr
;
4350 if (op
== NE_EXPR
|| norm2
)
4351 /* PARITY and NORM2. */
4355 arg_mask
= arg_array
->next
->next
;
4356 gcc_assert (arg_mask
!= NULL
);
4357 maskexpr
= arg_mask
->expr
;
4360 if (expr
->rank
== 0)
4362 /* Walk the arguments. */
4363 arrayss
= gfc_walk_expr (arrayexpr
);
4364 gcc_assert (arrayss
!= gfc_ss_terminator
);
4366 if (maskexpr
&& maskexpr
->rank
> 0)
4368 maskss
= gfc_walk_expr (maskexpr
);
4369 gcc_assert (maskss
!= gfc_ss_terminator
);
4374 /* Initialize the scalarizer. */
4375 gfc_init_loopinfo (&loop
);
4376 gfc_add_ss_to_loop (&loop
, arrayss
);
4377 if (maskexpr
&& maskexpr
->rank
> 0)
4378 gfc_add_ss_to_loop (&loop
, maskss
);
4380 /* Initialize the loop. */
4381 gfc_conv_ss_startstride (&loop
);
4382 gfc_conv_loop_setup (&loop
, &expr
->where
);
4384 gfc_mark_ss_chain_used (arrayss
, 1);
4385 if (maskexpr
&& maskexpr
->rank
> 0)
4386 gfc_mark_ss_chain_used (maskss
, 1);
4391 /* All the work has been done in the parent loops. */
4392 ploop
= enter_nested_loop (se
);
4396 /* Generate the loop body. */
4397 gfc_start_scalarized_body (ploop
, &body
);
4399 /* If we have a mask, only add this element if the mask is set. */
4400 if (maskexpr
&& maskexpr
->rank
> 0)
4402 gfc_init_se (&maskse
, parent_se
);
4403 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4404 if (expr
->rank
== 0)
4406 gfc_conv_expr_val (&maskse
, maskexpr
);
4407 gfc_add_block_to_block (&body
, &maskse
.pre
);
4409 gfc_start_block (&block
);
4412 gfc_init_block (&block
);
4414 /* Do the actual summation/product. */
4415 gfc_init_se (&arrayse
, parent_se
);
4416 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4417 if (expr
->rank
== 0)
4418 arrayse
.ss
= arrayss
;
4419 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4420 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4424 /* if (x (i) != 0.0)
4430 result = 1.0 + result * val * val;
4436 result += val * val;
4439 tree res1
, res2
, cond
, absX
, val
;
4440 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4442 gfc_init_block (&ifblock1
);
4444 absX
= gfc_create_var (type
, "absX");
4445 gfc_add_modify (&ifblock1
, absX
,
4446 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4448 val
= gfc_create_var (type
, "val");
4449 gfc_add_expr_to_block (&ifblock1
, val
);
4451 gfc_init_block (&ifblock2
);
4452 gfc_add_modify (&ifblock2
, val
,
4453 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4455 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4456 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4457 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4458 gfc_build_const (type
, integer_one_node
));
4459 gfc_add_modify (&ifblock2
, resvar
, res1
);
4460 gfc_add_modify (&ifblock2
, scale
, absX
);
4461 res1
= gfc_finish_block (&ifblock2
);
4463 gfc_init_block (&ifblock3
);
4464 gfc_add_modify (&ifblock3
, val
,
4465 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4467 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4468 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4469 gfc_add_modify (&ifblock3
, resvar
, res2
);
4470 res2
= gfc_finish_block (&ifblock3
);
4472 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4474 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4475 gfc_add_expr_to_block (&ifblock1
, tmp
);
4476 tmp
= gfc_finish_block (&ifblock1
);
4478 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
4480 gfc_build_const (type
, integer_zero_node
));
4482 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4483 gfc_add_expr_to_block (&block
, tmp
);
4487 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4488 gfc_add_modify (&block
, resvar
, tmp
);
4491 gfc_add_block_to_block (&block
, &arrayse
.post
);
4493 if (maskexpr
&& maskexpr
->rank
> 0)
4495 /* We enclose the above in if (mask) {...} . */
4497 tmp
= gfc_finish_block (&block
);
4498 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4499 build_empty_stmt (input_location
));
4502 tmp
= gfc_finish_block (&block
);
4503 gfc_add_expr_to_block (&body
, tmp
);
4505 gfc_trans_scalarizing_loops (ploop
, &body
);
4507 /* For a scalar mask, enclose the loop in an if statement. */
4508 if (maskexpr
&& maskexpr
->rank
== 0)
4510 gfc_init_block (&block
);
4511 gfc_add_block_to_block (&block
, &ploop
->pre
);
4512 gfc_add_block_to_block (&block
, &ploop
->post
);
4513 tmp
= gfc_finish_block (&block
);
4517 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4518 build_empty_stmt (input_location
));
4519 gfc_advance_se_ss_chain (se
);
4523 gcc_assert (expr
->rank
== 0);
4524 gfc_init_se (&maskse
, NULL
);
4525 gfc_conv_expr_val (&maskse
, maskexpr
);
4526 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4527 build_empty_stmt (input_location
));
4530 gfc_add_expr_to_block (&block
, tmp
);
4531 gfc_add_block_to_block (&se
->pre
, &block
);
4532 gcc_assert (se
->post
.head
== NULL
);
4536 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4537 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4540 if (expr
->rank
== 0)
4541 gfc_cleanup_loop (ploop
);
4545 /* result = scale * sqrt(result). */
4547 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4548 resvar
= build_call_expr_loc (input_location
,
4550 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4557 /* Inline implementation of the dot_product intrinsic. This function
4558 is based on gfc_conv_intrinsic_arith (the previous function). */
4560 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4568 gfc_actual_arglist
*actual
;
4569 gfc_ss
*arrayss1
, *arrayss2
;
4570 gfc_se arrayse1
, arrayse2
;
4571 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4573 type
= gfc_typenode_for_spec (&expr
->ts
);
4575 /* Initialize the result. */
4576 resvar
= gfc_create_var (type
, "val");
4577 if (expr
->ts
.type
== BT_LOGICAL
)
4578 tmp
= build_int_cst (type
, 0);
4580 tmp
= gfc_build_const (type
, integer_zero_node
);
4582 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4584 /* Walk argument #1. */
4585 actual
= expr
->value
.function
.actual
;
4586 arrayexpr1
= actual
->expr
;
4587 arrayss1
= gfc_walk_expr (arrayexpr1
);
4588 gcc_assert (arrayss1
!= gfc_ss_terminator
);
4590 /* Walk argument #2. */
4591 actual
= actual
->next
;
4592 arrayexpr2
= actual
->expr
;
4593 arrayss2
= gfc_walk_expr (arrayexpr2
);
4594 gcc_assert (arrayss2
!= gfc_ss_terminator
);
4596 /* Initialize the scalarizer. */
4597 gfc_init_loopinfo (&loop
);
4598 gfc_add_ss_to_loop (&loop
, arrayss1
);
4599 gfc_add_ss_to_loop (&loop
, arrayss2
);
4601 /* Initialize the loop. */
4602 gfc_conv_ss_startstride (&loop
);
4603 gfc_conv_loop_setup (&loop
, &expr
->where
);
4605 gfc_mark_ss_chain_used (arrayss1
, 1);
4606 gfc_mark_ss_chain_used (arrayss2
, 1);
4608 /* Generate the loop body. */
4609 gfc_start_scalarized_body (&loop
, &body
);
4610 gfc_init_block (&block
);
4612 /* Make the tree expression for [conjg(]array1[)]. */
4613 gfc_init_se (&arrayse1
, NULL
);
4614 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
4615 arrayse1
.ss
= arrayss1
;
4616 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
4617 if (expr
->ts
.type
== BT_COMPLEX
)
4618 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
4620 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
4622 /* Make the tree expression for array2. */
4623 gfc_init_se (&arrayse2
, NULL
);
4624 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
4625 arrayse2
.ss
= arrayss2
;
4626 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
4627 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
4629 /* Do the actual product and sum. */
4630 if (expr
->ts
.type
== BT_LOGICAL
)
4632 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
4633 arrayse1
.expr
, arrayse2
.expr
);
4634 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
4638 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
4640 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
4642 gfc_add_modify (&block
, resvar
, tmp
);
4644 /* Finish up the loop block and the loop. */
4645 tmp
= gfc_finish_block (&block
);
4646 gfc_add_expr_to_block (&body
, tmp
);
4648 gfc_trans_scalarizing_loops (&loop
, &body
);
4649 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4650 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4651 gfc_cleanup_loop (&loop
);
4657 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4658 we need to handle. For performance reasons we sometimes create two
4659 loops instead of one, where the second one is much simpler.
4660 Examples for minloc intrinsic:
4661 1) Result is an array, a call is generated
4662 2) Array mask is used and NaNs need to be supported:
4668 if (pos == 0) pos = S + (1 - from);
4669 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4676 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4680 3) NaNs need to be supported, but it is known at compile time or cheaply
4681 at runtime whether array is nonempty or not:
4686 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4689 if (from <= to) pos = 1;
4693 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4697 4) NaNs aren't supported, array mask is used:
4698 limit = infinities_supported ? Infinity : huge (limit);
4702 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4708 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4712 5) Same without array mask:
4713 limit = infinities_supported ? Infinity : huge (limit);
4714 pos = (from <= to) ? 1 : 0;
4717 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4720 For 3) and 5), if mask is scalar, this all goes into a conditional,
4721 setting pos = 0; in the else branch.
4723 Since we now also support the BACK argument, instead of using
4724 if (a[S] < limit), we now use
4727 cond = a[S] <= limit;
4729 cond = a[S] < limit;
4733 The optimizer is smart enough to move the condition out of the loop.
4734 The are now marked as unlikely to for further speedup. */
4737 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4741 stmtblock_t ifblock
;
4742 stmtblock_t elseblock
;
4754 gfc_actual_arglist
*actual
;
4759 gfc_expr
*arrayexpr
;
4766 actual
= expr
->value
.function
.actual
;
4768 /* The last argument, BACK, is passed by value. Ensure that
4769 by setting its name to %VAL. */
4770 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
4772 if (a
->next
== NULL
)
4778 gfc_conv_intrinsic_funcall (se
, expr
);
4782 arrayexpr
= actual
->expr
;
4784 /* Special case for character maxloc. Remove unneeded actual
4785 arguments, then call a library function. */
4787 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
4789 gfc_actual_arglist
*a
, *b
;
4794 if (b
->expr
== NULL
|| strcmp (b
->name
, "dim") == 0)
4798 gfc_free_actual_arglist (b
);
4803 gfc_conv_intrinsic_funcall (se
, expr
);
4807 /* Initialize the result. */
4808 pos
= gfc_create_var (gfc_array_index_type
, "pos");
4809 offset
= gfc_create_var (gfc_array_index_type
, "offset");
4810 type
= gfc_typenode_for_spec (&expr
->ts
);
4812 /* Walk the arguments. */
4813 arrayss
= gfc_walk_expr (arrayexpr
);
4814 gcc_assert (arrayss
!= gfc_ss_terminator
);
4816 actual
= actual
->next
->next
;
4817 gcc_assert (actual
);
4818 maskexpr
= actual
->expr
;
4819 backexpr
= actual
->next
->next
->expr
;
4821 if (maskexpr
&& maskexpr
->rank
!= 0)
4823 maskss
= gfc_walk_expr (maskexpr
);
4824 gcc_assert (maskss
!= gfc_ss_terminator
);
4829 if (gfc_array_size (arrayexpr
, &asize
))
4831 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4833 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4834 logical_type_node
, nonempty
,
4835 gfc_index_zero_node
);
4840 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
4841 switch (arrayexpr
->ts
.type
)
4844 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
4848 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
4849 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
4850 arrayexpr
->ts
.kind
);
4857 /* We start with the most negative possible value for MAXLOC, and the most
4858 positive possible value for MINLOC. The most negative possible value is
4859 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4860 possible value is HUGE in both cases. */
4862 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4863 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
4864 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
4865 build_int_cst (TREE_TYPE (tmp
), 1));
4867 gfc_add_modify (&se
->pre
, limit
, tmp
);
4869 /* Initialize the scalarizer. */
4870 gfc_init_loopinfo (&loop
);
4871 gfc_add_ss_to_loop (&loop
, arrayss
);
4873 gfc_add_ss_to_loop (&loop
, maskss
);
4875 /* Initialize the loop. */
4876 gfc_conv_ss_startstride (&loop
);
4878 /* The code generated can have more than one loop in sequence (see the
4879 comment at the function header). This doesn't work well with the
4880 scalarizer, which changes arrays' offset when the scalarization loops
4881 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4882 are currently inlined in the scalar case only (for which loop is of rank
4883 one). As there is no dependency to care about in that case, there is no
4884 temporary, so that we can use the scalarizer temporary code to handle
4885 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4886 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4888 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4889 should eventually go away. We could either create two loops properly,
4890 or find another way to save/restore the array offsets between the two
4891 loops (without conflicting with temporary management), or use a single
4892 loop minmaxloc implementation. See PR 31067. */
4893 loop
.temp_dim
= loop
.dimen
;
4894 gfc_conv_loop_setup (&loop
, &expr
->where
);
4896 gcc_assert (loop
.dimen
== 1);
4897 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
4898 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4899 loop
.from
[0], loop
.to
[0]);
4903 /* Initialize the position to zero, following Fortran 2003. We are free
4904 to do this because Fortran 95 allows the result of an entirely false
4905 mask to be processor dependent. If we know at compile time the array
4906 is non-empty and no MASK is used, we can initialize to 1 to simplify
4908 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
4909 gfc_add_modify (&loop
.pre
, pos
,
4910 fold_build3_loc (input_location
, COND_EXPR
,
4911 gfc_array_index_type
,
4912 nonempty
, gfc_index_one_node
,
4913 gfc_index_zero_node
));
4916 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
4917 lab1
= gfc_build_label_decl (NULL_TREE
);
4918 TREE_USED (lab1
) = 1;
4919 lab2
= gfc_build_label_decl (NULL_TREE
);
4920 TREE_USED (lab2
) = 1;
4923 /* An offset must be added to the loop
4924 counter to obtain the required position. */
4925 gcc_assert (loop
.from
[0]);
4927 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4928 gfc_index_one_node
, loop
.from
[0]);
4929 gfc_add_modify (&loop
.pre
, offset
, tmp
);
4931 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
4933 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
4934 /* Generate the loop body. */
4935 gfc_start_scalarized_body (&loop
, &body
);
4937 /* If we have a mask, only check this element if the mask is set. */
4940 gfc_init_se (&maskse
, NULL
);
4941 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4943 gfc_conv_expr_val (&maskse
, maskexpr
);
4944 gfc_add_block_to_block (&body
, &maskse
.pre
);
4946 gfc_start_block (&block
);
4949 gfc_init_block (&block
);
4951 /* Compare with the current limit. */
4952 gfc_init_se (&arrayse
, NULL
);
4953 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4954 arrayse
.ss
= arrayss
;
4955 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4956 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4958 gfc_init_se (&backse
, NULL
);
4959 gfc_conv_expr_val (&backse
, backexpr
);
4960 gfc_add_block_to_block (&block
, &backse
.pre
);
4962 /* We do the following if this is a more extreme value. */
4963 gfc_start_block (&ifblock
);
4965 /* Assign the value to the limit... */
4966 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4968 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
4970 stmtblock_t ifblock2
;
4973 gfc_start_block (&ifblock2
);
4974 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4975 loop
.loopvar
[0], offset
);
4976 gfc_add_modify (&ifblock2
, pos
, tmp
);
4977 ifbody2
= gfc_finish_block (&ifblock2
);
4978 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pos
,
4979 gfc_index_zero_node
);
4980 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
4981 build_empty_stmt (input_location
));
4982 gfc_add_expr_to_block (&block
, tmp
);
4985 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4986 loop
.loopvar
[0], offset
);
4987 gfc_add_modify (&ifblock
, pos
, tmp
);
4990 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
4992 ifbody
= gfc_finish_block (&ifblock
);
4994 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
4997 cond
= fold_build2_loc (input_location
,
4998 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4999 logical_type_node
, arrayse
.expr
, limit
);
5002 tree ifbody2
, elsebody2
;
5004 /* We switch to > or >= depending on the value of the BACK argument. */
5005 cond
= gfc_create_var (logical_type_node
, "cond");
5007 gfc_start_block (&ifblock
);
5008 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5009 logical_type_node
, arrayse
.expr
, limit
);
5011 gfc_add_modify (&ifblock
, cond
, b_if
);
5012 ifbody2
= gfc_finish_block (&ifblock
);
5014 gfc_start_block (&elseblock
);
5015 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5016 arrayse
.expr
, limit
);
5018 gfc_add_modify (&elseblock
, cond
, b_else
);
5019 elsebody2
= gfc_finish_block (&elseblock
);
5021 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5022 backse
.expr
, ifbody2
, elsebody2
);
5024 gfc_add_expr_to_block (&block
, tmp
);
5027 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5028 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
5029 build_empty_stmt (input_location
));
5031 gfc_add_expr_to_block (&block
, ifbody
);
5035 /* We enclose the above in if (mask) {...}. */
5036 tmp
= gfc_finish_block (&block
);
5038 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5039 build_empty_stmt (input_location
));
5042 tmp
= gfc_finish_block (&block
);
5043 gfc_add_expr_to_block (&body
, tmp
);
5047 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5049 if (HONOR_NANS (DECL_MODE (limit
)))
5051 if (nonempty
!= NULL
)
5053 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
5054 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
5055 build_empty_stmt (input_location
));
5056 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
5060 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
5061 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
5063 /* If we have a mask, only check this element if the mask is set. */
5066 gfc_init_se (&maskse
, NULL
);
5067 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5069 gfc_conv_expr_val (&maskse
, maskexpr
);
5070 gfc_add_block_to_block (&body
, &maskse
.pre
);
5072 gfc_start_block (&block
);
5075 gfc_init_block (&block
);
5077 /* Compare with the current limit. */
5078 gfc_init_se (&arrayse
, NULL
);
5079 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5080 arrayse
.ss
= arrayss
;
5081 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5082 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5084 /* We do the following if this is a more extreme value. */
5085 gfc_start_block (&ifblock
);
5087 /* Assign the value to the limit... */
5088 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5090 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
5091 loop
.loopvar
[0], offset
);
5092 gfc_add_modify (&ifblock
, pos
, tmp
);
5094 ifbody
= gfc_finish_block (&ifblock
);
5096 /* We switch to > or >= depending on the value of the BACK argument. */
5098 tree ifbody2
, elsebody2
;
5100 cond
= gfc_create_var (logical_type_node
, "cond");
5102 gfc_start_block (&ifblock
);
5103 b_if
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5104 logical_type_node
, arrayse
.expr
, limit
);
5106 gfc_add_modify (&ifblock
, cond
, b_if
);
5107 ifbody2
= gfc_finish_block (&ifblock
);
5109 gfc_start_block (&elseblock
);
5110 b_else
= fold_build2_loc (input_location
, op
, logical_type_node
,
5111 arrayse
.expr
, limit
);
5113 gfc_add_modify (&elseblock
, cond
, b_else
);
5114 elsebody2
= gfc_finish_block (&elseblock
);
5116 tmp
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
,
5117 backse
.expr
, ifbody2
, elsebody2
);
5120 gfc_add_expr_to_block (&block
, tmp
);
5121 cond
= gfc_unlikely (cond
, PRED_BUILTIN_EXPECT
);
5122 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
5123 build_empty_stmt (input_location
));
5125 gfc_add_expr_to_block (&block
, tmp
);
5129 /* We enclose the above in if (mask) {...}. */
5130 tmp
= gfc_finish_block (&block
);
5132 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5133 build_empty_stmt (input_location
));
5136 tmp
= gfc_finish_block (&block
);
5137 gfc_add_expr_to_block (&body
, tmp
);
5138 /* Avoid initializing loopvar[0] again, it should be left where
5139 it finished by the first loop. */
5140 loop
.from
[0] = loop
.loopvar
[0];
5143 gfc_trans_scalarizing_loops (&loop
, &body
);
5146 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
5148 /* For a scalar mask, enclose the loop in an if statement. */
5149 if (maskexpr
&& maskss
== NULL
)
5151 gfc_init_se (&maskse
, NULL
);
5152 gfc_conv_expr_val (&maskse
, maskexpr
);
5153 gfc_init_block (&block
);
5154 gfc_add_block_to_block (&block
, &loop
.pre
);
5155 gfc_add_block_to_block (&block
, &loop
.post
);
5156 tmp
= gfc_finish_block (&block
);
5158 /* For the else part of the scalar mask, just initialize
5159 the pos variable the same way as above. */
5161 gfc_init_block (&elseblock
);
5162 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
5163 elsetmp
= gfc_finish_block (&elseblock
);
5165 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
5166 gfc_add_expr_to_block (&block
, tmp
);
5167 gfc_add_block_to_block (&se
->pre
, &block
);
5171 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5172 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5174 gfc_cleanup_loop (&loop
);
5176 se
->expr
= convert (type
, pos
);
5179 /* Emit code for minval or maxval intrinsic. There are many different cases
5180 we need to handle. For performance reasons we sometimes create two
5181 loops instead of one, where the second one is much simpler.
5182 Examples for minval intrinsic:
5183 1) Result is an array, a call is generated
5184 2) Array mask is used and NaNs need to be supported, rank 1:
5189 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
5192 limit = nonempty ? NaN : huge (limit);
5194 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
5195 3) NaNs need to be supported, but it is known at compile time or cheaply
5196 at runtime whether array is nonempty or not, rank 1:
5199 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
5200 limit = (from <= to) ? NaN : huge (limit);
5202 while (S <= to) { limit = min (a[S], limit); S++; }
5203 4) Array mask is used and NaNs need to be supported, rank > 1:
5212 if (fast) limit = min (a[S1][S2], limit);
5215 if (a[S1][S2] <= limit) {
5226 limit = nonempty ? NaN : huge (limit);
5227 5) NaNs need to be supported, but it is known at compile time or cheaply
5228 at runtime whether array is nonempty or not, rank > 1:
5235 if (fast) limit = min (a[S1][S2], limit);
5237 if (a[S1][S2] <= limit) {
5247 limit = (nonempty_array) ? NaN : huge (limit);
5248 6) NaNs aren't supported, but infinities are. Array mask is used:
5253 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
5256 limit = nonempty ? limit : huge (limit);
5257 7) Same without array mask:
5260 while (S <= to) { limit = min (a[S], limit); S++; }
5261 limit = (from <= to) ? limit : huge (limit);
5262 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
5263 limit = huge (limit);
5265 while (S <= to) { limit = min (a[S], limit); S++); }
5267 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
5268 with array mask instead).
5269 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
5270 setting limit = huge (limit); in the else branch. */
5273 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5283 tree huge_cst
= NULL
, nan_cst
= NULL
;
5285 stmtblock_t block
, block2
;
5287 gfc_actual_arglist
*actual
;
5292 gfc_expr
*arrayexpr
;
5298 gfc_conv_intrinsic_funcall (se
, expr
);
5302 actual
= expr
->value
.function
.actual
;
5303 arrayexpr
= actual
->expr
;
5305 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5307 gfc_actual_arglist
*a2
, *a3
;
5308 a2
= actual
->next
; /* dim */
5309 a3
= a2
->next
; /* mask */
5310 if (a2
->expr
== NULL
|| expr
->rank
== 0)
5312 if (a3
->expr
== NULL
)
5313 actual
->next
= NULL
;
5319 gfc_free_actual_arglist (a2
);
5322 if (a3
->expr
== NULL
)
5325 gfc_free_actual_arglist (a3
);
5327 gfc_conv_intrinsic_funcall (se
, expr
);
5330 type
= gfc_typenode_for_spec (&expr
->ts
);
5331 /* Initialize the result. */
5332 limit
= gfc_create_var (type
, "limit");
5333 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
5334 switch (expr
->ts
.type
)
5337 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
5339 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5341 REAL_VALUE_TYPE real
;
5343 tmp
= build_real (type
, real
);
5347 if (HONOR_NANS (DECL_MODE (limit
)))
5348 nan_cst
= gfc_build_nan (type
, "");
5352 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
5359 /* We start with the most negative possible value for MAXVAL, and the most
5360 positive possible value for MINVAL. The most negative possible value is
5361 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5362 possible value is HUGE in both cases. */
5365 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5367 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
5368 TREE_TYPE (huge_cst
), huge_cst
);
5371 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
5372 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5373 tmp
, build_int_cst (type
, 1));
5375 gfc_add_modify (&se
->pre
, limit
, tmp
);
5377 /* Walk the arguments. */
5378 arrayss
= gfc_walk_expr (arrayexpr
);
5379 gcc_assert (arrayss
!= gfc_ss_terminator
);
5381 actual
= actual
->next
->next
;
5382 gcc_assert (actual
);
5383 maskexpr
= actual
->expr
;
5385 if (maskexpr
&& maskexpr
->rank
!= 0)
5387 maskss
= gfc_walk_expr (maskexpr
);
5388 gcc_assert (maskss
!= gfc_ss_terminator
);
5393 if (gfc_array_size (arrayexpr
, &asize
))
5395 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5397 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5398 logical_type_node
, nonempty
,
5399 gfc_index_zero_node
);
5404 /* Initialize the scalarizer. */
5405 gfc_init_loopinfo (&loop
);
5406 gfc_add_ss_to_loop (&loop
, arrayss
);
5408 gfc_add_ss_to_loop (&loop
, maskss
);
5410 /* Initialize the loop. */
5411 gfc_conv_ss_startstride (&loop
);
5413 /* The code generated can have more than one loop in sequence (see the
5414 comment at the function header). This doesn't work well with the
5415 scalarizer, which changes arrays' offset when the scalarization loops
5416 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5417 are currently inlined in the scalar case only. As there is no dependency
5418 to care about in that case, there is no temporary, so that we can use the
5419 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5420 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5421 gfc_trans_scalarized_loop_boundary even later to restore offset.
5422 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5423 should eventually go away. We could either create two loops properly,
5424 or find another way to save/restore the array offsets between the two
5425 loops (without conflicting with temporary management), or use a single
5426 loop minmaxval implementation. See PR 31067. */
5427 loop
.temp_dim
= loop
.dimen
;
5428 gfc_conv_loop_setup (&loop
, &expr
->where
);
5430 if (nonempty
== NULL
&& maskss
== NULL
5431 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5432 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5433 loop
.from
[0], loop
.to
[0]);
5434 nonempty_var
= NULL
;
5435 if (nonempty
== NULL
5436 && (HONOR_INFINITIES (DECL_MODE (limit
))
5437 || HONOR_NANS (DECL_MODE (limit
))))
5439 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
5440 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
5441 nonempty
= nonempty_var
;
5445 if (HONOR_NANS (DECL_MODE (limit
)))
5447 if (loop
.dimen
== 1)
5449 lab
= gfc_build_label_decl (NULL_TREE
);
5450 TREE_USED (lab
) = 1;
5454 fast
= gfc_create_var (logical_type_node
, "fast");
5455 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
5459 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5461 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5462 /* Generate the loop body. */
5463 gfc_start_scalarized_body (&loop
, &body
);
5465 /* If we have a mask, only add this element if the mask is set. */
5468 gfc_init_se (&maskse
, NULL
);
5469 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5471 gfc_conv_expr_val (&maskse
, maskexpr
);
5472 gfc_add_block_to_block (&body
, &maskse
.pre
);
5474 gfc_start_block (&block
);
5477 gfc_init_block (&block
);
5479 /* Compare with the current limit. */
5480 gfc_init_se (&arrayse
, NULL
);
5481 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5482 arrayse
.ss
= arrayss
;
5483 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5484 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5486 gfc_init_block (&block2
);
5489 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
5491 if (HONOR_NANS (DECL_MODE (limit
)))
5493 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5494 logical_type_node
, arrayse
.expr
, limit
);
5496 ifbody
= build1_v (GOTO_EXPR
, lab
);
5499 stmtblock_t ifblock
;
5501 gfc_init_block (&ifblock
);
5502 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5503 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
5504 ifbody
= gfc_finish_block (&ifblock
);
5506 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5507 build_empty_stmt (input_location
));
5508 gfc_add_expr_to_block (&block2
, tmp
);
5512 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5514 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5516 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5517 arrayse
.expr
, limit
);
5518 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5519 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5520 build_empty_stmt (input_location
));
5521 gfc_add_expr_to_block (&block2
, tmp
);
5525 tmp
= fold_build2_loc (input_location
,
5526 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5527 type
, arrayse
.expr
, limit
);
5528 gfc_add_modify (&block2
, limit
, tmp
);
5534 tree elsebody
= gfc_finish_block (&block2
);
5536 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5538 if (HONOR_NANS (DECL_MODE (limit
))
5539 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5541 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5542 arrayse
.expr
, limit
);
5543 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5544 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5545 build_empty_stmt (input_location
));
5549 tmp
= fold_build2_loc (input_location
,
5550 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5551 type
, arrayse
.expr
, limit
);
5552 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5554 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5555 gfc_add_expr_to_block (&block
, tmp
);
5558 gfc_add_block_to_block (&block
, &block2
);
5560 gfc_add_block_to_block (&block
, &arrayse
.post
);
5562 tmp
= gfc_finish_block (&block
);
5564 /* We enclose the above in if (mask) {...}. */
5565 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5566 build_empty_stmt (input_location
));
5567 gfc_add_expr_to_block (&body
, tmp
);
5571 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5573 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5575 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
5576 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
5578 /* If we have a mask, only add this element if the mask is set. */
5581 gfc_init_se (&maskse
, NULL
);
5582 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5584 gfc_conv_expr_val (&maskse
, maskexpr
);
5585 gfc_add_block_to_block (&body
, &maskse
.pre
);
5587 gfc_start_block (&block
);
5590 gfc_init_block (&block
);
5592 /* Compare with the current limit. */
5593 gfc_init_se (&arrayse
, NULL
);
5594 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5595 arrayse
.ss
= arrayss
;
5596 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5597 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5599 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5601 if (HONOR_NANS (DECL_MODE (limit
))
5602 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5604 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5605 arrayse
.expr
, limit
);
5606 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5607 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5608 build_empty_stmt (input_location
));
5609 gfc_add_expr_to_block (&block
, tmp
);
5613 tmp
= fold_build2_loc (input_location
,
5614 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5615 type
, arrayse
.expr
, limit
);
5616 gfc_add_modify (&block
, limit
, tmp
);
5619 gfc_add_block_to_block (&block
, &arrayse
.post
);
5621 tmp
= gfc_finish_block (&block
);
5623 /* We enclose the above in if (mask) {...}. */
5624 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5625 build_empty_stmt (input_location
));
5626 gfc_add_expr_to_block (&body
, tmp
);
5627 /* Avoid initializing loopvar[0] again, it should be left where
5628 it finished by the first loop. */
5629 loop
.from
[0] = loop
.loopvar
[0];
5631 gfc_trans_scalarizing_loops (&loop
, &body
);
5635 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5637 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5638 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
5640 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5642 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
5644 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
5646 gfc_add_modify (&loop
.pre
, limit
, tmp
);
5649 /* For a scalar mask, enclose the loop in an if statement. */
5650 if (maskexpr
&& maskss
== NULL
)
5654 gfc_init_se (&maskse
, NULL
);
5655 gfc_conv_expr_val (&maskse
, maskexpr
);
5656 gfc_init_block (&block
);
5657 gfc_add_block_to_block (&block
, &loop
.pre
);
5658 gfc_add_block_to_block (&block
, &loop
.post
);
5659 tmp
= gfc_finish_block (&block
);
5661 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5662 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
5664 else_stmt
= build_empty_stmt (input_location
);
5665 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
5666 gfc_add_expr_to_block (&block
, tmp
);
5667 gfc_add_block_to_block (&se
->pre
, &block
);
5671 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5672 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5675 gfc_cleanup_loop (&loop
);
5680 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5682 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
5688 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5689 type
= TREE_TYPE (args
[0]);
5691 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5692 build_int_cst (type
, 1), args
[1]);
5693 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
5694 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
5695 build_int_cst (type
, 0));
5696 type
= gfc_typenode_for_spec (&expr
->ts
);
5697 se
->expr
= convert (type
, tmp
);
5701 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5703 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5707 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5709 /* Convert both arguments to the unsigned type of the same size. */
5710 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
5711 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
5713 /* If they have unequal type size, convert to the larger one. */
5714 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
5715 > TYPE_PRECISION (TREE_TYPE (args
[1])))
5716 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
5717 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
5718 > TYPE_PRECISION (TREE_TYPE (args
[0])))
5719 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
5721 /* Now, we compare them. */
5722 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
5727 /* Generate code to perform the specified operation. */
5729 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5733 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5734 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
5740 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
5744 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5745 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5746 TREE_TYPE (arg
), arg
);
5749 /* Set or clear a single bit. */
5751 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
5758 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5759 type
= TREE_TYPE (args
[0]);
5761 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5762 build_int_cst (type
, 1), args
[1]);
5768 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
5770 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
5773 /* Extract a sequence of bits.
5774 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5776 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
5783 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5784 type
= TREE_TYPE (args
[0]);
5786 mask
= build_int_cst (type
, -1);
5787 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
5788 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
5790 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
5792 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
5796 gfc_conv_intrinsic_shape (gfc_se
*se
, gfc_expr
*expr
)
5798 gfc_actual_arglist
*s
, *k
;
5801 /* Remove the KIND argument, if present. */
5802 s
= expr
->value
.function
.actual
;
5808 gfc_conv_intrinsic_funcall (se
, expr
);
5812 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
5815 tree args
[2], type
, num_bits
, cond
;
5817 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5819 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5820 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5821 type
= TREE_TYPE (args
[0]);
5824 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
5826 gcc_assert (right_shift
);
5828 se
->expr
= fold_build2_loc (input_location
,
5829 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
5830 TREE_TYPE (args
[0]), args
[0], args
[1]);
5833 se
->expr
= fold_convert (type
, se
->expr
);
5835 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5836 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5838 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5839 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
5842 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5843 build_int_cst (type
, 0), se
->expr
);
5846 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5848 : ((shift >= 0) ? i << shift : i >> -shift)
5849 where all shifts are logical shifts. */
5851 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
5863 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5865 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5866 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5868 type
= TREE_TYPE (args
[0]);
5869 utype
= unsigned_type_for (type
);
5871 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
5874 /* Left shift if positive. */
5875 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
5877 /* Right shift if negative.
5878 We convert to an unsigned type because we want a logical shift.
5879 The standard doesn't define the case of shifting negative
5880 numbers, and we try to be compatible with other compilers, most
5881 notably g77, here. */
5882 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
5883 utype
, convert (utype
, args
[0]), width
));
5885 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
5886 build_int_cst (TREE_TYPE (args
[1]), 0));
5887 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
5889 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5890 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5892 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5893 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
5895 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5896 build_int_cst (type
, 0), tmp
);
5900 /* Circular shift. AKA rotate or barrel shift. */
5903 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
5911 unsigned int num_args
;
5913 num_args
= gfc_intrinsic_argument_list_length (expr
);
5914 args
= XALLOCAVEC (tree
, num_args
);
5916 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5920 /* Use a library function for the 3 parameter version. */
5921 tree int4type
= gfc_get_int_type (4);
5923 type
= TREE_TYPE (args
[0]);
5924 /* We convert the first argument to at least 4 bytes, and
5925 convert back afterwards. This removes the need for library
5926 functions for all argument sizes, and function will be
5927 aligned to at least 32 bits, so there's no loss. */
5928 if (expr
->ts
.kind
< 4)
5929 args
[0] = convert (int4type
, args
[0]);
5931 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5932 need loads of library functions. They cannot have values >
5933 BIT_SIZE (I) so the conversion is safe. */
5934 args
[1] = convert (int4type
, args
[1]);
5935 args
[2] = convert (int4type
, args
[2]);
5937 switch (expr
->ts
.kind
)
5942 tmp
= gfor_fndecl_math_ishftc4
;
5945 tmp
= gfor_fndecl_math_ishftc8
;
5948 tmp
= gfor_fndecl_math_ishftc16
;
5953 se
->expr
= build_call_expr_loc (input_location
,
5954 tmp
, 3, args
[0], args
[1], args
[2]);
5955 /* Convert the result back to the original type, if we extended
5956 the first argument's width above. */
5957 if (expr
->ts
.kind
< 4)
5958 se
->expr
= convert (type
, se
->expr
);
5962 type
= TREE_TYPE (args
[0]);
5964 /* Evaluate arguments only once. */
5965 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5966 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5968 /* Rotate left if positive. */
5969 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
5971 /* Rotate right if negative. */
5972 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
5974 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
5976 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
5977 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
5979 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
5981 /* Do nothing if shift == 0. */
5982 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
5984 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
5989 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5990 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5992 The conditional expression is necessary because the result of LEADZ(0)
5993 is defined, but the result of __builtin_clz(0) is undefined for most
5996 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5997 difference in bit size between the argument of LEADZ and the C int. */
6000 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
6012 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6013 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6015 /* Which variant of __builtin_clz* should we call? */
6016 if (argsize
<= INT_TYPE_SIZE
)
6018 arg_type
= unsigned_type_node
;
6019 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
6021 else if (argsize
<= LONG_TYPE_SIZE
)
6023 arg_type
= long_unsigned_type_node
;
6024 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
6026 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6028 arg_type
= long_long_unsigned_type_node
;
6029 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6033 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6034 arg_type
= gfc_build_uint_type (argsize
);
6038 /* Convert the actual argument twice: first, to the unsigned type of the
6039 same size; then, to the proper argument type for the built-in
6040 function. But the return type is of the default INTEGER kind. */
6041 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6042 arg
= fold_convert (arg_type
, arg
);
6043 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6044 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6046 /* Compute LEADZ for the case i .ne. 0. */
6049 s
= TYPE_PRECISION (arg_type
) - argsize
;
6050 tmp
= fold_convert (result_type
,
6051 build_call_expr_loc (input_location
, func
,
6053 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
6054 tmp
, build_int_cst (result_type
, s
));
6058 /* We end up here if the argument type is larger than 'long long'.
6059 We generate this code:
6061 if (x & (ULL_MAX << ULL_SIZE) != 0)
6062 return clzll ((unsigned long long) (x >> ULLSIZE));
6064 return ULL_SIZE + clzll ((unsigned long long) x);
6065 where ULL_MAX is the largest value that a ULL_MAX can hold
6066 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6067 is the bit-size of the long long type (64 in this example). */
6068 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
6070 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
6071 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6072 long_long_unsigned_type_node
,
6073 build_int_cst (long_long_unsigned_type_node
,
6076 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
6077 fold_convert (arg_type
, ullmax
), ullsize
);
6078 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
6080 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6081 cond
, build_int_cst (arg_type
, 0));
6083 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
6085 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
6086 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6087 tmp1
= fold_convert (result_type
,
6088 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
6090 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
6091 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
6092 tmp2
= fold_convert (result_type
,
6093 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
6094 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6097 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
6101 /* Build BIT_SIZE. */
6102 bit_size
= build_int_cst (result_type
, argsize
);
6104 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6105 arg
, build_int_cst (arg_type
, 0));
6106 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
6111 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
6113 The conditional expression is necessary because the result of TRAILZ(0)
6114 is defined, but the result of __builtin_ctz(0) is undefined for most
6118 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
6129 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6130 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6132 /* Which variant of __builtin_ctz* should we call? */
6133 if (argsize
<= INT_TYPE_SIZE
)
6135 arg_type
= unsigned_type_node
;
6136 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
6138 else if (argsize
<= LONG_TYPE_SIZE
)
6140 arg_type
= long_unsigned_type_node
;
6141 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
6143 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6145 arg_type
= long_long_unsigned_type_node
;
6146 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6150 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6151 arg_type
= gfc_build_uint_type (argsize
);
6155 /* Convert the actual argument twice: first, to the unsigned type of the
6156 same size; then, to the proper argument type for the built-in
6157 function. But the return type is of the default INTEGER kind. */
6158 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6159 arg
= fold_convert (arg_type
, arg
);
6160 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6161 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6163 /* Compute TRAILZ for the case i .ne. 0. */
6165 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
6169 /* We end up here if the argument type is larger than 'long long'.
6170 We generate this code:
6172 if ((x & ULL_MAX) == 0)
6173 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
6175 return ctzll ((unsigned long long) x);
6177 where ULL_MAX is the largest value that a ULL_MAX can hold
6178 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6179 is the bit-size of the long long type (64 in this example). */
6180 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
6182 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
6183 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6184 long_long_unsigned_type_node
,
6185 build_int_cst (long_long_unsigned_type_node
, 0));
6187 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
6188 fold_convert (arg_type
, ullmax
));
6189 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
6190 build_int_cst (arg_type
, 0));
6192 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
6194 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
6195 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6196 tmp1
= fold_convert (result_type
,
6197 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
6198 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6201 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
6202 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6203 tmp2
= fold_convert (result_type
,
6204 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
6206 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
6210 /* Build BIT_SIZE. */
6211 bit_size
= build_int_cst (result_type
, argsize
);
6213 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6214 arg
, build_int_cst (arg_type
, 0));
6215 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
6219 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
6220 for types larger than "long long", we call the long long built-in for
6221 the lower and higher bits and combine the result. */
6224 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
6232 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6233 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6234 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6236 /* Which variant of the builtin should we call? */
6237 if (argsize
<= INT_TYPE_SIZE
)
6239 arg_type
= unsigned_type_node
;
6240 func
= builtin_decl_explicit (parity
6242 : BUILT_IN_POPCOUNT
);
6244 else if (argsize
<= LONG_TYPE_SIZE
)
6246 arg_type
= long_unsigned_type_node
;
6247 func
= builtin_decl_explicit (parity
6249 : BUILT_IN_POPCOUNTL
);
6251 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6253 arg_type
= long_long_unsigned_type_node
;
6254 func
= builtin_decl_explicit (parity
6256 : BUILT_IN_POPCOUNTLL
);
6260 /* Our argument type is larger than 'long long', which mean none
6261 of the POPCOUNT builtins covers it. We thus call the 'long long'
6262 variant multiple times, and add the results. */
6263 tree utype
, arg2
, call1
, call2
;
6265 /* For now, we only cover the case where argsize is twice as large
6267 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6269 func
= builtin_decl_explicit (parity
6271 : BUILT_IN_POPCOUNTLL
);
6273 /* Convert it to an integer, and store into a variable. */
6274 utype
= gfc_build_uint_type (argsize
);
6275 arg
= fold_convert (utype
, arg
);
6276 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6278 /* Call the builtin twice. */
6279 call1
= build_call_expr_loc (input_location
, func
, 1,
6280 fold_convert (long_long_unsigned_type_node
,
6283 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
6284 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
6285 call2
= build_call_expr_loc (input_location
, func
, 1,
6286 fold_convert (long_long_unsigned_type_node
,
6289 /* Combine the results. */
6291 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
6294 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6300 /* Convert the actual argument twice: first, to the unsigned type of the
6301 same size; then, to the proper argument type for the built-in
6303 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6304 arg
= fold_convert (arg_type
, arg
);
6306 se
->expr
= fold_convert (result_type
,
6307 build_call_expr_loc (input_location
, func
, 1, arg
));
6311 /* Process an intrinsic with unspecified argument-types that has an optional
6312 argument (which could be of type character), e.g. EOSHIFT. For those, we
6313 need to append the string length of the optional argument if it is not
6314 present and the type is really character.
6315 primary specifies the position (starting at 1) of the non-optional argument
6316 specifying the type and optional gives the position of the optional
6317 argument in the arglist. */
6320 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
6321 unsigned primary
, unsigned optional
)
6323 gfc_actual_arglist
* prim_arg
;
6324 gfc_actual_arglist
* opt_arg
;
6326 gfc_actual_arglist
* arg
;
6328 vec
<tree
, va_gc
> *append_args
;
6330 /* Find the two arguments given as position. */
6334 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
6338 if (cur_pos
== primary
)
6340 if (cur_pos
== optional
)
6343 if (cur_pos
>= primary
&& cur_pos
>= optional
)
6346 gcc_assert (prim_arg
);
6347 gcc_assert (prim_arg
->expr
);
6348 gcc_assert (opt_arg
);
6350 /* If we do have type CHARACTER and the optional argument is really absent,
6351 append a dummy 0 as string length. */
6353 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
6357 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
6358 vec_alloc (append_args
, 1);
6359 append_args
->quick_push (dummy
);
6362 /* Build the call itself. */
6363 gcc_assert (!se
->ignore_optional
);
6364 sym
= gfc_get_symbol_for_expr (expr
, false);
6365 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6367 gfc_free_symbol (sym
);
6370 /* The length of a character string. */
6372 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
6381 gcc_assert (!se
->ss
);
6383 arg
= expr
->value
.function
.actual
->expr
;
6385 type
= gfc_typenode_for_spec (&expr
->ts
);
6386 switch (arg
->expr_type
)
6389 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
6393 /* Obtain the string length from the function used by
6394 trans-array.c(gfc_trans_array_constructor). */
6396 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
6400 if (arg
->ref
== NULL
6401 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6403 /* This doesn't catch all cases.
6404 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6405 and the surrounding thread. */
6406 sym
= arg
->symtree
->n
.sym
;
6407 decl
= gfc_get_symbol_decl (sym
);
6408 if (decl
== current_function_decl
&& sym
->attr
.function
6409 && (sym
->result
== sym
))
6410 decl
= gfc_get_fake_result_decl (sym
, 0);
6412 len
= sym
->ts
.u
.cl
->backend_decl
;
6420 /* Anybody stupid enough to do this deserves inefficient code. */
6421 gfc_init_se (&argse
, se
);
6423 gfc_conv_expr (&argse
, arg
);
6425 gfc_conv_expr_descriptor (&argse
, arg
);
6426 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6427 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6428 len
= argse
.string_length
;
6431 se
->expr
= convert (type
, len
);
6434 /* The length of a character string not including trailing blanks. */
6436 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6438 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6439 tree args
[2], type
, fndecl
;
6441 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6442 type
= gfc_typenode_for_spec (&expr
->ts
);
6445 fndecl
= gfor_fndecl_string_len_trim
;
6447 fndecl
= gfor_fndecl_string_len_trim_char4
;
6451 se
->expr
= build_call_expr_loc (input_location
,
6452 fndecl
, 2, args
[0], args
[1]);
6453 se
->expr
= convert (type
, se
->expr
);
6457 /* Returns the starting position of a substring within a string. */
6460 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6463 tree logical4_type_node
= gfc_get_logical_type (4);
6467 unsigned int num_args
;
6469 args
= XALLOCAVEC (tree
, 5);
6471 /* Get number of arguments; characters count double due to the
6472 string length argument. Kind= is not passed to the library
6473 and thus ignored. */
6474 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6479 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6480 type
= gfc_typenode_for_spec (&expr
->ts
);
6483 args
[4] = build_int_cst (logical4_type_node
, 0);
6485 args
[4] = convert (logical4_type_node
, args
[4]);
6487 fndecl
= build_addr (function
);
6488 se
->expr
= build_call_array_loc (input_location
,
6489 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6491 se
->expr
= convert (type
, se
->expr
);
6495 /* The ascii value for a single character. */
6497 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6499 tree args
[3], type
, pchartype
;
6502 nargs
= gfc_intrinsic_argument_list_length (expr
);
6503 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6504 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6505 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6506 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6507 type
= gfc_typenode_for_spec (&expr
->ts
);
6509 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6511 se
->expr
= convert (type
, se
->expr
);
6515 /* Intrinsic ISNAN calls __builtin_isnan. */
6518 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6522 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6523 se
->expr
= build_call_expr_loc (input_location
,
6524 builtin_decl_explicit (BUILT_IN_ISNAN
),
6526 STRIP_TYPE_NOPS (se
->expr
);
6527 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6531 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6532 their argument against a constant integer value. */
6535 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6539 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6540 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6541 gfc_typenode_for_spec (&expr
->ts
),
6542 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6547 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6550 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
6558 unsigned int num_args
;
6560 num_args
= gfc_intrinsic_argument_list_length (expr
);
6561 args
= XALLOCAVEC (tree
, num_args
);
6563 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6564 if (expr
->ts
.type
!= BT_CHARACTER
)
6572 /* We do the same as in the non-character case, but the argument
6573 list is different because of the string length arguments. We
6574 also have to set the string length for the result. */
6581 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
6583 se
->string_length
= len
;
6585 type
= TREE_TYPE (tsource
);
6586 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
6587 fold_convert (type
, fsource
));
6591 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6594 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
6596 tree args
[3], mask
, type
;
6598 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6599 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
6601 type
= TREE_TYPE (args
[0]);
6602 gcc_assert (TREE_TYPE (args
[1]) == type
);
6603 gcc_assert (TREE_TYPE (mask
) == type
);
6605 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
6606 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
6607 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6609 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
6614 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6615 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6618 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
6620 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
6623 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6624 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6626 type
= gfc_get_int_type (expr
->ts
.kind
);
6627 utype
= unsigned_type_for (type
);
6629 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
6630 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
6632 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
6633 build_int_cst (utype
, 0));
6637 /* Left-justified mask. */
6638 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
6640 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6641 fold_convert (utype
, res
));
6643 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6644 smaller than type width. */
6645 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6646 build_int_cst (TREE_TYPE (arg
), 0));
6647 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
6648 build_int_cst (utype
, 0), res
);
6652 /* Right-justified mask. */
6653 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6654 fold_convert (utype
, arg
));
6655 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
6657 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6658 strictly smaller than type width. */
6659 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6661 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
6662 cond
, allones
, res
);
6665 se
->expr
= fold_convert (type
, res
);
6669 /* FRACTION (s) is translated into:
6670 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6672 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
6674 tree arg
, type
, tmp
, res
, frexp
, cond
;
6676 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6678 type
= gfc_typenode_for_spec (&expr
->ts
);
6679 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6680 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6682 cond
= build_call_expr_loc (input_location
,
6683 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6686 tmp
= gfc_create_var (integer_type_node
, NULL
);
6687 res
= build_call_expr_loc (input_location
, frexp
, 2,
6688 fold_convert (type
, arg
),
6689 gfc_build_addr_expr (NULL_TREE
, tmp
));
6690 res
= fold_convert (type
, res
);
6692 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
6693 cond
, res
, gfc_build_nan (type
, ""));
6697 /* NEAREST (s, dir) is translated into
6698 tmp = copysign (HUGE_VAL, dir);
6699 return nextafter (s, tmp);
6702 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
6704 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
6706 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
6707 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
6709 type
= gfc_typenode_for_spec (&expr
->ts
);
6710 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6712 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
6713 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
6714 fold_convert (type
, args
[1]));
6715 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
6716 fold_convert (type
, args
[0]), tmp
);
6717 se
->expr
= fold_convert (type
, se
->expr
);
6721 /* SPACING (s) is translated into
6731 e = MAX_EXPR (e, emin);
6732 res = scalbn (1., e);
6736 where prec is the precision of s, gfc_real_kinds[k].digits,
6737 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6738 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6741 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
6743 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
6744 tree cond
, nan
, tmp
, frexp
, scalbn
;
6748 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6749 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
6750 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
6751 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
6753 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6754 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6756 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6757 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6759 type
= gfc_typenode_for_spec (&expr
->ts
);
6760 e
= gfc_create_var (integer_type_node
, NULL
);
6761 res
= gfc_create_var (type
, NULL
);
6764 /* Build the block for s /= 0. */
6765 gfc_start_block (&block
);
6766 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6767 gfc_build_addr_expr (NULL_TREE
, e
));
6768 gfc_add_expr_to_block (&block
, tmp
);
6770 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
6772 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
6773 integer_type_node
, tmp
, emin
));
6775 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
6776 build_real_from_int_cst (type
, integer_one_node
), e
);
6777 gfc_add_modify (&block
, res
, tmp
);
6779 /* Finish by building the IF statement for value zero. */
6780 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6781 build_real_from_int_cst (type
, integer_zero_node
));
6782 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
6783 gfc_finish_block (&block
));
6785 /* And deal with infinities and NaNs. */
6786 cond
= build_call_expr_loc (input_location
,
6787 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6789 nan
= gfc_build_nan (type
, "");
6790 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
6792 gfc_add_expr_to_block (&se
->pre
, tmp
);
6797 /* RRSPACING (s) is translated into
6806 x = scalbn (x, precision - e);
6813 where precision is gfc_real_kinds[k].digits. */
6816 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
6818 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
6822 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6823 prec
= gfc_real_kinds
[k
].digits
;
6825 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6826 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6827 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
6829 type
= gfc_typenode_for_spec (&expr
->ts
);
6830 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6831 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6833 e
= gfc_create_var (integer_type_node
, NULL
);
6834 x
= gfc_create_var (type
, NULL
);
6835 gfc_add_modify (&se
->pre
, x
,
6836 build_call_expr_loc (input_location
, fabs
, 1, arg
));
6839 gfc_start_block (&block
);
6840 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6841 gfc_build_addr_expr (NULL_TREE
, e
));
6842 gfc_add_expr_to_block (&block
, tmp
);
6844 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
6845 build_int_cst (integer_type_node
, prec
), e
);
6846 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
6847 gfc_add_modify (&block
, x
, tmp
);
6848 stmt
= gfc_finish_block (&block
);
6851 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
6852 build_real_from_int_cst (type
, integer_zero_node
));
6853 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
6855 /* And deal with infinities and NaNs. */
6856 cond
= build_call_expr_loc (input_location
,
6857 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6859 nan
= gfc_build_nan (type
, "");
6860 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
6862 gfc_add_expr_to_block (&se
->pre
, tmp
);
6863 se
->expr
= fold_convert (type
, x
);
6867 /* SCALE (s, i) is translated into scalbn (s, i). */
6869 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
6871 tree args
[2], type
, scalbn
;
6873 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6875 type
= gfc_typenode_for_spec (&expr
->ts
);
6876 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6877 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
6878 fold_convert (type
, args
[0]),
6879 fold_convert (integer_type_node
, args
[1]));
6880 se
->expr
= fold_convert (type
, se
->expr
);
6884 /* SET_EXPONENT (s, i) is translated into
6885 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6887 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
6889 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
6891 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6892 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6894 type
= gfc_typenode_for_spec (&expr
->ts
);
6895 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6896 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6898 tmp
= gfc_create_var (integer_type_node
, NULL
);
6899 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
6900 fold_convert (type
, args
[0]),
6901 gfc_build_addr_expr (NULL_TREE
, tmp
));
6902 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
6903 fold_convert (integer_type_node
, args
[1]));
6904 res
= fold_convert (type
, res
);
6906 /* Call to isfinite */
6907 cond
= build_call_expr_loc (input_location
,
6908 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6910 nan
= gfc_build_nan (type
, "");
6912 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6918 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
6920 gfc_actual_arglist
*actual
;
6927 gfc_init_se (&argse
, NULL
);
6928 actual
= expr
->value
.function
.actual
;
6930 if (actual
->expr
->ts
.type
== BT_CLASS
)
6931 gfc_add_class_array_ref (actual
->expr
);
6933 argse
.data_not_needed
= 1;
6934 if (gfc_is_class_array_function (actual
->expr
))
6936 /* For functions that return a class array conv_expr_descriptor is not
6937 able to get the descriptor right. Therefore this special case. */
6938 gfc_conv_expr_reference (&argse
, actual
->expr
);
6939 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6940 gfc_class_data_get (argse
.expr
));
6944 argse
.want_pointer
= 1;
6945 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
6947 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6948 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6949 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
6951 /* Build the call to size0. */
6952 fncall0
= build_call_expr_loc (input_location
,
6953 gfor_fndecl_size0
, 1, arg1
);
6955 actual
= actual
->next
;
6959 gfc_init_se (&argse
, NULL
);
6960 gfc_conv_expr_type (&argse
, actual
->expr
,
6961 gfc_array_index_type
);
6962 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6964 /* Unusually, for an intrinsic, size does not exclude
6965 an optional arg2, so we must test for it. */
6966 if (actual
->expr
->expr_type
== EXPR_VARIABLE
6967 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
6968 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
6971 /* Build the call to size1. */
6972 fncall1
= build_call_expr_loc (input_location
,
6973 gfor_fndecl_size1
, 2,
6976 gfc_init_se (&argse
, NULL
);
6977 argse
.want_pointer
= 1;
6978 argse
.data_not_needed
= 1;
6979 gfc_conv_expr (&argse
, actual
->expr
);
6980 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6981 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6982 argse
.expr
, null_pointer_node
);
6983 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6984 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
6985 pvoid_type_node
, tmp
, fncall1
, fncall0
);
6989 se
->expr
= NULL_TREE
;
6990 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6991 gfc_array_index_type
,
6992 argse
.expr
, gfc_index_one_node
);
6995 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
6997 argse
.expr
= gfc_index_zero_node
;
6998 se
->expr
= NULL_TREE
;
7003 if (se
->expr
== NULL_TREE
)
7005 tree ubound
, lbound
;
7007 arg1
= build_fold_indirect_ref_loc (input_location
,
7009 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
7010 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
7011 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
7012 gfc_array_index_type
, ubound
, lbound
);
7013 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
7014 gfc_array_index_type
,
7015 se
->expr
, gfc_index_one_node
);
7016 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
7017 gfc_array_index_type
, se
->expr
,
7018 gfc_index_zero_node
);
7021 type
= gfc_typenode_for_spec (&expr
->ts
);
7022 se
->expr
= convert (type
, se
->expr
);
7026 /* Helper function to compute the size of a character variable,
7027 excluding the terminating null characters. The result has
7028 gfc_array_index_type type. */
7031 size_of_string_in_bytes (int kind
, tree string_length
)
7034 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
7036 bytesize
= build_int_cst (gfc_array_index_type
,
7037 gfc_character_kinds
[i
].bit_size
/ 8);
7039 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7041 fold_convert (gfc_array_index_type
, string_length
));
7046 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
7058 gfc_init_se (&argse
, NULL
);
7059 arg
= expr
->value
.function
.actual
->expr
;
7061 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
7062 gfc_conv_expr_descriptor (&argse
, arg
);
7064 gfc_conv_expr_reference (&argse
, arg
);
7066 if (arg
->ts
.type
== BT_ASSUMED
)
7068 /* This only works if an array descriptor has been passed; thus, extract
7069 the size from the descriptor. */
7070 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
7071 == TYPE_PRECISION (size_type_node
));
7072 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
7073 tmp
= DECL_LANG_SPECIFIC (tmp
)
7074 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
7075 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
7076 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
7077 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7079 tmp
= gfc_conv_descriptor_dtype (tmp
);
7080 field
= gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
7081 GFC_DTYPE_ELEM_LEN
);
7082 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7083 tmp
, field
, NULL_TREE
);
7085 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
7087 else if (arg
->ts
.type
== BT_CLASS
)
7089 /* Conv_expr_descriptor returns a component_ref to _data component of the
7090 class object. The class object may be a non-pointer object, e.g.
7091 located on the stack, or a memory location pointed to, e.g. a
7092 parameter, i.e., an indirect_ref. */
7094 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
7095 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
7096 && GFC_DECL_CLASS (TREE_OPERAND (
7097 TREE_OPERAND (argse
.expr
, 0), 0)))
7098 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
7099 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
7100 else if (arg
->rank
> 0
7102 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
7103 /* The scalarizer added an additional temp. To get the class' vptr
7104 one has to look at the original backend_decl. */
7105 byte_size
= gfc_class_vtab_size_get (
7106 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
7108 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
7112 if (arg
->ts
.type
== BT_CHARACTER
)
7113 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
7117 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7120 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7121 byte_size
= fold_convert (gfc_array_index_type
,
7122 size_in_bytes (byte_size
));
7127 se
->expr
= byte_size
;
7130 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
7131 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
7133 if (arg
->rank
== -1)
7135 tree cond
, loop_var
, exit_label
;
7138 tmp
= fold_convert (gfc_array_index_type
,
7139 gfc_conv_descriptor_rank (argse
.expr
));
7140 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
7141 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
7142 exit_label
= gfc_build_label_decl (NULL_TREE
);
7149 source_bytes = source_bytes * array.dim[i].extent;
7153 gfc_start_block (&body
);
7154 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
7156 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7157 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7158 cond
, tmp
, build_empty_stmt (input_location
));
7159 gfc_add_expr_to_block (&body
, tmp
);
7161 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
7162 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
7163 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
7164 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7165 gfc_array_index_type
, tmp
, source_bytes
);
7166 gfc_add_modify (&body
, source_bytes
, tmp
);
7168 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7169 gfc_array_index_type
, loop_var
,
7170 gfc_index_one_node
);
7171 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
7173 tmp
= gfc_finish_block (&body
);
7175 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
7177 gfc_add_expr_to_block (&argse
.pre
, tmp
);
7179 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7180 gfc_add_expr_to_block (&argse
.pre
, tmp
);
7184 /* Obtain the size of the array in bytes. */
7185 for (n
= 0; n
< arg
->rank
; n
++)
7188 idx
= gfc_rank_cst
[n
];
7189 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7190 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7191 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
7192 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7193 gfc_array_index_type
, tmp
, source_bytes
);
7194 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7197 se
->expr
= source_bytes
;
7200 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7205 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
7209 tree type
, result_type
, tmp
;
7211 arg
= expr
->value
.function
.actual
->expr
;
7213 gfc_init_se (&argse
, NULL
);
7214 result_type
= gfc_get_int_type (expr
->ts
.kind
);
7218 if (arg
->ts
.type
== BT_CLASS
)
7220 gfc_add_vptr_component (arg
);
7221 gfc_add_size_component (arg
);
7222 gfc_conv_expr (&argse
, arg
);
7223 tmp
= fold_convert (result_type
, argse
.expr
);
7227 gfc_conv_expr_reference (&argse
, arg
);
7228 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7233 argse
.want_pointer
= 0;
7234 gfc_conv_expr_descriptor (&argse
, arg
);
7235 if (arg
->ts
.type
== BT_CLASS
)
7238 tmp
= gfc_class_vtab_size_get (
7239 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
7241 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
7242 tmp
= fold_convert (result_type
, tmp
);
7245 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7248 /* Obtain the argument's word length. */
7249 if (arg
->ts
.type
== BT_CHARACTER
)
7250 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
7252 tmp
= size_in_bytes (type
);
7253 tmp
= fold_convert (result_type
, tmp
);
7256 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
7257 build_int_cst (result_type
, BITS_PER_UNIT
));
7258 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7262 /* Intrinsic string comparison functions. */
7265 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
7269 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
7272 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
7273 expr
->value
.function
.actual
->expr
->ts
.kind
,
7275 se
->expr
= fold_build2_loc (input_location
, op
,
7276 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
7277 build_int_cst (TREE_TYPE (se
->expr
), 0));
7280 /* Generate a call to the adjustl/adjustr library function. */
7282 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
7290 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
7293 type
= TREE_TYPE (args
[2]);
7294 var
= gfc_conv_string_tmp (se
, type
, len
);
7297 tmp
= build_call_expr_loc (input_location
,
7298 fndecl
, 3, args
[0], args
[1], args
[2]);
7299 gfc_add_expr_to_block (&se
->pre
, tmp
);
7301 se
->string_length
= len
;
7305 /* Generate code for the TRANSFER intrinsic:
7307 DEST = TRANSFER (SOURCE, MOLD)
7309 typeof<DEST> = typeof<MOLD>
7314 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
7316 typeof<DEST> = typeof<MOLD>
7318 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
7319 sizeof (DEST(0) * SIZE). */
7321 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
7337 tree class_ref
= NULL_TREE
;
7338 gfc_actual_arglist
*arg
;
7340 gfc_array_info
*info
;
7344 gfc_expr
*source_expr
, *mold_expr
, *class_expr
;
7348 info
= &se
->ss
->info
->data
.array
;
7350 /* Convert SOURCE. The output from this stage is:-
7351 source_bytes = length of the source in bytes
7352 source = pointer to the source data. */
7353 arg
= expr
->value
.function
.actual
;
7354 source_expr
= arg
->expr
;
7356 /* Ensure double transfer through LOGICAL preserves all
7358 if (arg
->expr
->expr_type
== EXPR_FUNCTION
7359 && arg
->expr
->value
.function
.esym
== NULL
7360 && arg
->expr
->value
.function
.isym
!= NULL
7361 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
7362 && arg
->expr
->ts
.type
== BT_LOGICAL
7363 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
7364 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
7366 gfc_init_se (&argse
, NULL
);
7368 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7370 /* Obtain the pointer to source and the length of source in bytes. */
7371 if (arg
->expr
->rank
== 0)
7373 gfc_conv_expr_reference (&argse
, arg
->expr
);
7374 if (arg
->expr
->ts
.type
== BT_CLASS
)
7376 tmp
= build_fold_indirect_ref_loc (input_location
, argse
.expr
);
7377 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
7378 source
= gfc_class_data_get (tmp
);
7381 /* Array elements are evaluated as a reference to the data.
7382 To obtain the vptr for the element size, the argument
7383 expression must be stripped to the class reference and
7384 re-evaluated. The pre and post blocks are not needed. */
7385 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
7386 source
= argse
.expr
;
7387 class_expr
= gfc_find_and_cut_at_last_class_ref (arg
->expr
);
7388 gfc_init_se (&argse
, NULL
);
7389 gfc_conv_expr (&argse
, class_expr
);
7390 class_ref
= argse
.expr
;
7394 source
= argse
.expr
;
7396 /* Obtain the source word length. */
7397 switch (arg
->expr
->ts
.type
)
7400 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7401 argse
.string_length
);
7404 if (class_ref
!= NULL_TREE
)
7405 tmp
= gfc_class_vtab_size_get (class_ref
);
7407 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7410 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7412 tmp
= fold_convert (gfc_array_index_type
,
7413 size_in_bytes (source_type
));
7419 argse
.want_pointer
= 0;
7420 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7421 source
= gfc_conv_descriptor_data_get (argse
.expr
);
7422 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7424 /* Repack the source if not simply contiguous. */
7425 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
7427 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
7429 if (warn_array_temporaries
)
7430 gfc_warning (OPT_Warray_temporaries
,
7431 "Creating array temporary at %L", &expr
->where
);
7433 source
= build_call_expr_loc (input_location
,
7434 gfor_fndecl_in_pack
, 1, tmp
);
7435 source
= gfc_evaluate_now (source
, &argse
.pre
);
7437 /* Free the temporary. */
7438 gfc_start_block (&block
);
7439 tmp
= gfc_call_free (source
);
7440 gfc_add_expr_to_block (&block
, tmp
);
7441 stmt
= gfc_finish_block (&block
);
7443 /* Clean up if it was repacked. */
7444 gfc_init_block (&block
);
7445 tmp
= gfc_conv_array_data (argse
.expr
);
7446 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7448 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7449 build_empty_stmt (input_location
));
7450 gfc_add_expr_to_block (&block
, tmp
);
7451 gfc_add_block_to_block (&block
, &se
->post
);
7452 gfc_init_block (&se
->post
);
7453 gfc_add_block_to_block (&se
->post
, &block
);
7456 /* Obtain the source word length. */
7457 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7458 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7459 argse
.string_length
);
7461 tmp
= fold_convert (gfc_array_index_type
,
7462 size_in_bytes (source_type
));
7464 /* Obtain the size of the array in bytes. */
7465 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7466 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7469 idx
= gfc_rank_cst
[n
];
7470 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7471 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7472 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7473 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7474 gfc_array_index_type
, upper
, lower
);
7475 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7476 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7477 gfc_array_index_type
, extent
,
7478 gfc_index_one_node
);
7479 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7480 gfc_array_index_type
, tmp
, source_bytes
);
7484 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7485 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7486 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7488 /* Now convert MOLD. The outputs are:
7489 mold_type = the TREE type of MOLD
7490 dest_word_len = destination word length in bytes. */
7492 mold_expr
= arg
->expr
;
7494 gfc_init_se (&argse
, NULL
);
7496 scalar_mold
= arg
->expr
->rank
== 0;
7498 if (arg
->expr
->rank
== 0)
7500 gfc_conv_expr_reference (&argse
, arg
->expr
);
7501 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7506 gfc_init_se (&argse
, NULL
);
7507 argse
.want_pointer
= 0;
7508 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7509 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7512 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7513 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7515 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7517 /* If this TRANSFER is nested in another TRANSFER, use a type
7518 that preserves all bits. */
7519 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7520 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7523 /* Obtain the destination word length. */
7524 switch (arg
->expr
->ts
.type
)
7527 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7528 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7531 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7534 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7537 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7538 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7540 /* Finally convert SIZE, if it is present. */
7542 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7546 gfc_init_se (&argse
, NULL
);
7547 gfc_conv_expr_reference (&argse
, arg
->expr
);
7548 tmp
= convert (gfc_array_index_type
,
7549 build_fold_indirect_ref_loc (input_location
,
7551 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7552 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7557 /* Separate array and scalar results. */
7558 if (scalar_mold
&& tmp
== NULL_TREE
)
7559 goto scalar_transfer
;
7561 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7562 if (tmp
!= NULL_TREE
)
7563 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7564 tmp
, dest_word_len
);
7568 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
7569 gfc_add_modify (&se
->pre
, size_words
,
7570 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
7571 gfc_array_index_type
,
7572 size_bytes
, dest_word_len
));
7574 /* Evaluate the bounds of the result. If the loop range exists, we have
7575 to check if it is too large. If so, we modify loop->to be consistent
7576 with min(size, size(source)). Otherwise, size is made consistent with
7577 the loop range, so that the right number of bytes is transferred.*/
7578 n
= se
->loop
->order
[0];
7579 if (se
->loop
->to
[n
] != NULL_TREE
)
7581 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7582 se
->loop
->to
[n
], se
->loop
->from
[n
]);
7583 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7584 tmp
, gfc_index_one_node
);
7585 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7587 gfc_add_modify (&se
->pre
, size_words
, tmp
);
7588 gfc_add_modify (&se
->pre
, size_bytes
,
7589 fold_build2_loc (input_location
, MULT_EXPR
,
7590 gfc_array_index_type
,
7591 size_words
, dest_word_len
));
7592 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7593 size_words
, se
->loop
->from
[n
]);
7594 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7595 upper
, gfc_index_one_node
);
7599 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7600 size_words
, gfc_index_one_node
);
7601 se
->loop
->from
[n
] = gfc_index_zero_node
;
7604 se
->loop
->to
[n
] = upper
;
7606 /* Build a destination descriptor, using the pointer, source, as the
7608 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
7609 NULL_TREE
, false, true, false, &expr
->where
);
7611 /* Cast the pointer to the result. */
7612 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7613 tmp
= fold_convert (pvoid_type_node
, tmp
);
7615 /* Use memcpy to do the transfer. */
7617 = build_call_expr_loc (input_location
,
7618 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
7619 fold_convert (pvoid_type_node
, source
),
7620 fold_convert (size_type_node
,
7621 fold_build2_loc (input_location
,
7623 gfc_array_index_type
,
7626 gfc_add_expr_to_block (&se
->pre
, tmp
);
7628 se
->expr
= info
->descriptor
;
7629 if (expr
->ts
.type
== BT_CHARACTER
)
7630 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7634 /* Deal with scalar results. */
7636 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7637 dest_word_len
, source_bytes
);
7638 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7639 extent
, gfc_index_zero_node
);
7641 if (expr
->ts
.type
== BT_CHARACTER
)
7643 tree direct
, indirect
, free
;
7645 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
7646 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
7649 /* If source is longer than the destination, use a pointer to
7650 the source directly. */
7651 gfc_init_block (&block
);
7652 gfc_add_modify (&block
, tmpdecl
, ptr
);
7653 direct
= gfc_finish_block (&block
);
7655 /* Otherwise, allocate a string with the length of the destination
7656 and copy the source into it. */
7657 gfc_init_block (&block
);
7658 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
7659 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
7660 gfc_add_modify (&block
, tmpdecl
,
7661 fold_convert (TREE_TYPE (ptr
), tmp
));
7662 tmp
= build_call_expr_loc (input_location
,
7663 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7664 fold_convert (pvoid_type_node
, tmpdecl
),
7665 fold_convert (pvoid_type_node
, ptr
),
7666 fold_convert (size_type_node
, extent
));
7667 gfc_add_expr_to_block (&block
, tmp
);
7668 indirect
= gfc_finish_block (&block
);
7670 /* Wrap it up with the condition. */
7671 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
7672 dest_word_len
, source_bytes
);
7673 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
7674 gfc_add_expr_to_block (&se
->pre
, tmp
);
7676 /* Free the temporary string, if necessary. */
7677 free
= gfc_call_free (tmpdecl
);
7678 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7679 dest_word_len
, source_bytes
);
7680 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
7681 gfc_add_expr_to_block (&se
->post
, tmp
);
7684 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7688 tmpdecl
= gfc_create_var (mold_type
, "transfer");
7690 ptr
= convert (build_pointer_type (mold_type
), source
);
7692 /* For CLASS results, allocate the needed memory first. */
7693 if (mold_expr
->ts
.type
== BT_CLASS
)
7696 cdata
= gfc_class_data_get (tmpdecl
);
7697 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
7698 gfc_add_modify (&se
->pre
, cdata
, tmp
);
7701 /* Use memcpy to do the transfer. */
7702 if (mold_expr
->ts
.type
== BT_CLASS
)
7703 tmp
= gfc_class_data_get (tmpdecl
);
7705 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
7707 tmp
= build_call_expr_loc (input_location
,
7708 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7709 fold_convert (pvoid_type_node
, tmp
),
7710 fold_convert (pvoid_type_node
, ptr
),
7711 fold_convert (size_type_node
, extent
));
7712 gfc_add_expr_to_block (&se
->pre
, tmp
);
7714 /* For CLASS results, set the _vptr. */
7715 if (mold_expr
->ts
.type
== BT_CLASS
)
7719 vptr
= gfc_class_vptr_get (tmpdecl
);
7720 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
7722 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7723 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
7731 /* Generate a call to caf_is_present. */
7734 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
7736 tree caf_reference
, caf_decl
, token
, image_index
;
7738 /* Compile the reference chain. */
7739 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
7740 gcc_assert (caf_reference
!= NULL_TREE
);
7742 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
7743 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
7744 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
7745 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
7746 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
7749 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
7750 3, token
, image_index
, caf_reference
);
7754 /* Test whether this ref-chain refs this image only. */
7757 caf_this_image_ref (gfc_ref
*ref
)
7759 for ( ; ref
; ref
= ref
->next
)
7760 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
7761 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
7767 /* Generate code for the ALLOCATED intrinsic.
7768 Generate inline code that directly check the address of the argument. */
7771 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
7773 gfc_actual_arglist
*arg1
;
7776 symbol_attribute caf_attr
;
7778 gfc_init_se (&arg1se
, NULL
);
7779 arg1
= expr
->value
.function
.actual
;
7781 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7783 /* Make sure that class array expressions have both a _data
7784 component reference and an array reference.... */
7785 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
7786 gfc_add_class_array_ref (arg1
->expr
);
7787 /* .... whilst scalars only need the _data component. */
7789 gfc_add_data_component (arg1
->expr
);
7792 /* When arg1 references an allocatable component in a coarray, then call
7793 the caf-library function caf_is_present (). */
7794 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
7795 && arg1
->expr
->value
.function
.isym
7796 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
7797 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
7799 gfc_clear_attr (&caf_attr
);
7800 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
7801 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
7802 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
7805 if (arg1
->expr
->rank
== 0)
7807 /* Allocatable scalar. */
7808 arg1se
.want_pointer
= 1;
7809 gfc_conv_expr (&arg1se
, arg1
->expr
);
7814 /* Allocatable array. */
7815 arg1se
.descriptor_only
= 1;
7816 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7817 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7820 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
7821 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7824 /* Components of pointer array references sometimes come back with a pre block. */
7825 if (arg1se
.pre
.head
)
7826 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7828 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7832 /* Generate code for the ASSOCIATED intrinsic.
7833 If both POINTER and TARGET are arrays, generate a call to library function
7834 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7835 In other cases, generate inline code that directly compare the address of
7836 POINTER with the address of TARGET. */
7839 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
7841 gfc_actual_arglist
*arg1
;
7842 gfc_actual_arglist
*arg2
;
7847 tree nonzero_charlen
;
7848 tree nonzero_arraylen
;
7852 gfc_init_se (&arg1se
, NULL
);
7853 gfc_init_se (&arg2se
, NULL
);
7854 arg1
= expr
->value
.function
.actual
;
7857 /* Check whether the expression is a scalar or not; we cannot use
7858 arg1->expr->rank as it can be nonzero for proc pointers. */
7859 ss
= gfc_walk_expr (arg1
->expr
);
7860 scalar
= ss
== gfc_ss_terminator
;
7862 gfc_free_ss_chain (ss
);
7866 /* No optional target. */
7869 /* A pointer to a scalar. */
7870 arg1se
.want_pointer
= 1;
7871 gfc_conv_expr (&arg1se
, arg1
->expr
);
7872 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7873 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7874 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7876 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7878 tmp2
= gfc_class_data_get (arg1se
.expr
);
7879 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7880 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7887 /* A pointer to an array. */
7888 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7889 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7891 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7892 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7893 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
7894 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
7899 /* An optional target. */
7900 if (arg2
->expr
->ts
.type
== BT_CLASS
)
7901 gfc_add_data_component (arg2
->expr
);
7903 nonzero_charlen
= NULL_TREE
;
7904 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
7905 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
7907 arg1
->expr
->ts
.u
.cl
->backend_decl
,
7909 (TREE_TYPE (arg1
->expr
->ts
.u
.cl
->backend_decl
)));
7912 /* A pointer to a scalar. */
7913 arg1se
.want_pointer
= 1;
7914 gfc_conv_expr (&arg1se
, arg1
->expr
);
7915 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7916 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7917 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7919 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7920 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
7922 arg2se
.want_pointer
= 1;
7923 gfc_conv_expr (&arg2se
, arg2
->expr
);
7924 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7925 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
7926 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
7928 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7929 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7930 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7931 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7932 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7933 arg1se
.expr
, arg2se
.expr
);
7934 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7935 arg1se
.expr
, null_pointer_node
);
7936 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7937 logical_type_node
, tmp
, tmp2
);
7941 /* An array pointer of zero length is not associated if target is
7943 arg1se
.descriptor_only
= 1;
7944 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
7945 if (arg1
->expr
->rank
== -1)
7947 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
7948 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7949 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
7952 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
7953 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
7954 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
7955 logical_type_node
, tmp
,
7956 build_int_cst (TREE_TYPE (tmp
), 0));
7958 /* A pointer to an array, call library function _gfor_associated. */
7959 arg1se
.want_pointer
= 1;
7960 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7961 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7962 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7964 arg2se
.want_pointer
= 1;
7965 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
7966 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7967 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7968 se
->expr
= build_call_expr_loc (input_location
,
7969 gfor_fndecl_associated
, 2,
7970 arg1se
.expr
, arg2se
.expr
);
7971 se
->expr
= convert (logical_type_node
, se
->expr
);
7972 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7973 logical_type_node
, se
->expr
,
7977 /* If target is present zero character length pointers cannot
7979 if (nonzero_charlen
!= NULL_TREE
)
7980 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7982 se
->expr
, nonzero_charlen
);
7985 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7989 /* Generate code for the SAME_TYPE_AS intrinsic.
7990 Generate inline code that directly checks the vindices. */
7993 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
7998 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
8000 gfc_init_se (&se1
, NULL
);
8001 gfc_init_se (&se2
, NULL
);
8003 a
= expr
->value
.function
.actual
->expr
;
8004 b
= expr
->value
.function
.actual
->next
->expr
;
8006 if (UNLIMITED_POLY (a
))
8008 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
8009 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8010 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
8013 if (UNLIMITED_POLY (b
))
8015 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
8016 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8017 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
8020 if (a
->ts
.type
== BT_CLASS
)
8022 gfc_add_vptr_component (a
);
8023 gfc_add_hash_component (a
);
8025 else if (a
->ts
.type
== BT_DERIVED
)
8026 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8027 a
->ts
.u
.derived
->hash_value
);
8029 if (b
->ts
.type
== BT_CLASS
)
8031 gfc_add_vptr_component (b
);
8032 gfc_add_hash_component (b
);
8034 else if (b
->ts
.type
== BT_DERIVED
)
8035 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8036 b
->ts
.u
.derived
->hash_value
);
8038 gfc_conv_expr (&se1
, a
);
8039 gfc_conv_expr (&se2
, b
);
8041 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
8042 logical_type_node
, se1
.expr
,
8043 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
8046 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
8047 logical_type_node
, conda
, tmp
);
8050 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
8051 logical_type_node
, condb
, tmp
);
8053 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
8057 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
8060 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
8064 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
8065 se
->expr
= build_call_expr_loc (input_location
,
8066 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
8067 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8071 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
8074 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
8078 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8080 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
8081 type
= gfc_get_int_type (4);
8082 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
8084 /* Convert it to the required type. */
8085 type
= gfc_typenode_for_spec (&expr
->ts
);
8086 se
->expr
= build_call_expr_loc (input_location
,
8087 gfor_fndecl_si_kind
, 1, arg
);
8088 se
->expr
= fold_convert (type
, se
->expr
);
8092 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
8095 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
8097 gfc_actual_arglist
*actual
;
8100 vec
<tree
, va_gc
> *args
= NULL
;
8102 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
8104 gfc_init_se (&argse
, se
);
8106 /* Pass a NULL pointer for an absent arg. */
8107 if (actual
->expr
== NULL
)
8108 argse
.expr
= null_pointer_node
;
8114 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
8116 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
8117 ts
.type
= BT_INTEGER
;
8118 ts
.kind
= gfc_c_int_kind
;
8119 gfc_convert_type (actual
->expr
, &ts
, 2);
8121 gfc_conv_expr_reference (&argse
, actual
->expr
);
8124 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8125 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8126 vec_safe_push (args
, argse
.expr
);
8129 /* Convert it to the required type. */
8130 type
= gfc_typenode_for_spec (&expr
->ts
);
8131 se
->expr
= build_call_expr_loc_vec (input_location
,
8132 gfor_fndecl_sr_kind
, args
);
8133 se
->expr
= fold_convert (type
, se
->expr
);
8137 /* Generate code for TRIM (A) intrinsic function. */
8140 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
8150 unsigned int num_args
;
8152 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
8153 args
= XALLOCAVEC (tree
, num_args
);
8155 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
8156 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
8157 len
= gfc_create_var (gfc_charlen_type_node
, "len");
8159 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
8160 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
8163 if (expr
->ts
.kind
== 1)
8164 function
= gfor_fndecl_string_trim
;
8165 else if (expr
->ts
.kind
== 4)
8166 function
= gfor_fndecl_string_trim_char4
;
8170 fndecl
= build_addr (function
);
8171 tmp
= build_call_array_loc (input_location
,
8172 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
8174 gfc_add_expr_to_block (&se
->pre
, tmp
);
8176 /* Free the temporary afterwards, if necessary. */
8177 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8178 len
, build_int_cst (TREE_TYPE (len
), 0));
8179 tmp
= gfc_call_free (var
);
8180 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
8181 gfc_add_expr_to_block (&se
->post
, tmp
);
8184 se
->string_length
= len
;
8188 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
8191 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
8193 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
8194 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
8196 stmtblock_t block
, body
;
8199 /* We store in charsize the size of a character. */
8200 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
8201 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
8203 /* Get the arguments. */
8204 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
8205 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
8207 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
8208 ncopies_type
= TREE_TYPE (ncopies
);
8210 /* Check that NCOPIES is not negative. */
8211 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
8212 build_int_cst (ncopies_type
, 0));
8213 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
8214 "Argument NCOPIES of REPEAT intrinsic is negative "
8215 "(its value is %ld)",
8216 fold_convert (long_integer_type_node
, ncopies
));
8218 /* If the source length is zero, any non negative value of NCOPIES
8219 is valid, and nothing happens. */
8220 n
= gfc_create_var (ncopies_type
, "ncopies");
8221 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
8223 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
8224 build_int_cst (ncopies_type
, 0), ncopies
);
8225 gfc_add_modify (&se
->pre
, n
, tmp
);
8228 /* Check that ncopies is not too large: ncopies should be less than
8229 (or equal to) MAX / slen, where MAX is the maximal integer of
8230 the gfc_charlen_type_node type. If slen == 0, we need a special
8231 case to avoid the division by zero. */
8232 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
8233 fold_convert (sizetype
,
8234 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
8236 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
8237 ? sizetype
: ncopies_type
;
8238 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8239 fold_convert (largest
, ncopies
),
8240 fold_convert (largest
, max
));
8241 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
8243 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
8244 logical_false_node
, cond
);
8245 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
8246 "Argument NCOPIES of REPEAT intrinsic is too large");
8248 /* Compute the destination length. */
8249 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
8250 fold_convert (gfc_charlen_type_node
, slen
),
8251 fold_convert (gfc_charlen_type_node
, ncopies
));
8252 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
8253 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
8255 /* Generate the code to do the repeat operation:
8256 for (i = 0; i < ncopies; i++)
8257 memmove (dest + (i * slen * size), src, slen*size); */
8258 gfc_start_block (&block
);
8259 count
= gfc_create_var (sizetype
, "count");
8260 gfc_add_modify (&block
, count
, size_zero_node
);
8261 exit_label
= gfc_build_label_decl (NULL_TREE
);
8263 /* Start the loop body. */
8264 gfc_start_block (&body
);
8266 /* Exit the loop if count >= ncopies. */
8267 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
8268 fold_convert (sizetype
, ncopies
));
8269 tmp
= build1_v (GOTO_EXPR
, exit_label
);
8270 TREE_USED (exit_label
) = 1;
8271 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
8272 build_empty_stmt (input_location
));
8273 gfc_add_expr_to_block (&body
, tmp
);
8275 /* Call memmove (dest + (i*slen*size), src, slen*size). */
8276 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
8278 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
8280 tmp
= fold_build_pointer_plus_loc (input_location
,
8281 fold_convert (pvoid_type_node
, dest
), tmp
);
8282 tmp
= build_call_expr_loc (input_location
,
8283 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
8285 fold_build2_loc (input_location
, MULT_EXPR
,
8286 size_type_node
, slen
, size
));
8287 gfc_add_expr_to_block (&body
, tmp
);
8289 /* Increment count. */
8290 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
8291 count
, size_one_node
);
8292 gfc_add_modify (&body
, count
, tmp
);
8294 /* Build the loop. */
8295 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
8296 gfc_add_expr_to_block (&block
, tmp
);
8298 /* Add the exit label. */
8299 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8300 gfc_add_expr_to_block (&block
, tmp
);
8302 /* Finish the block. */
8303 tmp
= gfc_finish_block (&block
);
8304 gfc_add_expr_to_block (&se
->pre
, tmp
);
8306 /* Set the result value. */
8308 se
->string_length
= dlen
;
8312 /* Generate code for the IARGC intrinsic. */
8315 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
8321 /* Call the library function. This always returns an INTEGER(4). */
8322 fndecl
= gfor_fndecl_iargc
;
8323 tmp
= build_call_expr_loc (input_location
,
8326 /* Convert it to the required type. */
8327 type
= gfc_typenode_for_spec (&expr
->ts
);
8328 tmp
= fold_convert (type
, tmp
);
8334 /* Generate code for the KILL intrinsic. */
8337 conv_intrinsic_kill (gfc_se
*se
, gfc_expr
*expr
)
8340 tree int4_type_node
= gfc_get_int_type (4);
8344 unsigned int num_args
;
8346 num_args
= gfc_intrinsic_argument_list_length (expr
);
8347 args
= XALLOCAVEC (tree
, num_args
);
8348 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
8350 /* Convert PID to a INTEGER(4) entity. */
8351 pid
= convert (int4_type_node
, args
[0]);
8353 /* Convert SIG to a INTEGER(4) entity. */
8354 sig
= convert (int4_type_node
, args
[1]);
8356 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill
, 2, pid
, sig
);
8358 se
->expr
= fold_convert (TREE_TYPE (args
[0]), tmp
);
8363 conv_intrinsic_kill_sub (gfc_code
*code
)
8367 tree int4_type_node
= gfc_get_int_type (4);
8373 /* Make the function call. */
8374 gfc_init_block (&block
);
8375 gfc_init_se (&se
, NULL
);
8377 /* Convert PID to a INTEGER(4) entity. */
8378 gfc_conv_expr (&se
, code
->ext
.actual
->expr
);
8379 gfc_add_block_to_block (&block
, &se
.pre
);
8380 pid
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
8381 gfc_add_block_to_block (&block
, &se
.post
);
8383 /* Convert SIG to a INTEGER(4) entity. */
8384 gfc_conv_expr (&se
, code
->ext
.actual
->next
->expr
);
8385 gfc_add_block_to_block (&block
, &se
.pre
);
8386 sig
= fold_convert (int4_type_node
, gfc_evaluate_now (se
.expr
, &block
));
8387 gfc_add_block_to_block (&block
, &se
.post
);
8389 /* Deal with an optional STATUS. */
8390 if (code
->ext
.actual
->next
->next
->expr
)
8392 gfc_init_se (&se_stat
, NULL
);
8393 gfc_conv_expr (&se_stat
, code
->ext
.actual
->next
->next
->expr
);
8394 statp
= gfc_create_var (gfc_get_int_type (4), "_statp");
8399 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_kill_sub
, 3, pid
, sig
,
8400 statp
? gfc_build_addr_expr (NULL_TREE
, statp
) : null_pointer_node
);
8402 gfc_add_expr_to_block (&block
, tmp
);
8404 if (statp
&& statp
!= se_stat
.expr
)
8405 gfc_add_modify (&block
, se_stat
.expr
,
8406 fold_convert (TREE_TYPE (se_stat
.expr
), statp
));
8408 return gfc_finish_block (&block
);
8413 /* The loc intrinsic returns the address of its argument as
8414 gfc_index_integer_kind integer. */
8417 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
8422 gcc_assert (!se
->ss
);
8424 arg_expr
= expr
->value
.function
.actual
->expr
;
8425 if (arg_expr
->rank
== 0)
8427 if (arg_expr
->ts
.type
== BT_CLASS
)
8428 gfc_add_data_component (arg_expr
);
8429 gfc_conv_expr_reference (se
, arg_expr
);
8432 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
8433 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
8435 /* Create a temporary variable for loc return value. Without this,
8436 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
8437 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
8438 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
8439 se
->expr
= temp_var
;
8443 /* The following routine generates code for the intrinsic
8444 functions from the ISO_C_BINDING module:
8450 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
8452 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
8454 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
8456 if (arg
->expr
->rank
== 0)
8457 gfc_conv_expr_reference (se
, arg
->expr
);
8458 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
8459 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
8462 gfc_conv_expr_descriptor (se
, arg
->expr
);
8463 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
8466 /* TODO -- the following two lines shouldn't be necessary, but if
8467 they're removed, a bug is exposed later in the code path.
8468 This workaround was thus introduced, but will have to be
8469 removed; please see PR 35150 for details about the issue. */
8470 se
->expr
= convert (pvoid_type_node
, se
->expr
);
8471 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
8473 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
8474 gfc_conv_expr_reference (se
, arg
->expr
);
8475 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
8480 /* Build the addr_expr for the first argument. The argument is
8481 already an *address* so we don't need to set want_pointer in
8483 gfc_init_se (&arg1se
, NULL
);
8484 gfc_conv_expr (&arg1se
, arg
->expr
);
8485 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8486 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8488 /* See if we were given two arguments. */
8489 if (arg
->next
->expr
== NULL
)
8490 /* Only given one arg so generate a null and do a
8491 not-equal comparison against the first arg. */
8492 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8494 fold_convert (TREE_TYPE (arg1se
.expr
),
8495 null_pointer_node
));
8501 /* Given two arguments so build the arg2se from second arg. */
8502 gfc_init_se (&arg2se
, NULL
);
8503 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
8504 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8505 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8507 /* Generate test to compare that the two args are equal. */
8508 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8509 arg1se
.expr
, arg2se
.expr
);
8510 /* Generate test to ensure that the first arg is not null. */
8511 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
8513 arg1se
.expr
, null_pointer_node
);
8515 /* Finally, the generated test must check that both arg1 is not
8516 NULL and that it is equal to the second arg. */
8517 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8519 not_null_expr
, eq_expr
);
8527 /* The following routine generates code for the intrinsic
8528 subroutines from the ISO_C_BINDING module:
8530 * C_F_PROCPOINTER. */
8533 conv_isocbinding_subroutine (gfc_code
*code
)
8540 tree desc
, dim
, tmp
, stride
, offset
;
8541 stmtblock_t body
, block
;
8543 gfc_actual_arglist
*arg
= code
->ext
.actual
;
8545 gfc_init_se (&se
, NULL
);
8546 gfc_init_se (&cptrse
, NULL
);
8547 gfc_conv_expr (&cptrse
, arg
->expr
);
8548 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
8549 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
8551 gfc_init_se (&fptrse
, NULL
);
8552 if (arg
->next
->expr
->rank
== 0)
8554 fptrse
.want_pointer
= 1;
8555 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
8556 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
8557 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
8558 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8559 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
8560 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
8562 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8563 TREE_TYPE (fptrse
.expr
),
8565 fold_convert (TREE_TYPE (fptrse
.expr
),
8567 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
8568 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8569 return gfc_finish_block (&se
.pre
);
8572 gfc_start_block (&block
);
8574 /* Get the descriptor of the Fortran pointer. */
8575 fptrse
.descriptor_only
= 1;
8576 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
8577 gfc_add_block_to_block (&block
, &fptrse
.pre
);
8580 /* Set the span field. */
8581 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
8582 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8583 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
8585 /* Set data value, dtype, and offset. */
8586 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
8587 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
8588 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
8589 gfc_get_dtype (TREE_TYPE (desc
)));
8591 /* Start scalarization of the bounds, using the shape argument. */
8593 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
8594 gcc_assert (shape_ss
!= gfc_ss_terminator
);
8595 gfc_init_se (&shapese
, NULL
);
8597 gfc_init_loopinfo (&loop
);
8598 gfc_add_ss_to_loop (&loop
, shape_ss
);
8599 gfc_conv_ss_startstride (&loop
);
8600 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
8601 gfc_mark_ss_chain_used (shape_ss
, 1);
8603 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
8604 shapese
.ss
= shape_ss
;
8606 stride
= gfc_create_var (gfc_array_index_type
, "stride");
8607 offset
= gfc_create_var (gfc_array_index_type
, "offset");
8608 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
8609 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8612 gfc_start_scalarized_body (&loop
, &body
);
8614 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8615 loop
.loopvar
[0], loop
.from
[0]);
8617 /* Set bounds and stride. */
8618 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
8619 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
8621 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
8622 gfc_add_block_to_block (&body
, &shapese
.pre
);
8623 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
8624 gfc_add_block_to_block (&body
, &shapese
.post
);
8626 /* Calculate offset. */
8627 gfc_add_modify (&body
, offset
,
8628 fold_build2_loc (input_location
, PLUS_EXPR
,
8629 gfc_array_index_type
, offset
, stride
));
8630 /* Update stride. */
8631 gfc_add_modify (&body
, stride
,
8632 fold_build2_loc (input_location
, MULT_EXPR
,
8633 gfc_array_index_type
, stride
,
8634 fold_convert (gfc_array_index_type
,
8636 /* Finish scalarization loop. */
8637 gfc_trans_scalarizing_loops (&loop
, &body
);
8638 gfc_add_block_to_block (&block
, &loop
.pre
);
8639 gfc_add_block_to_block (&block
, &loop
.post
);
8640 gfc_add_block_to_block (&block
, &fptrse
.post
);
8641 gfc_cleanup_loop (&loop
);
8643 gfc_add_modify (&block
, offset
,
8644 fold_build1_loc (input_location
, NEGATE_EXPR
,
8645 gfc_array_index_type
, offset
));
8646 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
8648 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
8649 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8650 return gfc_finish_block (&se
.pre
);
8654 /* Save and restore floating-point state. */
8657 gfc_save_fp_state (stmtblock_t
*block
)
8659 tree type
, fpstate
, tmp
;
8661 type
= build_array_type (char_type_node
,
8662 build_range_type (size_type_node
, size_zero_node
,
8663 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
8664 fpstate
= gfc_create_var (type
, "fpstate");
8665 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
8667 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
8669 gfc_add_expr_to_block (block
, tmp
);
8676 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
8680 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
8682 gfc_add_expr_to_block (block
, tmp
);
8686 /* Generate code for arguments of IEEE functions. */
8689 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
8692 gfc_actual_arglist
*actual
;
8697 actual
= expr
->value
.function
.actual
;
8698 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
8700 gcc_assert (actual
);
8703 gfc_init_se (&argse
, se
);
8704 gfc_conv_expr_val (&argse
, e
);
8706 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8707 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8708 argarray
[arg
] = argse
.expr
;
8713 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8714 and IEEE_UNORDERED, which translate directly to GCC type-generic
8718 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
8719 enum built_in_function code
, int nargs
)
8722 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
8724 conv_ieee_function_args (se
, expr
, args
, nargs
);
8725 se
->expr
= build_call_expr_loc_array (input_location
,
8726 builtin_decl_explicit (code
),
8728 STRIP_TYPE_NOPS (se
->expr
);
8729 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8733 /* Generate code for IEEE_IS_NORMAL intrinsic:
8734 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8737 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
8739 tree arg
, isnormal
, iszero
;
8741 /* Convert arg, evaluate it only once. */
8742 conv_ieee_function_args (se
, expr
, &arg
, 1);
8743 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8745 isnormal
= build_call_expr_loc (input_location
,
8746 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
8748 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
8749 build_real_from_int_cst (TREE_TYPE (arg
),
8750 integer_zero_node
));
8751 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8752 logical_type_node
, isnormal
, iszero
);
8753 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8757 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8758 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8761 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
8763 tree arg
, signbit
, isnan
;
8765 /* Convert arg, evaluate it only once. */
8766 conv_ieee_function_args (se
, expr
, &arg
, 1);
8767 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8769 isnan
= build_call_expr_loc (input_location
,
8770 builtin_decl_explicit (BUILT_IN_ISNAN
),
8772 STRIP_TYPE_NOPS (isnan
);
8774 signbit
= build_call_expr_loc (input_location
,
8775 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8777 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8778 signbit
, integer_zero_node
);
8780 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8781 logical_type_node
, signbit
,
8782 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
8783 TREE_TYPE(isnan
), isnan
));
8785 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8789 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8792 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
8793 enum built_in_function code
)
8795 tree arg
, decl
, call
, fpstate
;
8798 conv_ieee_function_args (se
, expr
, &arg
, 1);
8799 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
8800 decl
= builtin_decl_for_precision (code
, argprec
);
8802 /* Save floating-point state. */
8803 fpstate
= gfc_save_fp_state (&se
->pre
);
8805 /* Make the function call. */
8806 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
8807 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
8809 /* Restore floating-point state. */
8810 gfc_restore_fp_state (&se
->post
, fpstate
);
8814 /* Generate code for IEEE_REM. */
8817 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
8819 tree args
[2], decl
, call
, fpstate
;
8822 conv_ieee_function_args (se
, expr
, args
, 2);
8824 /* If arguments have unequal size, convert them to the larger. */
8825 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
8826 > TYPE_PRECISION (TREE_TYPE (args
[1])))
8827 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8828 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
8829 > TYPE_PRECISION (TREE_TYPE (args
[0])))
8830 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
8832 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8833 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
8835 /* Save floating-point state. */
8836 fpstate
= gfc_save_fp_state (&se
->pre
);
8838 /* Make the function call. */
8839 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8840 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8842 /* Restore floating-point state. */
8843 gfc_restore_fp_state (&se
->post
, fpstate
);
8847 /* Generate code for IEEE_NEXT_AFTER. */
8850 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
8852 tree args
[2], decl
, call
, fpstate
;
8855 conv_ieee_function_args (se
, expr
, args
, 2);
8857 /* Result has the characteristics of first argument. */
8858 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8859 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8860 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
8862 /* Save floating-point state. */
8863 fpstate
= gfc_save_fp_state (&se
->pre
);
8865 /* Make the function call. */
8866 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8867 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8869 /* Restore floating-point state. */
8870 gfc_restore_fp_state (&se
->post
, fpstate
);
8874 /* Generate code for IEEE_SCALB. */
8877 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
8879 tree args
[2], decl
, call
, huge
, type
;
8882 conv_ieee_function_args (se
, expr
, args
, 2);
8884 /* Result has the characteristics of first argument. */
8885 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8886 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
8888 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
8890 /* We need to fold the integer into the range of a C int. */
8891 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
8892 type
= TREE_TYPE (args
[1]);
8894 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
8895 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
8897 huge
= fold_convert (type
, huge
);
8898 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
8900 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
8901 fold_build1_loc (input_location
, NEGATE_EXPR
,
8905 args
[1] = fold_convert (integer_type_node
, args
[1]);
8907 /* Make the function call. */
8908 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8909 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8913 /* Generate code for IEEE_COPY_SIGN. */
8916 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
8918 tree args
[2], decl
, sign
;
8921 conv_ieee_function_args (se
, expr
, args
, 2);
8923 /* Get the sign of the second argument. */
8924 sign
= build_call_expr_loc (input_location
,
8925 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8927 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8928 sign
, integer_zero_node
);
8930 /* Create a value of one, with the right sign. */
8931 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
8933 fold_build1_loc (input_location
, NEGATE_EXPR
,
8937 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
8939 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8940 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
8942 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8946 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8950 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
8952 const char *name
= expr
->value
.function
.name
;
8954 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8956 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
8957 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
8958 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
8959 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
8960 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
8961 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
8962 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
8963 conv_intrinsic_ieee_is_normal (se
, expr
);
8964 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
8965 conv_intrinsic_ieee_is_negative (se
, expr
);
8966 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
8967 conv_intrinsic_ieee_copy_sign (se
, expr
);
8968 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
8969 conv_intrinsic_ieee_scalb (se
, expr
);
8970 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
8971 conv_intrinsic_ieee_next_after (se
, expr
);
8972 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
8973 conv_intrinsic_ieee_rem (se
, expr
);
8974 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
8975 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
8976 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
8977 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
8979 /* It is not among the functions we translate directly. We return
8980 false, so a library function call is emitted. */
8989 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8992 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
8994 tree arg
, res
, restype
;
8996 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8997 arg
= fold_convert (size_type_node
, arg
);
8998 res
= build_call_expr_loc (input_location
,
8999 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
9000 restype
= gfc_typenode_for_spec (&expr
->ts
);
9001 se
->expr
= fold_convert (restype
, res
);
9005 /* Generate code for an intrinsic function. Some map directly to library
9006 calls, others get special handling. In some cases the name of the function
9007 used depends on the type specifiers. */
9010 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
9016 name
= &expr
->value
.function
.name
[2];
9020 lib
= gfc_is_intrinsic_libcall (expr
);
9024 se
->ignore_optional
= 1;
9026 switch (expr
->value
.function
.isym
->id
)
9028 case GFC_ISYM_EOSHIFT
:
9030 case GFC_ISYM_RESHAPE
:
9031 /* For all of those the first argument specifies the type and the
9032 third is optional. */
9033 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
9036 case GFC_ISYM_MINLOC
:
9037 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9040 case GFC_ISYM_MAXLOC
:
9041 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9044 case GFC_ISYM_SHAPE
:
9045 gfc_conv_intrinsic_shape (se
, expr
);
9049 gfc_conv_intrinsic_funcall (se
, expr
);
9057 switch (expr
->value
.function
.isym
->id
)
9062 case GFC_ISYM_REPEAT
:
9063 gfc_conv_intrinsic_repeat (se
, expr
);
9067 gfc_conv_intrinsic_trim (se
, expr
);
9070 case GFC_ISYM_SC_KIND
:
9071 gfc_conv_intrinsic_sc_kind (se
, expr
);
9074 case GFC_ISYM_SI_KIND
:
9075 gfc_conv_intrinsic_si_kind (se
, expr
);
9078 case GFC_ISYM_SR_KIND
:
9079 gfc_conv_intrinsic_sr_kind (se
, expr
);
9082 case GFC_ISYM_EXPONENT
:
9083 gfc_conv_intrinsic_exponent (se
, expr
);
9087 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9089 fndecl
= gfor_fndecl_string_scan
;
9091 fndecl
= gfor_fndecl_string_scan_char4
;
9095 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9098 case GFC_ISYM_VERIFY
:
9099 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9101 fndecl
= gfor_fndecl_string_verify
;
9103 fndecl
= gfor_fndecl_string_verify_char4
;
9107 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9110 case GFC_ISYM_ALLOCATED
:
9111 gfc_conv_allocated (se
, expr
);
9114 case GFC_ISYM_ASSOCIATED
:
9115 gfc_conv_associated(se
, expr
);
9118 case GFC_ISYM_SAME_TYPE_AS
:
9119 gfc_conv_same_type_as (se
, expr
);
9123 gfc_conv_intrinsic_abs (se
, expr
);
9126 case GFC_ISYM_ADJUSTL
:
9127 if (expr
->ts
.kind
== 1)
9128 fndecl
= gfor_fndecl_adjustl
;
9129 else if (expr
->ts
.kind
== 4)
9130 fndecl
= gfor_fndecl_adjustl_char4
;
9134 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
9137 case GFC_ISYM_ADJUSTR
:
9138 if (expr
->ts
.kind
== 1)
9139 fndecl
= gfor_fndecl_adjustr
;
9140 else if (expr
->ts
.kind
== 4)
9141 fndecl
= gfor_fndecl_adjustr_char4
;
9145 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
9148 case GFC_ISYM_AIMAG
:
9149 gfc_conv_intrinsic_imagpart (se
, expr
);
9153 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
9157 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
9160 case GFC_ISYM_ANINT
:
9161 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
9165 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
9169 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
9172 case GFC_ISYM_BTEST
:
9173 gfc_conv_intrinsic_btest (se
, expr
);
9177 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
9181 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
9185 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
9189 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
9192 case GFC_ISYM_C_ASSOCIATED
:
9193 case GFC_ISYM_C_FUNLOC
:
9194 case GFC_ISYM_C_LOC
:
9195 conv_isocbinding_function (se
, expr
);
9198 case GFC_ISYM_ACHAR
:
9200 gfc_conv_intrinsic_char (se
, expr
);
9203 case GFC_ISYM_CONVERSION
:
9205 case GFC_ISYM_LOGICAL
:
9207 gfc_conv_intrinsic_conversion (se
, expr
);
9210 /* Integer conversions are handled separately to make sure we get the
9211 correct rounding mode. */
9216 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
9220 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
9223 case GFC_ISYM_CEILING
:
9224 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
9227 case GFC_ISYM_FLOOR
:
9228 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
9232 gfc_conv_intrinsic_mod (se
, expr
, 0);
9235 case GFC_ISYM_MODULO
:
9236 gfc_conv_intrinsic_mod (se
, expr
, 1);
9239 case GFC_ISYM_CAF_GET
:
9240 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9244 case GFC_ISYM_CMPLX
:
9245 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
9248 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
9249 gfc_conv_intrinsic_iargc (se
, expr
);
9252 case GFC_ISYM_COMPLEX
:
9253 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
9256 case GFC_ISYM_CONJG
:
9257 gfc_conv_intrinsic_conjg (se
, expr
);
9260 case GFC_ISYM_COUNT
:
9261 gfc_conv_intrinsic_count (se
, expr
);
9264 case GFC_ISYM_CTIME
:
9265 gfc_conv_intrinsic_ctime (se
, expr
);
9269 gfc_conv_intrinsic_dim (se
, expr
);
9272 case GFC_ISYM_DOT_PRODUCT
:
9273 gfc_conv_intrinsic_dot_product (se
, expr
);
9276 case GFC_ISYM_DPROD
:
9277 gfc_conv_intrinsic_dprod (se
, expr
);
9280 case GFC_ISYM_DSHIFTL
:
9281 gfc_conv_intrinsic_dshift (se
, expr
, true);
9284 case GFC_ISYM_DSHIFTR
:
9285 gfc_conv_intrinsic_dshift (se
, expr
, false);
9288 case GFC_ISYM_FDATE
:
9289 gfc_conv_intrinsic_fdate (se
, expr
);
9292 case GFC_ISYM_FRACTION
:
9293 gfc_conv_intrinsic_fraction (se
, expr
);
9297 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
9301 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
9305 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
9308 case GFC_ISYM_IBCLR
:
9309 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
9312 case GFC_ISYM_IBITS
:
9313 gfc_conv_intrinsic_ibits (se
, expr
);
9316 case GFC_ISYM_IBSET
:
9317 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
9320 case GFC_ISYM_IACHAR
:
9321 case GFC_ISYM_ICHAR
:
9322 /* We assume ASCII character sequence. */
9323 gfc_conv_intrinsic_ichar (se
, expr
);
9326 case GFC_ISYM_IARGC
:
9327 gfc_conv_intrinsic_iargc (se
, expr
);
9331 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9334 case GFC_ISYM_INDEX
:
9335 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9337 fndecl
= gfor_fndecl_string_index
;
9339 fndecl
= gfor_fndecl_string_index_char4
;
9343 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9347 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9350 case GFC_ISYM_IPARITY
:
9351 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
9354 case GFC_ISYM_IS_IOSTAT_END
:
9355 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
9358 case GFC_ISYM_IS_IOSTAT_EOR
:
9359 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
9362 case GFC_ISYM_ISNAN
:
9363 gfc_conv_intrinsic_isnan (se
, expr
);
9367 conv_intrinsic_kill (se
, expr
);
9370 case GFC_ISYM_LSHIFT
:
9371 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9374 case GFC_ISYM_RSHIFT
:
9375 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9378 case GFC_ISYM_SHIFTA
:
9379 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9382 case GFC_ISYM_SHIFTL
:
9383 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9386 case GFC_ISYM_SHIFTR
:
9387 gfc_conv_intrinsic_shift (se
, expr
, true, false);
9390 case GFC_ISYM_ISHFT
:
9391 gfc_conv_intrinsic_ishft (se
, expr
);
9394 case GFC_ISYM_ISHFTC
:
9395 gfc_conv_intrinsic_ishftc (se
, expr
);
9398 case GFC_ISYM_LEADZ
:
9399 gfc_conv_intrinsic_leadz (se
, expr
);
9402 case GFC_ISYM_TRAILZ
:
9403 gfc_conv_intrinsic_trailz (se
, expr
);
9406 case GFC_ISYM_POPCNT
:
9407 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
9410 case GFC_ISYM_POPPAR
:
9411 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
9414 case GFC_ISYM_LBOUND
:
9415 gfc_conv_intrinsic_bound (se
, expr
, 0);
9418 case GFC_ISYM_LCOBOUND
:
9419 conv_intrinsic_cobound (se
, expr
);
9422 case GFC_ISYM_TRANSPOSE
:
9423 /* The scalarizer has already been set up for reversed dimension access
9424 order ; now we just get the argument value normally. */
9425 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
9429 gfc_conv_intrinsic_len (se
, expr
);
9432 case GFC_ISYM_LEN_TRIM
:
9433 gfc_conv_intrinsic_len_trim (se
, expr
);
9437 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
9441 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
9445 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
9449 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
9452 case GFC_ISYM_MALLOC
:
9453 gfc_conv_intrinsic_malloc (se
, expr
);
9456 case GFC_ISYM_MASKL
:
9457 gfc_conv_intrinsic_mask (se
, expr
, 1);
9460 case GFC_ISYM_MASKR
:
9461 gfc_conv_intrinsic_mask (se
, expr
, 0);
9465 if (expr
->ts
.type
== BT_CHARACTER
)
9466 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
9468 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
9471 case GFC_ISYM_MAXLOC
:
9472 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9475 case GFC_ISYM_MAXVAL
:
9476 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
9479 case GFC_ISYM_MERGE
:
9480 gfc_conv_intrinsic_merge (se
, expr
);
9483 case GFC_ISYM_MERGE_BITS
:
9484 gfc_conv_intrinsic_merge_bits (se
, expr
);
9488 if (expr
->ts
.type
== BT_CHARACTER
)
9489 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
9491 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
9494 case GFC_ISYM_MINLOC
:
9495 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9498 case GFC_ISYM_MINVAL
:
9499 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
9502 case GFC_ISYM_NEAREST
:
9503 gfc_conv_intrinsic_nearest (se
, expr
);
9506 case GFC_ISYM_NORM2
:
9507 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
9511 gfc_conv_intrinsic_not (se
, expr
);
9515 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9518 case GFC_ISYM_PARITY
:
9519 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
9522 case GFC_ISYM_PRESENT
:
9523 gfc_conv_intrinsic_present (se
, expr
);
9526 case GFC_ISYM_PRODUCT
:
9527 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
9531 gfc_conv_intrinsic_rank (se
, expr
);
9534 case GFC_ISYM_RRSPACING
:
9535 gfc_conv_intrinsic_rrspacing (se
, expr
);
9538 case GFC_ISYM_SET_EXPONENT
:
9539 gfc_conv_intrinsic_set_exponent (se
, expr
);
9542 case GFC_ISYM_SCALE
:
9543 gfc_conv_intrinsic_scale (se
, expr
);
9547 gfc_conv_intrinsic_sign (se
, expr
);
9551 gfc_conv_intrinsic_size (se
, expr
);
9554 case GFC_ISYM_SIZEOF
:
9555 case GFC_ISYM_C_SIZEOF
:
9556 gfc_conv_intrinsic_sizeof (se
, expr
);
9559 case GFC_ISYM_STORAGE_SIZE
:
9560 gfc_conv_intrinsic_storage_size (se
, expr
);
9563 case GFC_ISYM_SPACING
:
9564 gfc_conv_intrinsic_spacing (se
, expr
);
9567 case GFC_ISYM_STRIDE
:
9568 conv_intrinsic_stride (se
, expr
);
9572 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
9575 case GFC_ISYM_TEAM_NUMBER
:
9576 conv_intrinsic_team_number (se
, expr
);
9579 case GFC_ISYM_TRANSFER
:
9580 if (se
->ss
&& se
->ss
->info
->useflags
)
9581 /* Access the previously obtained result. */
9582 gfc_conv_tmp_array_ref (se
);
9584 gfc_conv_intrinsic_transfer (se
, expr
);
9587 case GFC_ISYM_TTYNAM
:
9588 gfc_conv_intrinsic_ttynam (se
, expr
);
9591 case GFC_ISYM_UBOUND
:
9592 gfc_conv_intrinsic_bound (se
, expr
, 1);
9595 case GFC_ISYM_UCOBOUND
:
9596 conv_intrinsic_cobound (se
, expr
);
9600 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9604 gfc_conv_intrinsic_loc (se
, expr
);
9607 case GFC_ISYM_THIS_IMAGE
:
9608 /* For num_images() == 1, handle as LCOBOUND. */
9609 if (expr
->value
.function
.actual
->expr
9610 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
9611 conv_intrinsic_cobound (se
, expr
);
9613 trans_this_image (se
, expr
);
9616 case GFC_ISYM_IMAGE_INDEX
:
9617 trans_image_index (se
, expr
);
9620 case GFC_ISYM_IMAGE_STATUS
:
9621 conv_intrinsic_image_status (se
, expr
);
9624 case GFC_ISYM_NUM_IMAGES
:
9625 trans_num_images (se
, expr
);
9628 case GFC_ISYM_ACCESS
:
9629 case GFC_ISYM_CHDIR
:
9630 case GFC_ISYM_CHMOD
:
9631 case GFC_ISYM_DTIME
:
9632 case GFC_ISYM_ETIME
:
9633 case GFC_ISYM_EXTENDS_TYPE_OF
:
9635 case GFC_ISYM_FGETC
:
9638 case GFC_ISYM_FPUTC
:
9639 case GFC_ISYM_FSTAT
:
9640 case GFC_ISYM_FTELL
:
9641 case GFC_ISYM_GETCWD
:
9642 case GFC_ISYM_GETGID
:
9643 case GFC_ISYM_GETPID
:
9644 case GFC_ISYM_GETUID
:
9645 case GFC_ISYM_HOSTNM
:
9646 case GFC_ISYM_IERRNO
:
9647 case GFC_ISYM_IRAND
:
9648 case GFC_ISYM_ISATTY
:
9651 case GFC_ISYM_LSTAT
:
9652 case GFC_ISYM_MATMUL
:
9653 case GFC_ISYM_MCLOCK
:
9654 case GFC_ISYM_MCLOCK8
:
9656 case GFC_ISYM_RENAME
:
9657 case GFC_ISYM_SECOND
:
9658 case GFC_ISYM_SECNDS
:
9659 case GFC_ISYM_SIGNAL
:
9661 case GFC_ISYM_SYMLNK
:
9662 case GFC_ISYM_SYSTEM
:
9664 case GFC_ISYM_TIME8
:
9665 case GFC_ISYM_UMASK
:
9666 case GFC_ISYM_UNLINK
:
9668 gfc_conv_intrinsic_funcall (se
, expr
);
9671 case GFC_ISYM_EOSHIFT
:
9673 case GFC_ISYM_RESHAPE
:
9674 /* For those, expr->rank should always be >0 and thus the if above the
9675 switch should have matched. */
9680 gfc_conv_intrinsic_lib_function (se
, expr
);
9687 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
9689 gfc_ss
*arg_ss
, *tmp_ss
;
9690 gfc_actual_arglist
*arg
;
9692 arg
= expr
->value
.function
.actual
;
9694 gcc_assert (arg
->expr
);
9696 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
9697 gcc_assert (arg_ss
!= gfc_ss_terminator
);
9699 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
9701 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
9702 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
9704 gcc_assert (tmp_ss
->dimen
== 2);
9706 /* We just invert dimensions. */
9707 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
9710 /* Stop when tmp_ss points to the last valid element of the chain... */
9711 if (tmp_ss
->next
== gfc_ss_terminator
)
9715 /* ... so that we can attach the rest of the chain to it. */
9722 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9723 This has the side effect of reversing the nested list, so there is no
9724 need to call gfc_reverse_ss on it (the given list is assumed not to be
9728 nest_loop_dimension (gfc_ss
*ss
, int dim
)
9731 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
9732 gfc_loopinfo
*new_loop
;
9734 gcc_assert (ss
!= gfc_ss_terminator
);
9736 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
9738 new_ss
= gfc_get_ss ();
9739 new_ss
->next
= prev_ss
;
9740 new_ss
->parent
= ss
;
9741 new_ss
->info
= ss
->info
;
9742 new_ss
->info
->refcount
++;
9745 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
9746 && ss
->info
->type
!= GFC_SS_REFERENCE
);
9749 new_ss
->dim
[0] = ss
->dim
[dim
];
9751 gcc_assert (dim
< ss
->dimen
);
9753 ss_dim
= --ss
->dimen
;
9754 for (i
= dim
; i
< ss_dim
; i
++)
9755 ss
->dim
[i
] = ss
->dim
[i
+ 1];
9757 ss
->dim
[ss_dim
] = 0;
9763 ss
->nested_ss
->parent
= new_ss
;
9764 new_ss
->nested_ss
= ss
->nested_ss
;
9766 ss
->nested_ss
= new_ss
;
9769 new_loop
= gfc_get_loopinfo ();
9770 gfc_init_loopinfo (new_loop
);
9772 gcc_assert (prev_ss
!= NULL
);
9773 gcc_assert (prev_ss
!= gfc_ss_terminator
);
9774 gfc_add_ss_to_loop (new_loop
, prev_ss
);
9775 return new_ss
->parent
;
9779 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9780 is to be inlined. */
9783 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
9785 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
9786 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
9788 bool scalar_mask
= false;
9790 /* The rank of the result will be determined later. */
9791 arg1
= expr
->value
.function
.actual
;
9794 gcc_assert (arg3
!= NULL
);
9796 if (expr
->rank
== 0)
9799 tmp_ss
= gfc_ss_terminator
;
9805 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
9806 if (mask_ss
== tmp_ss
)
9812 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
9813 gcc_assert (array_ss
!= tmp_ss
);
9815 /* Odd thing: If the mask is scalar, it is used by the frontend after
9816 the array (to make an if around the nested loop). Thus it shall
9817 be after array_ss once the gfc_ss list is reversed. */
9819 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
9823 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9825 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
9826 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
9834 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
9837 switch (expr
->value
.function
.isym
->id
)
9839 case GFC_ISYM_PRODUCT
:
9841 return walk_inline_intrinsic_arith (ss
, expr
);
9843 case GFC_ISYM_TRANSPOSE
:
9844 return walk_inline_intrinsic_transpose (ss
, expr
);
9853 /* This generates code to execute before entering the scalarization loop.
9854 Currently does nothing. */
9857 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
9859 switch (ss
->info
->expr
->value
.function
.isym
->id
)
9861 case GFC_ISYM_UBOUND
:
9862 case GFC_ISYM_LBOUND
:
9863 case GFC_ISYM_UCOBOUND
:
9864 case GFC_ISYM_LCOBOUND
:
9865 case GFC_ISYM_THIS_IMAGE
:
9874 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9875 are expanded into code inside the scalarization loop. */
9878 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
9880 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
9881 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
9883 /* The two argument version returns a scalar. */
9884 if (expr
->value
.function
.actual
->next
->expr
)
9887 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
9891 /* Walk an intrinsic array libcall. */
9894 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
9896 gcc_assert (expr
->rank
> 0);
9897 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9901 /* Return whether the function call expression EXPR will be expanded
9902 inline by gfc_conv_intrinsic_function. */
9905 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
9907 gfc_actual_arglist
*args
;
9909 if (!expr
->value
.function
.isym
)
9912 switch (expr
->value
.function
.isym
->id
)
9914 case GFC_ISYM_PRODUCT
:
9916 /* Disable inline expansion if code size matters. */
9920 args
= expr
->value
.function
.actual
;
9921 /* We need to be able to subset the SUM argument at compile-time. */
9922 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
9927 case GFC_ISYM_TRANSPOSE
:
9936 /* Returns nonzero if the specified intrinsic function call maps directly to
9937 an external library call. Should only be used for functions that return
9941 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
9943 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
9944 gcc_assert (expr
->rank
> 0);
9946 if (gfc_inline_intrinsic_function_p (expr
))
9949 switch (expr
->value
.function
.isym
->id
)
9953 case GFC_ISYM_COUNT
:
9957 case GFC_ISYM_IPARITY
:
9958 case GFC_ISYM_MATMUL
:
9959 case GFC_ISYM_MAXLOC
:
9960 case GFC_ISYM_MAXVAL
:
9961 case GFC_ISYM_MINLOC
:
9962 case GFC_ISYM_MINVAL
:
9963 case GFC_ISYM_NORM2
:
9964 case GFC_ISYM_PARITY
:
9965 case GFC_ISYM_PRODUCT
:
9967 case GFC_ISYM_SHAPE
:
9968 case GFC_ISYM_SPREAD
:
9970 /* Ignore absent optional parameters. */
9973 case GFC_ISYM_CSHIFT
:
9974 case GFC_ISYM_EOSHIFT
:
9975 case GFC_ISYM_GET_TEAM
:
9976 case GFC_ISYM_FAILED_IMAGES
:
9977 case GFC_ISYM_STOPPED_IMAGES
:
9979 case GFC_ISYM_RESHAPE
:
9980 case GFC_ISYM_UNPACK
:
9981 /* Pass absent optional parameters. */
9989 /* Walk an intrinsic function. */
9991 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
9992 gfc_intrinsic_sym
* isym
)
9996 if (isym
->elemental
)
9997 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9998 NULL
, GFC_SS_SCALAR
);
10000 if (expr
->rank
== 0)
10003 if (gfc_inline_intrinsic_function_p (expr
))
10004 return walk_inline_intrinsic_function (ss
, expr
);
10006 if (gfc_is_intrinsic_libcall (expr
))
10007 return gfc_walk_intrinsic_libfunc (ss
, expr
);
10009 /* Special cases. */
10012 case GFC_ISYM_LBOUND
:
10013 case GFC_ISYM_LCOBOUND
:
10014 case GFC_ISYM_UBOUND
:
10015 case GFC_ISYM_UCOBOUND
:
10016 case GFC_ISYM_THIS_IMAGE
:
10017 return gfc_walk_intrinsic_bound (ss
, expr
);
10019 case GFC_ISYM_TRANSFER
:
10020 case GFC_ISYM_CAF_GET
:
10021 return gfc_walk_intrinsic_libfunc (ss
, expr
);
10024 /* This probably meant someone forgot to add an intrinsic to the above
10025 list(s) when they implemented it, or something's gone horribly
10027 gcc_unreachable ();
10033 conv_co_collective (gfc_code
*code
)
10036 stmtblock_t block
, post_block
;
10037 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
10038 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
10040 gfc_start_block (&block
);
10041 gfc_init_block (&post_block
);
10043 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
10045 opr_expr
= code
->ext
.actual
->next
->expr
;
10046 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
10047 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10048 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
10053 image_idx_expr
= code
->ext
.actual
->next
->expr
;
10054 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
10055 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10061 gfc_init_se (&argse
, NULL
);
10062 gfc_conv_expr (&argse
, stat_expr
);
10063 gfc_add_block_to_block (&block
, &argse
.pre
);
10064 gfc_add_block_to_block (&post_block
, &argse
.post
);
10066 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
10067 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
10069 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
10072 stat
= null_pointer_node
;
10074 /* Early exit for GFC_FCOARRAY_SINGLE. */
10075 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
10077 if (stat
!= NULL_TREE
)
10078 gfc_add_modify (&block
, stat
,
10079 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
10080 return gfc_finish_block (&block
);
10083 /* Handle the array. */
10084 gfc_init_se (&argse
, NULL
);
10085 if (code
->ext
.actual
->expr
->rank
== 0)
10087 symbol_attribute attr
;
10088 gfc_clear_attr (&attr
);
10089 gfc_init_se (&argse
, NULL
);
10090 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10091 gfc_add_block_to_block (&block
, &argse
.pre
);
10092 gfc_add_block_to_block (&post_block
, &argse
.post
);
10093 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
10094 array
= gfc_build_addr_expr (NULL_TREE
, array
);
10098 argse
.want_pointer
= 1;
10099 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
10100 array
= argse
.expr
;
10102 gfc_add_block_to_block (&block
, &argse
.pre
);
10103 gfc_add_block_to_block (&post_block
, &argse
.post
);
10105 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
10106 strlen
= argse
.string_length
;
10108 strlen
= integer_zero_node
;
10111 if (image_idx_expr
)
10113 gfc_init_se (&argse
, NULL
);
10114 gfc_conv_expr (&argse
, image_idx_expr
);
10115 gfc_add_block_to_block (&block
, &argse
.pre
);
10116 gfc_add_block_to_block (&post_block
, &argse
.post
);
10117 image_index
= fold_convert (integer_type_node
, argse
.expr
);
10120 image_index
= integer_zero_node
;
10125 gfc_init_se (&argse
, NULL
);
10126 gfc_conv_expr (&argse
, errmsg_expr
);
10127 gfc_add_block_to_block (&block
, &argse
.pre
);
10128 gfc_add_block_to_block (&post_block
, &argse
.post
);
10129 errmsg
= argse
.expr
;
10130 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
10134 errmsg
= null_pointer_node
;
10135 errmsg_len
= build_zero_cst (size_type_node
);
10138 /* Generate the function call. */
10139 switch (code
->resolved_isym
->id
)
10141 case GFC_ISYM_CO_BROADCAST
:
10142 fndecl
= gfor_fndecl_co_broadcast
;
10144 case GFC_ISYM_CO_MAX
:
10145 fndecl
= gfor_fndecl_co_max
;
10147 case GFC_ISYM_CO_MIN
:
10148 fndecl
= gfor_fndecl_co_min
;
10150 case GFC_ISYM_CO_REDUCE
:
10151 fndecl
= gfor_fndecl_co_reduce
;
10153 case GFC_ISYM_CO_SUM
:
10154 fndecl
= gfor_fndecl_co_sum
;
10157 gcc_unreachable ();
10160 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
10161 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
10162 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
10163 image_index
, stat
, errmsg
, errmsg_len
);
10164 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
10165 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
10166 stat
, errmsg
, strlen
, errmsg_len
);
10169 tree opr
, opr_flags
;
10171 // FIXME: Handle TS29113's bind(C) strings with descriptor.
10173 if (gfc_is_proc_ptr_comp (opr_expr
))
10175 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
10176 opr_flag_int
= sym
->attr
.dimension
10177 || (sym
->ts
.type
== BT_CHARACTER
10178 && !sym
->attr
.is_bind_c
)
10179 ? GFC_CAF_BYREF
: 0;
10180 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
10181 && !sym
->attr
.is_bind_c
10182 ? GFC_CAF_HIDDENLEN
: 0;
10183 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
10187 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
10188 ? GFC_CAF_BYREF
: 0;
10189 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
10190 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
10191 ? GFC_CAF_HIDDENLEN
: 0;
10192 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
10193 ? GFC_CAF_ARG_VALUE
: 0;
10195 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
10196 gfc_conv_expr (&argse
, opr_expr
);
10198 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
10199 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
10202 gfc_add_expr_to_block (&block
, fndecl
);
10203 gfc_add_block_to_block (&block
, &post_block
);
10205 return gfc_finish_block (&block
);
10210 conv_intrinsic_atomic_op (gfc_code
*code
)
10213 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
10214 stmtblock_t block
, post_block
;
10215 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10216 gfc_expr
*stat_expr
;
10217 built_in_function fn
;
10219 if (atom_expr
->expr_type
== EXPR_FUNCTION
10220 && atom_expr
->value
.function
.isym
10221 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10222 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10224 gfc_start_block (&block
);
10225 gfc_init_block (&post_block
);
10227 gfc_init_se (&argse
, NULL
);
10228 argse
.want_pointer
= 1;
10229 gfc_conv_expr (&argse
, atom_expr
);
10230 gfc_add_block_to_block (&block
, &argse
.pre
);
10231 gfc_add_block_to_block (&post_block
, &argse
.post
);
10234 gfc_init_se (&argse
, NULL
);
10235 if (flag_coarray
== GFC_FCOARRAY_LIB
10236 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10237 argse
.want_pointer
= 1;
10238 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10239 gfc_add_block_to_block (&block
, &argse
.pre
);
10240 gfc_add_block_to_block (&post_block
, &argse
.post
);
10241 value
= argse
.expr
;
10243 switch (code
->resolved_isym
->id
)
10245 case GFC_ISYM_ATOMIC_ADD
:
10246 case GFC_ISYM_ATOMIC_AND
:
10247 case GFC_ISYM_ATOMIC_DEF
:
10248 case GFC_ISYM_ATOMIC_OR
:
10249 case GFC_ISYM_ATOMIC_XOR
:
10250 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
10251 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10252 old
= null_pointer_node
;
10255 gfc_init_se (&argse
, NULL
);
10256 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10257 argse
.want_pointer
= 1;
10258 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10259 gfc_add_block_to_block (&block
, &argse
.pre
);
10260 gfc_add_block_to_block (&post_block
, &argse
.post
);
10262 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
10266 if (stat_expr
!= NULL
)
10268 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
10269 gfc_init_se (&argse
, NULL
);
10270 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10271 argse
.want_pointer
= 1;
10272 gfc_conv_expr_val (&argse
, stat_expr
);
10273 gfc_add_block_to_block (&block
, &argse
.pre
);
10274 gfc_add_block_to_block (&post_block
, &argse
.post
);
10277 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10278 stat
= null_pointer_node
;
10280 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10282 tree image_index
, caf_decl
, offset
, token
;
10285 switch (code
->resolved_isym
->id
)
10287 case GFC_ISYM_ATOMIC_ADD
:
10288 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10289 op
= (int) GFC_CAF_ATOMIC_ADD
;
10291 case GFC_ISYM_ATOMIC_AND
:
10292 case GFC_ISYM_ATOMIC_FETCH_AND
:
10293 op
= (int) GFC_CAF_ATOMIC_AND
;
10295 case GFC_ISYM_ATOMIC_OR
:
10296 case GFC_ISYM_ATOMIC_FETCH_OR
:
10297 op
= (int) GFC_CAF_ATOMIC_OR
;
10299 case GFC_ISYM_ATOMIC_XOR
:
10300 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10301 op
= (int) GFC_CAF_ATOMIC_XOR
;
10303 case GFC_ISYM_ATOMIC_DEF
:
10304 op
= 0; /* Unused. */
10307 gcc_unreachable ();
10310 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10311 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10312 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10314 if (gfc_is_coindexed (atom_expr
))
10315 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10317 image_index
= integer_zero_node
;
10319 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10321 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10322 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
10323 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10326 gfc_init_se (&argse
, NULL
);
10327 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10330 gfc_add_block_to_block (&block
, &argse
.pre
);
10331 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
10332 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
10333 token
, offset
, image_index
, value
, stat
,
10334 build_int_cst (integer_type_node
,
10335 (int) atom_expr
->ts
.type
),
10336 build_int_cst (integer_type_node
,
10337 (int) atom_expr
->ts
.kind
));
10339 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
10340 build_int_cst (integer_type_node
, op
),
10341 token
, offset
, image_index
, value
, old
, stat
,
10342 build_int_cst (integer_type_node
,
10343 (int) atom_expr
->ts
.type
),
10344 build_int_cst (integer_type_node
,
10345 (int) atom_expr
->ts
.kind
));
10347 gfc_add_expr_to_block (&block
, tmp
);
10348 gfc_add_block_to_block (&block
, &argse
.post
);
10349 gfc_add_block_to_block (&block
, &post_block
);
10350 return gfc_finish_block (&block
);
10354 switch (code
->resolved_isym
->id
)
10356 case GFC_ISYM_ATOMIC_ADD
:
10357 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10358 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
10360 case GFC_ISYM_ATOMIC_AND
:
10361 case GFC_ISYM_ATOMIC_FETCH_AND
:
10362 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
10364 case GFC_ISYM_ATOMIC_DEF
:
10365 fn
= BUILT_IN_ATOMIC_STORE_N
;
10367 case GFC_ISYM_ATOMIC_OR
:
10368 case GFC_ISYM_ATOMIC_FETCH_OR
:
10369 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
10371 case GFC_ISYM_ATOMIC_XOR
:
10372 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10373 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
10376 gcc_unreachable ();
10379 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10380 fn
= (built_in_function
) ((int) fn
10381 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10383 tmp
= builtin_decl_explicit (fn
);
10384 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
10385 tmp
= builtin_decl_explicit (fn
);
10387 switch (code
->resolved_isym
->id
)
10389 case GFC_ISYM_ATOMIC_ADD
:
10390 case GFC_ISYM_ATOMIC_AND
:
10391 case GFC_ISYM_ATOMIC_DEF
:
10392 case GFC_ISYM_ATOMIC_OR
:
10393 case GFC_ISYM_ATOMIC_XOR
:
10394 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10395 fold_convert (itype
, value
),
10396 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10397 gfc_add_expr_to_block (&block
, tmp
);
10400 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10401 fold_convert (itype
, value
),
10402 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10403 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
10407 if (stat
!= NULL_TREE
)
10408 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10409 gfc_add_block_to_block (&block
, &post_block
);
10410 return gfc_finish_block (&block
);
10415 conv_intrinsic_atomic_ref (gfc_code
*code
)
10418 tree tmp
, atom
, value
, stat
= NULL_TREE
;
10419 stmtblock_t block
, post_block
;
10420 built_in_function fn
;
10421 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
10423 if (atom_expr
->expr_type
== EXPR_FUNCTION
10424 && atom_expr
->value
.function
.isym
10425 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10426 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10428 gfc_start_block (&block
);
10429 gfc_init_block (&post_block
);
10430 gfc_init_se (&argse
, NULL
);
10431 argse
.want_pointer
= 1;
10432 gfc_conv_expr (&argse
, atom_expr
);
10433 gfc_add_block_to_block (&block
, &argse
.pre
);
10434 gfc_add_block_to_block (&post_block
, &argse
.post
);
10437 gfc_init_se (&argse
, NULL
);
10438 if (flag_coarray
== GFC_FCOARRAY_LIB
10439 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10440 argse
.want_pointer
= 1;
10441 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10442 gfc_add_block_to_block (&block
, &argse
.pre
);
10443 gfc_add_block_to_block (&post_block
, &argse
.post
);
10444 value
= argse
.expr
;
10447 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
10449 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10451 gfc_init_se (&argse
, NULL
);
10452 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10453 argse
.want_pointer
= 1;
10454 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10455 gfc_add_block_to_block (&block
, &argse
.pre
);
10456 gfc_add_block_to_block (&post_block
, &argse
.post
);
10459 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10460 stat
= null_pointer_node
;
10462 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10464 tree image_index
, caf_decl
, offset
, token
;
10465 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
10467 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10468 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10469 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10471 if (gfc_is_coindexed (atom_expr
))
10472 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10474 image_index
= integer_zero_node
;
10476 gfc_init_se (&argse
, NULL
);
10477 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10479 gfc_add_block_to_block (&block
, &argse
.pre
);
10481 /* Different type, need type conversion. */
10482 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10484 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10485 orig_value
= value
;
10486 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
10489 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
10490 token
, offset
, image_index
, value
, stat
,
10491 build_int_cst (integer_type_node
,
10492 (int) atom_expr
->ts
.type
),
10493 build_int_cst (integer_type_node
,
10494 (int) atom_expr
->ts
.kind
));
10495 gfc_add_expr_to_block (&block
, tmp
);
10496 if (vardecl
!= NULL_TREE
)
10497 gfc_add_modify (&block
, orig_value
,
10498 fold_convert (TREE_TYPE (orig_value
), vardecl
));
10499 gfc_add_block_to_block (&block
, &argse
.post
);
10500 gfc_add_block_to_block (&block
, &post_block
);
10501 return gfc_finish_block (&block
);
10504 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10505 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
10506 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10508 tmp
= builtin_decl_explicit (fn
);
10509 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
10510 build_int_cst (integer_type_node
,
10511 MEMMODEL_RELAXED
));
10512 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
10514 if (stat
!= NULL_TREE
)
10515 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10516 gfc_add_block_to_block (&block
, &post_block
);
10517 return gfc_finish_block (&block
);
10522 conv_intrinsic_atomic_cas (gfc_code
*code
)
10525 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
10526 stmtblock_t block
, post_block
;
10527 built_in_function fn
;
10528 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10530 if (atom_expr
->expr_type
== EXPR_FUNCTION
10531 && atom_expr
->value
.function
.isym
10532 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10533 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10535 gfc_init_block (&block
);
10536 gfc_init_block (&post_block
);
10537 gfc_init_se (&argse
, NULL
);
10538 argse
.want_pointer
= 1;
10539 gfc_conv_expr (&argse
, atom_expr
);
10542 gfc_init_se (&argse
, NULL
);
10543 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10544 argse
.want_pointer
= 1;
10545 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10546 gfc_add_block_to_block (&block
, &argse
.pre
);
10547 gfc_add_block_to_block (&post_block
, &argse
.post
);
10550 gfc_init_se (&argse
, NULL
);
10551 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10552 argse
.want_pointer
= 1;
10553 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10554 gfc_add_block_to_block (&block
, &argse
.pre
);
10555 gfc_add_block_to_block (&post_block
, &argse
.post
);
10558 gfc_init_se (&argse
, NULL
);
10559 if (flag_coarray
== GFC_FCOARRAY_LIB
10560 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
10561 == atom_expr
->ts
.kind
)
10562 argse
.want_pointer
= 1;
10563 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
10564 gfc_add_block_to_block (&block
, &argse
.pre
);
10565 gfc_add_block_to_block (&post_block
, &argse
.post
);
10566 new_val
= argse
.expr
;
10569 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
10571 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
10573 gfc_init_se (&argse
, NULL
);
10574 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10575 argse
.want_pointer
= 1;
10576 gfc_conv_expr_val (&argse
,
10577 code
->ext
.actual
->next
->next
->next
->next
->expr
);
10578 gfc_add_block_to_block (&block
, &argse
.pre
);
10579 gfc_add_block_to_block (&post_block
, &argse
.post
);
10582 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10583 stat
= null_pointer_node
;
10585 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10587 tree image_index
, caf_decl
, offset
, token
;
10589 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10590 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10591 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10593 if (gfc_is_coindexed (atom_expr
))
10594 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10596 image_index
= integer_zero_node
;
10598 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
10600 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
10601 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
10602 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10605 /* Convert a constant to a pointer. */
10606 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
10608 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
10609 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
10610 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10613 gfc_init_se (&argse
, NULL
);
10614 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10616 gfc_add_block_to_block (&block
, &argse
.pre
);
10618 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
10619 token
, offset
, image_index
, old
, comp
, new_val
,
10620 stat
, build_int_cst (integer_type_node
,
10621 (int) atom_expr
->ts
.type
),
10622 build_int_cst (integer_type_node
,
10623 (int) atom_expr
->ts
.kind
));
10624 gfc_add_expr_to_block (&block
, tmp
);
10625 gfc_add_block_to_block (&block
, &argse
.post
);
10626 gfc_add_block_to_block (&block
, &post_block
);
10627 return gfc_finish_block (&block
);
10630 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10631 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10632 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10634 tmp
= builtin_decl_explicit (fn
);
10636 gfc_add_modify (&block
, old
, comp
);
10637 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
10638 gfc_build_addr_expr (NULL
, old
),
10639 fold_convert (TREE_TYPE (old
), new_val
),
10640 boolean_false_node
,
10641 build_int_cst (NULL
, MEMMODEL_RELAXED
),
10642 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10643 gfc_add_expr_to_block (&block
, tmp
);
10645 if (stat
!= NULL_TREE
)
10646 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10647 gfc_add_block_to_block (&block
, &post_block
);
10648 return gfc_finish_block (&block
);
10652 conv_intrinsic_event_query (gfc_code
*code
)
10655 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
10656 tree count
= NULL_TREE
, count2
= NULL_TREE
;
10658 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
10660 if (code
->ext
.actual
->next
->next
->expr
)
10662 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10664 gfc_init_se (&argse
, NULL
);
10665 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10668 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10669 stat
= null_pointer_node
;
10671 if (code
->ext
.actual
->next
->expr
)
10673 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
10674 gfc_init_se (&argse
, NULL
);
10675 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
10676 count
= argse
.expr
;
10679 gfc_start_block (&se
.pre
);
10680 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10682 tree tmp
, token
, image_index
;
10683 tree index
= size_zero_node
;
10685 if (event_expr
->expr_type
== EXPR_FUNCTION
10686 && event_expr
->value
.function
.isym
10687 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10688 event_expr
= event_expr
->value
.function
.actual
->expr
;
10690 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
10692 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10693 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
10694 != INTMOD_ISO_FORTRAN_ENV
10695 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
10696 != ISOFORTRAN_EVENT_TYPE
)
10698 gfc_error ("Sorry, the event component of derived type at %L is not "
10699 "yet supported", &event_expr
->where
);
10703 if (gfc_is_coindexed (event_expr
))
10705 gfc_error ("The event variable at %L shall not be coindexed",
10706 &event_expr
->where
);
10710 image_index
= integer_zero_node
;
10712 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10715 /* For arrays, obtain the array index. */
10716 if (gfc_expr_attr (event_expr
).dimension
)
10718 tree desc
, tmp
, extent
, lbound
, ubound
;
10719 gfc_array_ref
*ar
, ar2
;
10722 /* TODO: Extend this, once DT components are supported. */
10723 ar
= &event_expr
->ref
->u
.ar
;
10725 memset (ar
, '\0', sizeof (*ar
));
10727 ar
->type
= AR_FULL
;
10729 gfc_init_se (&argse
, NULL
);
10730 argse
.descriptor_only
= 1;
10731 gfc_conv_expr_descriptor (&argse
, event_expr
);
10732 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
10736 extent
= integer_one_node
;
10737 for (i
= 0; i
< ar
->dimen
; i
++)
10739 gfc_init_se (&argse
, NULL
);
10740 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
10741 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
10742 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
10743 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10744 integer_type_node
, argse
.expr
,
10745 fold_convert(integer_type_node
, lbound
));
10746 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10747 integer_type_node
, extent
, tmp
);
10748 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
10749 integer_type_node
, index
, tmp
);
10750 if (i
< ar
->dimen
- 1)
10752 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
10753 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10754 tmp
= fold_convert (integer_type_node
, tmp
);
10755 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
10756 integer_type_node
, extent
, tmp
);
10761 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
10764 count
= gfc_create_var (integer_type_node
, "count");
10767 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
10770 stat
= gfc_create_var (integer_type_node
, "stat");
10773 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
10774 token
, index
, image_index
, count
10775 ? gfc_build_addr_expr (NULL
, count
) : count
,
10776 stat
!= null_pointer_node
10777 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
10778 gfc_add_expr_to_block (&se
.pre
, tmp
);
10780 if (count2
!= NULL_TREE
)
10781 gfc_add_modify (&se
.pre
, count2
,
10782 fold_convert (TREE_TYPE (count2
), count
));
10784 if (stat2
!= NULL_TREE
)
10785 gfc_add_modify (&se
.pre
, stat2
,
10786 fold_convert (TREE_TYPE (stat2
), stat
));
10788 return gfc_finish_block (&se
.pre
);
10791 gfc_init_se (&argse
, NULL
);
10792 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
10793 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
10795 if (stat
!= NULL_TREE
)
10796 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10798 return gfc_finish_block (&se
.pre
);
10802 conv_intrinsic_move_alloc (gfc_code
*code
)
10805 gfc_expr
*from_expr
, *to_expr
;
10806 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
10807 gfc_se from_se
, to_se
;
10811 gfc_start_block (&block
);
10813 from_expr
= code
->ext
.actual
->expr
;
10814 to_expr
= code
->ext
.actual
->next
->expr
;
10816 gfc_init_se (&from_se
, NULL
);
10817 gfc_init_se (&to_se
, NULL
);
10819 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
10820 || to_expr
->ts
.type
== BT_CLASS
);
10821 coarray
= gfc_get_corank (from_expr
) != 0;
10823 if (from_expr
->rank
== 0 && !coarray
)
10825 if (from_expr
->ts
.type
!= BT_CLASS
)
10826 from_expr2
= from_expr
;
10829 from_expr2
= gfc_copy_expr (from_expr
);
10830 gfc_add_data_component (from_expr2
);
10833 if (to_expr
->ts
.type
!= BT_CLASS
)
10834 to_expr2
= to_expr
;
10837 to_expr2
= gfc_copy_expr (to_expr
);
10838 gfc_add_data_component (to_expr2
);
10841 from_se
.want_pointer
= 1;
10842 to_se
.want_pointer
= 1;
10843 gfc_conv_expr (&from_se
, from_expr2
);
10844 gfc_conv_expr (&to_se
, to_expr2
);
10845 gfc_add_block_to_block (&block
, &from_se
.pre
);
10846 gfc_add_block_to_block (&block
, &to_se
.pre
);
10848 /* Deallocate "to". */
10849 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10850 true, to_expr
, to_expr
->ts
);
10851 gfc_add_expr_to_block (&block
, tmp
);
10853 /* Assign (_data) pointers. */
10854 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10855 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
10857 /* Set "from" to NULL. */
10858 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10859 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
10861 gfc_add_block_to_block (&block
, &from_se
.post
);
10862 gfc_add_block_to_block (&block
, &to_se
.post
);
10865 if (to_expr
->ts
.type
== BT_CLASS
)
10869 gfc_free_expr (to_expr2
);
10870 gfc_init_se (&to_se
, NULL
);
10871 to_se
.want_pointer
= 1;
10872 gfc_add_vptr_component (to_expr
);
10873 gfc_conv_expr (&to_se
, to_expr
);
10875 if (from_expr
->ts
.type
== BT_CLASS
)
10877 if (UNLIMITED_POLY (from_expr
))
10881 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10885 gfc_free_expr (from_expr2
);
10886 gfc_init_se (&from_se
, NULL
);
10887 from_se
.want_pointer
= 1;
10888 gfc_add_vptr_component (from_expr
);
10889 gfc_conv_expr (&from_se
, from_expr
);
10890 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10891 fold_convert (TREE_TYPE (to_se
.expr
),
10894 /* Reset _vptr component to declared type. */
10896 /* Unlimited polymorphic. */
10897 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10898 fold_convert (TREE_TYPE (from_se
.expr
),
10899 null_pointer_node
));
10902 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10903 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10904 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10909 vtab
= gfc_find_vtab (&from_expr
->ts
);
10911 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10912 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10913 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10917 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10919 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10920 fold_convert (TREE_TYPE (to_se
.string_length
),
10921 from_se
.string_length
));
10922 if (from_expr
->ts
.deferred
)
10923 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10924 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10927 return gfc_finish_block (&block
);
10930 /* Update _vptr component. */
10931 if (to_expr
->ts
.type
== BT_CLASS
)
10935 to_se
.want_pointer
= 1;
10936 to_expr2
= gfc_copy_expr (to_expr
);
10937 gfc_add_vptr_component (to_expr2
);
10938 gfc_conv_expr (&to_se
, to_expr2
);
10940 if (from_expr
->ts
.type
== BT_CLASS
)
10942 if (UNLIMITED_POLY (from_expr
))
10946 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10950 from_se
.want_pointer
= 1;
10951 from_expr2
= gfc_copy_expr (from_expr
);
10952 gfc_add_vptr_component (from_expr2
);
10953 gfc_conv_expr (&from_se
, from_expr2
);
10954 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10955 fold_convert (TREE_TYPE (to_se
.expr
),
10958 /* Reset _vptr component to declared type. */
10960 /* Unlimited polymorphic. */
10961 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10962 fold_convert (TREE_TYPE (from_se
.expr
),
10963 null_pointer_node
));
10966 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10967 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10968 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10973 vtab
= gfc_find_vtab (&from_expr
->ts
);
10975 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10976 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10977 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10980 gfc_free_expr (to_expr2
);
10981 gfc_init_se (&to_se
, NULL
);
10983 if (from_expr
->ts
.type
== BT_CLASS
)
10985 gfc_free_expr (from_expr2
);
10986 gfc_init_se (&from_se
, NULL
);
10991 /* Deallocate "to". */
10992 if (from_expr
->rank
== 0)
10994 to_se
.want_coarray
= 1;
10995 from_se
.want_coarray
= 1;
10997 gfc_conv_expr_descriptor (&to_se
, to_expr
);
10998 gfc_conv_expr_descriptor (&from_se
, from_expr
);
11000 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
11001 is an image control "statement", cf. IR F08/0040 in 12-006A. */
11002 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
11006 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
11007 NULL_TREE
, NULL_TREE
, true, to_expr
,
11008 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
11009 gfc_add_expr_to_block (&block
, tmp
);
11011 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
11012 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
11013 logical_type_node
, tmp
,
11014 fold_convert (TREE_TYPE (tmp
),
11015 null_pointer_node
));
11016 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
11017 3, null_pointer_node
, null_pointer_node
,
11018 build_int_cst (integer_type_node
, 0));
11020 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
11021 tmp
, build_empty_stmt (input_location
));
11022 gfc_add_expr_to_block (&block
, tmp
);
11026 if (to_expr
->ts
.type
== BT_DERIVED
11027 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
11029 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
11030 to_se
.expr
, to_expr
->rank
);
11031 gfc_add_expr_to_block (&block
, tmp
);
11034 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
11035 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
11036 NULL_TREE
, true, to_expr
,
11037 GFC_CAF_COARRAY_NOCOARRAY
);
11038 gfc_add_expr_to_block (&block
, tmp
);
11041 /* Move the pointer and update the array descriptor data. */
11042 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
11044 /* Set "from" to NULL. */
11045 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
11046 gfc_add_modify_loc (input_location
, &block
, tmp
,
11047 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
11050 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
11052 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
11053 fold_convert (TREE_TYPE (to_se
.string_length
),
11054 from_se
.string_length
));
11055 if (from_expr
->ts
.deferred
)
11056 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
11057 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
11060 return gfc_finish_block (&block
);
11065 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
11069 gcc_assert (code
->resolved_isym
);
11071 switch (code
->resolved_isym
->id
)
11073 case GFC_ISYM_MOVE_ALLOC
:
11074 res
= conv_intrinsic_move_alloc (code
);
11077 case GFC_ISYM_ATOMIC_CAS
:
11078 res
= conv_intrinsic_atomic_cas (code
);
11081 case GFC_ISYM_ATOMIC_ADD
:
11082 case GFC_ISYM_ATOMIC_AND
:
11083 case GFC_ISYM_ATOMIC_DEF
:
11084 case GFC_ISYM_ATOMIC_OR
:
11085 case GFC_ISYM_ATOMIC_XOR
:
11086 case GFC_ISYM_ATOMIC_FETCH_ADD
:
11087 case GFC_ISYM_ATOMIC_FETCH_AND
:
11088 case GFC_ISYM_ATOMIC_FETCH_OR
:
11089 case GFC_ISYM_ATOMIC_FETCH_XOR
:
11090 res
= conv_intrinsic_atomic_op (code
);
11093 case GFC_ISYM_ATOMIC_REF
:
11094 res
= conv_intrinsic_atomic_ref (code
);
11097 case GFC_ISYM_EVENT_QUERY
:
11098 res
= conv_intrinsic_event_query (code
);
11101 case GFC_ISYM_C_F_POINTER
:
11102 case GFC_ISYM_C_F_PROCPOINTER
:
11103 res
= conv_isocbinding_subroutine (code
);
11106 case GFC_ISYM_CAF_SEND
:
11107 res
= conv_caf_send (code
);
11110 case GFC_ISYM_CO_BROADCAST
:
11111 case GFC_ISYM_CO_MIN
:
11112 case GFC_ISYM_CO_MAX
:
11113 case GFC_ISYM_CO_REDUCE
:
11114 case GFC_ISYM_CO_SUM
:
11115 res
= conv_co_collective (code
);
11118 case GFC_ISYM_FREE
:
11119 res
= conv_intrinsic_free (code
);
11122 case GFC_ISYM_RANDOM_INIT
:
11123 res
= conv_intrinsic_random_init (code
);
11126 case GFC_ISYM_KILL
:
11127 res
= conv_intrinsic_kill_sub (code
);
11130 case GFC_ISYM_SYSTEM_CLOCK
:
11131 res
= conv_intrinsic_system_clock (code
);
11142 #include "gt-fortran-trans-intrinsic.h"