1 /* Intrinsic translation
2 Copyright (C) 2002-2017 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 "tree-nested.h"
35 #include "stor-layout.h"
36 #include "toplev.h" /* For rest_of_decl_compilation. */
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 #include "dependency.h" /* For CAF array alias analysis. */
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 /* This maps Fortran intrinsic math functions to external library or GCC
46 typedef struct GTY(()) gfc_intrinsic_map_t
{
47 /* The explicit enum is required to work around inadequacies in the
48 garbage collection/gengtype parsing mechanism. */
51 /* Enum value from the "language-independent", aka C-centric, part
52 of gcc, or END_BUILTINS of no such value set. */
53 enum built_in_function float_built_in
;
54 enum built_in_function double_built_in
;
55 enum built_in_function long_double_built_in
;
56 enum built_in_function complex_float_built_in
;
57 enum built_in_function complex_double_built_in
;
58 enum built_in_function complex_long_double_built_in
;
60 /* True if the naming pattern is to prepend "c" for complex and
61 append "f" for kind=4. False if the naming pattern is to
62 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
65 /* True if a complex version of the function exists. */
66 bool complex_available
;
68 /* True if the function should be marked const. */
71 /* The base library name of this function. */
74 /* Cache decls created for the various operand types. */
86 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
87 defines complex variants of all of the entries in mathbuiltins.def
89 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
90 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
91 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
92 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
93 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
95 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
96 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
97 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
98 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
99 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
101 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
102 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
107 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
108 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
109 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
115 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
116 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
117 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
118 #include "mathbuiltins.def"
120 /* Functions in libgfortran. */
121 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
124 LIB_FUNCTION (NONE
, NULL
, false)
129 #undef DEFINE_MATH_BUILTIN
130 #undef DEFINE_MATH_BUILTIN_C
133 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
136 /* Find the correct variant of a given builtin from its argument. */
138 builtin_decl_for_precision (enum built_in_function base_built_in
,
141 enum built_in_function i
= END_BUILTINS
;
143 gfc_intrinsic_map_t
*m
;
144 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
147 if (precision
== TYPE_PRECISION (float_type_node
))
148 i
= m
->float_built_in
;
149 else if (precision
== TYPE_PRECISION (double_type_node
))
150 i
= m
->double_built_in
;
151 else if (precision
== TYPE_PRECISION (long_double_type_node
))
152 i
= m
->long_double_built_in
;
153 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
155 /* Special treatment, because it is not exactly a built-in, but
156 a library function. */
157 return m
->real16_decl
;
160 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
165 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
168 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
170 if (gfc_real_kinds
[i
].c_float128
)
172 /* For __float128, the story is a bit different, because we return
173 a decl to a library function rather than a built-in. */
174 gfc_intrinsic_map_t
*m
;
175 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
178 return m
->real16_decl
;
181 return builtin_decl_for_precision (double_built_in
,
182 gfc_real_kinds
[i
].mode_precision
);
186 /* Evaluate the arguments to an intrinsic function. The value
187 of NARGS may be less than the actual number of arguments in EXPR
188 to allow optional "KIND" arguments that are not included in the
189 generated code to be ignored. */
192 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
193 tree
*argarray
, int nargs
)
195 gfc_actual_arglist
*actual
;
197 gfc_intrinsic_arg
*formal
;
201 formal
= expr
->value
.function
.isym
->formal
;
202 actual
= expr
->value
.function
.actual
;
204 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
205 actual
= actual
->next
,
206 formal
= formal
? formal
->next
: NULL
)
210 /* Skip omitted optional arguments. */
217 /* Evaluate the parameter. This will substitute scalarized
218 references automatically. */
219 gfc_init_se (&argse
, se
);
221 if (e
->ts
.type
== BT_CHARACTER
)
223 gfc_conv_expr (&argse
, e
);
224 gfc_conv_string_parameter (&argse
);
225 argarray
[curr_arg
++] = argse
.string_length
;
226 gcc_assert (curr_arg
< nargs
);
229 gfc_conv_expr_val (&argse
, e
);
231 /* If an optional argument is itself an optional dummy argument,
232 check its presence and substitute a null if absent. */
233 if (e
->expr_type
== EXPR_VARIABLE
234 && e
->symtree
->n
.sym
->attr
.optional
237 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
239 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
240 gfc_add_block_to_block (&se
->post
, &argse
.post
);
241 argarray
[curr_arg
] = argse
.expr
;
245 /* Count the number of actual arguments to the intrinsic function EXPR
246 including any "hidden" string length arguments. */
249 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
252 gfc_actual_arglist
*actual
;
254 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
259 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
269 /* Conversions between different types are output by the frontend as
270 intrinsic functions. We implement these directly with inline code. */
273 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
279 nargs
= gfc_intrinsic_argument_list_length (expr
);
280 args
= XALLOCAVEC (tree
, nargs
);
282 /* Evaluate all the arguments passed. Whilst we're only interested in the
283 first one here, there are other parts of the front-end that assume this
284 and will trigger an ICE if it's not the case. */
285 type
= gfc_typenode_for_spec (&expr
->ts
);
286 gcc_assert (expr
->value
.function
.actual
->expr
);
287 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
289 /* Conversion between character kinds involves a call to a library
291 if (expr
->ts
.type
== BT_CHARACTER
)
293 tree fndecl
, var
, addr
, tmp
;
295 if (expr
->ts
.kind
== 1
296 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
297 fndecl
= gfor_fndecl_convert_char4_to_char1
;
298 else if (expr
->ts
.kind
== 4
299 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
300 fndecl
= gfor_fndecl_convert_char1_to_char4
;
304 /* Create the variable storing the converted value. */
305 type
= gfc_get_pchar_type (expr
->ts
.kind
);
306 var
= gfc_create_var (type
, "str");
307 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
309 /* Call the library function that will perform the conversion. */
310 gcc_assert (nargs
>= 2);
311 tmp
= build_call_expr_loc (input_location
,
312 fndecl
, 3, addr
, args
[0], args
[1]);
313 gfc_add_expr_to_block (&se
->pre
, tmp
);
315 /* Free the temporary afterwards. */
316 tmp
= gfc_call_free (var
);
317 gfc_add_expr_to_block (&se
->post
, tmp
);
320 se
->string_length
= args
[0];
325 /* Conversion from complex to non-complex involves taking the real
326 component of the value. */
327 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
328 && expr
->ts
.type
!= BT_COMPLEX
)
332 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
333 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
337 se
->expr
= convert (type
, args
[0]);
340 /* This is needed because the gcc backend only implements
341 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
342 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
343 Similarly for CEILING. */
346 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
353 argtype
= TREE_TYPE (arg
);
354 arg
= gfc_evaluate_now (arg
, pblock
);
356 intval
= convert (type
, arg
);
357 intval
= gfc_evaluate_now (intval
, pblock
);
359 tmp
= convert (argtype
, intval
);
360 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
361 boolean_type_node
, tmp
, arg
);
363 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
364 intval
, build_int_cst (type
, 1));
365 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
370 /* Round to nearest integer, away from zero. */
373 build_round_expr (tree arg
, tree restype
)
377 int argprec
, resprec
;
379 argtype
= TREE_TYPE (arg
);
380 argprec
= TYPE_PRECISION (argtype
);
381 resprec
= TYPE_PRECISION (restype
);
383 /* Depending on the type of the result, choose the int intrinsic
384 (iround, available only as a builtin, therefore cannot use it for
385 __float128), long int intrinsic (lround family) or long long
386 intrinsic (llround). We might also need to convert the result
388 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
389 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
390 else if (resprec
<= LONG_TYPE_SIZE
)
391 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
392 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
393 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
397 return fold_convert (restype
, build_call_expr_loc (input_location
,
402 /* Convert a real to an integer using a specific rounding mode.
403 Ideally we would just build the corresponding GENERIC node,
404 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
407 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
408 enum rounding_mode op
)
413 return build_fixbound_expr (pblock
, arg
, type
, 0);
416 return build_fixbound_expr (pblock
, arg
, type
, 1);
419 return build_round_expr (arg
, type
);
422 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
430 /* Round a real value using the specified rounding mode.
431 We use a temporary integer of that same kind size as the result.
432 Values larger than those that can be represented by this kind are
433 unchanged, as they will not be accurate enough to represent the
435 huge = HUGE (KIND (a))
436 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
440 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
452 kind
= expr
->ts
.kind
;
453 nargs
= gfc_intrinsic_argument_list_length (expr
);
456 /* We have builtin functions for some cases. */
460 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
464 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
471 /* Evaluate the argument. */
472 gcc_assert (expr
->value
.function
.actual
->expr
);
473 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
475 /* Use a builtin function if one exists. */
476 if (decl
!= NULL_TREE
)
478 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
482 /* This code is probably redundant, but we'll keep it lying around just
484 type
= gfc_typenode_for_spec (&expr
->ts
);
485 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
487 /* Test if the value is too large to handle sensibly. */
488 gfc_set_model_kind (kind
);
490 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
491 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
492 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
493 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
496 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
497 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
498 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
500 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
502 itype
= gfc_get_int_type (kind
);
504 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
505 tmp
= convert (type
, tmp
);
506 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
512 /* Convert to an integer using the specified rounding mode. */
515 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
521 nargs
= gfc_intrinsic_argument_list_length (expr
);
522 args
= XALLOCAVEC (tree
, nargs
);
524 /* Evaluate the argument, we process all arguments even though we only
525 use the first one for code generation purposes. */
526 type
= gfc_typenode_for_spec (&expr
->ts
);
527 gcc_assert (expr
->value
.function
.actual
->expr
);
528 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
530 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
532 /* Conversion to a different integer kind. */
533 se
->expr
= convert (type
, args
[0]);
537 /* Conversion from complex to non-complex involves taking the real
538 component of the value. */
539 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
540 && expr
->ts
.type
!= BT_COMPLEX
)
544 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
545 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
549 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
554 /* Get the imaginary component of a value. */
557 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
561 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
562 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
563 TREE_TYPE (TREE_TYPE (arg
)), arg
);
567 /* Get the complex conjugate of a value. */
570 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
574 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
575 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
581 define_quad_builtin (const char *name
, tree type
, bool is_const
)
584 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
587 /* Mark the decl as external. */
588 DECL_EXTERNAL (fndecl
) = 1;
589 TREE_PUBLIC (fndecl
) = 1;
591 /* Mark it __attribute__((const)). */
592 TREE_READONLY (fndecl
) = is_const
;
594 rest_of_decl_compilation (fndecl
, 1, 0);
601 /* Initialize function decls for library functions. The external functions
602 are created as required. Builtin functions are added here. */
605 gfc_build_intrinsic_lib_fndecls (void)
607 gfc_intrinsic_map_t
*m
;
608 tree quad_decls
[END_BUILTINS
+ 1];
610 if (gfc_real16_is_float128
)
612 /* If we have soft-float types, we create the decls for their
613 C99-like library functions. For now, we only handle __float128
614 q-suffixed functions. */
616 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
617 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
619 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
621 type
= gfc_float128_type_node
;
622 complex_type
= gfc_complex_float128_type_node
;
623 /* type (*) (type) */
624 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
626 func_iround
= build_function_type_list (integer_type_node
,
628 /* long (*) (type) */
629 func_lround
= build_function_type_list (long_integer_type_node
,
631 /* long long (*) (type) */
632 func_llround
= build_function_type_list (long_long_integer_type_node
,
634 /* type (*) (type, type) */
635 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
636 /* type (*) (type, &int) */
638 = build_function_type_list (type
,
640 build_pointer_type (integer_type_node
),
642 /* type (*) (type, int) */
643 func_scalbn
= build_function_type_list (type
,
644 type
, integer_type_node
, NULL_TREE
);
645 /* type (*) (complex type) */
646 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
647 /* complex type (*) (complex type, complex type) */
649 = build_function_type_list (complex_type
,
650 complex_type
, complex_type
, NULL_TREE
);
652 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
653 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
654 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
656 /* Only these built-ins are actually needed here. These are used directly
657 from the code, when calling builtin_decl_for_precision() or
658 builtin_decl_for_float_type(). The others are all constructed by
659 gfc_get_intrinsic_lib_fndecl(). */
660 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
661 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
663 #include "mathbuiltins.def"
667 #undef DEFINE_MATH_BUILTIN
668 #undef DEFINE_MATH_BUILTIN_C
670 /* There is one built-in we defined manually, because it gets called
671 with builtin_decl_for_precision() or builtin_decl_for_float_type()
672 even though it is not an OTHER_BUILTIN: it is SQRT. */
673 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
677 /* Add GCC builtin functions. */
678 for (m
= gfc_intrinsic_map
;
679 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
681 if (m
->float_built_in
!= END_BUILTINS
)
682 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
683 if (m
->complex_float_built_in
!= END_BUILTINS
)
684 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
685 if (m
->double_built_in
!= END_BUILTINS
)
686 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
687 if (m
->complex_double_built_in
!= END_BUILTINS
)
688 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
690 /* If real(kind=10) exists, it is always long double. */
691 if (m
->long_double_built_in
!= END_BUILTINS
)
692 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
693 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
695 = builtin_decl_explicit (m
->complex_long_double_built_in
);
697 if (!gfc_real16_is_float128
)
699 if (m
->long_double_built_in
!= END_BUILTINS
)
700 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
701 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
703 = builtin_decl_explicit (m
->complex_long_double_built_in
);
705 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m
->real16_decl
= quad_decls
[m
->double_built_in
];
712 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
714 /* Same thing for the complex ones. */
715 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
721 /* Create a fndecl for a simple intrinsic library function. */
724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
727 vec
<tree
, va_gc
> *argtypes
;
729 gfc_actual_arglist
*actual
;
732 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
735 if (ts
->type
== BT_REAL
)
740 pdecl
= &m
->real4_decl
;
743 pdecl
= &m
->real8_decl
;
746 pdecl
= &m
->real10_decl
;
749 pdecl
= &m
->real16_decl
;
755 else if (ts
->type
== BT_COMPLEX
)
757 gcc_assert (m
->complex_available
);
762 pdecl
= &m
->complex4_decl
;
765 pdecl
= &m
->complex8_decl
;
768 pdecl
= &m
->complex10_decl
;
771 pdecl
= &m
->complex16_decl
;
785 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
786 if (gfc_real_kinds
[n
].c_float
)
787 snprintf (name
, sizeof (name
), "%s%s%s",
788 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
789 else if (gfc_real_kinds
[n
].c_double
)
790 snprintf (name
, sizeof (name
), "%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
792 else if (gfc_real_kinds
[n
].c_long_double
)
793 snprintf (name
, sizeof (name
), "%s%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
795 else if (gfc_real_kinds
[n
].c_float128
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
803 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
804 ts
->type
== BT_COMPLEX
? 'c' : 'r',
809 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
811 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
812 vec_safe_push (argtypes
, type
);
814 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
815 fndecl
= build_decl (input_location
,
816 FUNCTION_DECL
, get_identifier (name
), type
);
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl
) = 1;
820 TREE_PUBLIC (fndecl
) = 1;
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl
) = m
->is_constant
;
825 rest_of_decl_compilation (fndecl
, 1, 0);
832 /* Convert an intrinsic function into an external or builtin call. */
835 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
837 gfc_intrinsic_map_t
*m
;
841 unsigned int num_args
;
844 id
= expr
->value
.function
.isym
->id
;
845 /* Find the entry for this function. */
846 for (m
= gfc_intrinsic_map
;
847 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
853 if (m
->id
== GFC_ISYM_NONE
)
855 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
856 expr
->value
.function
.name
, id
);
859 /* Get the decl and generate the call. */
860 num_args
= gfc_intrinsic_argument_list_length (expr
);
861 args
= XALLOCAVEC (tree
, num_args
);
863 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
864 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
865 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
867 fndecl
= build_addr (fndecl
);
868 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
877 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
878 tree a
, tree b
, stmtblock_t
* target
)
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
887 /* Compare the two string lengths. */
888 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
890 /* Output the runtime-check. */
891 name
= gfc_build_cstring_const (intr_name
);
892 name
= gfc_build_addr_expr (pchar_type_node
, name
);
893 gfc_trans_runtime_check (true, false, cond
, target
, where
,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node
, a
),
896 fold_convert (long_integer_type_node
, b
), name
);
900 /* The EXPONENT(X) intrinsic function is translated into
902 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
903 so that if X is a NaN or infinity, the result is HUGE(0).
907 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
909 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
912 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
913 expr
->value
.function
.actual
->expr
->ts
.kind
);
915 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
916 arg
= gfc_evaluate_now (arg
, &se
->pre
);
918 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
919 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
920 cond
= build_call_expr_loc (input_location
,
921 builtin_decl_explicit (BUILT_IN_ISFINITE
),
924 res
= gfc_create_var (integer_type_node
, NULL
);
925 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
926 gfc_build_addr_expr (NULL_TREE
, res
));
927 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
929 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
932 type
= gfc_typenode_for_spec (&expr
->ts
);
933 se
->expr
= fold_convert (type
, se
->expr
);
937 /* Fill in the following structure
938 struct caf_vector_t {
939 size_t nvec; // size of the vector
946 ptrdiff_t lower_bound;
947 ptrdiff_t upper_bound;
954 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
955 tree lower
, tree upper
, tree stride
,
956 tree vector
, int kind
, tree nvec
)
958 tree field
, type
, tmp
;
960 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
961 type
= TREE_TYPE (desc
);
963 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
964 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
965 desc
, field
, NULL_TREE
);
966 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
969 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
970 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
971 desc
, field
, NULL_TREE
);
972 type
= TREE_TYPE (desc
);
974 /* Access the inner struct. */
975 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
976 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
977 desc
, field
, NULL_TREE
);
978 type
= TREE_TYPE (desc
);
980 if (vector
!= NULL_TREE
)
982 /* Set vector and kind. */
983 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
984 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
985 desc
, field
, NULL_TREE
);
986 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
987 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
988 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
989 desc
, field
, NULL_TREE
);
990 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
994 /* Set dim.lower/upper/stride. */
995 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
996 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
997 desc
, field
, NULL_TREE
);
998 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1000 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1001 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1002 desc
, field
, NULL_TREE
);
1003 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1005 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1006 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1007 desc
, field
, NULL_TREE
);
1008 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1014 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1017 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1018 tree lbound
, ubound
, tmp
;
1021 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1023 for (i
= 0; i
< ar
->dimen
; i
++)
1024 switch (ar
->dimen_type
[i
])
1029 gfc_init_se (&argse
, NULL
);
1030 gfc_conv_expr (&argse
, ar
->end
[i
]);
1031 gfc_add_block_to_block (block
, &argse
.pre
);
1032 upper
= gfc_evaluate_now (argse
.expr
, block
);
1035 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1038 gfc_init_se (&argse
, NULL
);
1039 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1040 gfc_add_block_to_block (block
, &argse
.pre
);
1041 stride
= gfc_evaluate_now (argse
.expr
, block
);
1044 stride
= gfc_index_one_node
;
1050 gfc_init_se (&argse
, NULL
);
1051 gfc_conv_expr (&argse
, ar
->start
[i
]);
1052 gfc_add_block_to_block (block
, &argse
.pre
);
1053 lower
= gfc_evaluate_now (argse
.expr
, block
);
1056 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1057 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1060 stride
= gfc_index_one_node
;
1063 nvec
= size_zero_node
;
1064 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1069 gfc_init_se (&argse
, NULL
);
1070 argse
.descriptor_only
= 1;
1071 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1072 gfc_add_block_to_block (block
, &argse
.pre
);
1073 vector
= argse
.expr
;
1074 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1075 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1076 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1077 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1078 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1079 TREE_TYPE (nvec
), nvec
, tmp
);
1080 lower
= gfc_index_zero_node
;
1081 upper
= gfc_index_zero_node
;
1082 stride
= gfc_index_zero_node
;
1083 vector
= gfc_conv_descriptor_data_get (vector
);
1084 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1085 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1090 return gfc_build_addr_expr (NULL_TREE
, var
);
1095 compute_component_offset (tree field
, tree type
)
1098 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1099 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1101 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1102 DECL_FIELD_BIT_OFFSET (field
),
1104 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1107 return DECL_FIELD_OFFSET (field
);
1112 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1114 gfc_ref
*ref
= expr
->ref
, *last_comp_ref
;
1115 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1116 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1117 start
, end
, stride
, vector
, nvec
;
1119 bool ref_static_array
= false;
1120 tree last_component_ref_tree
= NULL_TREE
;
1125 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1126 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
1127 && !expr
->symtree
->n
.sym
->attr
.pointer
;
1130 /* Prevent uninit-warning. */
1131 reference_type
= NULL_TREE
;
1133 /* Skip refs upto the first coarray-ref. */
1134 last_comp_ref
= NULL
;
1135 while (ref
&& (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
== 0))
1137 /* Remember the type of components skipped. */
1138 if (ref
->type
== REF_COMPONENT
)
1139 last_comp_ref
= ref
;
1142 /* When a component was skipped, get the type information of the last
1143 component ref, else get the type from the symbol. */
1146 last_type
= gfc_typenode_for_spec (&last_comp_ref
->u
.c
.component
->ts
);
1147 last_type_n
= last_comp_ref
->u
.c
.component
->ts
.type
;
1151 last_type
= gfc_typenode_for_spec (&expr
->symtree
->n
.sym
->ts
);
1152 last_type_n
= expr
->symtree
->n
.sym
->ts
.type
;
1157 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0
1158 && ref
->u
.ar
.dimen
== 0)
1160 /* Skip pure coindexes. */
1164 tmp
= gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1165 reference_type
= TREE_TYPE (tmp
);
1167 if (caf_ref
== NULL_TREE
)
1170 /* Construct the chain of refs. */
1171 if (prev_caf_ref
!= NULL_TREE
)
1173 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1174 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1175 TREE_TYPE (field
), prev_caf_ref
, field
,
1177 gfc_add_modify (block
, tmp2
, gfc_build_addr_expr (TREE_TYPE (field
),
1185 last_type
= gfc_typenode_for_spec (&ref
->u
.c
.component
->ts
);
1186 last_type_n
= ref
->u
.c
.component
->ts
.type
;
1187 /* Set the type of the ref. */
1188 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1189 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1190 TREE_TYPE (field
), prev_caf_ref
, field
,
1192 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1193 GFC_CAF_REF_COMPONENT
));
1195 /* Ref the c in union u. */
1196 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1197 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1198 TREE_TYPE (field
), prev_caf_ref
, field
,
1200 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 0);
1201 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1202 TREE_TYPE (field
), tmp
, field
,
1205 /* Set the offset. */
1206 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1207 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1208 TREE_TYPE (field
), inner_struct
, field
,
1210 /* Computing the offset is somewhat harder. The bit_offset has to be
1211 taken into account. When the bit_offset in the field_decl is non-
1212 null, divide it by the bitsize_unit and add it to the regular
1214 tmp2
= compute_component_offset (ref
->u
.c
.component
->backend_decl
,
1216 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1218 /* Set caf_token_offset. */
1219 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 1);
1220 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1221 TREE_TYPE (field
), inner_struct
, field
,
1223 if ((ref
->u
.c
.component
->attr
.allocatable
1224 || ref
->u
.c
.component
->attr
.pointer
)
1225 && ref
->u
.c
.component
->attr
.dimension
)
1227 tree arr_desc_token_offset
;
1228 /* Get the token field from the descriptor. */
1229 arr_desc_token_offset
= TREE_OPERAND (
1230 gfc_conv_descriptor_token (ref
->u
.c
.component
->backend_decl
), 1);
1231 arr_desc_token_offset
1232 = compute_component_offset (arr_desc_token_offset
,
1234 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
,
1235 TREE_TYPE (tmp2
), tmp2
,
1236 arr_desc_token_offset
);
1238 else if (ref
->u
.c
.component
->caf_token
)
1239 tmp2
= compute_component_offset (ref
->u
.c
.component
->caf_token
,
1242 tmp2
= integer_zero_node
;
1243 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1245 /* Remember whether this ref was to a non-allocatable/non-pointer
1246 component so the next array ref can be tailored correctly. */
1247 ref_static_array
= !ref
->u
.c
.component
->attr
.allocatable
1248 && !ref
->u
.c
.component
->attr
.pointer
;
1249 last_component_ref_tree
= ref_static_array
1250 ? ref
->u
.c
.component
->backend_decl
: NULL_TREE
;
1253 if (ref_static_array
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
)
1254 ref_static_array
= false;
1255 /* Set the type of the ref. */
1256 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1257 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1258 TREE_TYPE (field
), prev_caf_ref
, field
,
1260 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1262 ? GFC_CAF_REF_STATIC_ARRAY
1263 : GFC_CAF_REF_ARRAY
));
1265 /* Ref the a in union u. */
1266 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1267 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1268 TREE_TYPE (field
), prev_caf_ref
, field
,
1270 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 1);
1271 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1272 TREE_TYPE (field
), tmp
, field
,
1275 /* Set the static_array_type in a for static arrays. */
1276 if (ref_static_array
)
1278 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)),
1280 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1281 TREE_TYPE (field
), inner_struct
, field
,
1283 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (tmp
),
1286 /* Ref the mode in the inner_struct. */
1287 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1288 mode
= fold_build3_loc (input_location
, COMPONENT_REF
,
1289 TREE_TYPE (field
), inner_struct
, field
,
1291 /* Ref the dim in the inner_struct. */
1292 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 2);
1293 dim_array
= fold_build3_loc (input_location
, COMPONENT_REF
,
1294 TREE_TYPE (field
), inner_struct
, field
,
1296 for (i
= 0; i
< ref
->u
.ar
.dimen
; ++i
)
1299 dim
= gfc_build_array_ref (dim_array
, gfc_rank_cst
[i
], NULL_TREE
);
1300 dim_type
= TREE_TYPE (dim
);
1301 mode_rhs
= start
= end
= stride
= NULL_TREE
;
1302 switch (ref
->u
.ar
.dimen_type
[i
])
1305 if (ref
->u
.ar
.end
[i
])
1307 gfc_init_se (&se
, NULL
);
1308 gfc_conv_expr (&se
, ref
->u
.ar
.end
[i
]);
1309 gfc_add_block_to_block (block
, &se
.pre
);
1310 if (ref_static_array
)
1312 /* Make the index zero-based, when reffing a static
1315 gfc_init_se (&se
, NULL
);
1316 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1317 gfc_add_block_to_block (block
, &se
.pre
);
1318 se
.expr
= fold_build2 (MINUS_EXPR
,
1319 gfc_array_index_type
,
1321 gfc_array_index_type
,
1324 end
= gfc_evaluate_now (fold_convert (
1325 gfc_array_index_type
,
1329 else if (ref_static_array
)
1330 end
= fold_build2 (MINUS_EXPR
,
1331 gfc_array_index_type
,
1332 gfc_conv_array_ubound (
1333 last_component_ref_tree
, i
),
1334 gfc_conv_array_lbound (
1335 last_component_ref_tree
, i
));
1339 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1340 GFC_CAF_ARR_REF_OPEN_END
);
1342 if (ref
->u
.ar
.stride
[i
])
1344 gfc_init_se (&se
, NULL
);
1345 gfc_conv_expr (&se
, ref
->u
.ar
.stride
[i
]);
1346 gfc_add_block_to_block (block
, &se
.pre
);
1347 stride
= gfc_evaluate_now (fold_convert (
1348 gfc_array_index_type
,
1351 if (ref_static_array
)
1353 /* Make the index zero-based, when reffing a static
1355 stride
= fold_build2 (MULT_EXPR
,
1356 gfc_array_index_type
,
1357 gfc_conv_array_stride (
1358 last_component_ref_tree
,
1361 gcc_assert (end
!= NULL_TREE
);
1362 /* Multiply with the product of array's stride and
1363 the step of the ref to a virtual upper bound.
1364 We can not compute the actual upper bound here or
1365 the caflib would compute the extend
1367 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1368 end
, gfc_conv_array_stride (
1369 last_component_ref_tree
,
1371 end
= gfc_evaluate_now (end
, block
);
1372 stride
= gfc_evaluate_now (stride
, block
);
1375 else if (ref_static_array
)
1377 stride
= gfc_conv_array_stride (last_component_ref_tree
,
1379 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1381 end
= gfc_evaluate_now (end
, block
);
1384 /* Always set a ref stride of one to make caflib's
1386 stride
= gfc_index_one_node
;
1390 if (ref
->u
.ar
.start
[i
])
1392 gfc_init_se (&se
, NULL
);
1393 gfc_conv_expr (&se
, ref
->u
.ar
.start
[i
]);
1394 gfc_add_block_to_block (block
, &se
.pre
);
1395 if (ref_static_array
)
1397 /* Make the index zero-based, when reffing a static
1399 start
= fold_convert (gfc_array_index_type
, se
.expr
);
1400 gfc_init_se (&se
, NULL
);
1401 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1402 gfc_add_block_to_block (block
, &se
.pre
);
1403 se
.expr
= fold_build2 (MINUS_EXPR
,
1404 gfc_array_index_type
,
1405 start
, fold_convert (
1406 gfc_array_index_type
,
1408 /* Multiply with the stride. */
1409 se
.expr
= fold_build2 (MULT_EXPR
,
1410 gfc_array_index_type
,
1412 gfc_conv_array_stride (
1413 last_component_ref_tree
,
1416 start
= gfc_evaluate_now (fold_convert (
1417 gfc_array_index_type
,
1420 if (mode_rhs
== NULL_TREE
)
1421 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1422 ref
->u
.ar
.dimen_type
[i
]
1424 ? GFC_CAF_ARR_REF_SINGLE
1425 : GFC_CAF_ARR_REF_RANGE
);
1427 else if (ref_static_array
)
1429 start
= integer_zero_node
;
1430 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1431 ref
->u
.ar
.start
[i
] == NULL
1432 ? GFC_CAF_ARR_REF_FULL
1433 : GFC_CAF_ARR_REF_RANGE
);
1435 else if (end
== NULL_TREE
)
1436 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1437 GFC_CAF_ARR_REF_FULL
);
1439 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1440 GFC_CAF_ARR_REF_OPEN_START
);
1442 /* Ref the s in dim. */
1443 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 0);
1444 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1445 TREE_TYPE (field
), dim
, field
,
1448 /* Set start in s. */
1449 if (start
!= NULL_TREE
)
1451 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1453 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1454 TREE_TYPE (field
), tmp
, field
,
1456 gfc_add_modify (block
, tmp2
,
1457 fold_convert (TREE_TYPE (tmp2
), start
));
1461 if (end
!= NULL_TREE
)
1463 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1465 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1466 TREE_TYPE (field
), tmp
, field
,
1468 gfc_add_modify (block
, tmp2
,
1469 fold_convert (TREE_TYPE (tmp2
), end
));
1473 if (stride
!= NULL_TREE
)
1475 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1477 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1478 TREE_TYPE (field
), tmp
, field
,
1480 gfc_add_modify (block
, tmp2
,
1481 fold_convert (TREE_TYPE (tmp2
), stride
));
1485 /* TODO: In case of static array. */
1486 gcc_assert (!ref_static_array
);
1487 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1488 GFC_CAF_ARR_REF_VECTOR
);
1489 gfc_init_se (&se
, NULL
);
1490 se
.descriptor_only
= 1;
1491 gfc_conv_expr_descriptor (&se
, ref
->u
.ar
.start
[i
]);
1492 gfc_add_block_to_block (block
, &se
.pre
);
1494 tmp
= gfc_conv_descriptor_lbound_get (vector
,
1496 tmp2
= gfc_conv_descriptor_ubound_get (vector
,
1498 nvec
= gfc_conv_array_extent_dim (tmp
, tmp2
, NULL
);
1499 tmp
= gfc_conv_descriptor_stride_get (vector
,
1501 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1502 TREE_TYPE (nvec
), nvec
, tmp
);
1503 vector
= gfc_conv_descriptor_data_get (vector
);
1505 /* Ref the v in dim. */
1506 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 1);
1507 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1508 TREE_TYPE (field
), dim
, field
,
1511 /* Set vector in v. */
1512 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 0);
1513 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1514 TREE_TYPE (field
), tmp
, field
,
1516 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1519 /* Set nvec in v. */
1520 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 1);
1521 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1522 TREE_TYPE (field
), tmp
, field
,
1524 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1527 /* Set kind in v. */
1528 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 2);
1529 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1530 TREE_TYPE (field
), tmp
, field
,
1532 gfc_add_modify (block
, tmp2
, build_int_cst (integer_type_node
,
1533 ref
->u
.ar
.start
[i
]->ts
.kind
));
1538 /* Set the mode for dim i. */
1539 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1540 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
),
1544 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1545 if (i
< GFC_MAX_DIMENSIONS
)
1547 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1548 gfc_add_modify (block
, tmp
,
1549 build_int_cst (unsigned_char_type_node
,
1550 GFC_CAF_ARR_REF_NONE
));
1557 /* Set the size of the current type. */
1558 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 2);
1559 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1560 prev_caf_ref
, field
, NULL_TREE
);
1561 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1562 TYPE_SIZE_UNIT (last_type
)));
1567 if (prev_caf_ref
!= NULL_TREE
)
1569 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1570 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1571 prev_caf_ref
, field
, NULL_TREE
);
1572 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1573 null_pointer_node
));
1575 return caf_ref
!= NULL_TREE
? gfc_build_addr_expr (NULL_TREE
, caf_ref
)
1579 /* Get data from a remote coarray. */
1582 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1583 tree may_require_tmp
, bool may_realloc
,
1584 symbol_attribute
*caf_attr
)
1586 gfc_expr
*array_expr
, *tmp_stat
;
1588 tree caf_decl
, token
, offset
, image_index
, tmp
;
1589 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
1591 symbol_attribute caf_attr_store
;
1593 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1595 if (se
->ss
&& se
->ss
->info
->useflags
)
1597 /* Access the previously obtained result. */
1598 gfc_conv_tmp_array_ref (se
);
1602 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1603 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1604 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1606 if (caf_attr
== NULL
)
1608 caf_attr_store
= gfc_caf_attr (array_expr
);
1609 caf_attr
= &caf_attr_store
;
1615 vec
= null_pointer_node
;
1616 tmp_stat
= gfc_find_stat_co (expr
);
1621 gfc_init_se (&stat_se
, NULL
);
1622 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1623 stat
= stat_se
.expr
;
1624 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1625 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1628 stat
= null_pointer_node
;
1630 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1631 is reallocatable or the right-hand side has allocatable components. */
1632 if (caf_attr
->alloc_comp
|| caf_attr
->pointer_comp
|| may_realloc
)
1634 /* Get using caf_get_by_ref. */
1635 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, array_expr
);
1637 if (caf_reference
!= NULL_TREE
)
1639 if (lhs
== NULL_TREE
)
1641 if (array_expr
->ts
.type
== BT_CHARACTER
)
1642 gfc_init_se (&argse
, NULL
);
1643 if (array_expr
->rank
== 0)
1645 symbol_attribute attr
;
1646 gfc_clear_attr (&attr
);
1647 if (array_expr
->ts
.type
== BT_CHARACTER
)
1649 res_var
= gfc_conv_string_tmp (se
,
1650 build_pointer_type (type
),
1651 array_expr
->ts
.u
.cl
->backend_decl
);
1652 argse
.string_length
= array_expr
->ts
.u
.cl
->backend_decl
;
1655 res_var
= gfc_create_var (type
, "caf_res");
1656 dst_var
= gfc_conv_scalar_to_descriptor (se
, res_var
, attr
);
1657 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1661 /* Create temporary. */
1662 if (array_expr
->ts
.type
== BT_CHARACTER
)
1663 gfc_conv_expr_descriptor (&argse
, array_expr
);
1664 may_realloc
= gfc_trans_create_temp_array (&se
->pre
,
1671 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1672 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1675 tmp
= gfc_conv_descriptor_data_get (res_var
);
1676 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
,
1677 NULL_TREE
, NULL_TREE
,
1680 GFC_CAF_COARRAY_NOCOARRAY
);
1681 gfc_add_expr_to_block (&se
->post
, tmp
);
1686 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1687 if (lhs_kind
== NULL_TREE
)
1690 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1691 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1692 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1693 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1695 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1698 /* No overlap possible as we have generated a temporary. */
1699 if (lhs
== NULL_TREE
)
1700 may_require_tmp
= boolean_false_node
;
1702 /* It guarantees memory consistency within the same segment. */
1703 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1704 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1705 gfc_build_string_const (1, ""), NULL_TREE
,
1706 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1708 ASM_VOLATILE_P (tmp
) = 1;
1709 gfc_add_expr_to_block (&se
->pre
, tmp
);
1711 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1712 9, token
, image_index
, dst_var
,
1713 caf_reference
, lhs_kind
, kind
,
1715 may_realloc
? boolean_true_node
:
1719 gfc_add_expr_to_block (&se
->pre
, tmp
);
1722 gfc_advance_se_ss_chain (se
);
1725 if (array_expr
->ts
.type
== BT_CHARACTER
)
1726 se
->string_length
= argse
.string_length
;
1732 gfc_init_se (&argse
, NULL
);
1733 if (array_expr
->rank
== 0)
1735 symbol_attribute attr
;
1737 gfc_clear_attr (&attr
);
1738 gfc_conv_expr (&argse
, array_expr
);
1740 if (lhs
== NULL_TREE
)
1742 gfc_clear_attr (&attr
);
1743 if (array_expr
->ts
.type
== BT_CHARACTER
)
1744 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1745 argse
.string_length
);
1747 res_var
= gfc_create_var (type
, "caf_res");
1748 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1749 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1751 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1752 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1756 /* If has_vector, pass descriptor for whole array and the
1757 vector bounds separately. */
1758 gfc_array_ref
*ar
, ar2
;
1759 bool has_vector
= false;
1761 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1764 ar
= gfc_find_array_ref (expr
);
1766 memset (ar
, '\0', sizeof (*ar
));
1770 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1771 gfc_conv_expr_descriptor (&argse
, array_expr
);
1772 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1773 has the wrong type if component references are done. */
1774 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1775 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1780 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1784 if (lhs
== NULL_TREE
)
1786 /* Create temporary. */
1787 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1788 if (se
->loop
->to
[n
] == NULL_TREE
)
1790 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1792 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1795 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1796 NULL_TREE
, false, true, false,
1797 &array_expr
->where
);
1798 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1799 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1801 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1804 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1805 if (lhs_kind
== NULL_TREE
)
1808 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1809 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1811 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1812 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1813 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1814 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1815 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1818 /* No overlap possible as we have generated a temporary. */
1819 if (lhs
== NULL_TREE
)
1820 may_require_tmp
= boolean_false_node
;
1822 /* It guarantees memory consistency within the same segment. */
1823 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1824 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1825 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1826 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1827 ASM_VOLATILE_P (tmp
) = 1;
1828 gfc_add_expr_to_block (&se
->pre
, tmp
);
1830 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1831 token
, offset
, image_index
, argse
.expr
, vec
,
1832 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1834 gfc_add_expr_to_block (&se
->pre
, tmp
);
1837 gfc_advance_se_ss_chain (se
);
1840 if (array_expr
->ts
.type
== BT_CHARACTER
)
1841 se
->string_length
= argse
.string_length
;
1845 /* Send data to a remote coarray. */
1848 conv_caf_send (gfc_code
*code
) {
1849 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
;
1850 gfc_se lhs_se
, rhs_se
;
1852 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1853 tree may_require_tmp
, src_stat
, dst_stat
;
1854 tree lhs_type
= NULL_TREE
;
1855 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1856 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1858 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1860 lhs_expr
= code
->ext
.actual
->expr
;
1861 rhs_expr
= code
->ext
.actual
->next
->expr
;
1862 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1863 ? boolean_false_node
: boolean_true_node
;
1864 gfc_init_block (&block
);
1866 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1867 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1868 src_stat
= dst_stat
= null_pointer_node
;
1871 gfc_init_se (&lhs_se
, NULL
);
1872 if (lhs_expr
->rank
== 0)
1874 symbol_attribute attr
;
1875 gfc_clear_attr (&attr
);
1876 gfc_conv_expr (&lhs_se
, lhs_expr
);
1877 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1878 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1879 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1881 else if ((lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
1882 && lhs_caf_attr
.codimension
)
1884 lhs_se
.want_pointer
= 1;
1885 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1886 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1887 has the wrong type if component references are done. */
1888 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1889 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1890 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1891 gfc_get_dtype_rank_type (
1892 gfc_has_vector_subscript (lhs_expr
)
1893 ? gfc_find_array_ref (lhs_expr
)->dimen
1899 /* If has_vector, pass descriptor for whole array and the
1900 vector bounds separately. */
1901 gfc_array_ref
*ar
, ar2
;
1902 bool has_vector
= false;
1904 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1907 ar
= gfc_find_array_ref (lhs_expr
);
1909 memset (ar
, '\0', sizeof (*ar
));
1913 lhs_se
.want_pointer
= 1;
1914 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1915 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1916 has the wrong type if component references are done. */
1917 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1918 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1919 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1920 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1925 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1930 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1932 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1933 temporary and a loop. */
1934 if (!gfc_is_coindexed (lhs_expr
)
1935 && (!lhs_caf_attr
.codimension
1936 || !(lhs_expr
->rank
> 0
1937 && (lhs_caf_attr
.allocatable
|| lhs_caf_attr
.pointer
))))
1939 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
1940 gcc_assert (gfc_is_coindexed (rhs_expr
));
1941 gfc_init_se (&rhs_se
, NULL
);
1942 if (lhs_expr
->rank
== 0 && lhs_caf_attr
.allocatable
)
1945 gfc_init_se (&scal_se
, NULL
);
1946 scal_se
.want_pointer
= 1;
1947 gfc_conv_expr (&scal_se
, lhs_expr
);
1948 /* Ensure scalar on lhs is allocated. */
1949 gfc_add_block_to_block (&block
, &scal_se
.pre
);
1951 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
1953 gfc_typenode_for_spec (&lhs_expr
->ts
)),
1955 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, scal_se
.expr
,
1957 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1958 tmp
, gfc_finish_block (&scal_se
.pre
),
1959 build_empty_stmt (input_location
));
1960 gfc_add_expr_to_block (&block
, tmp
);
1963 lhs_may_realloc
= lhs_may_realloc
1964 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
1965 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1966 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1967 may_require_tmp
, lhs_may_realloc
,
1969 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1970 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1971 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1972 return gfc_finish_block (&block
);
1975 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1977 /* Obtain token, offset and image index for the LHS. */
1978 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1979 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1980 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1981 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1983 if (lhs_caf_attr
.alloc_comp
)
1984 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
1987 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
1992 gfc_init_se (&rhs_se
, NULL
);
1993 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1994 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1995 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1996 if (rhs_expr
->rank
== 0)
1998 symbol_attribute attr
;
1999 gfc_clear_attr (&attr
);
2000 gfc_conv_expr (&rhs_se
, rhs_expr
);
2001 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
2002 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2004 else if ((rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2005 && rhs_caf_attr
.codimension
)
2008 rhs_se
.want_pointer
= 1;
2009 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2010 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2011 has the wrong type if component references are done. */
2012 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2013 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2014 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2015 gfc_get_dtype_rank_type (
2016 gfc_has_vector_subscript (rhs_expr
)
2017 ? gfc_find_array_ref (rhs_expr
)->dimen
2023 /* If has_vector, pass descriptor for whole array and the
2024 vector bounds separately. */
2025 gfc_array_ref
*ar
, ar2
;
2026 bool has_vector
= false;
2029 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2032 ar
= gfc_find_array_ref (rhs_expr
);
2034 memset (ar
, '\0', sizeof (*ar
));
2038 rhs_se
.want_pointer
= 1;
2039 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2040 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2041 has the wrong type if component references are done. */
2042 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2043 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2044 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2045 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2050 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2055 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2057 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2059 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2064 gfc_init_se (&stat_se
, NULL
);
2065 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2066 dst_stat
= stat_se
.expr
;
2067 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2068 gfc_add_block_to_block (&block
, &stat_se
.post
);
2071 if (!gfc_is_coindexed (rhs_expr
))
2073 if (lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
2075 tree reference
, dst_realloc
;
2076 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2077 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2078 : boolean_false_node
;
2079 tmp
= build_call_expr_loc (input_location
,
2080 gfor_fndecl_caf_send_by_ref
,
2081 9, token
, image_index
, rhs_se
.expr
,
2082 reference
, lhs_kind
, rhs_kind
,
2083 may_require_tmp
, dst_realloc
, src_stat
);
2086 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 10,
2087 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2088 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2089 may_require_tmp
, src_stat
);
2093 tree rhs_token
, rhs_offset
, rhs_image_index
;
2095 /* It guarantees memory consistency within the same segment. */
2096 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2097 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2098 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2099 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2100 ASM_VOLATILE_P (tmp
) = 1;
2101 gfc_add_expr_to_block (&block
, tmp
);
2103 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2104 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2105 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2106 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2108 if (rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2110 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2115 gfc_init_se (&stat_se
, NULL
);
2116 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2117 src_stat
= stat_se
.expr
;
2118 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2119 gfc_add_block_to_block (&block
, &stat_se
.post
);
2122 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2124 tree lhs_reference
, rhs_reference
;
2125 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2126 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2127 tmp
= build_call_expr_loc (input_location
,
2128 gfor_fndecl_caf_sendget_by_ref
, 11,
2129 token
, image_index
, lhs_reference
,
2130 rhs_token
, rhs_image_index
, rhs_reference
,
2131 lhs_kind
, rhs_kind
, may_require_tmp
,
2132 dst_stat
, src_stat
);
2136 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2138 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2139 14, token
, offset
, image_index
,
2140 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2141 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2142 rhs_kind
, may_require_tmp
, src_stat
);
2145 gfc_add_expr_to_block (&block
, tmp
);
2146 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2147 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2149 /* It guarantees memory consistency within the same segment. */
2150 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2151 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2152 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2153 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2154 ASM_VOLATILE_P (tmp
) = 1;
2155 gfc_add_expr_to_block (&block
, tmp
);
2157 return gfc_finish_block (&block
);
2162 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2165 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2166 lbound
, ubound
, extent
, ml
;
2169 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2171 if (expr
->value
.function
.actual
->expr
2172 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2173 distance
= expr
->value
.function
.actual
->expr
;
2175 /* The case -fcoarray=single is handled elsewhere. */
2176 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2178 /* Argument-free version: THIS_IMAGE(). */
2179 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2183 gfc_init_se (&argse
, NULL
);
2184 gfc_conv_expr_val (&argse
, distance
);
2185 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2186 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2187 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2190 tmp
= integer_zero_node
;
2191 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2193 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2198 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2200 type
= gfc_get_int_type (gfc_default_integer_kind
);
2201 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2202 rank
= expr
->value
.function
.actual
->expr
->rank
;
2204 /* Obtain the descriptor of the COARRAY. */
2205 gfc_init_se (&argse
, NULL
);
2206 argse
.want_coarray
= 1;
2207 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2208 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2209 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2214 /* Create an implicit second parameter from the loop variable. */
2215 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2216 gcc_assert (corank
> 0);
2217 gcc_assert (se
->loop
->dimen
== 1);
2218 gcc_assert (se
->ss
->info
->expr
== expr
);
2220 dim_arg
= se
->loop
->loopvar
[0];
2221 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2222 gfc_array_index_type
, dim_arg
,
2223 build_int_cst (TREE_TYPE (dim_arg
), 1));
2224 gfc_advance_se_ss_chain (se
);
2228 /* Use the passed DIM= argument. */
2229 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2230 gfc_init_se (&argse
, NULL
);
2231 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2232 gfc_array_index_type
);
2233 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2234 dim_arg
= argse
.expr
;
2236 if (INTEGER_CST_P (dim_arg
))
2238 if (wi::ltu_p (dim_arg
, 1)
2239 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2240 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2241 "dimension index", expr
->value
.function
.isym
->name
,
2244 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2246 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2247 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2249 build_int_cst (TREE_TYPE (dim_arg
), 1));
2250 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2251 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2253 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2254 boolean_type_node
, cond
, tmp
);
2255 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2260 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2261 one always has a dim_arg argument.
2263 m = this_image() - 1
2266 sub(1) = m + lcobound(corank)
2270 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2273 extent = gfc_extent(i)
2281 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2282 : m + lcobound(corank)
2285 /* this_image () - 1. */
2286 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2288 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2289 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2292 /* sub(1) = m + lcobound(corank). */
2293 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2294 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2296 lbound
= fold_convert (type
, lbound
);
2297 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2303 m
= gfc_create_var (type
, NULL
);
2304 ml
= gfc_create_var (type
, NULL
);
2305 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2306 min_var
= gfc_create_var (integer_type_node
, NULL
);
2308 /* m = this_image () - 1. */
2309 gfc_add_modify (&se
->pre
, m
, tmp
);
2311 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2312 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2313 fold_convert (integer_type_node
, dim_arg
),
2314 build_int_cst (integer_type_node
, rank
- 1));
2315 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2316 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2318 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2321 tmp
= build_int_cst (integer_type_node
, rank
);
2322 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2324 exit_label
= gfc_build_label_decl (NULL_TREE
);
2325 TREE_USED (exit_label
) = 1;
2328 gfc_init_block (&loop
);
2331 gfc_add_modify (&loop
, ml
, m
);
2334 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2335 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2336 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2337 extent
= fold_convert (type
, extent
);
2340 gfc_add_modify (&loop
, m
,
2341 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2344 /* Exit condition: if (i >= min_var) goto exit_label. */
2345 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
2347 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2348 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2349 build_empty_stmt (input_location
));
2350 gfc_add_expr_to_block (&loop
, tmp
);
2352 /* Increment loop variable: i++. */
2353 gfc_add_modify (&loop
, loop_var
,
2354 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2356 build_int_cst (integer_type_node
, 1)));
2358 /* Making the loop... actually loop! */
2359 tmp
= gfc_finish_block (&loop
);
2360 tmp
= build1_v (LOOP_EXPR
, tmp
);
2361 gfc_add_expr_to_block (&se
->pre
, tmp
);
2363 /* The exit label. */
2364 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2365 gfc_add_expr_to_block (&se
->pre
, tmp
);
2367 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2368 : m + lcobound(corank) */
2370 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
2371 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2373 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2374 fold_build2_loc (input_location
, PLUS_EXPR
,
2375 gfc_array_index_type
, dim_arg
,
2376 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2377 lbound
= fold_convert (type
, lbound
);
2379 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2380 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2382 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2384 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2385 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2390 /* Convert a call to image_status. */
2393 conv_intrinsic_image_status (gfc_se
*se
, gfc_expr
*expr
)
2395 unsigned int num_args
;
2398 num_args
= gfc_intrinsic_argument_list_length (expr
);
2399 args
= XALLOCAVEC (tree
, num_args
);
2400 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2401 /* In args[0] the number of the image the status is desired for has to be
2404 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2407 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2408 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2409 fold_convert (integer_type_node
, arg
),
2411 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2412 tmp
, integer_zero_node
,
2413 build_int_cst (integer_type_node
,
2414 GFC_STAT_STOPPED_IMAGE
));
2416 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2417 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_image_status
, 2,
2418 args
[0], build_int_cst (integer_type_node
, -1));
2427 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2429 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2431 gfc_se argse
, subse
;
2432 int rank
, corank
, codim
;
2434 type
= gfc_get_int_type (gfc_default_integer_kind
);
2435 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2436 rank
= expr
->value
.function
.actual
->expr
->rank
;
2438 /* Obtain the descriptor of the COARRAY. */
2439 gfc_init_se (&argse
, NULL
);
2440 argse
.want_coarray
= 1;
2441 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2442 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2443 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2446 /* Obtain a handle to the SUB argument. */
2447 gfc_init_se (&subse
, NULL
);
2448 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2449 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2450 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2451 subdesc
= build_fold_indirect_ref_loc (input_location
,
2452 gfc_conv_descriptor_data_get (subse
.expr
));
2454 /* Fortran 2008 does not require that the values remain in the cobounds,
2455 thus we need explicitly check this - and return 0 if they are exceeded. */
2457 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2458 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2459 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2460 fold_convert (gfc_array_index_type
, tmp
),
2463 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2465 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2466 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2467 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2468 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2469 fold_convert (gfc_array_index_type
, tmp
),
2471 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2472 boolean_type_node
, invalid_bound
, cond
);
2473 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2474 fold_convert (gfc_array_index_type
, tmp
),
2476 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2477 boolean_type_node
, invalid_bound
, cond
);
2480 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2482 /* See Fortran 2008, C.10 for the following algorithm. */
2484 /* coindex = sub(corank) - lcobound(n). */
2485 coindex
= fold_convert (gfc_array_index_type
,
2486 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2488 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2489 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2490 fold_convert (gfc_array_index_type
, coindex
),
2493 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2495 tree extent
, ubound
;
2497 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2498 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2499 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2500 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2502 /* coindex *= extent. */
2503 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2504 gfc_array_index_type
, coindex
, extent
);
2506 /* coindex += sub(codim). */
2507 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2508 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2509 gfc_array_index_type
, coindex
,
2510 fold_convert (gfc_array_index_type
, tmp
));
2512 /* coindex -= lbound(codim). */
2513 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2514 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2515 gfc_array_index_type
, coindex
, lbound
);
2518 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2519 fold_convert(type
, coindex
),
2520 build_int_cst (type
, 1));
2522 /* Return 0 if "coindex" exceeds num_images(). */
2524 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2525 num_images
= build_int_cst (type
, 1);
2528 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2530 build_int_cst (integer_type_node
, -1));
2531 num_images
= fold_convert (type
, tmp
);
2534 tmp
= gfc_create_var (type
, NULL
);
2535 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2537 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
2539 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
2541 fold_convert (boolean_type_node
, invalid_bound
));
2542 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2543 build_int_cst (type
, 0), tmp
);
2548 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2550 tree tmp
, distance
, failed
;
2553 if (expr
->value
.function
.actual
->expr
)
2555 gfc_init_se (&argse
, NULL
);
2556 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2557 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2558 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2559 distance
= fold_convert (integer_type_node
, argse
.expr
);
2562 distance
= integer_zero_node
;
2564 if (expr
->value
.function
.actual
->next
->expr
)
2566 gfc_init_se (&argse
, NULL
);
2567 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2568 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2569 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2570 failed
= fold_convert (integer_type_node
, argse
.expr
);
2573 failed
= build_int_cst (integer_type_node
, -1);
2575 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2577 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2582 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2586 gfc_init_se (&argse
, NULL
);
2587 argse
.data_not_needed
= 1;
2588 argse
.descriptor_only
= 1;
2590 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2591 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2592 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2594 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2598 /* Evaluate a single upper or lower bound. */
2599 /* TODO: bound intrinsic generates way too much unnecessary code. */
2602 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2604 gfc_actual_arglist
*arg
;
2605 gfc_actual_arglist
*arg2
;
2610 tree cond
, cond1
, cond3
, cond4
, size
;
2614 gfc_array_spec
* as
;
2615 bool assumed_rank_lb_one
;
2617 arg
= expr
->value
.function
.actual
;
2622 /* Create an implicit second parameter from the loop variable. */
2623 gcc_assert (!arg2
->expr
);
2624 gcc_assert (se
->loop
->dimen
== 1);
2625 gcc_assert (se
->ss
->info
->expr
== expr
);
2626 gfc_advance_se_ss_chain (se
);
2627 bound
= se
->loop
->loopvar
[0];
2628 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2629 gfc_array_index_type
, bound
,
2634 /* use the passed argument. */
2635 gcc_assert (arg2
->expr
);
2636 gfc_init_se (&argse
, NULL
);
2637 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2638 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2640 /* Convert from one based to zero based. */
2641 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2642 gfc_array_index_type
, bound
,
2643 gfc_index_one_node
);
2646 /* TODO: don't re-evaluate the descriptor on each iteration. */
2647 /* Get a descriptor for the first parameter. */
2648 gfc_init_se (&argse
, NULL
);
2649 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2650 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2651 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2655 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2657 if (INTEGER_CST_P (bound
))
2659 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2660 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2661 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
2662 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2663 "dimension index", upper
? "UBOUND" : "LBOUND",
2667 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
2669 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2671 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2672 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2673 bound
, build_int_cst (TREE_TYPE (bound
), 0));
2674 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2675 tmp
= gfc_conv_descriptor_rank (desc
);
2677 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
2678 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2679 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
2680 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2681 boolean_type_node
, cond
, tmp
);
2682 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2687 /* Take care of the lbound shift for assumed-rank arrays, which are
2688 nonallocatable and nonpointers. Those has a lbound of 1. */
2689 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
2690 && ((arg
->expr
->ts
.type
!= BT_CLASS
2691 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
2692 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
2693 || (arg
->expr
->ts
.type
== BT_CLASS
2694 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
2695 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
2697 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2698 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2700 /* 13.14.53: Result value for LBOUND
2702 Case (i): For an array section or for an array expression other than a
2703 whole array or array structure component, LBOUND(ARRAY, DIM)
2704 has the value 1. For a whole array or array structure
2705 component, LBOUND(ARRAY, DIM) has the value:
2706 (a) equal to the lower bound for subscript DIM of ARRAY if
2707 dimension DIM of ARRAY does not have extent zero
2708 or if ARRAY is an assumed-size array of rank DIM,
2711 13.14.113: Result value for UBOUND
2713 Case (i): For an array section or for an array expression other than a
2714 whole array or array structure component, UBOUND(ARRAY, DIM)
2715 has the value equal to the number of elements in the given
2716 dimension; otherwise, it has a value equal to the upper bound
2717 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2718 not have size zero and has value zero if dimension DIM has
2721 if (!upper
&& assumed_rank_lb_one
)
2722 se
->expr
= gfc_index_one_node
;
2725 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
2727 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2729 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2730 stride
, gfc_index_zero_node
);
2731 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2732 boolean_type_node
, cond3
, cond1
);
2733 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2734 stride
, gfc_index_zero_node
);
2739 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2740 boolean_type_node
, cond3
, cond4
);
2741 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2742 gfc_index_one_node
, lbound
);
2743 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2744 boolean_type_node
, cond4
, cond5
);
2746 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2747 boolean_type_node
, cond
, cond5
);
2749 if (assumed_rank_lb_one
)
2751 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2752 gfc_array_index_type
, ubound
, lbound
);
2753 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2754 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2759 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2760 gfc_array_index_type
, cond
,
2761 tmp
, gfc_index_zero_node
);
2765 if (as
->type
== AS_ASSUMED_SIZE
)
2766 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2767 bound
, build_int_cst (TREE_TYPE (bound
),
2768 arg
->expr
->rank
- 1));
2770 cond
= boolean_false_node
;
2772 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2773 boolean_type_node
, cond3
, cond4
);
2774 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2775 boolean_type_node
, cond
, cond1
);
2777 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2778 gfc_array_index_type
, cond
,
2779 lbound
, gfc_index_one_node
);
2786 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2787 gfc_array_index_type
, ubound
, lbound
);
2788 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2789 gfc_array_index_type
, size
,
2790 gfc_index_one_node
);
2791 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2792 gfc_array_index_type
, se
->expr
,
2793 gfc_index_zero_node
);
2796 se
->expr
= gfc_index_one_node
;
2799 type
= gfc_typenode_for_spec (&expr
->ts
);
2800 se
->expr
= convert (type
, se
->expr
);
2805 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2807 gfc_actual_arglist
*arg
;
2808 gfc_actual_arglist
*arg2
;
2810 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2814 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2815 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2816 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2818 arg
= expr
->value
.function
.actual
;
2821 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2822 corank
= gfc_get_corank (arg
->expr
);
2824 gfc_init_se (&argse
, NULL
);
2825 argse
.want_coarray
= 1;
2827 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2828 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2829 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2834 /* Create an implicit second parameter from the loop variable. */
2835 gcc_assert (!arg2
->expr
);
2836 gcc_assert (corank
> 0);
2837 gcc_assert (se
->loop
->dimen
== 1);
2838 gcc_assert (se
->ss
->info
->expr
== expr
);
2840 bound
= se
->loop
->loopvar
[0];
2841 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2842 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2843 gfc_advance_se_ss_chain (se
);
2847 /* use the passed argument. */
2848 gcc_assert (arg2
->expr
);
2849 gfc_init_se (&argse
, NULL
);
2850 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2851 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2854 if (INTEGER_CST_P (bound
))
2856 if (wi::ltu_p (bound
, 1)
2857 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2858 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2859 "dimension index", expr
->value
.function
.isym
->name
,
2862 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2864 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2865 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2866 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2867 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2868 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2870 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2871 boolean_type_node
, cond
, tmp
);
2872 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2877 /* Subtract 1 to get to zero based and add dimensions. */
2878 switch (arg
->expr
->rank
)
2881 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2882 gfc_array_index_type
, bound
,
2883 gfc_index_one_node
);
2887 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2888 gfc_array_index_type
, bound
,
2889 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2893 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2895 /* Handle UCOBOUND with special handling of the last codimension. */
2896 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2898 /* Last codimension: For -fcoarray=single just return
2899 the lcobound - otherwise add
2900 ceiling (real (num_images ()) / real (size)) - 1
2901 = (num_images () + size - 1) / size - 1
2902 = (num_images - 1) / size(),
2903 where size is the product of the extent of all but the last
2906 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2910 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2911 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2912 2, integer_zero_node
,
2913 build_int_cst (integer_type_node
, -1));
2914 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2915 gfc_array_index_type
,
2916 fold_convert (gfc_array_index_type
, tmp
),
2917 build_int_cst (gfc_array_index_type
, 1));
2918 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2919 gfc_array_index_type
, tmp
,
2920 fold_convert (gfc_array_index_type
, cosize
));
2921 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2922 gfc_array_index_type
, resbound
, tmp
);
2924 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2926 /* ubound = lbound + num_images() - 1. */
2927 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2928 2, integer_zero_node
,
2929 build_int_cst (integer_type_node
, -1));
2930 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2931 gfc_array_index_type
,
2932 fold_convert (gfc_array_index_type
, tmp
),
2933 build_int_cst (gfc_array_index_type
, 1));
2934 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2935 gfc_array_index_type
, resbound
, tmp
);
2940 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2942 build_int_cst (TREE_TYPE (bound
),
2943 arg
->expr
->rank
+ corank
- 1));
2945 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2946 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2947 gfc_array_index_type
, cond
,
2948 resbound
, resbound2
);
2951 se
->expr
= resbound
;
2954 se
->expr
= resbound
;
2956 type
= gfc_typenode_for_spec (&expr
->ts
);
2957 se
->expr
= convert (type
, se
->expr
);
2962 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2964 gfc_actual_arglist
*array_arg
;
2965 gfc_actual_arglist
*dim_arg
;
2969 array_arg
= expr
->value
.function
.actual
;
2970 dim_arg
= array_arg
->next
;
2972 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2974 gfc_init_se (&argse
, NULL
);
2975 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2976 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2977 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2980 gcc_assert (dim_arg
->expr
);
2981 gfc_init_se (&argse
, NULL
);
2982 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2983 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2984 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2985 argse
.expr
, gfc_index_one_node
);
2986 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2991 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2995 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2997 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
3001 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
3006 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
3007 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
3016 /* Create a complex value from one or two real components. */
3019 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
3025 unsigned int num_args
;
3027 num_args
= gfc_intrinsic_argument_list_length (expr
);
3028 args
= XALLOCAVEC (tree
, num_args
);
3030 type
= gfc_typenode_for_spec (&expr
->ts
);
3031 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3032 real
= convert (TREE_TYPE (type
), args
[0]);
3034 imag
= convert (TREE_TYPE (type
), args
[1]);
3035 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
3037 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
3038 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
3039 imag
= convert (TREE_TYPE (type
), imag
);
3042 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3044 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3048 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3049 MODULO(A, P) = A - FLOOR (A / P) * P
3051 The obvious algorithms above are numerically instable for large
3052 arguments, hence these intrinsics are instead implemented via calls
3053 to the fmod family of functions. It is the responsibility of the
3054 user to ensure that the second argument is non-zero. */
3057 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3067 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3069 switch (expr
->ts
.type
)
3072 /* Integer case is easy, we've got a builtin op. */
3073 type
= TREE_TYPE (args
[0]);
3076 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3079 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3085 /* Check if we have a builtin fmod. */
3086 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3088 /* The builtin should always be available. */
3089 gcc_assert (fmod
!= NULL_TREE
);
3091 tmp
= build_addr (fmod
);
3092 se
->expr
= build_call_array_loc (input_location
,
3093 TREE_TYPE (TREE_TYPE (fmod
)),
3098 type
= TREE_TYPE (args
[0]);
3100 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3101 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3104 modulo = arg - floor (arg/arg2) * arg2
3106 In order to calculate the result accurately, we use the fmod
3107 function as follows.
3109 res = fmod (arg, arg2);
3112 if ((arg < 0) xor (arg2 < 0))
3116 res = copysign (0., arg2);
3118 => As two nested ternary exprs:
3120 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3121 : copysign (0., arg2);
3125 zero
= gfc_build_const (type
, integer_zero_node
);
3126 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3127 if (!flag_signed_zeros
)
3129 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3131 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3133 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3134 boolean_type_node
, test
, test2
);
3135 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3137 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3138 boolean_type_node
, test
, test2
);
3139 test
= gfc_evaluate_now (test
, &se
->pre
);
3140 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3141 fold_build2_loc (input_location
,
3143 type
, tmp
, args
[1]),
3148 tree expr1
, copysign
, cscall
;
3149 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3151 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3153 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3155 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3156 boolean_type_node
, test
, test2
);
3157 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3158 fold_build2_loc (input_location
,
3160 type
, tmp
, args
[1]),
3162 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3164 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3166 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3176 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3177 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3178 where the right shifts are logical (i.e. 0's are shifted in).
3179 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3180 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3182 DSHIFTL(I,J,BITSIZE) = J
3184 DSHIFTR(I,J,BITSIZE) = I. */
3187 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3189 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3190 tree args
[3], cond
, tmp
;
3193 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3195 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3196 type
= TREE_TYPE (args
[0]);
3197 bitsize
= TYPE_PRECISION (type
);
3198 utype
= unsigned_type_for (type
);
3199 stype
= TREE_TYPE (args
[2]);
3201 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3202 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3203 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3205 /* The generic case. */
3206 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3207 build_int_cst (stype
, bitsize
), shift
);
3208 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3209 arg1
, dshiftl
? shift
: tmp
);
3211 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3212 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3213 right
= fold_convert (type
, right
);
3215 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3217 /* Special cases. */
3218 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
3219 build_int_cst (stype
, 0));
3220 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3221 dshiftl
? arg1
: arg2
, res
);
3223 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
3224 build_int_cst (stype
, bitsize
));
3225 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3226 dshiftl
? arg2
: arg1
, res
);
3232 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3235 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3243 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3244 type
= TREE_TYPE (args
[0]);
3246 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3247 val
= gfc_evaluate_now (val
, &se
->pre
);
3249 zero
= gfc_build_const (type
, integer_zero_node
);
3250 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
3251 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3255 /* SIGN(A, B) is absolute value of A times sign of B.
3256 The real value versions use library functions to ensure the correct
3257 handling of negative zero. Integer case implemented as:
3258 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3262 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3268 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3269 if (expr
->ts
.type
== BT_REAL
)
3273 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3274 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3276 /* We explicitly have to ignore the minus sign. We do so by using
3277 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3279 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3282 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3283 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3285 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3286 TREE_TYPE (args
[0]), cond
,
3287 build_call_expr_loc (input_location
, abs
, 1,
3289 build_call_expr_loc (input_location
, tmp
, 2,
3293 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3298 /* Having excluded floating point types, we know we are now dealing
3299 with signed integer types. */
3300 type
= TREE_TYPE (args
[0]);
3302 /* Args[0] is used multiple times below. */
3303 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3305 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3306 the signs of A and B are the same, and of all ones if they differ. */
3307 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3308 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3309 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3310 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3312 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3313 is all ones (i.e. -1). */
3314 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3315 fold_build2_loc (input_location
, PLUS_EXPR
,
3316 type
, args
[0], tmp
), tmp
);
3320 /* Test for the presence of an optional argument. */
3323 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3327 arg
= expr
->value
.function
.actual
->expr
;
3328 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3329 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3330 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3334 /* Calculate the double precision product of two single precision values. */
3337 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3342 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3344 /* Convert the args to double precision before multiplying. */
3345 type
= gfc_typenode_for_spec (&expr
->ts
);
3346 args
[0] = convert (type
, args
[0]);
3347 args
[1] = convert (type
, args
[1]);
3348 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3353 /* Return a length one character string containing an ascii character. */
3356 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3361 unsigned int num_args
;
3363 num_args
= gfc_intrinsic_argument_list_length (expr
);
3364 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3366 type
= gfc_get_char_type (expr
->ts
.kind
);
3367 var
= gfc_create_var (type
, "char");
3369 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3370 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3371 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3372 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3377 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3385 unsigned int num_args
;
3387 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3388 args
= XALLOCAVEC (tree
, num_args
);
3390 var
= gfc_create_var (pchar_type_node
, "pstr");
3391 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3393 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3394 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3395 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3397 fndecl
= build_addr (gfor_fndecl_ctime
);
3398 tmp
= build_call_array_loc (input_location
,
3399 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3400 fndecl
, num_args
, args
);
3401 gfc_add_expr_to_block (&se
->pre
, tmp
);
3403 /* Free the temporary afterwards, if necessary. */
3404 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3405 len
, build_int_cst (TREE_TYPE (len
), 0));
3406 tmp
= gfc_call_free (var
);
3407 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3408 gfc_add_expr_to_block (&se
->post
, tmp
);
3411 se
->string_length
= len
;
3416 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3424 unsigned int num_args
;
3426 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3427 args
= XALLOCAVEC (tree
, num_args
);
3429 var
= gfc_create_var (pchar_type_node
, "pstr");
3430 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3432 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3433 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3434 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3436 fndecl
= build_addr (gfor_fndecl_fdate
);
3437 tmp
= build_call_array_loc (input_location
,
3438 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3439 fndecl
, num_args
, args
);
3440 gfc_add_expr_to_block (&se
->pre
, tmp
);
3442 /* Free the temporary afterwards, if necessary. */
3443 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3444 len
, build_int_cst (TREE_TYPE (len
), 0));
3445 tmp
= gfc_call_free (var
);
3446 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3447 gfc_add_expr_to_block (&se
->post
, tmp
);
3450 se
->string_length
= len
;
3454 /* Generate a direct call to free() for the FREE subroutine. */
3457 conv_intrinsic_free (gfc_code
*code
)
3463 gfc_init_se (&argse
, NULL
);
3464 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3465 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3467 gfc_init_block (&block
);
3468 call
= build_call_expr_loc (input_location
,
3469 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3470 gfc_add_expr_to_block (&block
, call
);
3471 return gfc_finish_block (&block
);
3475 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3479 conv_intrinsic_system_clock (gfc_code
*code
)
3482 gfc_se count_se
, count_rate_se
, count_max_se
;
3483 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3487 gfc_expr
*count
= code
->ext
.actual
->expr
;
3488 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3489 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3491 /* Evaluate our arguments. */
3494 gfc_init_se (&count_se
, NULL
);
3495 gfc_conv_expr (&count_se
, count
);
3500 gfc_init_se (&count_rate_se
, NULL
);
3501 gfc_conv_expr (&count_rate_se
, count_rate
);
3506 gfc_init_se (&count_max_se
, NULL
);
3507 gfc_conv_expr (&count_max_se
, count_max
);
3510 /* Find the smallest kind found of the arguments. */
3512 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3513 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3515 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3518 /* Prepare temporary variables. */
3523 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3524 else if (least
== 4)
3525 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3526 else if (count
->ts
.kind
== 1)
3527 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3530 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3537 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3538 else if (least
== 4)
3539 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3541 arg2
= integer_zero_node
;
3547 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3548 else if (least
== 4)
3549 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3551 arg3
= integer_zero_node
;
3554 /* Make the function call. */
3555 gfc_init_block (&block
);
3561 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3562 : null_pointer_node
;
3563 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3564 : null_pointer_node
;
3565 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3566 : null_pointer_node
;
3571 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3572 : null_pointer_node
;
3573 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3574 : null_pointer_node
;
3575 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3576 : null_pointer_node
;
3583 tmp
= build_call_expr_loc (input_location
,
3584 gfor_fndecl_system_clock4
, 3,
3585 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3586 : null_pointer_node
,
3587 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3588 : null_pointer_node
,
3589 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3590 : null_pointer_node
);
3591 gfc_add_expr_to_block (&block
, tmp
);
3593 /* Handle kind>=8, 10, or 16 arguments */
3596 tmp
= build_call_expr_loc (input_location
,
3597 gfor_fndecl_system_clock8
, 3,
3598 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3599 : null_pointer_node
,
3600 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3601 : null_pointer_node
,
3602 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3603 : null_pointer_node
);
3604 gfc_add_expr_to_block (&block
, tmp
);
3608 /* And store values back if needed. */
3609 if (arg1
&& arg1
!= count_se
.expr
)
3610 gfc_add_modify (&block
, count_se
.expr
,
3611 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
3612 if (arg2
&& arg2
!= count_rate_se
.expr
)
3613 gfc_add_modify (&block
, count_rate_se
.expr
,
3614 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
3615 if (arg3
&& arg3
!= count_max_se
.expr
)
3616 gfc_add_modify (&block
, count_max_se
.expr
,
3617 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
3619 return gfc_finish_block (&block
);
3623 /* Return a character string containing the tty name. */
3626 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
3634 unsigned int num_args
;
3636 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3637 args
= XALLOCAVEC (tree
, num_args
);
3639 var
= gfc_create_var (pchar_type_node
, "pstr");
3640 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3642 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3643 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3644 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3646 fndecl
= build_addr (gfor_fndecl_ttynam
);
3647 tmp
= build_call_array_loc (input_location
,
3648 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
3649 fndecl
, num_args
, args
);
3650 gfc_add_expr_to_block (&se
->pre
, tmp
);
3652 /* Free the temporary afterwards, if necessary. */
3653 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3654 len
, build_int_cst (TREE_TYPE (len
), 0));
3655 tmp
= gfc_call_free (var
);
3656 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3657 gfc_add_expr_to_block (&se
->post
, tmp
);
3660 se
->string_length
= len
;
3664 /* Get the minimum/maximum value of all the parameters.
3665 minmax (a1, a2, a3, ...)
3668 if (a2 .op. mvar || isnan (mvar))
3670 if (a3 .op. mvar || isnan (mvar))
3677 /* TODO: Mismatching types can occur when specific names are used.
3678 These should be handled during resolution. */
3680 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3688 gfc_actual_arglist
*argexpr
;
3689 unsigned int i
, nargs
;
3691 nargs
= gfc_intrinsic_argument_list_length (expr
);
3692 args
= XALLOCAVEC (tree
, nargs
);
3694 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
3695 type
= gfc_typenode_for_spec (&expr
->ts
);
3697 argexpr
= expr
->value
.function
.actual
;
3698 if (TREE_TYPE (args
[0]) != type
)
3699 args
[0] = convert (type
, args
[0]);
3700 /* Only evaluate the argument once. */
3701 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
3702 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3704 mvar
= gfc_create_var (type
, "M");
3705 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
3706 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
3712 /* Handle absent optional arguments by ignoring the comparison. */
3713 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
3714 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
3715 && TREE_CODE (val
) == INDIRECT_REF
)
3716 cond
= fold_build2_loc (input_location
,
3717 NE_EXPR
, boolean_type_node
,
3718 TREE_OPERAND (val
, 0),
3719 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
3724 /* Only evaluate the argument once. */
3725 if (!VAR_P (val
) && !TREE_CONSTANT (val
))
3726 val
= gfc_evaluate_now (val
, &se
->pre
);
3729 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
3731 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3732 convert (type
, val
), mvar
);
3734 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3735 __builtin_isnan might be made dependent on that module being loaded,
3736 to help performance of programs that don't rely on IEEE semantics. */
3737 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
3739 isnan
= build_call_expr_loc (input_location
,
3740 builtin_decl_explicit (BUILT_IN_ISNAN
),
3742 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3743 boolean_type_node
, tmp
,
3744 fold_convert (boolean_type_node
, isnan
));
3746 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
3747 build_empty_stmt (input_location
));
3749 if (cond
!= NULL_TREE
)
3750 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
3751 build_empty_stmt (input_location
));
3753 gfc_add_expr_to_block (&se
->pre
, tmp
);
3754 argexpr
= argexpr
->next
;
3760 /* Generate library calls for MIN and MAX intrinsics for character
3763 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
3766 tree var
, len
, fndecl
, tmp
, cond
, function
;
3769 nargs
= gfc_intrinsic_argument_list_length (expr
);
3770 args
= XALLOCAVEC (tree
, nargs
+ 4);
3771 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
3773 /* Create the result variables. */
3774 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3775 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3776 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3777 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3778 args
[2] = build_int_cst (integer_type_node
, op
);
3779 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3781 if (expr
->ts
.kind
== 1)
3782 function
= gfor_fndecl_string_minmax
;
3783 else if (expr
->ts
.kind
== 4)
3784 function
= gfor_fndecl_string_minmax_char4
;
3788 /* Make the function call. */
3789 fndecl
= build_addr (function
);
3790 tmp
= build_call_array_loc (input_location
,
3791 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3793 gfc_add_expr_to_block (&se
->pre
, tmp
);
3795 /* Free the temporary afterwards, if necessary. */
3796 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3797 len
, build_int_cst (TREE_TYPE (len
), 0));
3798 tmp
= gfc_call_free (var
);
3799 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3800 gfc_add_expr_to_block (&se
->post
, tmp
);
3803 se
->string_length
= len
;
3807 /* Create a symbol node for this intrinsic. The symbol from the frontend
3808 has the generic name. */
3811 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3815 /* TODO: Add symbols for intrinsic function to the global namespace. */
3816 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3817 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3820 sym
->attr
.external
= 1;
3821 sym
->attr
.function
= 1;
3822 sym
->attr
.always_explicit
= 1;
3823 sym
->attr
.proc
= PROC_INTRINSIC
;
3824 sym
->attr
.flavor
= FL_PROCEDURE
;
3828 sym
->attr
.dimension
= 1;
3829 sym
->as
= gfc_get_array_spec ();
3830 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3831 sym
->as
->rank
= expr
->rank
;
3834 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3835 ignore_optional
? expr
->value
.function
.actual
3841 /* Generate a call to an external intrinsic function. */
3843 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3846 vec
<tree
, va_gc
> *append_args
;
3848 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3851 gcc_assert (expr
->rank
> 0);
3853 gcc_assert (expr
->rank
== 0);
3855 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3857 /* Calls to libgfortran_matmul need to be appended special arguments,
3858 to be able to call the BLAS ?gemm functions if required and possible. */
3860 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3861 && sym
->ts
.type
!= BT_LOGICAL
)
3863 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3865 if (flag_external_blas
3866 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3867 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3871 if (sym
->ts
.type
== BT_REAL
)
3873 if (sym
->ts
.kind
== 4)
3874 gemm_fndecl
= gfor_fndecl_sgemm
;
3876 gemm_fndecl
= gfor_fndecl_dgemm
;
3880 if (sym
->ts
.kind
== 4)
3881 gemm_fndecl
= gfor_fndecl_cgemm
;
3883 gemm_fndecl
= gfor_fndecl_zgemm
;
3886 vec_alloc (append_args
, 3);
3887 append_args
->quick_push (build_int_cst (cint
, 1));
3888 append_args
->quick_push (build_int_cst (cint
,
3889 flag_blas_matmul_limit
));
3890 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3895 vec_alloc (append_args
, 3);
3896 append_args
->quick_push (build_int_cst (cint
, 0));
3897 append_args
->quick_push (build_int_cst (cint
, 0));
3898 append_args
->quick_push (null_pointer_node
);
3902 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3904 gfc_free_symbol (sym
);
3907 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3927 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3936 gfc_actual_arglist
*actual
;
3943 gfc_conv_intrinsic_funcall (se
, expr
);
3947 actual
= expr
->value
.function
.actual
;
3948 type
= gfc_typenode_for_spec (&expr
->ts
);
3949 /* Initialize the result. */
3950 resvar
= gfc_create_var (type
, "test");
3952 tmp
= convert (type
, boolean_true_node
);
3954 tmp
= convert (type
, boolean_false_node
);
3955 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3957 /* Walk the arguments. */
3958 arrayss
= gfc_walk_expr (actual
->expr
);
3959 gcc_assert (arrayss
!= gfc_ss_terminator
);
3961 /* Initialize the scalarizer. */
3962 gfc_init_loopinfo (&loop
);
3963 exit_label
= gfc_build_label_decl (NULL_TREE
);
3964 TREE_USED (exit_label
) = 1;
3965 gfc_add_ss_to_loop (&loop
, arrayss
);
3967 /* Initialize the loop. */
3968 gfc_conv_ss_startstride (&loop
);
3969 gfc_conv_loop_setup (&loop
, &expr
->where
);
3971 gfc_mark_ss_chain_used (arrayss
, 1);
3972 /* Generate the loop body. */
3973 gfc_start_scalarized_body (&loop
, &body
);
3975 /* If the condition matches then set the return value. */
3976 gfc_start_block (&block
);
3978 tmp
= convert (type
, boolean_false_node
);
3980 tmp
= convert (type
, boolean_true_node
);
3981 gfc_add_modify (&block
, resvar
, tmp
);
3983 /* And break out of the loop. */
3984 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3985 gfc_add_expr_to_block (&block
, tmp
);
3987 found
= gfc_finish_block (&block
);
3989 /* Check this element. */
3990 gfc_init_se (&arrayse
, NULL
);
3991 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3992 arrayse
.ss
= arrayss
;
3993 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3995 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3996 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3997 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3998 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3999 gfc_add_expr_to_block (&body
, tmp
);
4000 gfc_add_block_to_block (&body
, &arrayse
.post
);
4002 gfc_trans_scalarizing_loops (&loop
, &body
);
4004 /* Add the exit label. */
4005 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4006 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4008 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4009 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4010 gfc_cleanup_loop (&loop
);
4015 /* COUNT(A) = Number of true elements in A. */
4017 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4024 gfc_actual_arglist
*actual
;
4030 gfc_conv_intrinsic_funcall (se
, expr
);
4034 actual
= expr
->value
.function
.actual
;
4036 type
= gfc_typenode_for_spec (&expr
->ts
);
4037 /* Initialize the result. */
4038 resvar
= gfc_create_var (type
, "count");
4039 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4041 /* Walk the arguments. */
4042 arrayss
= gfc_walk_expr (actual
->expr
);
4043 gcc_assert (arrayss
!= gfc_ss_terminator
);
4045 /* Initialize the scalarizer. */
4046 gfc_init_loopinfo (&loop
);
4047 gfc_add_ss_to_loop (&loop
, arrayss
);
4049 /* Initialize the loop. */
4050 gfc_conv_ss_startstride (&loop
);
4051 gfc_conv_loop_setup (&loop
, &expr
->where
);
4053 gfc_mark_ss_chain_used (arrayss
, 1);
4054 /* Generate the loop body. */
4055 gfc_start_scalarized_body (&loop
, &body
);
4057 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4058 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4059 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4061 gfc_init_se (&arrayse
, NULL
);
4062 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4063 arrayse
.ss
= arrayss
;
4064 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4065 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4066 build_empty_stmt (input_location
));
4068 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4069 gfc_add_expr_to_block (&body
, tmp
);
4070 gfc_add_block_to_block (&body
, &arrayse
.post
);
4072 gfc_trans_scalarizing_loops (&loop
, &body
);
4074 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4075 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4076 gfc_cleanup_loop (&loop
);
4082 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4083 struct and return the corresponding loopinfo. */
4085 static gfc_loopinfo
*
4086 enter_nested_loop (gfc_se
*se
)
4088 se
->ss
= se
->ss
->nested_ss
;
4089 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4091 return se
->ss
->loop
;
4095 /* Inline implementation of the sum and product intrinsics. */
4097 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4101 tree scale
= NULL_TREE
;
4106 gfc_loopinfo loop
, *ploop
;
4107 gfc_actual_arglist
*arg_array
, *arg_mask
;
4108 gfc_ss
*arrayss
= NULL
;
4109 gfc_ss
*maskss
= NULL
;
4113 gfc_expr
*arrayexpr
;
4118 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4124 type
= gfc_typenode_for_spec (&expr
->ts
);
4125 /* Initialize the result. */
4126 resvar
= gfc_create_var (type
, "val");
4131 scale
= gfc_create_var (type
, "scale");
4132 gfc_add_modify (&se
->pre
, scale
,
4133 gfc_build_const (type
, integer_one_node
));
4134 tmp
= gfc_build_const (type
, integer_zero_node
);
4136 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4137 tmp
= gfc_build_const (type
, integer_zero_node
);
4138 else if (op
== NE_EXPR
)
4140 tmp
= convert (type
, boolean_false_node
);
4141 else if (op
== BIT_AND_EXPR
)
4142 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4143 type
, integer_one_node
));
4145 tmp
= gfc_build_const (type
, integer_one_node
);
4147 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4149 arg_array
= expr
->value
.function
.actual
;
4151 arrayexpr
= arg_array
->expr
;
4153 if (op
== NE_EXPR
|| norm2
)
4154 /* PARITY and NORM2. */
4158 arg_mask
= arg_array
->next
->next
;
4159 gcc_assert (arg_mask
!= NULL
);
4160 maskexpr
= arg_mask
->expr
;
4163 if (expr
->rank
== 0)
4165 /* Walk the arguments. */
4166 arrayss
= gfc_walk_expr (arrayexpr
);
4167 gcc_assert (arrayss
!= gfc_ss_terminator
);
4169 if (maskexpr
&& maskexpr
->rank
> 0)
4171 maskss
= gfc_walk_expr (maskexpr
);
4172 gcc_assert (maskss
!= gfc_ss_terminator
);
4177 /* Initialize the scalarizer. */
4178 gfc_init_loopinfo (&loop
);
4179 gfc_add_ss_to_loop (&loop
, arrayss
);
4180 if (maskexpr
&& maskexpr
->rank
> 0)
4181 gfc_add_ss_to_loop (&loop
, maskss
);
4183 /* Initialize the loop. */
4184 gfc_conv_ss_startstride (&loop
);
4185 gfc_conv_loop_setup (&loop
, &expr
->where
);
4187 gfc_mark_ss_chain_used (arrayss
, 1);
4188 if (maskexpr
&& maskexpr
->rank
> 0)
4189 gfc_mark_ss_chain_used (maskss
, 1);
4194 /* All the work has been done in the parent loops. */
4195 ploop
= enter_nested_loop (se
);
4199 /* Generate the loop body. */
4200 gfc_start_scalarized_body (ploop
, &body
);
4202 /* If we have a mask, only add this element if the mask is set. */
4203 if (maskexpr
&& maskexpr
->rank
> 0)
4205 gfc_init_se (&maskse
, parent_se
);
4206 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4207 if (expr
->rank
== 0)
4209 gfc_conv_expr_val (&maskse
, maskexpr
);
4210 gfc_add_block_to_block (&body
, &maskse
.pre
);
4212 gfc_start_block (&block
);
4215 gfc_init_block (&block
);
4217 /* Do the actual summation/product. */
4218 gfc_init_se (&arrayse
, parent_se
);
4219 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4220 if (expr
->rank
== 0)
4221 arrayse
.ss
= arrayss
;
4222 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4223 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4227 /* if (x (i) != 0.0)
4233 result = 1.0 + result * val * val;
4239 result += val * val;
4242 tree res1
, res2
, cond
, absX
, val
;
4243 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4245 gfc_init_block (&ifblock1
);
4247 absX
= gfc_create_var (type
, "absX");
4248 gfc_add_modify (&ifblock1
, absX
,
4249 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4251 val
= gfc_create_var (type
, "val");
4252 gfc_add_expr_to_block (&ifblock1
, val
);
4254 gfc_init_block (&ifblock2
);
4255 gfc_add_modify (&ifblock2
, val
,
4256 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4258 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4259 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4260 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4261 gfc_build_const (type
, integer_one_node
));
4262 gfc_add_modify (&ifblock2
, resvar
, res1
);
4263 gfc_add_modify (&ifblock2
, scale
, absX
);
4264 res1
= gfc_finish_block (&ifblock2
);
4266 gfc_init_block (&ifblock3
);
4267 gfc_add_modify (&ifblock3
, val
,
4268 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4270 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4271 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4272 gfc_add_modify (&ifblock3
, resvar
, res2
);
4273 res2
= gfc_finish_block (&ifblock3
);
4275 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
4277 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4278 gfc_add_expr_to_block (&ifblock1
, tmp
);
4279 tmp
= gfc_finish_block (&ifblock1
);
4281 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4283 gfc_build_const (type
, integer_zero_node
));
4285 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4286 gfc_add_expr_to_block (&block
, tmp
);
4290 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4291 gfc_add_modify (&block
, resvar
, tmp
);
4294 gfc_add_block_to_block (&block
, &arrayse
.post
);
4296 if (maskexpr
&& maskexpr
->rank
> 0)
4298 /* We enclose the above in if (mask) {...} . */
4300 tmp
= gfc_finish_block (&block
);
4301 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4302 build_empty_stmt (input_location
));
4305 tmp
= gfc_finish_block (&block
);
4306 gfc_add_expr_to_block (&body
, tmp
);
4308 gfc_trans_scalarizing_loops (ploop
, &body
);
4310 /* For a scalar mask, enclose the loop in an if statement. */
4311 if (maskexpr
&& maskexpr
->rank
== 0)
4313 gfc_init_block (&block
);
4314 gfc_add_block_to_block (&block
, &ploop
->pre
);
4315 gfc_add_block_to_block (&block
, &ploop
->post
);
4316 tmp
= gfc_finish_block (&block
);
4320 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4321 build_empty_stmt (input_location
));
4322 gfc_advance_se_ss_chain (se
);
4326 gcc_assert (expr
->rank
== 0);
4327 gfc_init_se (&maskse
, NULL
);
4328 gfc_conv_expr_val (&maskse
, maskexpr
);
4329 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4330 build_empty_stmt (input_location
));
4333 gfc_add_expr_to_block (&block
, tmp
);
4334 gfc_add_block_to_block (&se
->pre
, &block
);
4335 gcc_assert (se
->post
.head
== NULL
);
4339 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4340 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4343 if (expr
->rank
== 0)
4344 gfc_cleanup_loop (ploop
);
4348 /* result = scale * sqrt(result). */
4350 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4351 resvar
= build_call_expr_loc (input_location
,
4353 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4360 /* Inline implementation of the dot_product intrinsic. This function
4361 is based on gfc_conv_intrinsic_arith (the previous function). */
4363 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4371 gfc_actual_arglist
*actual
;
4372 gfc_ss
*arrayss1
, *arrayss2
;
4373 gfc_se arrayse1
, arrayse2
;
4374 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4376 type
= gfc_typenode_for_spec (&expr
->ts
);
4378 /* Initialize the result. */
4379 resvar
= gfc_create_var (type
, "val");
4380 if (expr
->ts
.type
== BT_LOGICAL
)
4381 tmp
= build_int_cst (type
, 0);
4383 tmp
= gfc_build_const (type
, integer_zero_node
);
4385 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4387 /* Walk argument #1. */
4388 actual
= expr
->value
.function
.actual
;
4389 arrayexpr1
= actual
->expr
;
4390 arrayss1
= gfc_walk_expr (arrayexpr1
);
4391 gcc_assert (arrayss1
!= gfc_ss_terminator
);
4393 /* Walk argument #2. */
4394 actual
= actual
->next
;
4395 arrayexpr2
= actual
->expr
;
4396 arrayss2
= gfc_walk_expr (arrayexpr2
);
4397 gcc_assert (arrayss2
!= gfc_ss_terminator
);
4399 /* Initialize the scalarizer. */
4400 gfc_init_loopinfo (&loop
);
4401 gfc_add_ss_to_loop (&loop
, arrayss1
);
4402 gfc_add_ss_to_loop (&loop
, arrayss2
);
4404 /* Initialize the loop. */
4405 gfc_conv_ss_startstride (&loop
);
4406 gfc_conv_loop_setup (&loop
, &expr
->where
);
4408 gfc_mark_ss_chain_used (arrayss1
, 1);
4409 gfc_mark_ss_chain_used (arrayss2
, 1);
4411 /* Generate the loop body. */
4412 gfc_start_scalarized_body (&loop
, &body
);
4413 gfc_init_block (&block
);
4415 /* Make the tree expression for [conjg(]array1[)]. */
4416 gfc_init_se (&arrayse1
, NULL
);
4417 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
4418 arrayse1
.ss
= arrayss1
;
4419 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
4420 if (expr
->ts
.type
== BT_COMPLEX
)
4421 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
4423 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
4425 /* Make the tree expression for array2. */
4426 gfc_init_se (&arrayse2
, NULL
);
4427 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
4428 arrayse2
.ss
= arrayss2
;
4429 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
4430 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
4432 /* Do the actual product and sum. */
4433 if (expr
->ts
.type
== BT_LOGICAL
)
4435 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
4436 arrayse1
.expr
, arrayse2
.expr
);
4437 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
4441 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
4443 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
4445 gfc_add_modify (&block
, resvar
, tmp
);
4447 /* Finish up the loop block and the loop. */
4448 tmp
= gfc_finish_block (&block
);
4449 gfc_add_expr_to_block (&body
, tmp
);
4451 gfc_trans_scalarizing_loops (&loop
, &body
);
4452 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4453 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4454 gfc_cleanup_loop (&loop
);
4460 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4461 we need to handle. For performance reasons we sometimes create two
4462 loops instead of one, where the second one is much simpler.
4463 Examples for minloc intrinsic:
4464 1) Result is an array, a call is generated
4465 2) Array mask is used and NaNs need to be supported:
4471 if (pos == 0) pos = S + (1 - from);
4472 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4479 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4483 3) NaNs need to be supported, but it is known at compile time or cheaply
4484 at runtime whether array is nonempty or not:
4489 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4492 if (from <= to) pos = 1;
4496 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4500 4) NaNs aren't supported, array mask is used:
4501 limit = infinities_supported ? Infinity : huge (limit);
4505 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4511 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4515 5) Same without array mask:
4516 limit = infinities_supported ? Infinity : huge (limit);
4517 pos = (from <= to) ? 1 : 0;
4520 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4523 For 3) and 5), if mask is scalar, this all goes into a conditional,
4524 setting pos = 0; in the else branch. */
4527 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4531 stmtblock_t ifblock
;
4532 stmtblock_t elseblock
;
4543 gfc_actual_arglist
*actual
;
4548 gfc_expr
*arrayexpr
;
4555 gfc_conv_intrinsic_funcall (se
, expr
);
4559 /* Initialize the result. */
4560 pos
= gfc_create_var (gfc_array_index_type
, "pos");
4561 offset
= gfc_create_var (gfc_array_index_type
, "offset");
4562 type
= gfc_typenode_for_spec (&expr
->ts
);
4564 /* Walk the arguments. */
4565 actual
= expr
->value
.function
.actual
;
4566 arrayexpr
= actual
->expr
;
4567 arrayss
= gfc_walk_expr (arrayexpr
);
4568 gcc_assert (arrayss
!= gfc_ss_terminator
);
4570 actual
= actual
->next
->next
;
4571 gcc_assert (actual
);
4572 maskexpr
= actual
->expr
;
4574 if (maskexpr
&& maskexpr
->rank
!= 0)
4576 maskss
= gfc_walk_expr (maskexpr
);
4577 gcc_assert (maskss
!= gfc_ss_terminator
);
4582 if (gfc_array_size (arrayexpr
, &asize
))
4584 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4586 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4587 boolean_type_node
, nonempty
,
4588 gfc_index_zero_node
);
4593 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
4594 switch (arrayexpr
->ts
.type
)
4597 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
4601 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
4602 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
4603 arrayexpr
->ts
.kind
);
4610 /* We start with the most negative possible value for MAXLOC, and the most
4611 positive possible value for MINLOC. The most negative possible value is
4612 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4613 possible value is HUGE in both cases. */
4615 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4616 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
4617 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
4618 build_int_cst (TREE_TYPE (tmp
), 1));
4620 gfc_add_modify (&se
->pre
, limit
, tmp
);
4622 /* Initialize the scalarizer. */
4623 gfc_init_loopinfo (&loop
);
4624 gfc_add_ss_to_loop (&loop
, arrayss
);
4626 gfc_add_ss_to_loop (&loop
, maskss
);
4628 /* Initialize the loop. */
4629 gfc_conv_ss_startstride (&loop
);
4631 /* The code generated can have more than one loop in sequence (see the
4632 comment at the function header). This doesn't work well with the
4633 scalarizer, which changes arrays' offset when the scalarization loops
4634 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4635 are currently inlined in the scalar case only (for which loop is of rank
4636 one). As there is no dependency to care about in that case, there is no
4637 temporary, so that we can use the scalarizer temporary code to handle
4638 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4639 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4641 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4642 should eventually go away. We could either create two loops properly,
4643 or find another way to save/restore the array offsets between the two
4644 loops (without conflicting with temporary management), or use a single
4645 loop minmaxloc implementation. See PR 31067. */
4646 loop
.temp_dim
= loop
.dimen
;
4647 gfc_conv_loop_setup (&loop
, &expr
->where
);
4649 gcc_assert (loop
.dimen
== 1);
4650 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
4651 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4652 loop
.from
[0], loop
.to
[0]);
4656 /* Initialize the position to zero, following Fortran 2003. We are free
4657 to do this because Fortran 95 allows the result of an entirely false
4658 mask to be processor dependent. If we know at compile time the array
4659 is non-empty and no MASK is used, we can initialize to 1 to simplify
4661 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
4662 gfc_add_modify (&loop
.pre
, pos
,
4663 fold_build3_loc (input_location
, COND_EXPR
,
4664 gfc_array_index_type
,
4665 nonempty
, gfc_index_one_node
,
4666 gfc_index_zero_node
));
4669 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
4670 lab1
= gfc_build_label_decl (NULL_TREE
);
4671 TREE_USED (lab1
) = 1;
4672 lab2
= gfc_build_label_decl (NULL_TREE
);
4673 TREE_USED (lab2
) = 1;
4676 /* An offset must be added to the loop
4677 counter to obtain the required position. */
4678 gcc_assert (loop
.from
[0]);
4680 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4681 gfc_index_one_node
, loop
.from
[0]);
4682 gfc_add_modify (&loop
.pre
, offset
, tmp
);
4684 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
4686 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
4687 /* Generate the loop body. */
4688 gfc_start_scalarized_body (&loop
, &body
);
4690 /* If we have a mask, only check this element if the mask is set. */
4693 gfc_init_se (&maskse
, NULL
);
4694 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4696 gfc_conv_expr_val (&maskse
, maskexpr
);
4697 gfc_add_block_to_block (&body
, &maskse
.pre
);
4699 gfc_start_block (&block
);
4702 gfc_init_block (&block
);
4704 /* Compare with the current limit. */
4705 gfc_init_se (&arrayse
, NULL
);
4706 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4707 arrayse
.ss
= arrayss
;
4708 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4709 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4711 /* We do the following if this is a more extreme value. */
4712 gfc_start_block (&ifblock
);
4714 /* Assign the value to the limit... */
4715 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4717 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
4719 stmtblock_t ifblock2
;
4722 gfc_start_block (&ifblock2
);
4723 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4724 loop
.loopvar
[0], offset
);
4725 gfc_add_modify (&ifblock2
, pos
, tmp
);
4726 ifbody2
= gfc_finish_block (&ifblock2
);
4727 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
4728 gfc_index_zero_node
);
4729 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
4730 build_empty_stmt (input_location
));
4731 gfc_add_expr_to_block (&block
, tmp
);
4734 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4735 loop
.loopvar
[0], offset
);
4736 gfc_add_modify (&ifblock
, pos
, tmp
);
4739 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
4741 ifbody
= gfc_finish_block (&ifblock
);
4743 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
4746 cond
= fold_build2_loc (input_location
,
4747 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4748 boolean_type_node
, arrayse
.expr
, limit
);
4750 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4751 arrayse
.expr
, limit
);
4753 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
4754 build_empty_stmt (input_location
));
4756 gfc_add_expr_to_block (&block
, ifbody
);
4760 /* We enclose the above in if (mask) {...}. */
4761 tmp
= gfc_finish_block (&block
);
4763 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4764 build_empty_stmt (input_location
));
4767 tmp
= gfc_finish_block (&block
);
4768 gfc_add_expr_to_block (&body
, tmp
);
4772 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4774 if (HONOR_NANS (DECL_MODE (limit
)))
4776 if (nonempty
!= NULL
)
4778 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
4779 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
4780 build_empty_stmt (input_location
));
4781 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
4785 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
4786 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
4788 /* If we have a mask, only check this element if the mask is set. */
4791 gfc_init_se (&maskse
, NULL
);
4792 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4794 gfc_conv_expr_val (&maskse
, maskexpr
);
4795 gfc_add_block_to_block (&body
, &maskse
.pre
);
4797 gfc_start_block (&block
);
4800 gfc_init_block (&block
);
4802 /* Compare with the current limit. */
4803 gfc_init_se (&arrayse
, NULL
);
4804 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4805 arrayse
.ss
= arrayss
;
4806 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4807 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4809 /* We do the following if this is a more extreme value. */
4810 gfc_start_block (&ifblock
);
4812 /* Assign the value to the limit... */
4813 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4815 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4816 loop
.loopvar
[0], offset
);
4817 gfc_add_modify (&ifblock
, pos
, tmp
);
4819 ifbody
= gfc_finish_block (&ifblock
);
4821 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4822 arrayse
.expr
, limit
);
4824 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4825 build_empty_stmt (input_location
));
4826 gfc_add_expr_to_block (&block
, tmp
);
4830 /* We enclose the above in if (mask) {...}. */
4831 tmp
= gfc_finish_block (&block
);
4833 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4834 build_empty_stmt (input_location
));
4837 tmp
= gfc_finish_block (&block
);
4838 gfc_add_expr_to_block (&body
, tmp
);
4839 /* Avoid initializing loopvar[0] again, it should be left where
4840 it finished by the first loop. */
4841 loop
.from
[0] = loop
.loopvar
[0];
4844 gfc_trans_scalarizing_loops (&loop
, &body
);
4847 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4849 /* For a scalar mask, enclose the loop in an if statement. */
4850 if (maskexpr
&& maskss
== NULL
)
4852 gfc_init_se (&maskse
, NULL
);
4853 gfc_conv_expr_val (&maskse
, maskexpr
);
4854 gfc_init_block (&block
);
4855 gfc_add_block_to_block (&block
, &loop
.pre
);
4856 gfc_add_block_to_block (&block
, &loop
.post
);
4857 tmp
= gfc_finish_block (&block
);
4859 /* For the else part of the scalar mask, just initialize
4860 the pos variable the same way as above. */
4862 gfc_init_block (&elseblock
);
4863 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4864 elsetmp
= gfc_finish_block (&elseblock
);
4866 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4867 gfc_add_expr_to_block (&block
, tmp
);
4868 gfc_add_block_to_block (&se
->pre
, &block
);
4872 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4873 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4875 gfc_cleanup_loop (&loop
);
4877 se
->expr
= convert (type
, pos
);
4880 /* Emit code for minval or maxval intrinsic. There are many different cases
4881 we need to handle. For performance reasons we sometimes create two
4882 loops instead of one, where the second one is much simpler.
4883 Examples for minval intrinsic:
4884 1) Result is an array, a call is generated
4885 2) Array mask is used and NaNs need to be supported, rank 1:
4890 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4893 limit = nonempty ? NaN : huge (limit);
4895 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4896 3) NaNs need to be supported, but it is known at compile time or cheaply
4897 at runtime whether array is nonempty or not, rank 1:
4900 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4901 limit = (from <= to) ? NaN : huge (limit);
4903 while (S <= to) { limit = min (a[S], limit); S++; }
4904 4) Array mask is used and NaNs need to be supported, rank > 1:
4913 if (fast) limit = min (a[S1][S2], limit);
4916 if (a[S1][S2] <= limit) {
4927 limit = nonempty ? NaN : huge (limit);
4928 5) NaNs need to be supported, but it is known at compile time or cheaply
4929 at runtime whether array is nonempty or not, rank > 1:
4936 if (fast) limit = min (a[S1][S2], limit);
4938 if (a[S1][S2] <= limit) {
4948 limit = (nonempty_array) ? NaN : huge (limit);
4949 6) NaNs aren't supported, but infinities are. Array mask is used:
4954 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4957 limit = nonempty ? limit : huge (limit);
4958 7) Same without array mask:
4961 while (S <= to) { limit = min (a[S], limit); S++; }
4962 limit = (from <= to) ? limit : huge (limit);
4963 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4964 limit = huge (limit);
4966 while (S <= to) { limit = min (a[S], limit); S++); }
4968 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4969 with array mask instead).
4970 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4971 setting limit = huge (limit); in the else branch. */
4974 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4984 tree huge_cst
= NULL
, nan_cst
= NULL
;
4986 stmtblock_t block
, block2
;
4988 gfc_actual_arglist
*actual
;
4993 gfc_expr
*arrayexpr
;
4999 gfc_conv_intrinsic_funcall (se
, expr
);
5003 type
= gfc_typenode_for_spec (&expr
->ts
);
5004 /* Initialize the result. */
5005 limit
= gfc_create_var (type
, "limit");
5006 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
5007 switch (expr
->ts
.type
)
5010 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
5012 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5014 REAL_VALUE_TYPE real
;
5016 tmp
= build_real (type
, real
);
5020 if (HONOR_NANS (DECL_MODE (limit
)))
5021 nan_cst
= gfc_build_nan (type
, "");
5025 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
5032 /* We start with the most negative possible value for MAXVAL, and the most
5033 positive possible value for MINVAL. The most negative possible value is
5034 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5035 possible value is HUGE in both cases. */
5038 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5040 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
5041 TREE_TYPE (huge_cst
), huge_cst
);
5044 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
5045 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5046 tmp
, build_int_cst (type
, 1));
5048 gfc_add_modify (&se
->pre
, limit
, tmp
);
5050 /* Walk the arguments. */
5051 actual
= expr
->value
.function
.actual
;
5052 arrayexpr
= actual
->expr
;
5053 arrayss
= gfc_walk_expr (arrayexpr
);
5054 gcc_assert (arrayss
!= gfc_ss_terminator
);
5056 actual
= actual
->next
->next
;
5057 gcc_assert (actual
);
5058 maskexpr
= actual
->expr
;
5060 if (maskexpr
&& maskexpr
->rank
!= 0)
5062 maskss
= gfc_walk_expr (maskexpr
);
5063 gcc_assert (maskss
!= gfc_ss_terminator
);
5068 if (gfc_array_size (arrayexpr
, &asize
))
5070 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5072 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5073 boolean_type_node
, nonempty
,
5074 gfc_index_zero_node
);
5079 /* Initialize the scalarizer. */
5080 gfc_init_loopinfo (&loop
);
5081 gfc_add_ss_to_loop (&loop
, arrayss
);
5083 gfc_add_ss_to_loop (&loop
, maskss
);
5085 /* Initialize the loop. */
5086 gfc_conv_ss_startstride (&loop
);
5088 /* The code generated can have more than one loop in sequence (see the
5089 comment at the function header). This doesn't work well with the
5090 scalarizer, which changes arrays' offset when the scalarization loops
5091 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5092 are currently inlined in the scalar case only. As there is no dependency
5093 to care about in that case, there is no temporary, so that we can use the
5094 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5095 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5096 gfc_trans_scalarized_loop_boundary even later to restore offset.
5097 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5098 should eventually go away. We could either create two loops properly,
5099 or find another way to save/restore the array offsets between the two
5100 loops (without conflicting with temporary management), or use a single
5101 loop minmaxval implementation. See PR 31067. */
5102 loop
.temp_dim
= loop
.dimen
;
5103 gfc_conv_loop_setup (&loop
, &expr
->where
);
5105 if (nonempty
== NULL
&& maskss
== NULL
5106 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5107 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5108 loop
.from
[0], loop
.to
[0]);
5109 nonempty_var
= NULL
;
5110 if (nonempty
== NULL
5111 && (HONOR_INFINITIES (DECL_MODE (limit
))
5112 || HONOR_NANS (DECL_MODE (limit
))))
5114 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
5115 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
5116 nonempty
= nonempty_var
;
5120 if (HONOR_NANS (DECL_MODE (limit
)))
5122 if (loop
.dimen
== 1)
5124 lab
= gfc_build_label_decl (NULL_TREE
);
5125 TREE_USED (lab
) = 1;
5129 fast
= gfc_create_var (boolean_type_node
, "fast");
5130 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
5134 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5136 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5137 /* Generate the loop body. */
5138 gfc_start_scalarized_body (&loop
, &body
);
5140 /* If we have a mask, only add this element if the mask is set. */
5143 gfc_init_se (&maskse
, NULL
);
5144 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5146 gfc_conv_expr_val (&maskse
, maskexpr
);
5147 gfc_add_block_to_block (&body
, &maskse
.pre
);
5149 gfc_start_block (&block
);
5152 gfc_init_block (&block
);
5154 /* Compare with the current limit. */
5155 gfc_init_se (&arrayse
, NULL
);
5156 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5157 arrayse
.ss
= arrayss
;
5158 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5159 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5161 gfc_init_block (&block2
);
5164 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
5166 if (HONOR_NANS (DECL_MODE (limit
)))
5168 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5169 boolean_type_node
, arrayse
.expr
, limit
);
5171 ifbody
= build1_v (GOTO_EXPR
, lab
);
5174 stmtblock_t ifblock
;
5176 gfc_init_block (&ifblock
);
5177 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5178 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
5179 ifbody
= gfc_finish_block (&ifblock
);
5181 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5182 build_empty_stmt (input_location
));
5183 gfc_add_expr_to_block (&block2
, tmp
);
5187 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5189 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5191 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5192 arrayse
.expr
, limit
);
5193 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5194 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5195 build_empty_stmt (input_location
));
5196 gfc_add_expr_to_block (&block2
, tmp
);
5200 tmp
= fold_build2_loc (input_location
,
5201 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5202 type
, arrayse
.expr
, limit
);
5203 gfc_add_modify (&block2
, limit
, tmp
);
5209 tree elsebody
= gfc_finish_block (&block2
);
5211 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5213 if (HONOR_NANS (DECL_MODE (limit
))
5214 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5216 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5217 arrayse
.expr
, limit
);
5218 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5219 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5220 build_empty_stmt (input_location
));
5224 tmp
= fold_build2_loc (input_location
,
5225 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5226 type
, arrayse
.expr
, limit
);
5227 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5229 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5230 gfc_add_expr_to_block (&block
, tmp
);
5233 gfc_add_block_to_block (&block
, &block2
);
5235 gfc_add_block_to_block (&block
, &arrayse
.post
);
5237 tmp
= gfc_finish_block (&block
);
5239 /* We enclose the above in if (mask) {...}. */
5240 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5241 build_empty_stmt (input_location
));
5242 gfc_add_expr_to_block (&body
, tmp
);
5246 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5248 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5250 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
5251 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
5253 /* If we have a mask, only add this element if the mask is set. */
5256 gfc_init_se (&maskse
, NULL
);
5257 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5259 gfc_conv_expr_val (&maskse
, maskexpr
);
5260 gfc_add_block_to_block (&body
, &maskse
.pre
);
5262 gfc_start_block (&block
);
5265 gfc_init_block (&block
);
5267 /* Compare with the current limit. */
5268 gfc_init_se (&arrayse
, NULL
);
5269 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5270 arrayse
.ss
= arrayss
;
5271 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5272 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5274 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5276 if (HONOR_NANS (DECL_MODE (limit
))
5277 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5279 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5280 arrayse
.expr
, limit
);
5281 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5282 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5283 build_empty_stmt (input_location
));
5284 gfc_add_expr_to_block (&block
, tmp
);
5288 tmp
= fold_build2_loc (input_location
,
5289 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5290 type
, arrayse
.expr
, limit
);
5291 gfc_add_modify (&block
, limit
, tmp
);
5294 gfc_add_block_to_block (&block
, &arrayse
.post
);
5296 tmp
= gfc_finish_block (&block
);
5298 /* We enclose the above in if (mask) {...}. */
5299 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5300 build_empty_stmt (input_location
));
5301 gfc_add_expr_to_block (&body
, tmp
);
5302 /* Avoid initializing loopvar[0] again, it should be left where
5303 it finished by the first loop. */
5304 loop
.from
[0] = loop
.loopvar
[0];
5306 gfc_trans_scalarizing_loops (&loop
, &body
);
5310 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5312 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5313 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
5315 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5317 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
5319 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
5321 gfc_add_modify (&loop
.pre
, limit
, tmp
);
5324 /* For a scalar mask, enclose the loop in an if statement. */
5325 if (maskexpr
&& maskss
== NULL
)
5329 gfc_init_se (&maskse
, NULL
);
5330 gfc_conv_expr_val (&maskse
, maskexpr
);
5331 gfc_init_block (&block
);
5332 gfc_add_block_to_block (&block
, &loop
.pre
);
5333 gfc_add_block_to_block (&block
, &loop
.post
);
5334 tmp
= gfc_finish_block (&block
);
5336 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5337 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
5339 else_stmt
= build_empty_stmt (input_location
);
5340 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
5341 gfc_add_expr_to_block (&block
, tmp
);
5342 gfc_add_block_to_block (&se
->pre
, &block
);
5346 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5347 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5350 gfc_cleanup_loop (&loop
);
5355 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5357 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
5363 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5364 type
= TREE_TYPE (args
[0]);
5366 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5367 build_int_cst (type
, 1), args
[1]);
5368 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
5369 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5370 build_int_cst (type
, 0));
5371 type
= gfc_typenode_for_spec (&expr
->ts
);
5372 se
->expr
= convert (type
, tmp
);
5376 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5378 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5382 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5384 /* Convert both arguments to the unsigned type of the same size. */
5385 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
5386 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
5388 /* If they have unequal type size, convert to the larger one. */
5389 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
5390 > TYPE_PRECISION (TREE_TYPE (args
[1])))
5391 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
5392 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
5393 > TYPE_PRECISION (TREE_TYPE (args
[0])))
5394 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
5396 /* Now, we compare them. */
5397 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5402 /* Generate code to perform the specified operation. */
5404 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5408 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5409 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
5415 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
5419 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5420 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5421 TREE_TYPE (arg
), arg
);
5424 /* Set or clear a single bit. */
5426 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
5433 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5434 type
= TREE_TYPE (args
[0]);
5436 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5437 build_int_cst (type
, 1), args
[1]);
5443 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
5445 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
5448 /* Extract a sequence of bits.
5449 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5451 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
5458 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5459 type
= TREE_TYPE (args
[0]);
5461 mask
= build_int_cst (type
, -1);
5462 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
5463 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
5465 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
5467 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
5471 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
5474 tree args
[2], type
, num_bits
, cond
;
5476 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5478 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5479 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5480 type
= TREE_TYPE (args
[0]);
5483 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
5485 gcc_assert (right_shift
);
5487 se
->expr
= fold_build2_loc (input_location
,
5488 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
5489 TREE_TYPE (args
[0]), args
[0], args
[1]);
5492 se
->expr
= fold_convert (type
, se
->expr
);
5494 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5495 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5497 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5498 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5501 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5502 build_int_cst (type
, 0), se
->expr
);
5505 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5507 : ((shift >= 0) ? i << shift : i >> -shift)
5508 where all shifts are logical shifts. */
5510 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
5522 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5524 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5525 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5527 type
= TREE_TYPE (args
[0]);
5528 utype
= unsigned_type_for (type
);
5530 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
5533 /* Left shift if positive. */
5534 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
5536 /* Right shift if negative.
5537 We convert to an unsigned type because we want a logical shift.
5538 The standard doesn't define the case of shifting negative
5539 numbers, and we try to be compatible with other compilers, most
5540 notably g77, here. */
5541 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
5542 utype
, convert (utype
, args
[0]), width
));
5544 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
5545 build_int_cst (TREE_TYPE (args
[1]), 0));
5546 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
5548 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5549 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5551 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5552 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
5554 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5555 build_int_cst (type
, 0), tmp
);
5559 /* Circular shift. AKA rotate or barrel shift. */
5562 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
5570 unsigned int num_args
;
5572 num_args
= gfc_intrinsic_argument_list_length (expr
);
5573 args
= XALLOCAVEC (tree
, num_args
);
5575 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5579 /* Use a library function for the 3 parameter version. */
5580 tree int4type
= gfc_get_int_type (4);
5582 type
= TREE_TYPE (args
[0]);
5583 /* We convert the first argument to at least 4 bytes, and
5584 convert back afterwards. This removes the need for library
5585 functions for all argument sizes, and function will be
5586 aligned to at least 32 bits, so there's no loss. */
5587 if (expr
->ts
.kind
< 4)
5588 args
[0] = convert (int4type
, args
[0]);
5590 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5591 need loads of library functions. They cannot have values >
5592 BIT_SIZE (I) so the conversion is safe. */
5593 args
[1] = convert (int4type
, args
[1]);
5594 args
[2] = convert (int4type
, args
[2]);
5596 switch (expr
->ts
.kind
)
5601 tmp
= gfor_fndecl_math_ishftc4
;
5604 tmp
= gfor_fndecl_math_ishftc8
;
5607 tmp
= gfor_fndecl_math_ishftc16
;
5612 se
->expr
= build_call_expr_loc (input_location
,
5613 tmp
, 3, args
[0], args
[1], args
[2]);
5614 /* Convert the result back to the original type, if we extended
5615 the first argument's width above. */
5616 if (expr
->ts
.kind
< 4)
5617 se
->expr
= convert (type
, se
->expr
);
5621 type
= TREE_TYPE (args
[0]);
5623 /* Evaluate arguments only once. */
5624 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5625 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5627 /* Rotate left if positive. */
5628 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
5630 /* Rotate right if negative. */
5631 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
5633 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
5635 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
5636 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
5638 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
5640 /* Do nothing if shift == 0. */
5641 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
5643 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
5648 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5649 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5651 The conditional expression is necessary because the result of LEADZ(0)
5652 is defined, but the result of __builtin_clz(0) is undefined for most
5655 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5656 difference in bit size between the argument of LEADZ and the C int. */
5659 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
5671 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5672 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5674 /* Which variant of __builtin_clz* should we call? */
5675 if (argsize
<= INT_TYPE_SIZE
)
5677 arg_type
= unsigned_type_node
;
5678 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
5680 else if (argsize
<= LONG_TYPE_SIZE
)
5682 arg_type
= long_unsigned_type_node
;
5683 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
5685 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5687 arg_type
= long_long_unsigned_type_node
;
5688 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5692 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5693 arg_type
= gfc_build_uint_type (argsize
);
5697 /* Convert the actual argument twice: first, to the unsigned type of the
5698 same size; then, to the proper argument type for the built-in
5699 function. But the return type is of the default INTEGER kind. */
5700 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5701 arg
= fold_convert (arg_type
, arg
);
5702 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5703 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5705 /* Compute LEADZ for the case i .ne. 0. */
5708 s
= TYPE_PRECISION (arg_type
) - argsize
;
5709 tmp
= fold_convert (result_type
,
5710 build_call_expr_loc (input_location
, func
,
5712 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
5713 tmp
, build_int_cst (result_type
, s
));
5717 /* We end up here if the argument type is larger than 'long long'.
5718 We generate this code:
5720 if (x & (ULL_MAX << ULL_SIZE) != 0)
5721 return clzll ((unsigned long long) (x >> ULLSIZE));
5723 return ULL_SIZE + clzll ((unsigned long long) x);
5724 where ULL_MAX is the largest value that a ULL_MAX can hold
5725 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5726 is the bit-size of the long long type (64 in this example). */
5727 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5729 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5730 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5731 long_long_unsigned_type_node
,
5732 build_int_cst (long_long_unsigned_type_node
,
5735 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
5736 fold_convert (arg_type
, ullmax
), ullsize
);
5737 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
5739 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5740 cond
, build_int_cst (arg_type
, 0));
5742 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5744 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5745 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5746 tmp1
= fold_convert (result_type
,
5747 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5749 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5750 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5751 tmp2
= fold_convert (result_type
,
5752 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5753 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5756 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5760 /* Build BIT_SIZE. */
5761 bit_size
= build_int_cst (result_type
, argsize
);
5763 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5764 arg
, build_int_cst (arg_type
, 0));
5765 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5770 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5772 The conditional expression is necessary because the result of TRAILZ(0)
5773 is defined, but the result of __builtin_ctz(0) is undefined for most
5777 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
5788 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5789 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5791 /* Which variant of __builtin_ctz* should we call? */
5792 if (argsize
<= INT_TYPE_SIZE
)
5794 arg_type
= unsigned_type_node
;
5795 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5797 else if (argsize
<= LONG_TYPE_SIZE
)
5799 arg_type
= long_unsigned_type_node
;
5800 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5802 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5804 arg_type
= long_long_unsigned_type_node
;
5805 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5809 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5810 arg_type
= gfc_build_uint_type (argsize
);
5814 /* Convert the actual argument twice: first, to the unsigned type of the
5815 same size; then, to the proper argument type for the built-in
5816 function. But the return type is of the default INTEGER kind. */
5817 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5818 arg
= fold_convert (arg_type
, arg
);
5819 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5820 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5822 /* Compute TRAILZ for the case i .ne. 0. */
5824 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5828 /* We end up here if the argument type is larger than 'long long'.
5829 We generate this code:
5831 if ((x & ULL_MAX) == 0)
5832 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5834 return ctzll ((unsigned long long) x);
5836 where ULL_MAX is the largest value that a ULL_MAX can hold
5837 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5838 is the bit-size of the long long type (64 in this example). */
5839 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5841 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5842 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5843 long_long_unsigned_type_node
,
5844 build_int_cst (long_long_unsigned_type_node
, 0));
5846 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5847 fold_convert (arg_type
, ullmax
));
5848 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
5849 build_int_cst (arg_type
, 0));
5851 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5853 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5854 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5855 tmp1
= fold_convert (result_type
,
5856 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5857 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5860 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5861 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5862 tmp2
= fold_convert (result_type
,
5863 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5865 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5869 /* Build BIT_SIZE. */
5870 bit_size
= build_int_cst (result_type
, argsize
);
5872 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5873 arg
, build_int_cst (arg_type
, 0));
5874 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5878 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5879 for types larger than "long long", we call the long long built-in for
5880 the lower and higher bits and combine the result. */
5883 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5891 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5892 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5893 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5895 /* Which variant of the builtin should we call? */
5896 if (argsize
<= INT_TYPE_SIZE
)
5898 arg_type
= unsigned_type_node
;
5899 func
= builtin_decl_explicit (parity
5901 : BUILT_IN_POPCOUNT
);
5903 else if (argsize
<= LONG_TYPE_SIZE
)
5905 arg_type
= long_unsigned_type_node
;
5906 func
= builtin_decl_explicit (parity
5908 : BUILT_IN_POPCOUNTL
);
5910 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5912 arg_type
= long_long_unsigned_type_node
;
5913 func
= builtin_decl_explicit (parity
5915 : BUILT_IN_POPCOUNTLL
);
5919 /* Our argument type is larger than 'long long', which mean none
5920 of the POPCOUNT builtins covers it. We thus call the 'long long'
5921 variant multiple times, and add the results. */
5922 tree utype
, arg2
, call1
, call2
;
5924 /* For now, we only cover the case where argsize is twice as large
5926 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5928 func
= builtin_decl_explicit (parity
5930 : BUILT_IN_POPCOUNTLL
);
5932 /* Convert it to an integer, and store into a variable. */
5933 utype
= gfc_build_uint_type (argsize
);
5934 arg
= fold_convert (utype
, arg
);
5935 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5937 /* Call the builtin twice. */
5938 call1
= build_call_expr_loc (input_location
, func
, 1,
5939 fold_convert (long_long_unsigned_type_node
,
5942 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5943 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5944 call2
= build_call_expr_loc (input_location
, func
, 1,
5945 fold_convert (long_long_unsigned_type_node
,
5948 /* Combine the results. */
5950 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5953 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5959 /* Convert the actual argument twice: first, to the unsigned type of the
5960 same size; then, to the proper argument type for the built-in
5962 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5963 arg
= fold_convert (arg_type
, arg
);
5965 se
->expr
= fold_convert (result_type
,
5966 build_call_expr_loc (input_location
, func
, 1, arg
));
5970 /* Process an intrinsic with unspecified argument-types that has an optional
5971 argument (which could be of type character), e.g. EOSHIFT. For those, we
5972 need to append the string length of the optional argument if it is not
5973 present and the type is really character.
5974 primary specifies the position (starting at 1) of the non-optional argument
5975 specifying the type and optional gives the position of the optional
5976 argument in the arglist. */
5979 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5980 unsigned primary
, unsigned optional
)
5982 gfc_actual_arglist
* prim_arg
;
5983 gfc_actual_arglist
* opt_arg
;
5985 gfc_actual_arglist
* arg
;
5987 vec
<tree
, va_gc
> *append_args
;
5989 /* Find the two arguments given as position. */
5993 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5997 if (cur_pos
== primary
)
5999 if (cur_pos
== optional
)
6002 if (cur_pos
>= primary
&& cur_pos
>= optional
)
6005 gcc_assert (prim_arg
);
6006 gcc_assert (prim_arg
->expr
);
6007 gcc_assert (opt_arg
);
6009 /* If we do have type CHARACTER and the optional argument is really absent,
6010 append a dummy 0 as string length. */
6012 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
6016 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
6017 vec_alloc (append_args
, 1);
6018 append_args
->quick_push (dummy
);
6021 /* Build the call itself. */
6022 gcc_assert (!se
->ignore_optional
);
6023 sym
= gfc_get_symbol_for_expr (expr
, false);
6024 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6026 gfc_free_symbol (sym
);
6030 /* The length of a character string. */
6032 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
6041 gcc_assert (!se
->ss
);
6043 arg
= expr
->value
.function
.actual
->expr
;
6045 type
= gfc_typenode_for_spec (&expr
->ts
);
6046 switch (arg
->expr_type
)
6049 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
6053 /* Obtain the string length from the function used by
6054 trans-array.c(gfc_trans_array_constructor). */
6056 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
6060 if (arg
->ref
== NULL
6061 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6063 /* This doesn't catch all cases.
6064 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6065 and the surrounding thread. */
6066 sym
= arg
->symtree
->n
.sym
;
6067 decl
= gfc_get_symbol_decl (sym
);
6068 if (decl
== current_function_decl
&& sym
->attr
.function
6069 && (sym
->result
== sym
))
6070 decl
= gfc_get_fake_result_decl (sym
, 0);
6072 len
= sym
->ts
.u
.cl
->backend_decl
;
6080 /* Anybody stupid enough to do this deserves inefficient code. */
6081 gfc_init_se (&argse
, se
);
6083 gfc_conv_expr (&argse
, arg
);
6085 gfc_conv_expr_descriptor (&argse
, arg
);
6086 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6087 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6088 len
= argse
.string_length
;
6091 se
->expr
= convert (type
, len
);
6094 /* The length of a character string not including trailing blanks. */
6096 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6098 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6099 tree args
[2], type
, fndecl
;
6101 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6102 type
= gfc_typenode_for_spec (&expr
->ts
);
6105 fndecl
= gfor_fndecl_string_len_trim
;
6107 fndecl
= gfor_fndecl_string_len_trim_char4
;
6111 se
->expr
= build_call_expr_loc (input_location
,
6112 fndecl
, 2, args
[0], args
[1]);
6113 se
->expr
= convert (type
, se
->expr
);
6117 /* Returns the starting position of a substring within a string. */
6120 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6123 tree logical4_type_node
= gfc_get_logical_type (4);
6127 unsigned int num_args
;
6129 args
= XALLOCAVEC (tree
, 5);
6131 /* Get number of arguments; characters count double due to the
6132 string length argument. Kind= is not passed to the library
6133 and thus ignored. */
6134 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6139 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6140 type
= gfc_typenode_for_spec (&expr
->ts
);
6143 args
[4] = build_int_cst (logical4_type_node
, 0);
6145 args
[4] = convert (logical4_type_node
, args
[4]);
6147 fndecl
= build_addr (function
);
6148 se
->expr
= build_call_array_loc (input_location
,
6149 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6151 se
->expr
= convert (type
, se
->expr
);
6155 /* The ascii value for a single character. */
6157 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6159 tree args
[3], type
, pchartype
;
6162 nargs
= gfc_intrinsic_argument_list_length (expr
);
6163 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6164 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6165 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6166 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6167 type
= gfc_typenode_for_spec (&expr
->ts
);
6169 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6171 se
->expr
= convert (type
, se
->expr
);
6175 /* Intrinsic ISNAN calls __builtin_isnan. */
6178 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6182 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6183 se
->expr
= build_call_expr_loc (input_location
,
6184 builtin_decl_explicit (BUILT_IN_ISNAN
),
6186 STRIP_TYPE_NOPS (se
->expr
);
6187 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6191 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6192 their argument against a constant integer value. */
6195 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6199 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6200 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6201 gfc_typenode_for_spec (&expr
->ts
),
6202 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6207 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6210 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
6218 unsigned int num_args
;
6220 num_args
= gfc_intrinsic_argument_list_length (expr
);
6221 args
= XALLOCAVEC (tree
, num_args
);
6223 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6224 if (expr
->ts
.type
!= BT_CHARACTER
)
6232 /* We do the same as in the non-character case, but the argument
6233 list is different because of the string length arguments. We
6234 also have to set the string length for the result. */
6241 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
6243 se
->string_length
= len
;
6245 type
= TREE_TYPE (tsource
);
6246 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
6247 fold_convert (type
, fsource
));
6251 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6254 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
6256 tree args
[3], mask
, type
;
6258 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6259 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
6261 type
= TREE_TYPE (args
[0]);
6262 gcc_assert (TREE_TYPE (args
[1]) == type
);
6263 gcc_assert (TREE_TYPE (mask
) == type
);
6265 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
6266 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
6267 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6269 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
6274 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6275 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6278 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
6280 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
6283 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6284 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6286 type
= gfc_get_int_type (expr
->ts
.kind
);
6287 utype
= unsigned_type_for (type
);
6289 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
6290 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
6292 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
6293 build_int_cst (utype
, 0));
6297 /* Left-justified mask. */
6298 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
6300 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6301 fold_convert (utype
, res
));
6303 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6304 smaller than type width. */
6305 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
6306 build_int_cst (TREE_TYPE (arg
), 0));
6307 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
6308 build_int_cst (utype
, 0), res
);
6312 /* Right-justified mask. */
6313 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6314 fold_convert (utype
, arg
));
6315 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
6317 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6318 strictly smaller than type width. */
6319 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6321 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
6322 cond
, allones
, res
);
6325 se
->expr
= fold_convert (type
, res
);
6329 /* FRACTION (s) is translated into:
6330 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6332 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
6334 tree arg
, type
, tmp
, res
, frexp
, cond
;
6336 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6338 type
= gfc_typenode_for_spec (&expr
->ts
);
6339 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6340 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6342 cond
= build_call_expr_loc (input_location
,
6343 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6346 tmp
= gfc_create_var (integer_type_node
, NULL
);
6347 res
= build_call_expr_loc (input_location
, frexp
, 2,
6348 fold_convert (type
, arg
),
6349 gfc_build_addr_expr (NULL_TREE
, tmp
));
6350 res
= fold_convert (type
, res
);
6352 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
6353 cond
, res
, gfc_build_nan (type
, ""));
6357 /* NEAREST (s, dir) is translated into
6358 tmp = copysign (HUGE_VAL, dir);
6359 return nextafter (s, tmp);
6362 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
6364 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
6366 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
6367 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
6369 type
= gfc_typenode_for_spec (&expr
->ts
);
6370 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6372 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
6373 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
6374 fold_convert (type
, args
[1]));
6375 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
6376 fold_convert (type
, args
[0]), tmp
);
6377 se
->expr
= fold_convert (type
, se
->expr
);
6381 /* SPACING (s) is translated into
6391 e = MAX_EXPR (e, emin);
6392 res = scalbn (1., e);
6396 where prec is the precision of s, gfc_real_kinds[k].digits,
6397 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6398 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6401 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
6403 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
6404 tree cond
, nan
, tmp
, frexp
, scalbn
;
6408 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6409 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
6410 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
6411 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
6413 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6414 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6416 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6417 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6419 type
= gfc_typenode_for_spec (&expr
->ts
);
6420 e
= gfc_create_var (integer_type_node
, NULL
);
6421 res
= gfc_create_var (type
, NULL
);
6424 /* Build the block for s /= 0. */
6425 gfc_start_block (&block
);
6426 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6427 gfc_build_addr_expr (NULL_TREE
, e
));
6428 gfc_add_expr_to_block (&block
, tmp
);
6430 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
6432 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
6433 integer_type_node
, tmp
, emin
));
6435 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
6436 build_real_from_int_cst (type
, integer_one_node
), e
);
6437 gfc_add_modify (&block
, res
, tmp
);
6439 /* Finish by building the IF statement for value zero. */
6440 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
6441 build_real_from_int_cst (type
, integer_zero_node
));
6442 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
6443 gfc_finish_block (&block
));
6445 /* And deal with infinities and NaNs. */
6446 cond
= build_call_expr_loc (input_location
,
6447 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6449 nan
= gfc_build_nan (type
, "");
6450 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
6452 gfc_add_expr_to_block (&se
->pre
, tmp
);
6457 /* RRSPACING (s) is translated into
6466 x = scalbn (x, precision - e);
6473 where precision is gfc_real_kinds[k].digits. */
6476 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
6478 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
6482 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6483 prec
= gfc_real_kinds
[k
].digits
;
6485 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6486 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6487 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
6489 type
= gfc_typenode_for_spec (&expr
->ts
);
6490 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6491 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6493 e
= gfc_create_var (integer_type_node
, NULL
);
6494 x
= gfc_create_var (type
, NULL
);
6495 gfc_add_modify (&se
->pre
, x
,
6496 build_call_expr_loc (input_location
, fabs
, 1, arg
));
6499 gfc_start_block (&block
);
6500 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6501 gfc_build_addr_expr (NULL_TREE
, e
));
6502 gfc_add_expr_to_block (&block
, tmp
);
6504 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
6505 build_int_cst (integer_type_node
, prec
), e
);
6506 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
6507 gfc_add_modify (&block
, x
, tmp
);
6508 stmt
= gfc_finish_block (&block
);
6511 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
6512 build_real_from_int_cst (type
, integer_zero_node
));
6513 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
6515 /* And deal with infinities and NaNs. */
6516 cond
= build_call_expr_loc (input_location
,
6517 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6519 nan
= gfc_build_nan (type
, "");
6520 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
6522 gfc_add_expr_to_block (&se
->pre
, tmp
);
6523 se
->expr
= fold_convert (type
, x
);
6527 /* SCALE (s, i) is translated into scalbn (s, i). */
6529 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
6531 tree args
[2], type
, scalbn
;
6533 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6535 type
= gfc_typenode_for_spec (&expr
->ts
);
6536 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6537 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
6538 fold_convert (type
, args
[0]),
6539 fold_convert (integer_type_node
, args
[1]));
6540 se
->expr
= fold_convert (type
, se
->expr
);
6544 /* SET_EXPONENT (s, i) is translated into
6545 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6547 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
6549 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
6551 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6552 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6554 type
= gfc_typenode_for_spec (&expr
->ts
);
6555 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6556 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6558 tmp
= gfc_create_var (integer_type_node
, NULL
);
6559 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
6560 fold_convert (type
, args
[0]),
6561 gfc_build_addr_expr (NULL_TREE
, tmp
));
6562 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
6563 fold_convert (integer_type_node
, args
[1]));
6564 res
= fold_convert (type
, res
);
6566 /* Call to isfinite */
6567 cond
= build_call_expr_loc (input_location
,
6568 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6570 nan
= gfc_build_nan (type
, "");
6572 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6578 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
6580 gfc_actual_arglist
*actual
;
6587 gfc_init_se (&argse
, NULL
);
6588 actual
= expr
->value
.function
.actual
;
6590 if (actual
->expr
->ts
.type
== BT_CLASS
)
6591 gfc_add_class_array_ref (actual
->expr
);
6593 argse
.data_not_needed
= 1;
6594 if (gfc_is_alloc_class_array_function (actual
->expr
))
6596 /* For functions that return a class array conv_expr_descriptor is not
6597 able to get the descriptor right. Therefore this special case. */
6598 gfc_conv_expr_reference (&argse
, actual
->expr
);
6599 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6600 gfc_class_data_get (argse
.expr
));
6604 argse
.want_pointer
= 1;
6605 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
6607 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6608 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6609 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
6611 /* Build the call to size0. */
6612 fncall0
= build_call_expr_loc (input_location
,
6613 gfor_fndecl_size0
, 1, arg1
);
6615 actual
= actual
->next
;
6619 gfc_init_se (&argse
, NULL
);
6620 gfc_conv_expr_type (&argse
, actual
->expr
,
6621 gfc_array_index_type
);
6622 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6624 /* Unusually, for an intrinsic, size does not exclude
6625 an optional arg2, so we must test for it. */
6626 if (actual
->expr
->expr_type
== EXPR_VARIABLE
6627 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
6628 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
6631 /* Build the call to size1. */
6632 fncall1
= build_call_expr_loc (input_location
,
6633 gfor_fndecl_size1
, 2,
6636 gfc_init_se (&argse
, NULL
);
6637 argse
.want_pointer
= 1;
6638 argse
.data_not_needed
= 1;
6639 gfc_conv_expr (&argse
, actual
->expr
);
6640 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6641 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6642 argse
.expr
, null_pointer_node
);
6643 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6644 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
6645 pvoid_type_node
, tmp
, fncall1
, fncall0
);
6649 se
->expr
= NULL_TREE
;
6650 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6651 gfc_array_index_type
,
6652 argse
.expr
, gfc_index_one_node
);
6655 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
6657 argse
.expr
= gfc_index_zero_node
;
6658 se
->expr
= NULL_TREE
;
6663 if (se
->expr
== NULL_TREE
)
6665 tree ubound
, lbound
;
6667 arg1
= build_fold_indirect_ref_loc (input_location
,
6669 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
6670 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
6671 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6672 gfc_array_index_type
, ubound
, lbound
);
6673 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
6674 gfc_array_index_type
,
6675 se
->expr
, gfc_index_one_node
);
6676 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6677 gfc_array_index_type
, se
->expr
,
6678 gfc_index_zero_node
);
6681 type
= gfc_typenode_for_spec (&expr
->ts
);
6682 se
->expr
= convert (type
, se
->expr
);
6686 /* Helper function to compute the size of a character variable,
6687 excluding the terminating null characters. The result has
6688 gfc_array_index_type type. */
6691 size_of_string_in_bytes (int kind
, tree string_length
)
6694 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
6696 bytesize
= build_int_cst (gfc_array_index_type
,
6697 gfc_character_kinds
[i
].bit_size
/ 8);
6699 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6701 fold_convert (gfc_array_index_type
, string_length
));
6706 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
6717 gfc_init_se (&argse
, NULL
);
6718 arg
= expr
->value
.function
.actual
->expr
;
6720 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
6721 gfc_conv_expr_descriptor (&argse
, arg
);
6723 gfc_conv_expr_reference (&argse
, arg
);
6725 if (arg
->ts
.type
== BT_ASSUMED
)
6727 /* This only works if an array descriptor has been passed; thus, extract
6728 the size from the descriptor. */
6729 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
6730 == TYPE_PRECISION (size_type_node
));
6731 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
6732 tmp
= DECL_LANG_SPECIFIC (tmp
)
6733 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
6734 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
6735 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
6736 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6737 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
6738 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
6739 build_int_cst (TREE_TYPE (tmp
),
6740 GFC_DTYPE_SIZE_SHIFT
));
6741 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
6743 else if (arg
->ts
.type
== BT_CLASS
)
6745 /* Conv_expr_descriptor returns a component_ref to _data component of the
6746 class object. The class object may be a non-pointer object, e.g.
6747 located on the stack, or a memory location pointed to, e.g. a
6748 parameter, i.e., an indirect_ref. */
6750 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
6751 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
6752 && GFC_DECL_CLASS (TREE_OPERAND (
6753 TREE_OPERAND (argse
.expr
, 0), 0)))
6754 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
6755 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6756 else if (arg
->rank
> 0
6758 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
6759 /* The scalarizer added an additional temp. To get the class' vptr
6760 one has to look at the original backend_decl. */
6761 byte_size
= gfc_class_vtab_size_get (
6762 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6764 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
6768 if (arg
->ts
.type
== BT_CHARACTER
)
6769 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6773 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6776 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6777 byte_size
= fold_convert (gfc_array_index_type
,
6778 size_in_bytes (byte_size
));
6783 se
->expr
= byte_size
;
6786 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
6787 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
6789 if (arg
->rank
== -1)
6791 tree cond
, loop_var
, exit_label
;
6794 tmp
= fold_convert (gfc_array_index_type
,
6795 gfc_conv_descriptor_rank (argse
.expr
));
6796 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
6797 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
6798 exit_label
= gfc_build_label_decl (NULL_TREE
);
6805 source_bytes = source_bytes * array.dim[i].extent;
6809 gfc_start_block (&body
);
6810 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6812 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6813 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6814 cond
, tmp
, build_empty_stmt (input_location
));
6815 gfc_add_expr_to_block (&body
, tmp
);
6817 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6818 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6819 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6820 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6821 gfc_array_index_type
, tmp
, source_bytes
);
6822 gfc_add_modify (&body
, source_bytes
, tmp
);
6824 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6825 gfc_array_index_type
, loop_var
,
6826 gfc_index_one_node
);
6827 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6829 tmp
= gfc_finish_block (&body
);
6831 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6833 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6835 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6836 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6840 /* Obtain the size of the array in bytes. */
6841 for (n
= 0; n
< arg
->rank
; n
++)
6844 idx
= gfc_rank_cst
[n
];
6845 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6846 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6847 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6848 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6849 gfc_array_index_type
, tmp
, source_bytes
);
6850 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6853 se
->expr
= source_bytes
;
6856 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6861 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6865 tree type
, result_type
, tmp
;
6867 arg
= expr
->value
.function
.actual
->expr
;
6869 gfc_init_se (&argse
, NULL
);
6870 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6874 if (arg
->ts
.type
== BT_CLASS
)
6876 gfc_add_vptr_component (arg
);
6877 gfc_add_size_component (arg
);
6878 gfc_conv_expr (&argse
, arg
);
6879 tmp
= fold_convert (result_type
, argse
.expr
);
6883 gfc_conv_expr_reference (&argse
, arg
);
6884 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6889 argse
.want_pointer
= 0;
6890 gfc_conv_expr_descriptor (&argse
, arg
);
6891 if (arg
->ts
.type
== BT_CLASS
)
6894 tmp
= gfc_class_vtab_size_get (
6895 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6897 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6898 tmp
= fold_convert (result_type
, tmp
);
6901 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6904 /* Obtain the argument's word length. */
6905 if (arg
->ts
.type
== BT_CHARACTER
)
6906 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6908 tmp
= size_in_bytes (type
);
6909 tmp
= fold_convert (result_type
, tmp
);
6912 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6913 build_int_cst (result_type
, BITS_PER_UNIT
));
6914 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6918 /* Intrinsic string comparison functions. */
6921 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6925 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6928 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6929 expr
->value
.function
.actual
->expr
->ts
.kind
,
6931 se
->expr
= fold_build2_loc (input_location
, op
,
6932 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6933 build_int_cst (TREE_TYPE (se
->expr
), 0));
6936 /* Generate a call to the adjustl/adjustr library function. */
6938 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6946 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6949 type
= TREE_TYPE (args
[2]);
6950 var
= gfc_conv_string_tmp (se
, type
, len
);
6953 tmp
= build_call_expr_loc (input_location
,
6954 fndecl
, 3, args
[0], args
[1], args
[2]);
6955 gfc_add_expr_to_block (&se
->pre
, tmp
);
6957 se
->string_length
= len
;
6961 /* Generate code for the TRANSFER intrinsic:
6963 DEST = TRANSFER (SOURCE, MOLD)
6965 typeof<DEST> = typeof<MOLD>
6970 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6972 typeof<DEST> = typeof<MOLD>
6974 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6975 sizeof (DEST(0) * SIZE). */
6977 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6993 gfc_actual_arglist
*arg
;
6995 gfc_array_info
*info
;
6999 gfc_expr
*source_expr
, *mold_expr
;
7003 info
= &se
->ss
->info
->data
.array
;
7005 /* Convert SOURCE. The output from this stage is:-
7006 source_bytes = length of the source in bytes
7007 source = pointer to the source data. */
7008 arg
= expr
->value
.function
.actual
;
7009 source_expr
= arg
->expr
;
7011 /* Ensure double transfer through LOGICAL preserves all
7013 if (arg
->expr
->expr_type
== EXPR_FUNCTION
7014 && arg
->expr
->value
.function
.esym
== NULL
7015 && arg
->expr
->value
.function
.isym
!= NULL
7016 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
7017 && arg
->expr
->ts
.type
== BT_LOGICAL
7018 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
7019 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
7021 gfc_init_se (&argse
, NULL
);
7023 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7025 /* Obtain the pointer to source and the length of source in bytes. */
7026 if (arg
->expr
->rank
== 0)
7028 gfc_conv_expr_reference (&argse
, arg
->expr
);
7029 if (arg
->expr
->ts
.type
== BT_CLASS
)
7030 source
= gfc_class_data_get (argse
.expr
);
7032 source
= argse
.expr
;
7034 /* Obtain the source word length. */
7035 switch (arg
->expr
->ts
.type
)
7038 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7039 argse
.string_length
);
7042 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7045 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7047 tmp
= fold_convert (gfc_array_index_type
,
7048 size_in_bytes (source_type
));
7054 argse
.want_pointer
= 0;
7055 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7056 source
= gfc_conv_descriptor_data_get (argse
.expr
);
7057 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7059 /* Repack the source if not simply contiguous. */
7060 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
7062 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
7064 if (warn_array_temporaries
)
7065 gfc_warning (OPT_Warray_temporaries
,
7066 "Creating array temporary at %L", &expr
->where
);
7068 source
= build_call_expr_loc (input_location
,
7069 gfor_fndecl_in_pack
, 1, tmp
);
7070 source
= gfc_evaluate_now (source
, &argse
.pre
);
7072 /* Free the temporary. */
7073 gfc_start_block (&block
);
7074 tmp
= gfc_call_free (source
);
7075 gfc_add_expr_to_block (&block
, tmp
);
7076 stmt
= gfc_finish_block (&block
);
7078 /* Clean up if it was repacked. */
7079 gfc_init_block (&block
);
7080 tmp
= gfc_conv_array_data (argse
.expr
);
7081 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7083 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7084 build_empty_stmt (input_location
));
7085 gfc_add_expr_to_block (&block
, tmp
);
7086 gfc_add_block_to_block (&block
, &se
->post
);
7087 gfc_init_block (&se
->post
);
7088 gfc_add_block_to_block (&se
->post
, &block
);
7091 /* Obtain the source word length. */
7092 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7093 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7094 argse
.string_length
);
7096 tmp
= fold_convert (gfc_array_index_type
,
7097 size_in_bytes (source_type
));
7099 /* Obtain the size of the array in bytes. */
7100 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7101 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7104 idx
= gfc_rank_cst
[n
];
7105 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7106 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7107 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7108 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7109 gfc_array_index_type
, upper
, lower
);
7110 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7111 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7112 gfc_array_index_type
, extent
,
7113 gfc_index_one_node
);
7114 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7115 gfc_array_index_type
, tmp
, source_bytes
);
7119 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7120 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7121 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7123 /* Now convert MOLD. The outputs are:
7124 mold_type = the TREE type of MOLD
7125 dest_word_len = destination word length in bytes. */
7127 mold_expr
= arg
->expr
;
7129 gfc_init_se (&argse
, NULL
);
7131 scalar_mold
= arg
->expr
->rank
== 0;
7133 if (arg
->expr
->rank
== 0)
7135 gfc_conv_expr_reference (&argse
, arg
->expr
);
7136 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7141 gfc_init_se (&argse
, NULL
);
7142 argse
.want_pointer
= 0;
7143 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7144 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7147 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7148 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7150 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7152 /* If this TRANSFER is nested in another TRANSFER, use a type
7153 that preserves all bits. */
7154 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7155 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7158 /* Obtain the destination word length. */
7159 switch (arg
->expr
->ts
.type
)
7162 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7163 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7166 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7169 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7172 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7173 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7175 /* Finally convert SIZE, if it is present. */
7177 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7181 gfc_init_se (&argse
, NULL
);
7182 gfc_conv_expr_reference (&argse
, arg
->expr
);
7183 tmp
= convert (gfc_array_index_type
,
7184 build_fold_indirect_ref_loc (input_location
,
7186 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7187 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7192 /* Separate array and scalar results. */
7193 if (scalar_mold
&& tmp
== NULL_TREE
)
7194 goto scalar_transfer
;
7196 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7197 if (tmp
!= NULL_TREE
)
7198 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7199 tmp
, dest_word_len
);
7203 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
7204 gfc_add_modify (&se
->pre
, size_words
,
7205 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
7206 gfc_array_index_type
,
7207 size_bytes
, dest_word_len
));
7209 /* Evaluate the bounds of the result. If the loop range exists, we have
7210 to check if it is too large. If so, we modify loop->to be consistent
7211 with min(size, size(source)). Otherwise, size is made consistent with
7212 the loop range, so that the right number of bytes is transferred.*/
7213 n
= se
->loop
->order
[0];
7214 if (se
->loop
->to
[n
] != NULL_TREE
)
7216 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7217 se
->loop
->to
[n
], se
->loop
->from
[n
]);
7218 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7219 tmp
, gfc_index_one_node
);
7220 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7222 gfc_add_modify (&se
->pre
, size_words
, tmp
);
7223 gfc_add_modify (&se
->pre
, size_bytes
,
7224 fold_build2_loc (input_location
, MULT_EXPR
,
7225 gfc_array_index_type
,
7226 size_words
, dest_word_len
));
7227 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7228 size_words
, se
->loop
->from
[n
]);
7229 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7230 upper
, gfc_index_one_node
);
7234 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7235 size_words
, gfc_index_one_node
);
7236 se
->loop
->from
[n
] = gfc_index_zero_node
;
7239 se
->loop
->to
[n
] = upper
;
7241 /* Build a destination descriptor, using the pointer, source, as the
7243 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
7244 NULL_TREE
, false, true, false, &expr
->where
);
7246 /* Cast the pointer to the result. */
7247 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7248 tmp
= fold_convert (pvoid_type_node
, tmp
);
7250 /* Use memcpy to do the transfer. */
7252 = build_call_expr_loc (input_location
,
7253 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
7254 fold_convert (pvoid_type_node
, source
),
7255 fold_convert (size_type_node
,
7256 fold_build2_loc (input_location
,
7258 gfc_array_index_type
,
7261 gfc_add_expr_to_block (&se
->pre
, tmp
);
7263 se
->expr
= info
->descriptor
;
7264 if (expr
->ts
.type
== BT_CHARACTER
)
7265 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7269 /* Deal with scalar results. */
7271 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7272 dest_word_len
, source_bytes
);
7273 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7274 extent
, gfc_index_zero_node
);
7276 if (expr
->ts
.type
== BT_CHARACTER
)
7278 tree direct
, indirect
, free
;
7280 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
7281 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
7284 /* If source is longer than the destination, use a pointer to
7285 the source directly. */
7286 gfc_init_block (&block
);
7287 gfc_add_modify (&block
, tmpdecl
, ptr
);
7288 direct
= gfc_finish_block (&block
);
7290 /* Otherwise, allocate a string with the length of the destination
7291 and copy the source into it. */
7292 gfc_init_block (&block
);
7293 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
7294 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
7295 gfc_add_modify (&block
, tmpdecl
,
7296 fold_convert (TREE_TYPE (ptr
), tmp
));
7297 tmp
= build_call_expr_loc (input_location
,
7298 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7299 fold_convert (pvoid_type_node
, tmpdecl
),
7300 fold_convert (pvoid_type_node
, ptr
),
7301 fold_convert (size_type_node
, extent
));
7302 gfc_add_expr_to_block (&block
, tmp
);
7303 indirect
= gfc_finish_block (&block
);
7305 /* Wrap it up with the condition. */
7306 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
7307 dest_word_len
, source_bytes
);
7308 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
7309 gfc_add_expr_to_block (&se
->pre
, tmp
);
7311 /* Free the temporary string, if necessary. */
7312 free
= gfc_call_free (tmpdecl
);
7313 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7314 dest_word_len
, source_bytes
);
7315 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
7316 gfc_add_expr_to_block (&se
->post
, tmp
);
7319 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7323 tmpdecl
= gfc_create_var (mold_type
, "transfer");
7325 ptr
= convert (build_pointer_type (mold_type
), source
);
7327 /* For CLASS results, allocate the needed memory first. */
7328 if (mold_expr
->ts
.type
== BT_CLASS
)
7331 cdata
= gfc_class_data_get (tmpdecl
);
7332 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
7333 gfc_add_modify (&se
->pre
, cdata
, tmp
);
7336 /* Use memcpy to do the transfer. */
7337 if (mold_expr
->ts
.type
== BT_CLASS
)
7338 tmp
= gfc_class_data_get (tmpdecl
);
7340 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
7342 tmp
= build_call_expr_loc (input_location
,
7343 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7344 fold_convert (pvoid_type_node
, tmp
),
7345 fold_convert (pvoid_type_node
, ptr
),
7346 fold_convert (size_type_node
, extent
));
7347 gfc_add_expr_to_block (&se
->pre
, tmp
);
7349 /* For CLASS results, set the _vptr. */
7350 if (mold_expr
->ts
.type
== BT_CLASS
)
7354 vptr
= gfc_class_vptr_get (tmpdecl
);
7355 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
7357 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7358 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
7366 /* Generate a call to caf_is_present. */
7369 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
7371 tree caf_reference
, caf_decl
, token
, image_index
;
7373 /* Compile the reference chain. */
7374 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
7375 gcc_assert (caf_reference
!= NULL_TREE
);
7377 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
7378 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
7379 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
7380 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
7381 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
7384 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
7385 3, token
, image_index
, caf_reference
);
7389 /* Test whether this ref-chain refs this image only. */
7392 caf_this_image_ref (gfc_ref
*ref
)
7394 for ( ; ref
; ref
= ref
->next
)
7395 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
7396 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
7402 /* Generate code for the ALLOCATED intrinsic.
7403 Generate inline code that directly check the address of the argument. */
7406 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
7408 gfc_actual_arglist
*arg1
;
7411 symbol_attribute caf_attr
;
7413 gfc_init_se (&arg1se
, NULL
);
7414 arg1
= expr
->value
.function
.actual
;
7416 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7418 /* Make sure that class array expressions have both a _data
7419 component reference and an array reference.... */
7420 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
7421 gfc_add_class_array_ref (arg1
->expr
);
7422 /* .... whilst scalars only need the _data component. */
7424 gfc_add_data_component (arg1
->expr
);
7427 /* When arg1 references an allocatable component in a coarray, then call
7428 the caf-library function caf_is_present (). */
7429 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
7430 && arg1
->expr
->value
.function
.isym
7431 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
7432 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
7434 gfc_clear_attr (&caf_attr
);
7435 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
7436 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
7437 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
7440 if (arg1
->expr
->rank
== 0)
7442 /* Allocatable scalar. */
7443 arg1se
.want_pointer
= 1;
7444 gfc_conv_expr (&arg1se
, arg1
->expr
);
7449 /* Allocatable array. */
7450 arg1se
.descriptor_only
= 1;
7451 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7452 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7455 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
7456 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7458 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7462 /* Generate code for the ASSOCIATED intrinsic.
7463 If both POINTER and TARGET are arrays, generate a call to library function
7464 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7465 In other cases, generate inline code that directly compare the address of
7466 POINTER with the address of TARGET. */
7469 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
7471 gfc_actual_arglist
*arg1
;
7472 gfc_actual_arglist
*arg2
;
7477 tree nonzero_charlen
;
7478 tree nonzero_arraylen
;
7482 gfc_init_se (&arg1se
, NULL
);
7483 gfc_init_se (&arg2se
, NULL
);
7484 arg1
= expr
->value
.function
.actual
;
7487 /* Check whether the expression is a scalar or not; we cannot use
7488 arg1->expr->rank as it can be nonzero for proc pointers. */
7489 ss
= gfc_walk_expr (arg1
->expr
);
7490 scalar
= ss
== gfc_ss_terminator
;
7492 gfc_free_ss_chain (ss
);
7496 /* No optional target. */
7499 /* A pointer to a scalar. */
7500 arg1se
.want_pointer
= 1;
7501 gfc_conv_expr (&arg1se
, arg1
->expr
);
7502 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7503 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7504 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7506 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7508 tmp2
= gfc_class_data_get (arg1se
.expr
);
7509 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7510 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7517 /* A pointer to an array. */
7518 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7519 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7521 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7522 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7523 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
7524 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
7529 /* An optional target. */
7530 if (arg2
->expr
->ts
.type
== BT_CLASS
)
7531 gfc_add_data_component (arg2
->expr
);
7533 nonzero_charlen
= NULL_TREE
;
7534 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
7535 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
7537 arg1
->expr
->ts
.u
.cl
->backend_decl
,
7541 /* A pointer to a scalar. */
7542 arg1se
.want_pointer
= 1;
7543 gfc_conv_expr (&arg1se
, arg1
->expr
);
7544 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7545 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7546 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7548 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7549 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
7551 arg2se
.want_pointer
= 1;
7552 gfc_conv_expr (&arg2se
, arg2
->expr
);
7553 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7554 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
7555 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
7557 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7558 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7559 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7560 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7561 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7562 arg1se
.expr
, arg2se
.expr
);
7563 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7564 arg1se
.expr
, null_pointer_node
);
7565 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7566 boolean_type_node
, tmp
, tmp2
);
7570 /* An array pointer of zero length is not associated if target is
7572 arg1se
.descriptor_only
= 1;
7573 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
7574 if (arg1
->expr
->rank
== -1)
7576 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
7577 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7578 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
7581 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
7582 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
7583 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
7584 boolean_type_node
, tmp
,
7585 build_int_cst (TREE_TYPE (tmp
), 0));
7587 /* A pointer to an array, call library function _gfor_associated. */
7588 arg1se
.want_pointer
= 1;
7589 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7591 arg2se
.want_pointer
= 1;
7592 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
7593 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7594 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7595 se
->expr
= build_call_expr_loc (input_location
,
7596 gfor_fndecl_associated
, 2,
7597 arg1se
.expr
, arg2se
.expr
);
7598 se
->expr
= convert (boolean_type_node
, se
->expr
);
7599 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7600 boolean_type_node
, se
->expr
,
7604 /* If target is present zero character length pointers cannot
7606 if (nonzero_charlen
!= NULL_TREE
)
7607 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7609 se
->expr
, nonzero_charlen
);
7612 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7616 /* Generate code for the SAME_TYPE_AS intrinsic.
7617 Generate inline code that directly checks the vindices. */
7620 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
7625 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
7627 gfc_init_se (&se1
, NULL
);
7628 gfc_init_se (&se2
, NULL
);
7630 a
= expr
->value
.function
.actual
->expr
;
7631 b
= expr
->value
.function
.actual
->next
->expr
;
7633 if (UNLIMITED_POLY (a
))
7635 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
7636 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7637 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7640 if (UNLIMITED_POLY (b
))
7642 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
7643 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7644 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7647 if (a
->ts
.type
== BT_CLASS
)
7649 gfc_add_vptr_component (a
);
7650 gfc_add_hash_component (a
);
7652 else if (a
->ts
.type
== BT_DERIVED
)
7653 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7654 a
->ts
.u
.derived
->hash_value
);
7656 if (b
->ts
.type
== BT_CLASS
)
7658 gfc_add_vptr_component (b
);
7659 gfc_add_hash_component (b
);
7661 else if (b
->ts
.type
== BT_DERIVED
)
7662 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7663 b
->ts
.u
.derived
->hash_value
);
7665 gfc_conv_expr (&se1
, a
);
7666 gfc_conv_expr (&se2
, b
);
7668 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
7669 boolean_type_node
, se1
.expr
,
7670 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
7673 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7674 boolean_type_node
, conda
, tmp
);
7677 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7678 boolean_type_node
, condb
, tmp
);
7680 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7684 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
7687 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
7691 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7692 se
->expr
= build_call_expr_loc (input_location
,
7693 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
7694 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7698 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
7701 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
7705 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7707 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
7708 type
= gfc_get_int_type (4);
7709 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
7711 /* Convert it to the required type. */
7712 type
= gfc_typenode_for_spec (&expr
->ts
);
7713 se
->expr
= build_call_expr_loc (input_location
,
7714 gfor_fndecl_si_kind
, 1, arg
);
7715 se
->expr
= fold_convert (type
, se
->expr
);
7719 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
7722 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
7724 gfc_actual_arglist
*actual
;
7727 vec
<tree
, va_gc
> *args
= NULL
;
7729 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
7731 gfc_init_se (&argse
, se
);
7733 /* Pass a NULL pointer for an absent arg. */
7734 if (actual
->expr
== NULL
)
7735 argse
.expr
= null_pointer_node
;
7741 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
7743 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
7744 ts
.type
= BT_INTEGER
;
7745 ts
.kind
= gfc_c_int_kind
;
7746 gfc_convert_type (actual
->expr
, &ts
, 2);
7748 gfc_conv_expr_reference (&argse
, actual
->expr
);
7751 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7752 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7753 vec_safe_push (args
, argse
.expr
);
7756 /* Convert it to the required type. */
7757 type
= gfc_typenode_for_spec (&expr
->ts
);
7758 se
->expr
= build_call_expr_loc_vec (input_location
,
7759 gfor_fndecl_sr_kind
, args
);
7760 se
->expr
= fold_convert (type
, se
->expr
);
7764 /* Generate code for TRIM (A) intrinsic function. */
7767 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
7777 unsigned int num_args
;
7779 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
7780 args
= XALLOCAVEC (tree
, num_args
);
7782 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
7783 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
7784 len
= gfc_create_var (gfc_charlen_type_node
, "len");
7786 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
7787 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
7790 if (expr
->ts
.kind
== 1)
7791 function
= gfor_fndecl_string_trim
;
7792 else if (expr
->ts
.kind
== 4)
7793 function
= gfor_fndecl_string_trim_char4
;
7797 fndecl
= build_addr (function
);
7798 tmp
= build_call_array_loc (input_location
,
7799 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7801 gfc_add_expr_to_block (&se
->pre
, tmp
);
7803 /* Free the temporary afterwards, if necessary. */
7804 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7805 len
, build_int_cst (TREE_TYPE (len
), 0));
7806 tmp
= gfc_call_free (var
);
7807 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
7808 gfc_add_expr_to_block (&se
->post
, tmp
);
7811 se
->string_length
= len
;
7815 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
7818 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
7820 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
7821 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
7823 stmtblock_t block
, body
;
7826 /* We store in charsize the size of a character. */
7827 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
7828 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
7830 /* Get the arguments. */
7831 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7832 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
7834 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
7835 ncopies_type
= TREE_TYPE (ncopies
);
7837 /* Check that NCOPIES is not negative. */
7838 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
7839 build_int_cst (ncopies_type
, 0));
7840 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7841 "Argument NCOPIES of REPEAT intrinsic is negative "
7842 "(its value is %ld)",
7843 fold_convert (long_integer_type_node
, ncopies
));
7845 /* If the source length is zero, any non negative value of NCOPIES
7846 is valid, and nothing happens. */
7847 n
= gfc_create_var (ncopies_type
, "ncopies");
7848 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7849 build_int_cst (size_type_node
, 0));
7850 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
7851 build_int_cst (ncopies_type
, 0), ncopies
);
7852 gfc_add_modify (&se
->pre
, n
, tmp
);
7855 /* Check that ncopies is not too large: ncopies should be less than
7856 (or equal to) MAX / slen, where MAX is the maximal integer of
7857 the gfc_charlen_type_node type. If slen == 0, we need a special
7858 case to avoid the division by zero. */
7859 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
7860 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
7861 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
7862 fold_convert (size_type_node
, max
), slen
);
7863 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
7864 ? size_type_node
: ncopies_type
;
7865 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7866 fold_convert (largest
, ncopies
),
7867 fold_convert (largest
, max
));
7868 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7869 build_int_cst (size_type_node
, 0));
7870 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
7871 boolean_false_node
, cond
);
7872 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7873 "Argument NCOPIES of REPEAT intrinsic is too large");
7875 /* Compute the destination length. */
7876 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7877 fold_convert (gfc_charlen_type_node
, slen
),
7878 fold_convert (gfc_charlen_type_node
, ncopies
));
7879 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
7880 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
7882 /* Generate the code to do the repeat operation:
7883 for (i = 0; i < ncopies; i++)
7884 memmove (dest + (i * slen * size), src, slen*size); */
7885 gfc_start_block (&block
);
7886 count
= gfc_create_var (ncopies_type
, "count");
7887 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
7888 exit_label
= gfc_build_label_decl (NULL_TREE
);
7890 /* Start the loop body. */
7891 gfc_start_block (&body
);
7893 /* Exit the loop if count >= ncopies. */
7894 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
7896 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7897 TREE_USED (exit_label
) = 1;
7898 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7899 build_empty_stmt (input_location
));
7900 gfc_add_expr_to_block (&body
, tmp
);
7902 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7903 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7904 fold_convert (gfc_charlen_type_node
, slen
),
7905 fold_convert (gfc_charlen_type_node
, count
));
7906 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7907 tmp
, fold_convert (gfc_charlen_type_node
, size
));
7908 tmp
= fold_build_pointer_plus_loc (input_location
,
7909 fold_convert (pvoid_type_node
, dest
), tmp
);
7910 tmp
= build_call_expr_loc (input_location
,
7911 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7913 fold_build2_loc (input_location
, MULT_EXPR
,
7914 size_type_node
, slen
,
7915 fold_convert (size_type_node
,
7917 gfc_add_expr_to_block (&body
, tmp
);
7919 /* Increment count. */
7920 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
7921 count
, build_int_cst (TREE_TYPE (count
), 1));
7922 gfc_add_modify (&body
, count
, tmp
);
7924 /* Build the loop. */
7925 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7926 gfc_add_expr_to_block (&block
, tmp
);
7928 /* Add the exit label. */
7929 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7930 gfc_add_expr_to_block (&block
, tmp
);
7932 /* Finish the block. */
7933 tmp
= gfc_finish_block (&block
);
7934 gfc_add_expr_to_block (&se
->pre
, tmp
);
7936 /* Set the result value. */
7938 se
->string_length
= dlen
;
7942 /* Generate code for the IARGC intrinsic. */
7945 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
7951 /* Call the library function. This always returns an INTEGER(4). */
7952 fndecl
= gfor_fndecl_iargc
;
7953 tmp
= build_call_expr_loc (input_location
,
7956 /* Convert it to the required type. */
7957 type
= gfc_typenode_for_spec (&expr
->ts
);
7958 tmp
= fold_convert (type
, tmp
);
7964 /* The loc intrinsic returns the address of its argument as
7965 gfc_index_integer_kind integer. */
7968 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7973 gcc_assert (!se
->ss
);
7975 arg_expr
= expr
->value
.function
.actual
->expr
;
7976 if (arg_expr
->rank
== 0)
7978 if (arg_expr
->ts
.type
== BT_CLASS
)
7979 gfc_add_data_component (arg_expr
);
7980 gfc_conv_expr_reference (se
, arg_expr
);
7983 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7984 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7986 /* Create a temporary variable for loc return value. Without this,
7987 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7988 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7989 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7990 se
->expr
= temp_var
;
7994 /* The following routine generates code for the intrinsic
7995 functions from the ISO_C_BINDING module:
8001 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
8003 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
8005 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
8007 if (arg
->expr
->rank
== 0)
8008 gfc_conv_expr_reference (se
, arg
->expr
);
8009 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
8010 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
8013 gfc_conv_expr_descriptor (se
, arg
->expr
);
8014 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
8017 /* TODO -- the following two lines shouldn't be necessary, but if
8018 they're removed, a bug is exposed later in the code path.
8019 This workaround was thus introduced, but will have to be
8020 removed; please see PR 35150 for details about the issue. */
8021 se
->expr
= convert (pvoid_type_node
, se
->expr
);
8022 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
8024 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
8025 gfc_conv_expr_reference (se
, arg
->expr
);
8026 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
8031 /* Build the addr_expr for the first argument. The argument is
8032 already an *address* so we don't need to set want_pointer in
8034 gfc_init_se (&arg1se
, NULL
);
8035 gfc_conv_expr (&arg1se
, arg
->expr
);
8036 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8037 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8039 /* See if we were given two arguments. */
8040 if (arg
->next
->expr
== NULL
)
8041 /* Only given one arg so generate a null and do a
8042 not-equal comparison against the first arg. */
8043 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8045 fold_convert (TREE_TYPE (arg1se
.expr
),
8046 null_pointer_node
));
8052 /* Given two arguments so build the arg2se from second arg. */
8053 gfc_init_se (&arg2se
, NULL
);
8054 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
8055 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8056 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8058 /* Generate test to compare that the two args are equal. */
8059 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8060 arg1se
.expr
, arg2se
.expr
);
8061 /* Generate test to ensure that the first arg is not null. */
8062 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
8064 arg1se
.expr
, null_pointer_node
);
8066 /* Finally, the generated test must check that both arg1 is not
8067 NULL and that it is equal to the second arg. */
8068 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8070 not_null_expr
, eq_expr
);
8078 /* The following routine generates code for the intrinsic
8079 subroutines from the ISO_C_BINDING module:
8081 * C_F_PROCPOINTER. */
8084 conv_isocbinding_subroutine (gfc_code
*code
)
8091 tree desc
, dim
, tmp
, stride
, offset
;
8092 stmtblock_t body
, block
;
8094 gfc_actual_arglist
*arg
= code
->ext
.actual
;
8096 gfc_init_se (&se
, NULL
);
8097 gfc_init_se (&cptrse
, NULL
);
8098 gfc_conv_expr (&cptrse
, arg
->expr
);
8099 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
8100 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
8102 gfc_init_se (&fptrse
, NULL
);
8103 if (arg
->next
->expr
->rank
== 0)
8105 fptrse
.want_pointer
= 1;
8106 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
8107 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
8108 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
8109 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8110 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
8111 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
8113 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8114 TREE_TYPE (fptrse
.expr
),
8116 fold_convert (TREE_TYPE (fptrse
.expr
),
8118 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
8119 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8120 return gfc_finish_block (&se
.pre
);
8123 gfc_start_block (&block
);
8125 /* Get the descriptor of the Fortran pointer. */
8126 fptrse
.descriptor_only
= 1;
8127 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
8128 gfc_add_block_to_block (&block
, &fptrse
.pre
);
8131 /* Set the span field. */
8132 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
8133 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8134 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
8136 /* Set data value, dtype, and offset. */
8137 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
8138 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
8139 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
8140 gfc_get_dtype (TREE_TYPE (desc
)));
8142 /* Start scalarization of the bounds, using the shape argument. */
8144 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
8145 gcc_assert (shape_ss
!= gfc_ss_terminator
);
8146 gfc_init_se (&shapese
, NULL
);
8148 gfc_init_loopinfo (&loop
);
8149 gfc_add_ss_to_loop (&loop
, shape_ss
);
8150 gfc_conv_ss_startstride (&loop
);
8151 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
8152 gfc_mark_ss_chain_used (shape_ss
, 1);
8154 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
8155 shapese
.ss
= shape_ss
;
8157 stride
= gfc_create_var (gfc_array_index_type
, "stride");
8158 offset
= gfc_create_var (gfc_array_index_type
, "offset");
8159 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
8160 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8163 gfc_start_scalarized_body (&loop
, &body
);
8165 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8166 loop
.loopvar
[0], loop
.from
[0]);
8168 /* Set bounds and stride. */
8169 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
8170 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
8172 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
8173 gfc_add_block_to_block (&body
, &shapese
.pre
);
8174 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
8175 gfc_add_block_to_block (&body
, &shapese
.post
);
8177 /* Calculate offset. */
8178 gfc_add_modify (&body
, offset
,
8179 fold_build2_loc (input_location
, PLUS_EXPR
,
8180 gfc_array_index_type
, offset
, stride
));
8181 /* Update stride. */
8182 gfc_add_modify (&body
, stride
,
8183 fold_build2_loc (input_location
, MULT_EXPR
,
8184 gfc_array_index_type
, stride
,
8185 fold_convert (gfc_array_index_type
,
8187 /* Finish scalarization loop. */
8188 gfc_trans_scalarizing_loops (&loop
, &body
);
8189 gfc_add_block_to_block (&block
, &loop
.pre
);
8190 gfc_add_block_to_block (&block
, &loop
.post
);
8191 gfc_add_block_to_block (&block
, &fptrse
.post
);
8192 gfc_cleanup_loop (&loop
);
8194 gfc_add_modify (&block
, offset
,
8195 fold_build1_loc (input_location
, NEGATE_EXPR
,
8196 gfc_array_index_type
, offset
));
8197 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
8199 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
8200 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8201 return gfc_finish_block (&se
.pre
);
8205 /* Save and restore floating-point state. */
8208 gfc_save_fp_state (stmtblock_t
*block
)
8210 tree type
, fpstate
, tmp
;
8212 type
= build_array_type (char_type_node
,
8213 build_range_type (size_type_node
, size_zero_node
,
8214 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
8215 fpstate
= gfc_create_var (type
, "fpstate");
8216 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
8218 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
8220 gfc_add_expr_to_block (block
, tmp
);
8227 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
8231 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
8233 gfc_add_expr_to_block (block
, tmp
);
8237 /* Generate code for arguments of IEEE functions. */
8240 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
8243 gfc_actual_arglist
*actual
;
8248 actual
= expr
->value
.function
.actual
;
8249 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
8251 gcc_assert (actual
);
8254 gfc_init_se (&argse
, se
);
8255 gfc_conv_expr_val (&argse
, e
);
8257 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8258 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8259 argarray
[arg
] = argse
.expr
;
8264 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8265 and IEEE_UNORDERED, which translate directly to GCC type-generic
8269 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
8270 enum built_in_function code
, int nargs
)
8273 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
8275 conv_ieee_function_args (se
, expr
, args
, nargs
);
8276 se
->expr
= build_call_expr_loc_array (input_location
,
8277 builtin_decl_explicit (code
),
8279 STRIP_TYPE_NOPS (se
->expr
);
8280 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8284 /* Generate code for IEEE_IS_NORMAL intrinsic:
8285 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8288 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
8290 tree arg
, isnormal
, iszero
;
8292 /* Convert arg, evaluate it only once. */
8293 conv_ieee_function_args (se
, expr
, &arg
, 1);
8294 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8296 isnormal
= build_call_expr_loc (input_location
,
8297 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
8299 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
8300 build_real_from_int_cst (TREE_TYPE (arg
),
8301 integer_zero_node
));
8302 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8303 boolean_type_node
, isnormal
, iszero
);
8304 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8308 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8309 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8312 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
8314 tree arg
, signbit
, isnan
;
8316 /* Convert arg, evaluate it only once. */
8317 conv_ieee_function_args (se
, expr
, &arg
, 1);
8318 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8320 isnan
= build_call_expr_loc (input_location
,
8321 builtin_decl_explicit (BUILT_IN_ISNAN
),
8323 STRIP_TYPE_NOPS (isnan
);
8325 signbit
= build_call_expr_loc (input_location
,
8326 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8328 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8329 signbit
, integer_zero_node
);
8331 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8332 boolean_type_node
, signbit
,
8333 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
8334 TREE_TYPE(isnan
), isnan
));
8336 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8340 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8343 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
8344 enum built_in_function code
)
8346 tree arg
, decl
, call
, fpstate
;
8349 conv_ieee_function_args (se
, expr
, &arg
, 1);
8350 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
8351 decl
= builtin_decl_for_precision (code
, argprec
);
8353 /* Save floating-point state. */
8354 fpstate
= gfc_save_fp_state (&se
->pre
);
8356 /* Make the function call. */
8357 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
8358 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
8360 /* Restore floating-point state. */
8361 gfc_restore_fp_state (&se
->post
, fpstate
);
8365 /* Generate code for IEEE_REM. */
8368 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
8370 tree args
[2], decl
, call
, fpstate
;
8373 conv_ieee_function_args (se
, expr
, args
, 2);
8375 /* If arguments have unequal size, convert them to the larger. */
8376 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
8377 > TYPE_PRECISION (TREE_TYPE (args
[1])))
8378 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8379 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
8380 > TYPE_PRECISION (TREE_TYPE (args
[0])))
8381 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
8383 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8384 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
8386 /* Save floating-point state. */
8387 fpstate
= gfc_save_fp_state (&se
->pre
);
8389 /* Make the function call. */
8390 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8391 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8393 /* Restore floating-point state. */
8394 gfc_restore_fp_state (&se
->post
, fpstate
);
8398 /* Generate code for IEEE_NEXT_AFTER. */
8401 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
8403 tree args
[2], decl
, call
, fpstate
;
8406 conv_ieee_function_args (se
, expr
, args
, 2);
8408 /* Result has the characteristics of first argument. */
8409 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8410 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8411 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
8413 /* Save floating-point state. */
8414 fpstate
= gfc_save_fp_state (&se
->pre
);
8416 /* Make the function call. */
8417 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8418 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8420 /* Restore floating-point state. */
8421 gfc_restore_fp_state (&se
->post
, fpstate
);
8425 /* Generate code for IEEE_SCALB. */
8428 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
8430 tree args
[2], decl
, call
, huge
, type
;
8433 conv_ieee_function_args (se
, expr
, args
, 2);
8435 /* Result has the characteristics of first argument. */
8436 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8437 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
8439 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
8441 /* We need to fold the integer into the range of a C int. */
8442 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
8443 type
= TREE_TYPE (args
[1]);
8445 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
8446 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
8448 huge
= fold_convert (type
, huge
);
8449 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
8451 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
8452 fold_build1_loc (input_location
, NEGATE_EXPR
,
8456 args
[1] = fold_convert (integer_type_node
, args
[1]);
8458 /* Make the function call. */
8459 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8460 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8464 /* Generate code for IEEE_COPY_SIGN. */
8467 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
8469 tree args
[2], decl
, sign
;
8472 conv_ieee_function_args (se
, expr
, args
, 2);
8474 /* Get the sign of the second argument. */
8475 sign
= build_call_expr_loc (input_location
,
8476 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8478 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8479 sign
, integer_zero_node
);
8481 /* Create a value of one, with the right sign. */
8482 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
8484 fold_build1_loc (input_location
, NEGATE_EXPR
,
8488 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
8490 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8491 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
8493 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8497 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8501 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
8503 const char *name
= expr
->value
.function
.name
;
8505 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8507 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
8508 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
8509 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
8510 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
8511 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
8512 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
8513 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
8514 conv_intrinsic_ieee_is_normal (se
, expr
);
8515 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
8516 conv_intrinsic_ieee_is_negative (se
, expr
);
8517 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
8518 conv_intrinsic_ieee_copy_sign (se
, expr
);
8519 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
8520 conv_intrinsic_ieee_scalb (se
, expr
);
8521 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
8522 conv_intrinsic_ieee_next_after (se
, expr
);
8523 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
8524 conv_intrinsic_ieee_rem (se
, expr
);
8525 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
8526 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
8527 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
8528 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
8530 /* It is not among the functions we translate directly. We return
8531 false, so a library function call is emitted. */
8540 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8543 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
8545 tree arg
, res
, restype
;
8547 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8548 arg
= fold_convert (size_type_node
, arg
);
8549 res
= build_call_expr_loc (input_location
,
8550 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
8551 restype
= gfc_typenode_for_spec (&expr
->ts
);
8552 se
->expr
= fold_convert (restype
, res
);
8556 /* Generate code for an intrinsic function. Some map directly to library
8557 calls, others get special handling. In some cases the name of the function
8558 used depends on the type specifiers. */
8561 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
8567 name
= &expr
->value
.function
.name
[2];
8571 lib
= gfc_is_intrinsic_libcall (expr
);
8575 se
->ignore_optional
= 1;
8577 switch (expr
->value
.function
.isym
->id
)
8579 case GFC_ISYM_EOSHIFT
:
8581 case GFC_ISYM_RESHAPE
:
8582 /* For all of those the first argument specifies the type and the
8583 third is optional. */
8584 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
8588 gfc_conv_intrinsic_funcall (se
, expr
);
8596 switch (expr
->value
.function
.isym
->id
)
8601 case GFC_ISYM_REPEAT
:
8602 gfc_conv_intrinsic_repeat (se
, expr
);
8606 gfc_conv_intrinsic_trim (se
, expr
);
8609 case GFC_ISYM_SC_KIND
:
8610 gfc_conv_intrinsic_sc_kind (se
, expr
);
8613 case GFC_ISYM_SI_KIND
:
8614 gfc_conv_intrinsic_si_kind (se
, expr
);
8617 case GFC_ISYM_SR_KIND
:
8618 gfc_conv_intrinsic_sr_kind (se
, expr
);
8621 case GFC_ISYM_EXPONENT
:
8622 gfc_conv_intrinsic_exponent (se
, expr
);
8626 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8628 fndecl
= gfor_fndecl_string_scan
;
8630 fndecl
= gfor_fndecl_string_scan_char4
;
8634 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8637 case GFC_ISYM_VERIFY
:
8638 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8640 fndecl
= gfor_fndecl_string_verify
;
8642 fndecl
= gfor_fndecl_string_verify_char4
;
8646 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8649 case GFC_ISYM_ALLOCATED
:
8650 gfc_conv_allocated (se
, expr
);
8653 case GFC_ISYM_ASSOCIATED
:
8654 gfc_conv_associated(se
, expr
);
8657 case GFC_ISYM_SAME_TYPE_AS
:
8658 gfc_conv_same_type_as (se
, expr
);
8662 gfc_conv_intrinsic_abs (se
, expr
);
8665 case GFC_ISYM_ADJUSTL
:
8666 if (expr
->ts
.kind
== 1)
8667 fndecl
= gfor_fndecl_adjustl
;
8668 else if (expr
->ts
.kind
== 4)
8669 fndecl
= gfor_fndecl_adjustl_char4
;
8673 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8676 case GFC_ISYM_ADJUSTR
:
8677 if (expr
->ts
.kind
== 1)
8678 fndecl
= gfor_fndecl_adjustr
;
8679 else if (expr
->ts
.kind
== 4)
8680 fndecl
= gfor_fndecl_adjustr_char4
;
8684 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8687 case GFC_ISYM_AIMAG
:
8688 gfc_conv_intrinsic_imagpart (se
, expr
);
8692 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
8696 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
8699 case GFC_ISYM_ANINT
:
8700 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
8704 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8708 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
8711 case GFC_ISYM_BTEST
:
8712 gfc_conv_intrinsic_btest (se
, expr
);
8716 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
8720 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
8724 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
8728 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
8731 case GFC_ISYM_C_ASSOCIATED
:
8732 case GFC_ISYM_C_FUNLOC
:
8733 case GFC_ISYM_C_LOC
:
8734 conv_isocbinding_function (se
, expr
);
8737 case GFC_ISYM_ACHAR
:
8739 gfc_conv_intrinsic_char (se
, expr
);
8742 case GFC_ISYM_CONVERSION
:
8744 case GFC_ISYM_LOGICAL
:
8746 gfc_conv_intrinsic_conversion (se
, expr
);
8749 /* Integer conversions are handled separately to make sure we get the
8750 correct rounding mode. */
8755 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
8759 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
8762 case GFC_ISYM_CEILING
:
8763 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
8766 case GFC_ISYM_FLOOR
:
8767 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
8771 gfc_conv_intrinsic_mod (se
, expr
, 0);
8774 case GFC_ISYM_MODULO
:
8775 gfc_conv_intrinsic_mod (se
, expr
, 1);
8778 case GFC_ISYM_CAF_GET
:
8779 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
8783 case GFC_ISYM_CMPLX
:
8784 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
8787 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
8788 gfc_conv_intrinsic_iargc (se
, expr
);
8791 case GFC_ISYM_COMPLEX
:
8792 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
8795 case GFC_ISYM_CONJG
:
8796 gfc_conv_intrinsic_conjg (se
, expr
);
8799 case GFC_ISYM_COUNT
:
8800 gfc_conv_intrinsic_count (se
, expr
);
8803 case GFC_ISYM_CTIME
:
8804 gfc_conv_intrinsic_ctime (se
, expr
);
8808 gfc_conv_intrinsic_dim (se
, expr
);
8811 case GFC_ISYM_DOT_PRODUCT
:
8812 gfc_conv_intrinsic_dot_product (se
, expr
);
8815 case GFC_ISYM_DPROD
:
8816 gfc_conv_intrinsic_dprod (se
, expr
);
8819 case GFC_ISYM_DSHIFTL
:
8820 gfc_conv_intrinsic_dshift (se
, expr
, true);
8823 case GFC_ISYM_DSHIFTR
:
8824 gfc_conv_intrinsic_dshift (se
, expr
, false);
8827 case GFC_ISYM_FDATE
:
8828 gfc_conv_intrinsic_fdate (se
, expr
);
8831 case GFC_ISYM_FRACTION
:
8832 gfc_conv_intrinsic_fraction (se
, expr
);
8836 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
8840 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8844 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
8847 case GFC_ISYM_IBCLR
:
8848 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
8851 case GFC_ISYM_IBITS
:
8852 gfc_conv_intrinsic_ibits (se
, expr
);
8855 case GFC_ISYM_IBSET
:
8856 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
8859 case GFC_ISYM_IACHAR
:
8860 case GFC_ISYM_ICHAR
:
8861 /* We assume ASCII character sequence. */
8862 gfc_conv_intrinsic_ichar (se
, expr
);
8865 case GFC_ISYM_IARGC
:
8866 gfc_conv_intrinsic_iargc (se
, expr
);
8870 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8873 case GFC_ISYM_INDEX
:
8874 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8876 fndecl
= gfor_fndecl_string_index
;
8878 fndecl
= gfor_fndecl_string_index_char4
;
8882 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8886 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8889 case GFC_ISYM_IPARITY
:
8890 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
8893 case GFC_ISYM_IS_IOSTAT_END
:
8894 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
8897 case GFC_ISYM_IS_IOSTAT_EOR
:
8898 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
8901 case GFC_ISYM_ISNAN
:
8902 gfc_conv_intrinsic_isnan (se
, expr
);
8905 case GFC_ISYM_LSHIFT
:
8906 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8909 case GFC_ISYM_RSHIFT
:
8910 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8913 case GFC_ISYM_SHIFTA
:
8914 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8917 case GFC_ISYM_SHIFTL
:
8918 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8921 case GFC_ISYM_SHIFTR
:
8922 gfc_conv_intrinsic_shift (se
, expr
, true, false);
8925 case GFC_ISYM_ISHFT
:
8926 gfc_conv_intrinsic_ishft (se
, expr
);
8929 case GFC_ISYM_ISHFTC
:
8930 gfc_conv_intrinsic_ishftc (se
, expr
);
8933 case GFC_ISYM_LEADZ
:
8934 gfc_conv_intrinsic_leadz (se
, expr
);
8937 case GFC_ISYM_TRAILZ
:
8938 gfc_conv_intrinsic_trailz (se
, expr
);
8941 case GFC_ISYM_POPCNT
:
8942 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
8945 case GFC_ISYM_POPPAR
:
8946 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
8949 case GFC_ISYM_LBOUND
:
8950 gfc_conv_intrinsic_bound (se
, expr
, 0);
8953 case GFC_ISYM_LCOBOUND
:
8954 conv_intrinsic_cobound (se
, expr
);
8957 case GFC_ISYM_TRANSPOSE
:
8958 /* The scalarizer has already been set up for reversed dimension access
8959 order ; now we just get the argument value normally. */
8960 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
8964 gfc_conv_intrinsic_len (se
, expr
);
8967 case GFC_ISYM_LEN_TRIM
:
8968 gfc_conv_intrinsic_len_trim (se
, expr
);
8972 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
8976 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
8980 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
8984 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
8987 case GFC_ISYM_MALLOC
:
8988 gfc_conv_intrinsic_malloc (se
, expr
);
8991 case GFC_ISYM_MASKL
:
8992 gfc_conv_intrinsic_mask (se
, expr
, 1);
8995 case GFC_ISYM_MASKR
:
8996 gfc_conv_intrinsic_mask (se
, expr
, 0);
9000 if (expr
->ts
.type
== BT_CHARACTER
)
9001 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
9003 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
9006 case GFC_ISYM_MAXLOC
:
9007 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9010 case GFC_ISYM_MAXVAL
:
9011 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
9014 case GFC_ISYM_MERGE
:
9015 gfc_conv_intrinsic_merge (se
, expr
);
9018 case GFC_ISYM_MERGE_BITS
:
9019 gfc_conv_intrinsic_merge_bits (se
, expr
);
9023 if (expr
->ts
.type
== BT_CHARACTER
)
9024 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
9026 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
9029 case GFC_ISYM_MINLOC
:
9030 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9033 case GFC_ISYM_MINVAL
:
9034 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
9037 case GFC_ISYM_NEAREST
:
9038 gfc_conv_intrinsic_nearest (se
, expr
);
9041 case GFC_ISYM_NORM2
:
9042 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
9046 gfc_conv_intrinsic_not (se
, expr
);
9050 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9053 case GFC_ISYM_PARITY
:
9054 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
9057 case GFC_ISYM_PRESENT
:
9058 gfc_conv_intrinsic_present (se
, expr
);
9061 case GFC_ISYM_PRODUCT
:
9062 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
9066 gfc_conv_intrinsic_rank (se
, expr
);
9069 case GFC_ISYM_RRSPACING
:
9070 gfc_conv_intrinsic_rrspacing (se
, expr
);
9073 case GFC_ISYM_SET_EXPONENT
:
9074 gfc_conv_intrinsic_set_exponent (se
, expr
);
9077 case GFC_ISYM_SCALE
:
9078 gfc_conv_intrinsic_scale (se
, expr
);
9082 gfc_conv_intrinsic_sign (se
, expr
);
9086 gfc_conv_intrinsic_size (se
, expr
);
9089 case GFC_ISYM_SIZEOF
:
9090 case GFC_ISYM_C_SIZEOF
:
9091 gfc_conv_intrinsic_sizeof (se
, expr
);
9094 case GFC_ISYM_STORAGE_SIZE
:
9095 gfc_conv_intrinsic_storage_size (se
, expr
);
9098 case GFC_ISYM_SPACING
:
9099 gfc_conv_intrinsic_spacing (se
, expr
);
9102 case GFC_ISYM_STRIDE
:
9103 conv_intrinsic_stride (se
, expr
);
9107 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
9110 case GFC_ISYM_TRANSFER
:
9111 if (se
->ss
&& se
->ss
->info
->useflags
)
9112 /* Access the previously obtained result. */
9113 gfc_conv_tmp_array_ref (se
);
9115 gfc_conv_intrinsic_transfer (se
, expr
);
9118 case GFC_ISYM_TTYNAM
:
9119 gfc_conv_intrinsic_ttynam (se
, expr
);
9122 case GFC_ISYM_UBOUND
:
9123 gfc_conv_intrinsic_bound (se
, expr
, 1);
9126 case GFC_ISYM_UCOBOUND
:
9127 conv_intrinsic_cobound (se
, expr
);
9131 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9135 gfc_conv_intrinsic_loc (se
, expr
);
9138 case GFC_ISYM_THIS_IMAGE
:
9139 /* For num_images() == 1, handle as LCOBOUND. */
9140 if (expr
->value
.function
.actual
->expr
9141 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
9142 conv_intrinsic_cobound (se
, expr
);
9144 trans_this_image (se
, expr
);
9147 case GFC_ISYM_IMAGE_INDEX
:
9148 trans_image_index (se
, expr
);
9151 case GFC_ISYM_IMAGE_STATUS
:
9152 conv_intrinsic_image_status (se
, expr
);
9155 case GFC_ISYM_NUM_IMAGES
:
9156 trans_num_images (se
, expr
);
9159 case GFC_ISYM_ACCESS
:
9160 case GFC_ISYM_CHDIR
:
9161 case GFC_ISYM_CHMOD
:
9162 case GFC_ISYM_DTIME
:
9163 case GFC_ISYM_ETIME
:
9164 case GFC_ISYM_EXTENDS_TYPE_OF
:
9166 case GFC_ISYM_FGETC
:
9169 case GFC_ISYM_FPUTC
:
9170 case GFC_ISYM_FSTAT
:
9171 case GFC_ISYM_FTELL
:
9172 case GFC_ISYM_GETCWD
:
9173 case GFC_ISYM_GETGID
:
9174 case GFC_ISYM_GETPID
:
9175 case GFC_ISYM_GETUID
:
9176 case GFC_ISYM_HOSTNM
:
9178 case GFC_ISYM_IERRNO
:
9179 case GFC_ISYM_IRAND
:
9180 case GFC_ISYM_ISATTY
:
9183 case GFC_ISYM_LSTAT
:
9184 case GFC_ISYM_MATMUL
:
9185 case GFC_ISYM_MCLOCK
:
9186 case GFC_ISYM_MCLOCK8
:
9188 case GFC_ISYM_RENAME
:
9189 case GFC_ISYM_SECOND
:
9190 case GFC_ISYM_SECNDS
:
9191 case GFC_ISYM_SIGNAL
:
9193 case GFC_ISYM_SYMLNK
:
9194 case GFC_ISYM_SYSTEM
:
9196 case GFC_ISYM_TIME8
:
9197 case GFC_ISYM_UMASK
:
9198 case GFC_ISYM_UNLINK
:
9200 gfc_conv_intrinsic_funcall (se
, expr
);
9203 case GFC_ISYM_EOSHIFT
:
9205 case GFC_ISYM_RESHAPE
:
9206 /* For those, expr->rank should always be >0 and thus the if above the
9207 switch should have matched. */
9212 gfc_conv_intrinsic_lib_function (se
, expr
);
9219 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
9221 gfc_ss
*arg_ss
, *tmp_ss
;
9222 gfc_actual_arglist
*arg
;
9224 arg
= expr
->value
.function
.actual
;
9226 gcc_assert (arg
->expr
);
9228 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
9229 gcc_assert (arg_ss
!= gfc_ss_terminator
);
9231 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
9233 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
9234 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
9236 gcc_assert (tmp_ss
->dimen
== 2);
9238 /* We just invert dimensions. */
9239 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
9242 /* Stop when tmp_ss points to the last valid element of the chain... */
9243 if (tmp_ss
->next
== gfc_ss_terminator
)
9247 /* ... so that we can attach the rest of the chain to it. */
9254 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9255 This has the side effect of reversing the nested list, so there is no
9256 need to call gfc_reverse_ss on it (the given list is assumed not to be
9260 nest_loop_dimension (gfc_ss
*ss
, int dim
)
9263 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
9264 gfc_loopinfo
*new_loop
;
9266 gcc_assert (ss
!= gfc_ss_terminator
);
9268 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
9270 new_ss
= gfc_get_ss ();
9271 new_ss
->next
= prev_ss
;
9272 new_ss
->parent
= ss
;
9273 new_ss
->info
= ss
->info
;
9274 new_ss
->info
->refcount
++;
9277 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
9278 && ss
->info
->type
!= GFC_SS_REFERENCE
);
9281 new_ss
->dim
[0] = ss
->dim
[dim
];
9283 gcc_assert (dim
< ss
->dimen
);
9285 ss_dim
= --ss
->dimen
;
9286 for (i
= dim
; i
< ss_dim
; i
++)
9287 ss
->dim
[i
] = ss
->dim
[i
+ 1];
9289 ss
->dim
[ss_dim
] = 0;
9295 ss
->nested_ss
->parent
= new_ss
;
9296 new_ss
->nested_ss
= ss
->nested_ss
;
9298 ss
->nested_ss
= new_ss
;
9301 new_loop
= gfc_get_loopinfo ();
9302 gfc_init_loopinfo (new_loop
);
9304 gcc_assert (prev_ss
!= NULL
);
9305 gcc_assert (prev_ss
!= gfc_ss_terminator
);
9306 gfc_add_ss_to_loop (new_loop
, prev_ss
);
9307 return new_ss
->parent
;
9311 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9312 is to be inlined. */
9315 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
9317 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
9318 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
9320 bool scalar_mask
= false;
9322 /* The rank of the result will be determined later. */
9323 arg1
= expr
->value
.function
.actual
;
9326 gcc_assert (arg3
!= NULL
);
9328 if (expr
->rank
== 0)
9331 tmp_ss
= gfc_ss_terminator
;
9337 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
9338 if (mask_ss
== tmp_ss
)
9344 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
9345 gcc_assert (array_ss
!= tmp_ss
);
9347 /* Odd thing: If the mask is scalar, it is used by the frontend after
9348 the array (to make an if around the nested loop). Thus it shall
9349 be after array_ss once the gfc_ss list is reversed. */
9351 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
9355 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9357 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
9358 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
9366 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
9369 switch (expr
->value
.function
.isym
->id
)
9371 case GFC_ISYM_PRODUCT
:
9373 return walk_inline_intrinsic_arith (ss
, expr
);
9375 case GFC_ISYM_TRANSPOSE
:
9376 return walk_inline_intrinsic_transpose (ss
, expr
);
9385 /* This generates code to execute before entering the scalarization loop.
9386 Currently does nothing. */
9389 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
9391 switch (ss
->info
->expr
->value
.function
.isym
->id
)
9393 case GFC_ISYM_UBOUND
:
9394 case GFC_ISYM_LBOUND
:
9395 case GFC_ISYM_UCOBOUND
:
9396 case GFC_ISYM_LCOBOUND
:
9397 case GFC_ISYM_THIS_IMAGE
:
9406 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9407 are expanded into code inside the scalarization loop. */
9410 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
9412 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
9413 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
9415 /* The two argument version returns a scalar. */
9416 if (expr
->value
.function
.actual
->next
->expr
)
9419 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
9423 /* Walk an intrinsic array libcall. */
9426 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
9428 gcc_assert (expr
->rank
> 0);
9429 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9433 /* Return whether the function call expression EXPR will be expanded
9434 inline by gfc_conv_intrinsic_function. */
9437 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
9439 gfc_actual_arglist
*args
;
9441 if (!expr
->value
.function
.isym
)
9444 switch (expr
->value
.function
.isym
->id
)
9446 case GFC_ISYM_PRODUCT
:
9448 /* Disable inline expansion if code size matters. */
9452 args
= expr
->value
.function
.actual
;
9453 /* We need to be able to subset the SUM argument at compile-time. */
9454 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
9459 case GFC_ISYM_TRANSPOSE
:
9468 /* Returns nonzero if the specified intrinsic function call maps directly to
9469 an external library call. Should only be used for functions that return
9473 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
9475 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
9476 gcc_assert (expr
->rank
> 0);
9478 if (gfc_inline_intrinsic_function_p (expr
))
9481 switch (expr
->value
.function
.isym
->id
)
9485 case GFC_ISYM_COUNT
:
9489 case GFC_ISYM_IPARITY
:
9490 case GFC_ISYM_MATMUL
:
9491 case GFC_ISYM_MAXLOC
:
9492 case GFC_ISYM_MAXVAL
:
9493 case GFC_ISYM_MINLOC
:
9494 case GFC_ISYM_MINVAL
:
9495 case GFC_ISYM_NORM2
:
9496 case GFC_ISYM_PARITY
:
9497 case GFC_ISYM_PRODUCT
:
9499 case GFC_ISYM_SHAPE
:
9500 case GFC_ISYM_SPREAD
:
9502 /* Ignore absent optional parameters. */
9505 case GFC_ISYM_CSHIFT
:
9506 case GFC_ISYM_EOSHIFT
:
9507 case GFC_ISYM_FAILED_IMAGES
:
9508 case GFC_ISYM_STOPPED_IMAGES
:
9510 case GFC_ISYM_RESHAPE
:
9511 case GFC_ISYM_UNPACK
:
9512 /* Pass absent optional parameters. */
9520 /* Walk an intrinsic function. */
9522 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
9523 gfc_intrinsic_sym
* isym
)
9527 if (isym
->elemental
)
9528 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9529 NULL
, GFC_SS_SCALAR
);
9531 if (expr
->rank
== 0)
9534 if (gfc_inline_intrinsic_function_p (expr
))
9535 return walk_inline_intrinsic_function (ss
, expr
);
9537 if (gfc_is_intrinsic_libcall (expr
))
9538 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9540 /* Special cases. */
9543 case GFC_ISYM_LBOUND
:
9544 case GFC_ISYM_LCOBOUND
:
9545 case GFC_ISYM_UBOUND
:
9546 case GFC_ISYM_UCOBOUND
:
9547 case GFC_ISYM_THIS_IMAGE
:
9548 return gfc_walk_intrinsic_bound (ss
, expr
);
9550 case GFC_ISYM_TRANSFER
:
9551 case GFC_ISYM_CAF_GET
:
9552 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9555 /* This probably meant someone forgot to add an intrinsic to the above
9556 list(s) when they implemented it, or something's gone horribly
9564 conv_co_collective (gfc_code
*code
)
9567 stmtblock_t block
, post_block
;
9568 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
9569 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
9571 gfc_start_block (&block
);
9572 gfc_init_block (&post_block
);
9574 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
9576 opr_expr
= code
->ext
.actual
->next
->expr
;
9577 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
9578 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9579 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
9584 image_idx_expr
= code
->ext
.actual
->next
->expr
;
9585 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9586 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9592 gfc_init_se (&argse
, NULL
);
9593 gfc_conv_expr (&argse
, stat_expr
);
9594 gfc_add_block_to_block (&block
, &argse
.pre
);
9595 gfc_add_block_to_block (&post_block
, &argse
.post
);
9597 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
9598 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
9600 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9603 stat
= null_pointer_node
;
9605 /* Early exit for GFC_FCOARRAY_SINGLE. */
9606 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9608 if (stat
!= NULL_TREE
)
9609 gfc_add_modify (&block
, stat
,
9610 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
9611 return gfc_finish_block (&block
);
9614 /* Handle the array. */
9615 gfc_init_se (&argse
, NULL
);
9616 if (code
->ext
.actual
->expr
->rank
== 0)
9618 symbol_attribute attr
;
9619 gfc_clear_attr (&attr
);
9620 gfc_init_se (&argse
, NULL
);
9621 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9622 gfc_add_block_to_block (&block
, &argse
.pre
);
9623 gfc_add_block_to_block (&post_block
, &argse
.post
);
9624 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
9625 array
= gfc_build_addr_expr (NULL_TREE
, array
);
9629 argse
.want_pointer
= 1;
9630 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
9633 gfc_add_block_to_block (&block
, &argse
.pre
);
9634 gfc_add_block_to_block (&post_block
, &argse
.post
);
9636 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
9637 strlen
= argse
.string_length
;
9639 strlen
= integer_zero_node
;
9644 gfc_init_se (&argse
, NULL
);
9645 gfc_conv_expr (&argse
, image_idx_expr
);
9646 gfc_add_block_to_block (&block
, &argse
.pre
);
9647 gfc_add_block_to_block (&post_block
, &argse
.post
);
9648 image_index
= fold_convert (integer_type_node
, argse
.expr
);
9651 image_index
= integer_zero_node
;
9656 gfc_init_se (&argse
, NULL
);
9657 gfc_conv_expr (&argse
, errmsg_expr
);
9658 gfc_add_block_to_block (&block
, &argse
.pre
);
9659 gfc_add_block_to_block (&post_block
, &argse
.post
);
9660 errmsg
= argse
.expr
;
9661 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
9665 errmsg
= null_pointer_node
;
9666 errmsg_len
= integer_zero_node
;
9669 /* Generate the function call. */
9670 switch (code
->resolved_isym
->id
)
9672 case GFC_ISYM_CO_BROADCAST
:
9673 fndecl
= gfor_fndecl_co_broadcast
;
9675 case GFC_ISYM_CO_MAX
:
9676 fndecl
= gfor_fndecl_co_max
;
9678 case GFC_ISYM_CO_MIN
:
9679 fndecl
= gfor_fndecl_co_min
;
9681 case GFC_ISYM_CO_REDUCE
:
9682 fndecl
= gfor_fndecl_co_reduce
;
9684 case GFC_ISYM_CO_SUM
:
9685 fndecl
= gfor_fndecl_co_sum
;
9691 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
9692 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
9693 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
9694 image_index
, stat
, errmsg
, errmsg_len
);
9695 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
9696 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
9697 stat
, errmsg
, strlen
, errmsg_len
);
9700 tree opr
, opr_flags
;
9702 // FIXME: Handle TS29113's bind(C) strings with descriptor.
9704 if (gfc_is_proc_ptr_comp (opr_expr
))
9706 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
9707 opr_flag_int
= sym
->attr
.dimension
9708 || (sym
->ts
.type
== BT_CHARACTER
9709 && !sym
->attr
.is_bind_c
)
9710 ? GFC_CAF_BYREF
: 0;
9711 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9712 && !sym
->attr
.is_bind_c
9713 ? GFC_CAF_HIDDENLEN
: 0;
9714 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
9718 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
9719 ? GFC_CAF_BYREF
: 0;
9720 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9721 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
9722 ? GFC_CAF_HIDDENLEN
: 0;
9723 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
9724 ? GFC_CAF_ARG_VALUE
: 0;
9726 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
9727 gfc_conv_expr (&argse
, opr_expr
);
9729 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
9730 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
9733 gfc_add_expr_to_block (&block
, fndecl
);
9734 gfc_add_block_to_block (&block
, &post_block
);
9736 return gfc_finish_block (&block
);
9741 conv_intrinsic_atomic_op (gfc_code
*code
)
9744 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
9745 stmtblock_t block
, post_block
;
9746 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9747 gfc_expr
*stat_expr
;
9748 built_in_function fn
;
9750 if (atom_expr
->expr_type
== EXPR_FUNCTION
9751 && atom_expr
->value
.function
.isym
9752 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9753 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9755 gfc_start_block (&block
);
9756 gfc_init_block (&post_block
);
9758 gfc_init_se (&argse
, NULL
);
9759 argse
.want_pointer
= 1;
9760 gfc_conv_expr (&argse
, atom_expr
);
9761 gfc_add_block_to_block (&block
, &argse
.pre
);
9762 gfc_add_block_to_block (&post_block
, &argse
.post
);
9765 gfc_init_se (&argse
, NULL
);
9766 if (flag_coarray
== GFC_FCOARRAY_LIB
9767 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9768 argse
.want_pointer
= 1;
9769 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9770 gfc_add_block_to_block (&block
, &argse
.pre
);
9771 gfc_add_block_to_block (&post_block
, &argse
.post
);
9774 switch (code
->resolved_isym
->id
)
9776 case GFC_ISYM_ATOMIC_ADD
:
9777 case GFC_ISYM_ATOMIC_AND
:
9778 case GFC_ISYM_ATOMIC_DEF
:
9779 case GFC_ISYM_ATOMIC_OR
:
9780 case GFC_ISYM_ATOMIC_XOR
:
9781 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9782 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9783 old
= null_pointer_node
;
9786 gfc_init_se (&argse
, NULL
);
9787 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9788 argse
.want_pointer
= 1;
9789 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9790 gfc_add_block_to_block (&block
, &argse
.pre
);
9791 gfc_add_block_to_block (&post_block
, &argse
.post
);
9793 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9797 if (stat_expr
!= NULL
)
9799 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
9800 gfc_init_se (&argse
, NULL
);
9801 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9802 argse
.want_pointer
= 1;
9803 gfc_conv_expr_val (&argse
, stat_expr
);
9804 gfc_add_block_to_block (&block
, &argse
.pre
);
9805 gfc_add_block_to_block (&post_block
, &argse
.post
);
9808 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9809 stat
= null_pointer_node
;
9811 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9813 tree image_index
, caf_decl
, offset
, token
;
9816 switch (code
->resolved_isym
->id
)
9818 case GFC_ISYM_ATOMIC_ADD
:
9819 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9820 op
= (int) GFC_CAF_ATOMIC_ADD
;
9822 case GFC_ISYM_ATOMIC_AND
:
9823 case GFC_ISYM_ATOMIC_FETCH_AND
:
9824 op
= (int) GFC_CAF_ATOMIC_AND
;
9826 case GFC_ISYM_ATOMIC_OR
:
9827 case GFC_ISYM_ATOMIC_FETCH_OR
:
9828 op
= (int) GFC_CAF_ATOMIC_OR
;
9830 case GFC_ISYM_ATOMIC_XOR
:
9831 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9832 op
= (int) GFC_CAF_ATOMIC_XOR
;
9834 case GFC_ISYM_ATOMIC_DEF
:
9835 op
= 0; /* Unused. */
9841 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9842 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9843 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9845 if (gfc_is_coindexed (atom_expr
))
9846 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9848 image_index
= integer_zero_node
;
9850 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9852 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9853 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
9854 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9857 gfc_init_se (&argse
, NULL
);
9858 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
9861 gfc_add_block_to_block (&block
, &argse
.pre
);
9862 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
9863 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
9864 token
, offset
, image_index
, value
, stat
,
9865 build_int_cst (integer_type_node
,
9866 (int) atom_expr
->ts
.type
),
9867 build_int_cst (integer_type_node
,
9868 (int) atom_expr
->ts
.kind
));
9870 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
9871 build_int_cst (integer_type_node
, op
),
9872 token
, offset
, image_index
, value
, old
, stat
,
9873 build_int_cst (integer_type_node
,
9874 (int) atom_expr
->ts
.type
),
9875 build_int_cst (integer_type_node
,
9876 (int) atom_expr
->ts
.kind
));
9878 gfc_add_expr_to_block (&block
, tmp
);
9879 gfc_add_block_to_block (&block
, &argse
.post
);
9880 gfc_add_block_to_block (&block
, &post_block
);
9881 return gfc_finish_block (&block
);
9885 switch (code
->resolved_isym
->id
)
9887 case GFC_ISYM_ATOMIC_ADD
:
9888 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9889 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
9891 case GFC_ISYM_ATOMIC_AND
:
9892 case GFC_ISYM_ATOMIC_FETCH_AND
:
9893 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
9895 case GFC_ISYM_ATOMIC_DEF
:
9896 fn
= BUILT_IN_ATOMIC_STORE_N
;
9898 case GFC_ISYM_ATOMIC_OR
:
9899 case GFC_ISYM_ATOMIC_FETCH_OR
:
9900 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
9902 case GFC_ISYM_ATOMIC_XOR
:
9903 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9904 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
9910 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9911 fn
= (built_in_function
) ((int) fn
9912 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9914 tmp
= builtin_decl_explicit (fn
);
9915 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
9916 tmp
= builtin_decl_explicit (fn
);
9918 switch (code
->resolved_isym
->id
)
9920 case GFC_ISYM_ATOMIC_ADD
:
9921 case GFC_ISYM_ATOMIC_AND
:
9922 case GFC_ISYM_ATOMIC_DEF
:
9923 case GFC_ISYM_ATOMIC_OR
:
9924 case GFC_ISYM_ATOMIC_XOR
:
9925 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9926 fold_convert (itype
, value
),
9927 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9928 gfc_add_expr_to_block (&block
, tmp
);
9931 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9932 fold_convert (itype
, value
),
9933 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9934 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
9938 if (stat
!= NULL_TREE
)
9939 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9940 gfc_add_block_to_block (&block
, &post_block
);
9941 return gfc_finish_block (&block
);
9946 conv_intrinsic_atomic_ref (gfc_code
*code
)
9949 tree tmp
, atom
, value
, stat
= NULL_TREE
;
9950 stmtblock_t block
, post_block
;
9951 built_in_function fn
;
9952 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
9954 if (atom_expr
->expr_type
== EXPR_FUNCTION
9955 && atom_expr
->value
.function
.isym
9956 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9957 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9959 gfc_start_block (&block
);
9960 gfc_init_block (&post_block
);
9961 gfc_init_se (&argse
, NULL
);
9962 argse
.want_pointer
= 1;
9963 gfc_conv_expr (&argse
, atom_expr
);
9964 gfc_add_block_to_block (&block
, &argse
.pre
);
9965 gfc_add_block_to_block (&post_block
, &argse
.post
);
9968 gfc_init_se (&argse
, NULL
);
9969 if (flag_coarray
== GFC_FCOARRAY_LIB
9970 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9971 argse
.want_pointer
= 1;
9972 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9973 gfc_add_block_to_block (&block
, &argse
.pre
);
9974 gfc_add_block_to_block (&post_block
, &argse
.post
);
9978 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
9980 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9982 gfc_init_se (&argse
, NULL
);
9983 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9984 argse
.want_pointer
= 1;
9985 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9986 gfc_add_block_to_block (&block
, &argse
.pre
);
9987 gfc_add_block_to_block (&post_block
, &argse
.post
);
9990 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9991 stat
= null_pointer_node
;
9993 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9995 tree image_index
, caf_decl
, offset
, token
;
9996 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
9998 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9999 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10000 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10002 if (gfc_is_coindexed (atom_expr
))
10003 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10005 image_index
= integer_zero_node
;
10007 gfc_init_se (&argse
, NULL
);
10008 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10010 gfc_add_block_to_block (&block
, &argse
.pre
);
10012 /* Different type, need type conversion. */
10013 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10015 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10016 orig_value
= value
;
10017 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
10020 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
10021 token
, offset
, image_index
, value
, stat
,
10022 build_int_cst (integer_type_node
,
10023 (int) atom_expr
->ts
.type
),
10024 build_int_cst (integer_type_node
,
10025 (int) atom_expr
->ts
.kind
));
10026 gfc_add_expr_to_block (&block
, tmp
);
10027 if (vardecl
!= NULL_TREE
)
10028 gfc_add_modify (&block
, orig_value
,
10029 fold_convert (TREE_TYPE (orig_value
), vardecl
));
10030 gfc_add_block_to_block (&block
, &argse
.post
);
10031 gfc_add_block_to_block (&block
, &post_block
);
10032 return gfc_finish_block (&block
);
10035 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10036 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
10037 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10039 tmp
= builtin_decl_explicit (fn
);
10040 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
10041 build_int_cst (integer_type_node
,
10042 MEMMODEL_RELAXED
));
10043 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
10045 if (stat
!= NULL_TREE
)
10046 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10047 gfc_add_block_to_block (&block
, &post_block
);
10048 return gfc_finish_block (&block
);
10053 conv_intrinsic_atomic_cas (gfc_code
*code
)
10056 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
10057 stmtblock_t block
, post_block
;
10058 built_in_function fn
;
10059 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10061 if (atom_expr
->expr_type
== EXPR_FUNCTION
10062 && atom_expr
->value
.function
.isym
10063 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10064 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10066 gfc_init_block (&block
);
10067 gfc_init_block (&post_block
);
10068 gfc_init_se (&argse
, NULL
);
10069 argse
.want_pointer
= 1;
10070 gfc_conv_expr (&argse
, atom_expr
);
10073 gfc_init_se (&argse
, NULL
);
10074 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10075 argse
.want_pointer
= 1;
10076 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10077 gfc_add_block_to_block (&block
, &argse
.pre
);
10078 gfc_add_block_to_block (&post_block
, &argse
.post
);
10081 gfc_init_se (&argse
, NULL
);
10082 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10083 argse
.want_pointer
= 1;
10084 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10085 gfc_add_block_to_block (&block
, &argse
.pre
);
10086 gfc_add_block_to_block (&post_block
, &argse
.post
);
10089 gfc_init_se (&argse
, NULL
);
10090 if (flag_coarray
== GFC_FCOARRAY_LIB
10091 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
10092 == atom_expr
->ts
.kind
)
10093 argse
.want_pointer
= 1;
10094 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
10095 gfc_add_block_to_block (&block
, &argse
.pre
);
10096 gfc_add_block_to_block (&post_block
, &argse
.post
);
10097 new_val
= argse
.expr
;
10100 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
10102 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
10104 gfc_init_se (&argse
, NULL
);
10105 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10106 argse
.want_pointer
= 1;
10107 gfc_conv_expr_val (&argse
,
10108 code
->ext
.actual
->next
->next
->next
->next
->expr
);
10109 gfc_add_block_to_block (&block
, &argse
.pre
);
10110 gfc_add_block_to_block (&post_block
, &argse
.post
);
10113 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10114 stat
= null_pointer_node
;
10116 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10118 tree image_index
, caf_decl
, offset
, token
;
10120 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10121 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10122 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10124 if (gfc_is_coindexed (atom_expr
))
10125 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10127 image_index
= integer_zero_node
;
10129 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
10131 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
10132 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
10133 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10136 /* Convert a constant to a pointer. */
10137 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
10139 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
10140 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
10141 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10144 gfc_init_se (&argse
, NULL
);
10145 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10147 gfc_add_block_to_block (&block
, &argse
.pre
);
10149 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
10150 token
, offset
, image_index
, old
, comp
, new_val
,
10151 stat
, build_int_cst (integer_type_node
,
10152 (int) atom_expr
->ts
.type
),
10153 build_int_cst (integer_type_node
,
10154 (int) atom_expr
->ts
.kind
));
10155 gfc_add_expr_to_block (&block
, tmp
);
10156 gfc_add_block_to_block (&block
, &argse
.post
);
10157 gfc_add_block_to_block (&block
, &post_block
);
10158 return gfc_finish_block (&block
);
10161 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10162 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10163 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10165 tmp
= builtin_decl_explicit (fn
);
10167 gfc_add_modify (&block
, old
, comp
);
10168 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
10169 gfc_build_addr_expr (NULL
, old
),
10170 fold_convert (TREE_TYPE (old
), new_val
),
10171 boolean_false_node
,
10172 build_int_cst (NULL
, MEMMODEL_RELAXED
),
10173 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10174 gfc_add_expr_to_block (&block
, tmp
);
10176 if (stat
!= NULL_TREE
)
10177 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10178 gfc_add_block_to_block (&block
, &post_block
);
10179 return gfc_finish_block (&block
);
10183 conv_intrinsic_event_query (gfc_code
*code
)
10186 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
10187 tree count
= NULL_TREE
, count2
= NULL_TREE
;
10189 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
10191 if (code
->ext
.actual
->next
->next
->expr
)
10193 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10195 gfc_init_se (&argse
, NULL
);
10196 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10199 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10200 stat
= null_pointer_node
;
10202 if (code
->ext
.actual
->next
->expr
)
10204 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
10205 gfc_init_se (&argse
, NULL
);
10206 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
10207 count
= argse
.expr
;
10210 gfc_start_block (&se
.pre
);
10211 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10213 tree tmp
, token
, image_index
;
10214 tree index
= size_zero_node
;
10216 if (event_expr
->expr_type
== EXPR_FUNCTION
10217 && event_expr
->value
.function
.isym
10218 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10219 event_expr
= event_expr
->value
.function
.actual
->expr
;
10221 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
10223 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10224 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
10225 != INTMOD_ISO_FORTRAN_ENV
10226 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
10227 != ISOFORTRAN_EVENT_TYPE
)
10229 gfc_error ("Sorry, the event component of derived type at %L is not "
10230 "yet supported", &event_expr
->where
);
10234 if (gfc_is_coindexed (event_expr
))
10236 gfc_error ("The event variable at %L shall not be coindexed",
10237 &event_expr
->where
);
10241 image_index
= integer_zero_node
;
10243 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10246 /* For arrays, obtain the array index. */
10247 if (gfc_expr_attr (event_expr
).dimension
)
10249 tree desc
, tmp
, extent
, lbound
, ubound
;
10250 gfc_array_ref
*ar
, ar2
;
10253 /* TODO: Extend this, once DT components are supported. */
10254 ar
= &event_expr
->ref
->u
.ar
;
10256 memset (ar
, '\0', sizeof (*ar
));
10258 ar
->type
= AR_FULL
;
10260 gfc_init_se (&argse
, NULL
);
10261 argse
.descriptor_only
= 1;
10262 gfc_conv_expr_descriptor (&argse
, event_expr
);
10263 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
10267 extent
= integer_one_node
;
10268 for (i
= 0; i
< ar
->dimen
; i
++)
10270 gfc_init_se (&argse
, NULL
);
10271 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
10272 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
10273 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
10274 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10275 integer_type_node
, argse
.expr
,
10276 fold_convert(integer_type_node
, lbound
));
10277 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10278 integer_type_node
, extent
, tmp
);
10279 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
10280 integer_type_node
, index
, tmp
);
10281 if (i
< ar
->dimen
- 1)
10283 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
10284 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10285 tmp
= fold_convert (integer_type_node
, tmp
);
10286 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
10287 integer_type_node
, extent
, tmp
);
10292 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
10295 count
= gfc_create_var (integer_type_node
, "count");
10298 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
10301 stat
= gfc_create_var (integer_type_node
, "stat");
10304 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
10305 token
, index
, image_index
, count
10306 ? gfc_build_addr_expr (NULL
, count
) : count
,
10307 stat
!= null_pointer_node
10308 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
10309 gfc_add_expr_to_block (&se
.pre
, tmp
);
10311 if (count2
!= NULL_TREE
)
10312 gfc_add_modify (&se
.pre
, count2
,
10313 fold_convert (TREE_TYPE (count2
), count
));
10315 if (stat2
!= NULL_TREE
)
10316 gfc_add_modify (&se
.pre
, stat2
,
10317 fold_convert (TREE_TYPE (stat2
), stat
));
10319 return gfc_finish_block (&se
.pre
);
10322 gfc_init_se (&argse
, NULL
);
10323 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
10324 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
10326 if (stat
!= NULL_TREE
)
10327 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10329 return gfc_finish_block (&se
.pre
);
10333 conv_intrinsic_move_alloc (gfc_code
*code
)
10336 gfc_expr
*from_expr
, *to_expr
;
10337 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
10338 gfc_se from_se
, to_se
;
10342 gfc_start_block (&block
);
10344 from_expr
= code
->ext
.actual
->expr
;
10345 to_expr
= code
->ext
.actual
->next
->expr
;
10347 gfc_init_se (&from_se
, NULL
);
10348 gfc_init_se (&to_se
, NULL
);
10350 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
10351 || to_expr
->ts
.type
== BT_CLASS
);
10352 coarray
= gfc_get_corank (from_expr
) != 0;
10354 if (from_expr
->rank
== 0 && !coarray
)
10356 if (from_expr
->ts
.type
!= BT_CLASS
)
10357 from_expr2
= from_expr
;
10360 from_expr2
= gfc_copy_expr (from_expr
);
10361 gfc_add_data_component (from_expr2
);
10364 if (to_expr
->ts
.type
!= BT_CLASS
)
10365 to_expr2
= to_expr
;
10368 to_expr2
= gfc_copy_expr (to_expr
);
10369 gfc_add_data_component (to_expr2
);
10372 from_se
.want_pointer
= 1;
10373 to_se
.want_pointer
= 1;
10374 gfc_conv_expr (&from_se
, from_expr2
);
10375 gfc_conv_expr (&to_se
, to_expr2
);
10376 gfc_add_block_to_block (&block
, &from_se
.pre
);
10377 gfc_add_block_to_block (&block
, &to_se
.pre
);
10379 /* Deallocate "to". */
10380 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10381 true, to_expr
, to_expr
->ts
);
10382 gfc_add_expr_to_block (&block
, tmp
);
10384 /* Assign (_data) pointers. */
10385 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10386 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
10388 /* Set "from" to NULL. */
10389 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10390 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
10392 gfc_add_block_to_block (&block
, &from_se
.post
);
10393 gfc_add_block_to_block (&block
, &to_se
.post
);
10396 if (to_expr
->ts
.type
== BT_CLASS
)
10400 gfc_free_expr (to_expr2
);
10401 gfc_init_se (&to_se
, NULL
);
10402 to_se
.want_pointer
= 1;
10403 gfc_add_vptr_component (to_expr
);
10404 gfc_conv_expr (&to_se
, to_expr
);
10406 if (from_expr
->ts
.type
== BT_CLASS
)
10408 if (UNLIMITED_POLY (from_expr
))
10412 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10416 gfc_free_expr (from_expr2
);
10417 gfc_init_se (&from_se
, NULL
);
10418 from_se
.want_pointer
= 1;
10419 gfc_add_vptr_component (from_expr
);
10420 gfc_conv_expr (&from_se
, from_expr
);
10421 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10422 fold_convert (TREE_TYPE (to_se
.expr
),
10425 /* Reset _vptr component to declared type. */
10427 /* Unlimited polymorphic. */
10428 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10429 fold_convert (TREE_TYPE (from_se
.expr
),
10430 null_pointer_node
));
10433 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10434 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10435 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10440 vtab
= gfc_find_vtab (&from_expr
->ts
);
10442 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10443 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10444 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10448 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10450 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10451 fold_convert (TREE_TYPE (to_se
.string_length
),
10452 from_se
.string_length
));
10453 if (from_expr
->ts
.deferred
)
10454 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10455 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10458 return gfc_finish_block (&block
);
10461 /* Update _vptr component. */
10462 if (to_expr
->ts
.type
== BT_CLASS
)
10466 to_se
.want_pointer
= 1;
10467 to_expr2
= gfc_copy_expr (to_expr
);
10468 gfc_add_vptr_component (to_expr2
);
10469 gfc_conv_expr (&to_se
, to_expr2
);
10471 if (from_expr
->ts
.type
== BT_CLASS
)
10473 if (UNLIMITED_POLY (from_expr
))
10477 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10481 from_se
.want_pointer
= 1;
10482 from_expr2
= gfc_copy_expr (from_expr
);
10483 gfc_add_vptr_component (from_expr2
);
10484 gfc_conv_expr (&from_se
, from_expr2
);
10485 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10486 fold_convert (TREE_TYPE (to_se
.expr
),
10489 /* Reset _vptr component to declared type. */
10491 /* Unlimited polymorphic. */
10492 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10493 fold_convert (TREE_TYPE (from_se
.expr
),
10494 null_pointer_node
));
10497 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10498 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10499 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10504 vtab
= gfc_find_vtab (&from_expr
->ts
);
10506 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10507 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10508 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10511 gfc_free_expr (to_expr2
);
10512 gfc_init_se (&to_se
, NULL
);
10514 if (from_expr
->ts
.type
== BT_CLASS
)
10516 gfc_free_expr (from_expr2
);
10517 gfc_init_se (&from_se
, NULL
);
10522 /* Deallocate "to". */
10523 if (from_expr
->rank
== 0)
10525 to_se
.want_coarray
= 1;
10526 from_se
.want_coarray
= 1;
10528 gfc_conv_expr_descriptor (&to_se
, to_expr
);
10529 gfc_conv_expr_descriptor (&from_se
, from_expr
);
10531 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10532 is an image control "statement", cf. IR F08/0040 in 12-006A. */
10533 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10537 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10538 NULL_TREE
, NULL_TREE
, true, to_expr
,
10539 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
10540 gfc_add_expr_to_block (&block
, tmp
);
10542 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10543 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10544 boolean_type_node
, tmp
,
10545 fold_convert (TREE_TYPE (tmp
),
10546 null_pointer_node
));
10547 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
10548 3, null_pointer_node
, null_pointer_node
,
10549 build_int_cst (integer_type_node
, 0));
10551 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
10552 tmp
, build_empty_stmt (input_location
));
10553 gfc_add_expr_to_block (&block
, tmp
);
10557 if (to_expr
->ts
.type
== BT_DERIVED
10558 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
10560 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
10561 to_se
.expr
, to_expr
->rank
);
10562 gfc_add_expr_to_block (&block
, tmp
);
10565 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10566 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10567 NULL_TREE
, true, to_expr
,
10568 GFC_CAF_COARRAY_NOCOARRAY
);
10569 gfc_add_expr_to_block (&block
, tmp
);
10572 /* Move the pointer and update the array descriptor data. */
10573 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
10575 /* Set "from" to NULL. */
10576 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
10577 gfc_add_modify_loc (input_location
, &block
, tmp
,
10578 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
10581 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10583 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10584 fold_convert (TREE_TYPE (to_se
.string_length
),
10585 from_se
.string_length
));
10586 if (from_expr
->ts
.deferred
)
10587 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10588 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10591 return gfc_finish_block (&block
);
10596 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
10600 gcc_assert (code
->resolved_isym
);
10602 switch (code
->resolved_isym
->id
)
10604 case GFC_ISYM_MOVE_ALLOC
:
10605 res
= conv_intrinsic_move_alloc (code
);
10608 case GFC_ISYM_ATOMIC_CAS
:
10609 res
= conv_intrinsic_atomic_cas (code
);
10612 case GFC_ISYM_ATOMIC_ADD
:
10613 case GFC_ISYM_ATOMIC_AND
:
10614 case GFC_ISYM_ATOMIC_DEF
:
10615 case GFC_ISYM_ATOMIC_OR
:
10616 case GFC_ISYM_ATOMIC_XOR
:
10617 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10618 case GFC_ISYM_ATOMIC_FETCH_AND
:
10619 case GFC_ISYM_ATOMIC_FETCH_OR
:
10620 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10621 res
= conv_intrinsic_atomic_op (code
);
10624 case GFC_ISYM_ATOMIC_REF
:
10625 res
= conv_intrinsic_atomic_ref (code
);
10628 case GFC_ISYM_EVENT_QUERY
:
10629 res
= conv_intrinsic_event_query (code
);
10632 case GFC_ISYM_C_F_POINTER
:
10633 case GFC_ISYM_C_F_PROCPOINTER
:
10634 res
= conv_isocbinding_subroutine (code
);
10637 case GFC_ISYM_CAF_SEND
:
10638 res
= conv_caf_send (code
);
10641 case GFC_ISYM_CO_BROADCAST
:
10642 case GFC_ISYM_CO_MIN
:
10643 case GFC_ISYM_CO_MAX
:
10644 case GFC_ISYM_CO_REDUCE
:
10645 case GFC_ISYM_CO_SUM
:
10646 res
= conv_co_collective (code
);
10649 case GFC_ISYM_FREE
:
10650 res
= conv_intrinsic_free (code
);
10653 case GFC_ISYM_SYSTEM_CLOCK
:
10654 res
= conv_intrinsic_system_clock (code
);
10665 #include "gt-fortran-trans-intrinsic.h"