1 /* Intrinsic translation
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "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 logical_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
, logical_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
, logical_type_node
, arg
[0],
500 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, logical_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
, logical_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 if (lhs_expr
->ts
.type
== BT_CHARACTER
&& lhs_expr
->ts
.deferred
)
1876 lhs_se
.expr
= gfc_get_tree_for_caf_expr (lhs_expr
);
1877 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1881 symbol_attribute attr
;
1882 gfc_clear_attr (&attr
);
1883 gfc_conv_expr (&lhs_se
, lhs_expr
);
1884 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1885 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
,
1887 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1890 else if ((lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
1891 && lhs_caf_attr
.codimension
)
1893 lhs_se
.want_pointer
= 1;
1894 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1895 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1896 has the wrong type if component references are done. */
1897 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1898 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1899 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1900 gfc_get_dtype_rank_type (
1901 gfc_has_vector_subscript (lhs_expr
)
1902 ? gfc_find_array_ref (lhs_expr
)->dimen
1908 /* If has_vector, pass descriptor for whole array and the
1909 vector bounds separately. */
1910 gfc_array_ref
*ar
, ar2
;
1911 bool has_vector
= false;
1913 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1916 ar
= gfc_find_array_ref (lhs_expr
);
1918 memset (ar
, '\0', sizeof (*ar
));
1922 lhs_se
.want_pointer
= 1;
1923 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1924 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1925 has the wrong type if component references are done. */
1926 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1927 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1928 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1929 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1934 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1939 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1941 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1942 temporary and a loop. */
1943 if (!gfc_is_coindexed (lhs_expr
)
1944 && (!lhs_caf_attr
.codimension
1945 || !(lhs_expr
->rank
> 0
1946 && (lhs_caf_attr
.allocatable
|| lhs_caf_attr
.pointer
))))
1948 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
1949 gcc_assert (gfc_is_coindexed (rhs_expr
));
1950 gfc_init_se (&rhs_se
, NULL
);
1951 if (lhs_expr
->rank
== 0 && lhs_caf_attr
.allocatable
)
1954 gfc_init_se (&scal_se
, NULL
);
1955 scal_se
.want_pointer
= 1;
1956 gfc_conv_expr (&scal_se
, lhs_expr
);
1957 /* Ensure scalar on lhs is allocated. */
1958 gfc_add_block_to_block (&block
, &scal_se
.pre
);
1960 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
1962 gfc_typenode_for_spec (&lhs_expr
->ts
)),
1964 tmp
= fold_build2 (EQ_EXPR
, logical_type_node
, scal_se
.expr
,
1966 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1967 tmp
, gfc_finish_block (&scal_se
.pre
),
1968 build_empty_stmt (input_location
));
1969 gfc_add_expr_to_block (&block
, tmp
);
1972 lhs_may_realloc
= lhs_may_realloc
1973 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
1974 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1975 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1976 may_require_tmp
, lhs_may_realloc
,
1978 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1979 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1980 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1981 return gfc_finish_block (&block
);
1984 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1986 /* Obtain token, offset and image index for the LHS. */
1987 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1988 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1989 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1990 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1992 if (lhs_caf_attr
.alloc_comp
)
1993 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
1996 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
2001 gfc_init_se (&rhs_se
, NULL
);
2002 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
2003 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2004 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
2005 if (rhs_expr
->rank
== 0)
2007 symbol_attribute attr
;
2008 gfc_clear_attr (&attr
);
2009 gfc_conv_expr (&rhs_se
, rhs_expr
);
2010 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
2011 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2013 else if ((rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2014 && rhs_caf_attr
.codimension
)
2017 rhs_se
.want_pointer
= 1;
2018 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2019 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2020 has the wrong type if component references are done. */
2021 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2022 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2023 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2024 gfc_get_dtype_rank_type (
2025 gfc_has_vector_subscript (rhs_expr
)
2026 ? gfc_find_array_ref (rhs_expr
)->dimen
2032 /* If has_vector, pass descriptor for whole array and the
2033 vector bounds separately. */
2034 gfc_array_ref
*ar
, ar2
;
2035 bool has_vector
= false;
2038 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2041 ar
= gfc_find_array_ref (rhs_expr
);
2043 memset (ar
, '\0', sizeof (*ar
));
2047 rhs_se
.want_pointer
= 1;
2048 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2049 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2050 has the wrong type if component references are done. */
2051 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2052 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2053 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2054 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2059 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2064 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2066 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2068 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2073 gfc_init_se (&stat_se
, NULL
);
2074 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2075 dst_stat
= stat_se
.expr
;
2076 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2077 gfc_add_block_to_block (&block
, &stat_se
.post
);
2080 if (!gfc_is_coindexed (rhs_expr
))
2082 if (lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
2084 tree reference
, dst_realloc
;
2085 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2086 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2087 : boolean_false_node
;
2088 tmp
= build_call_expr_loc (input_location
,
2089 gfor_fndecl_caf_send_by_ref
,
2090 9, token
, image_index
, rhs_se
.expr
,
2091 reference
, lhs_kind
, rhs_kind
,
2092 may_require_tmp
, dst_realloc
, src_stat
);
2095 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 10,
2096 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2097 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2098 may_require_tmp
, src_stat
);
2102 tree rhs_token
, rhs_offset
, rhs_image_index
;
2104 /* It guarantees memory consistency within the same segment. */
2105 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2106 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2107 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2108 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2109 ASM_VOLATILE_P (tmp
) = 1;
2110 gfc_add_expr_to_block (&block
, tmp
);
2112 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2113 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2114 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2115 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2117 if (rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2119 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2124 gfc_init_se (&stat_se
, NULL
);
2125 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2126 src_stat
= stat_se
.expr
;
2127 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2128 gfc_add_block_to_block (&block
, &stat_se
.post
);
2131 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2133 tree lhs_reference
, rhs_reference
;
2134 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2135 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2136 tmp
= build_call_expr_loc (input_location
,
2137 gfor_fndecl_caf_sendget_by_ref
, 11,
2138 token
, image_index
, lhs_reference
,
2139 rhs_token
, rhs_image_index
, rhs_reference
,
2140 lhs_kind
, rhs_kind
, may_require_tmp
,
2141 dst_stat
, src_stat
);
2145 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2147 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2148 14, token
, offset
, image_index
,
2149 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2150 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2151 rhs_kind
, may_require_tmp
, src_stat
);
2154 gfc_add_expr_to_block (&block
, tmp
);
2155 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2156 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2158 /* It guarantees memory consistency within the same segment. */
2159 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2160 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2161 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2162 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2163 ASM_VOLATILE_P (tmp
) = 1;
2164 gfc_add_expr_to_block (&block
, tmp
);
2166 return gfc_finish_block (&block
);
2171 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2174 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2175 lbound
, ubound
, extent
, ml
;
2178 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2180 if (expr
->value
.function
.actual
->expr
2181 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2182 distance
= expr
->value
.function
.actual
->expr
;
2184 /* The case -fcoarray=single is handled elsewhere. */
2185 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2187 /* Argument-free version: THIS_IMAGE(). */
2188 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2192 gfc_init_se (&argse
, NULL
);
2193 gfc_conv_expr_val (&argse
, distance
);
2194 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2195 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2196 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2199 tmp
= integer_zero_node
;
2200 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2202 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2207 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2209 type
= gfc_get_int_type (gfc_default_integer_kind
);
2210 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2211 rank
= expr
->value
.function
.actual
->expr
->rank
;
2213 /* Obtain the descriptor of the COARRAY. */
2214 gfc_init_se (&argse
, NULL
);
2215 argse
.want_coarray
= 1;
2216 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2217 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2218 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2223 /* Create an implicit second parameter from the loop variable. */
2224 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2225 gcc_assert (corank
> 0);
2226 gcc_assert (se
->loop
->dimen
== 1);
2227 gcc_assert (se
->ss
->info
->expr
== expr
);
2229 dim_arg
= se
->loop
->loopvar
[0];
2230 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2231 gfc_array_index_type
, dim_arg
,
2232 build_int_cst (TREE_TYPE (dim_arg
), 1));
2233 gfc_advance_se_ss_chain (se
);
2237 /* Use the passed DIM= argument. */
2238 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2239 gfc_init_se (&argse
, NULL
);
2240 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2241 gfc_array_index_type
);
2242 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2243 dim_arg
= argse
.expr
;
2245 if (INTEGER_CST_P (dim_arg
))
2247 if (wi::ltu_p (wi::to_wide (dim_arg
), 1)
2248 || wi::gtu_p (wi::to_wide (dim_arg
),
2249 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2250 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2251 "dimension index", expr
->value
.function
.isym
->name
,
2254 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2256 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2257 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2259 build_int_cst (TREE_TYPE (dim_arg
), 1));
2260 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2261 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2263 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2264 logical_type_node
, cond
, tmp
);
2265 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2270 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2271 one always has a dim_arg argument.
2273 m = this_image() - 1
2276 sub(1) = m + lcobound(corank)
2280 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2283 extent = gfc_extent(i)
2291 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2292 : m + lcobound(corank)
2295 /* this_image () - 1. */
2296 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2298 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2299 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2302 /* sub(1) = m + lcobound(corank). */
2303 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2304 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2306 lbound
= fold_convert (type
, lbound
);
2307 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2313 m
= gfc_create_var (type
, NULL
);
2314 ml
= gfc_create_var (type
, NULL
);
2315 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2316 min_var
= gfc_create_var (integer_type_node
, NULL
);
2318 /* m = this_image () - 1. */
2319 gfc_add_modify (&se
->pre
, m
, tmp
);
2321 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2322 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2323 fold_convert (integer_type_node
, dim_arg
),
2324 build_int_cst (integer_type_node
, rank
- 1));
2325 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2326 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2328 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2331 tmp
= build_int_cst (integer_type_node
, rank
);
2332 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2334 exit_label
= gfc_build_label_decl (NULL_TREE
);
2335 TREE_USED (exit_label
) = 1;
2338 gfc_init_block (&loop
);
2341 gfc_add_modify (&loop
, ml
, m
);
2344 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2345 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2346 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2347 extent
= fold_convert (type
, extent
);
2350 gfc_add_modify (&loop
, m
,
2351 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2354 /* Exit condition: if (i >= min_var) goto exit_label. */
2355 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, loop_var
,
2357 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2358 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2359 build_empty_stmt (input_location
));
2360 gfc_add_expr_to_block (&loop
, tmp
);
2362 /* Increment loop variable: i++. */
2363 gfc_add_modify (&loop
, loop_var
,
2364 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2366 build_int_cst (integer_type_node
, 1)));
2368 /* Making the loop... actually loop! */
2369 tmp
= gfc_finish_block (&loop
);
2370 tmp
= build1_v (LOOP_EXPR
, tmp
);
2371 gfc_add_expr_to_block (&se
->pre
, tmp
);
2373 /* The exit label. */
2374 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2375 gfc_add_expr_to_block (&se
->pre
, tmp
);
2377 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2378 : m + lcobound(corank) */
2380 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, dim_arg
,
2381 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2383 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2384 fold_build2_loc (input_location
, PLUS_EXPR
,
2385 gfc_array_index_type
, dim_arg
,
2386 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2387 lbound
= fold_convert (type
, lbound
);
2389 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2390 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2392 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2394 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2395 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2400 /* Convert a call to image_status. */
2403 conv_intrinsic_image_status (gfc_se
*se
, gfc_expr
*expr
)
2405 unsigned int num_args
;
2408 num_args
= gfc_intrinsic_argument_list_length (expr
);
2409 args
= XALLOCAVEC (tree
, num_args
);
2410 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2411 /* In args[0] the number of the image the status is desired for has to be
2414 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2417 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2418 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2419 fold_convert (integer_type_node
, arg
),
2421 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2422 tmp
, integer_zero_node
,
2423 build_int_cst (integer_type_node
,
2424 GFC_STAT_STOPPED_IMAGE
));
2426 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2427 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_image_status
, 2,
2428 args
[0], build_int_cst (integer_type_node
, -1));
2437 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2439 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2441 gfc_se argse
, subse
;
2442 int rank
, corank
, codim
;
2444 type
= gfc_get_int_type (gfc_default_integer_kind
);
2445 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2446 rank
= expr
->value
.function
.actual
->expr
->rank
;
2448 /* Obtain the descriptor of the COARRAY. */
2449 gfc_init_se (&argse
, NULL
);
2450 argse
.want_coarray
= 1;
2451 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2452 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2453 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2456 /* Obtain a handle to the SUB argument. */
2457 gfc_init_se (&subse
, NULL
);
2458 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2459 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2460 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2461 subdesc
= build_fold_indirect_ref_loc (input_location
,
2462 gfc_conv_descriptor_data_get (subse
.expr
));
2464 /* Fortran 2008 does not require that the values remain in the cobounds,
2465 thus we need explicitly check this - and return 0 if they are exceeded. */
2467 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2468 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2469 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2470 fold_convert (gfc_array_index_type
, tmp
),
2473 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2475 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2476 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2477 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2478 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2479 fold_convert (gfc_array_index_type
, tmp
),
2481 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2482 logical_type_node
, invalid_bound
, cond
);
2483 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2484 fold_convert (gfc_array_index_type
, tmp
),
2486 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2487 logical_type_node
, invalid_bound
, cond
);
2490 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2492 /* See Fortran 2008, C.10 for the following algorithm. */
2494 /* coindex = sub(corank) - lcobound(n). */
2495 coindex
= fold_convert (gfc_array_index_type
,
2496 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2498 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2499 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2500 fold_convert (gfc_array_index_type
, coindex
),
2503 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2505 tree extent
, ubound
;
2507 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2508 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2509 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2510 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2512 /* coindex *= extent. */
2513 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2514 gfc_array_index_type
, coindex
, extent
);
2516 /* coindex += sub(codim). */
2517 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2518 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2519 gfc_array_index_type
, coindex
,
2520 fold_convert (gfc_array_index_type
, tmp
));
2522 /* coindex -= lbound(codim). */
2523 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2524 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2525 gfc_array_index_type
, coindex
, lbound
);
2528 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2529 fold_convert(type
, coindex
),
2530 build_int_cst (type
, 1));
2532 /* Return 0 if "coindex" exceeds num_images(). */
2534 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2535 num_images
= build_int_cst (type
, 1);
2538 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2540 build_int_cst (integer_type_node
, -1));
2541 num_images
= fold_convert (type
, tmp
);
2544 tmp
= gfc_create_var (type
, NULL
);
2545 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2547 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, tmp
,
2549 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
2551 fold_convert (logical_type_node
, invalid_bound
));
2552 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2553 build_int_cst (type
, 0), tmp
);
2558 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2560 tree tmp
, distance
, failed
;
2563 if (expr
->value
.function
.actual
->expr
)
2565 gfc_init_se (&argse
, NULL
);
2566 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2567 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2568 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2569 distance
= fold_convert (integer_type_node
, argse
.expr
);
2572 distance
= integer_zero_node
;
2574 if (expr
->value
.function
.actual
->next
->expr
)
2576 gfc_init_se (&argse
, NULL
);
2577 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2578 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2579 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2580 failed
= fold_convert (integer_type_node
, argse
.expr
);
2583 failed
= build_int_cst (integer_type_node
, -1);
2585 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2587 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2592 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2596 gfc_init_se (&argse
, NULL
);
2597 argse
.data_not_needed
= 1;
2598 argse
.descriptor_only
= 1;
2600 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2601 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2602 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2604 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2605 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2610 /* Evaluate a single upper or lower bound. */
2611 /* TODO: bound intrinsic generates way too much unnecessary code. */
2614 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2616 gfc_actual_arglist
*arg
;
2617 gfc_actual_arglist
*arg2
;
2622 tree cond
, cond1
, cond3
, cond4
, size
;
2626 gfc_array_spec
* as
;
2627 bool assumed_rank_lb_one
;
2629 arg
= expr
->value
.function
.actual
;
2634 /* Create an implicit second parameter from the loop variable. */
2635 gcc_assert (!arg2
->expr
);
2636 gcc_assert (se
->loop
->dimen
== 1);
2637 gcc_assert (se
->ss
->info
->expr
== expr
);
2638 gfc_advance_se_ss_chain (se
);
2639 bound
= se
->loop
->loopvar
[0];
2640 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2641 gfc_array_index_type
, bound
,
2646 /* use the passed argument. */
2647 gcc_assert (arg2
->expr
);
2648 gfc_init_se (&argse
, NULL
);
2649 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2650 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2652 /* Convert from one based to zero based. */
2653 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2654 gfc_array_index_type
, bound
,
2655 gfc_index_one_node
);
2658 /* TODO: don't re-evaluate the descriptor on each iteration. */
2659 /* Get a descriptor for the first parameter. */
2660 gfc_init_se (&argse
, NULL
);
2661 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2662 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2663 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2667 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2669 if (INTEGER_CST_P (bound
))
2671 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2672 && wi::geu_p (wi::to_wide (bound
),
2673 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2674 || wi::gtu_p (wi::to_wide (bound
), GFC_MAX_DIMENSIONS
))
2675 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2676 "dimension index", upper
? "UBOUND" : "LBOUND",
2680 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
2682 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2684 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2685 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2686 bound
, build_int_cst (TREE_TYPE (bound
), 0));
2687 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2688 tmp
= gfc_conv_descriptor_rank (desc
);
2690 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
2691 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2692 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
2693 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2694 logical_type_node
, cond
, tmp
);
2695 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2700 /* Take care of the lbound shift for assumed-rank arrays, which are
2701 nonallocatable and nonpointers. Those has a lbound of 1. */
2702 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
2703 && ((arg
->expr
->ts
.type
!= BT_CLASS
2704 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
2705 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
2706 || (arg
->expr
->ts
.type
== BT_CLASS
2707 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
2708 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
2710 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2711 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2713 /* 13.14.53: Result value for LBOUND
2715 Case (i): For an array section or for an array expression other than a
2716 whole array or array structure component, LBOUND(ARRAY, DIM)
2717 has the value 1. For a whole array or array structure
2718 component, LBOUND(ARRAY, DIM) has the value:
2719 (a) equal to the lower bound for subscript DIM of ARRAY if
2720 dimension DIM of ARRAY does not have extent zero
2721 or if ARRAY is an assumed-size array of rank DIM,
2724 13.14.113: Result value for UBOUND
2726 Case (i): For an array section or for an array expression other than a
2727 whole array or array structure component, UBOUND(ARRAY, DIM)
2728 has the value equal to the number of elements in the given
2729 dimension; otherwise, it has a value equal to the upper bound
2730 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2731 not have size zero and has value zero if dimension DIM has
2734 if (!upper
&& assumed_rank_lb_one
)
2735 se
->expr
= gfc_index_one_node
;
2738 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
2740 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2742 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2743 stride
, gfc_index_zero_node
);
2744 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2745 logical_type_node
, cond3
, cond1
);
2746 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2747 stride
, gfc_index_zero_node
);
2752 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2753 logical_type_node
, cond3
, cond4
);
2754 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2755 gfc_index_one_node
, lbound
);
2756 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2757 logical_type_node
, cond4
, cond5
);
2759 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2760 logical_type_node
, cond
, cond5
);
2762 if (assumed_rank_lb_one
)
2764 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2765 gfc_array_index_type
, ubound
, lbound
);
2766 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2767 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2772 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2773 gfc_array_index_type
, cond
,
2774 tmp
, gfc_index_zero_node
);
2778 if (as
->type
== AS_ASSUMED_SIZE
)
2779 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2780 bound
, build_int_cst (TREE_TYPE (bound
),
2781 arg
->expr
->rank
- 1));
2783 cond
= logical_false_node
;
2785 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2786 logical_type_node
, cond3
, cond4
);
2787 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2788 logical_type_node
, cond
, cond1
);
2790 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2791 gfc_array_index_type
, cond
,
2792 lbound
, gfc_index_one_node
);
2799 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2800 gfc_array_index_type
, ubound
, lbound
);
2801 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2802 gfc_array_index_type
, size
,
2803 gfc_index_one_node
);
2804 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2805 gfc_array_index_type
, se
->expr
,
2806 gfc_index_zero_node
);
2809 se
->expr
= gfc_index_one_node
;
2812 type
= gfc_typenode_for_spec (&expr
->ts
);
2813 se
->expr
= convert (type
, se
->expr
);
2818 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2820 gfc_actual_arglist
*arg
;
2821 gfc_actual_arglist
*arg2
;
2823 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2827 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2828 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2829 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2831 arg
= expr
->value
.function
.actual
;
2834 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2835 corank
= gfc_get_corank (arg
->expr
);
2837 gfc_init_se (&argse
, NULL
);
2838 argse
.want_coarray
= 1;
2840 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2841 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2842 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2847 /* Create an implicit second parameter from the loop variable. */
2848 gcc_assert (!arg2
->expr
);
2849 gcc_assert (corank
> 0);
2850 gcc_assert (se
->loop
->dimen
== 1);
2851 gcc_assert (se
->ss
->info
->expr
== expr
);
2853 bound
= se
->loop
->loopvar
[0];
2854 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2855 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2856 gfc_advance_se_ss_chain (se
);
2860 /* use the passed argument. */
2861 gcc_assert (arg2
->expr
);
2862 gfc_init_se (&argse
, NULL
);
2863 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2864 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2867 if (INTEGER_CST_P (bound
))
2869 if (wi::ltu_p (wi::to_wide (bound
), 1)
2870 || wi::gtu_p (wi::to_wide (bound
),
2871 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2872 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2873 "dimension index", expr
->value
.function
.isym
->name
,
2876 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2878 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2879 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2880 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2881 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2882 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2884 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2885 logical_type_node
, cond
, tmp
);
2886 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2891 /* Subtract 1 to get to zero based and add dimensions. */
2892 switch (arg
->expr
->rank
)
2895 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2896 gfc_array_index_type
, bound
,
2897 gfc_index_one_node
);
2901 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2902 gfc_array_index_type
, bound
,
2903 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2907 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2909 /* Handle UCOBOUND with special handling of the last codimension. */
2910 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2912 /* Last codimension: For -fcoarray=single just return
2913 the lcobound - otherwise add
2914 ceiling (real (num_images ()) / real (size)) - 1
2915 = (num_images () + size - 1) / size - 1
2916 = (num_images - 1) / size(),
2917 where size is the product of the extent of all but the last
2920 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2924 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2925 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2926 2, integer_zero_node
,
2927 build_int_cst (integer_type_node
, -1));
2928 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2929 gfc_array_index_type
,
2930 fold_convert (gfc_array_index_type
, tmp
),
2931 build_int_cst (gfc_array_index_type
, 1));
2932 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2933 gfc_array_index_type
, tmp
,
2934 fold_convert (gfc_array_index_type
, cosize
));
2935 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2936 gfc_array_index_type
, resbound
, tmp
);
2938 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2940 /* ubound = lbound + num_images() - 1. */
2941 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2942 2, integer_zero_node
,
2943 build_int_cst (integer_type_node
, -1));
2944 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2945 gfc_array_index_type
,
2946 fold_convert (gfc_array_index_type
, tmp
),
2947 build_int_cst (gfc_array_index_type
, 1));
2948 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2949 gfc_array_index_type
, resbound
, tmp
);
2954 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2956 build_int_cst (TREE_TYPE (bound
),
2957 arg
->expr
->rank
+ corank
- 1));
2959 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2960 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2961 gfc_array_index_type
, cond
,
2962 resbound
, resbound2
);
2965 se
->expr
= resbound
;
2968 se
->expr
= resbound
;
2970 type
= gfc_typenode_for_spec (&expr
->ts
);
2971 se
->expr
= convert (type
, se
->expr
);
2976 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2978 gfc_actual_arglist
*array_arg
;
2979 gfc_actual_arglist
*dim_arg
;
2983 array_arg
= expr
->value
.function
.actual
;
2984 dim_arg
= array_arg
->next
;
2986 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2988 gfc_init_se (&argse
, NULL
);
2989 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2990 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2991 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2994 gcc_assert (dim_arg
->expr
);
2995 gfc_init_se (&argse
, NULL
);
2996 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2997 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2998 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2999 argse
.expr
, gfc_index_one_node
);
3000 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
3005 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
3009 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3011 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
3015 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
3020 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
3021 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
3030 /* Create a complex value from one or two real components. */
3033 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
3039 unsigned int num_args
;
3041 num_args
= gfc_intrinsic_argument_list_length (expr
);
3042 args
= XALLOCAVEC (tree
, num_args
);
3044 type
= gfc_typenode_for_spec (&expr
->ts
);
3045 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3046 real
= convert (TREE_TYPE (type
), args
[0]);
3048 imag
= convert (TREE_TYPE (type
), args
[1]);
3049 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
3051 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
3052 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
3053 imag
= convert (TREE_TYPE (type
), imag
);
3056 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3058 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3062 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3063 MODULO(A, P) = A - FLOOR (A / P) * P
3065 The obvious algorithms above are numerically instable for large
3066 arguments, hence these intrinsics are instead implemented via calls
3067 to the fmod family of functions. It is the responsibility of the
3068 user to ensure that the second argument is non-zero. */
3071 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3081 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3083 switch (expr
->ts
.type
)
3086 /* Integer case is easy, we've got a builtin op. */
3087 type
= TREE_TYPE (args
[0]);
3090 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3093 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3099 /* Check if we have a builtin fmod. */
3100 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3102 /* The builtin should always be available. */
3103 gcc_assert (fmod
!= NULL_TREE
);
3105 tmp
= build_addr (fmod
);
3106 se
->expr
= build_call_array_loc (input_location
,
3107 TREE_TYPE (TREE_TYPE (fmod
)),
3112 type
= TREE_TYPE (args
[0]);
3114 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3115 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3118 modulo = arg - floor (arg/arg2) * arg2
3120 In order to calculate the result accurately, we use the fmod
3121 function as follows.
3123 res = fmod (arg, arg2);
3126 if ((arg < 0) xor (arg2 < 0))
3130 res = copysign (0., arg2);
3132 => As two nested ternary exprs:
3134 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3135 : copysign (0., arg2);
3139 zero
= gfc_build_const (type
, integer_zero_node
);
3140 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3141 if (!flag_signed_zeros
)
3143 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3145 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3147 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3148 logical_type_node
, test
, test2
);
3149 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3151 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3152 logical_type_node
, test
, test2
);
3153 test
= gfc_evaluate_now (test
, &se
->pre
);
3154 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3155 fold_build2_loc (input_location
,
3157 type
, tmp
, args
[1]),
3162 tree expr1
, copysign
, cscall
;
3163 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3165 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3167 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3169 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3170 logical_type_node
, test
, test2
);
3171 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3172 fold_build2_loc (input_location
,
3174 type
, tmp
, args
[1]),
3176 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3178 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3180 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3190 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3191 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3192 where the right shifts are logical (i.e. 0's are shifted in).
3193 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3194 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3196 DSHIFTL(I,J,BITSIZE) = J
3198 DSHIFTR(I,J,BITSIZE) = I. */
3201 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3203 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3204 tree args
[3], cond
, tmp
;
3207 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3209 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3210 type
= TREE_TYPE (args
[0]);
3211 bitsize
= TYPE_PRECISION (type
);
3212 utype
= unsigned_type_for (type
);
3213 stype
= TREE_TYPE (args
[2]);
3215 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3216 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3217 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3219 /* The generic case. */
3220 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3221 build_int_cst (stype
, bitsize
), shift
);
3222 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3223 arg1
, dshiftl
? shift
: tmp
);
3225 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3226 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3227 right
= fold_convert (type
, right
);
3229 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3231 /* Special cases. */
3232 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3233 build_int_cst (stype
, 0));
3234 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3235 dshiftl
? arg1
: arg2
, res
);
3237 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3238 build_int_cst (stype
, bitsize
));
3239 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3240 dshiftl
? arg2
: arg1
, res
);
3246 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3249 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3257 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3258 type
= TREE_TYPE (args
[0]);
3260 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3261 val
= gfc_evaluate_now (val
, &se
->pre
);
3263 zero
= gfc_build_const (type
, integer_zero_node
);
3264 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, val
, zero
);
3265 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3269 /* SIGN(A, B) is absolute value of A times sign of B.
3270 The real value versions use library functions to ensure the correct
3271 handling of negative zero. Integer case implemented as:
3272 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3276 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3282 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3283 if (expr
->ts
.type
== BT_REAL
)
3287 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3288 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3290 /* We explicitly have to ignore the minus sign. We do so by using
3291 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3293 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3296 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3297 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3299 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3300 TREE_TYPE (args
[0]), cond
,
3301 build_call_expr_loc (input_location
, abs
, 1,
3303 build_call_expr_loc (input_location
, tmp
, 2,
3307 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3312 /* Having excluded floating point types, we know we are now dealing
3313 with signed integer types. */
3314 type
= TREE_TYPE (args
[0]);
3316 /* Args[0] is used multiple times below. */
3317 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3319 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3320 the signs of A and B are the same, and of all ones if they differ. */
3321 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3322 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3323 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3324 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3326 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3327 is all ones (i.e. -1). */
3328 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3329 fold_build2_loc (input_location
, PLUS_EXPR
,
3330 type
, args
[0], tmp
), tmp
);
3334 /* Test for the presence of an optional argument. */
3337 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3341 arg
= expr
->value
.function
.actual
->expr
;
3342 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3343 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3344 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3348 /* Calculate the double precision product of two single precision values. */
3351 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3356 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3358 /* Convert the args to double precision before multiplying. */
3359 type
= gfc_typenode_for_spec (&expr
->ts
);
3360 args
[0] = convert (type
, args
[0]);
3361 args
[1] = convert (type
, args
[1]);
3362 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3367 /* Return a length one character string containing an ascii character. */
3370 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3375 unsigned int num_args
;
3377 num_args
= gfc_intrinsic_argument_list_length (expr
);
3378 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3380 type
= gfc_get_char_type (expr
->ts
.kind
);
3381 var
= gfc_create_var (type
, "char");
3383 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3384 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3385 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3386 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3391 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3399 unsigned int num_args
;
3401 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3402 args
= XALLOCAVEC (tree
, num_args
);
3404 var
= gfc_create_var (pchar_type_node
, "pstr");
3405 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3407 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3408 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3409 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3411 fndecl
= build_addr (gfor_fndecl_ctime
);
3412 tmp
= build_call_array_loc (input_location
,
3413 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3414 fndecl
, num_args
, args
);
3415 gfc_add_expr_to_block (&se
->pre
, tmp
);
3417 /* Free the temporary afterwards, if necessary. */
3418 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3419 len
, build_int_cst (TREE_TYPE (len
), 0));
3420 tmp
= gfc_call_free (var
);
3421 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3422 gfc_add_expr_to_block (&se
->post
, tmp
);
3425 se
->string_length
= len
;
3430 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3438 unsigned int num_args
;
3440 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3441 args
= XALLOCAVEC (tree
, num_args
);
3443 var
= gfc_create_var (pchar_type_node
, "pstr");
3444 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3446 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3447 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3448 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3450 fndecl
= build_addr (gfor_fndecl_fdate
);
3451 tmp
= build_call_array_loc (input_location
,
3452 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3453 fndecl
, num_args
, args
);
3454 gfc_add_expr_to_block (&se
->pre
, tmp
);
3456 /* Free the temporary afterwards, if necessary. */
3457 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3458 len
, build_int_cst (TREE_TYPE (len
), 0));
3459 tmp
= gfc_call_free (var
);
3460 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3461 gfc_add_expr_to_block (&se
->post
, tmp
);
3464 se
->string_length
= len
;
3468 /* Generate a direct call to free() for the FREE subroutine. */
3471 conv_intrinsic_free (gfc_code
*code
)
3477 gfc_init_se (&argse
, NULL
);
3478 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3479 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3481 gfc_init_block (&block
);
3482 call
= build_call_expr_loc (input_location
,
3483 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3484 gfc_add_expr_to_block (&block
, call
);
3485 return gfc_finish_block (&block
);
3489 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3493 conv_intrinsic_system_clock (gfc_code
*code
)
3496 gfc_se count_se
, count_rate_se
, count_max_se
;
3497 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3501 gfc_expr
*count
= code
->ext
.actual
->expr
;
3502 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3503 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3505 /* Evaluate our arguments. */
3508 gfc_init_se (&count_se
, NULL
);
3509 gfc_conv_expr (&count_se
, count
);
3514 gfc_init_se (&count_rate_se
, NULL
);
3515 gfc_conv_expr (&count_rate_se
, count_rate
);
3520 gfc_init_se (&count_max_se
, NULL
);
3521 gfc_conv_expr (&count_max_se
, count_max
);
3524 /* Find the smallest kind found of the arguments. */
3526 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3527 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3529 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3532 /* Prepare temporary variables. */
3537 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3538 else if (least
== 4)
3539 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3540 else if (count
->ts
.kind
== 1)
3541 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3544 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3551 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3552 else if (least
== 4)
3553 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3555 arg2
= integer_zero_node
;
3561 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3562 else if (least
== 4)
3563 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3565 arg3
= integer_zero_node
;
3568 /* Make the function call. */
3569 gfc_init_block (&block
);
3575 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3576 : null_pointer_node
;
3577 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3578 : null_pointer_node
;
3579 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3580 : null_pointer_node
;
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
;
3597 tmp
= build_call_expr_loc (input_location
,
3598 gfor_fndecl_system_clock4
, 3,
3599 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3600 : null_pointer_node
,
3601 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3602 : null_pointer_node
,
3603 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3604 : null_pointer_node
);
3605 gfc_add_expr_to_block (&block
, tmp
);
3607 /* Handle kind>=8, 10, or 16 arguments */
3610 tmp
= build_call_expr_loc (input_location
,
3611 gfor_fndecl_system_clock8
, 3,
3612 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3613 : null_pointer_node
,
3614 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3615 : null_pointer_node
,
3616 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3617 : null_pointer_node
);
3618 gfc_add_expr_to_block (&block
, tmp
);
3622 /* And store values back if needed. */
3623 if (arg1
&& arg1
!= count_se
.expr
)
3624 gfc_add_modify (&block
, count_se
.expr
,
3625 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
3626 if (arg2
&& arg2
!= count_rate_se
.expr
)
3627 gfc_add_modify (&block
, count_rate_se
.expr
,
3628 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
3629 if (arg3
&& arg3
!= count_max_se
.expr
)
3630 gfc_add_modify (&block
, count_max_se
.expr
,
3631 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
3633 return gfc_finish_block (&block
);
3637 /* Return a character string containing the tty name. */
3640 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
3648 unsigned int num_args
;
3650 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3651 args
= XALLOCAVEC (tree
, num_args
);
3653 var
= gfc_create_var (pchar_type_node
, "pstr");
3654 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3656 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3657 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3658 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3660 fndecl
= build_addr (gfor_fndecl_ttynam
);
3661 tmp
= build_call_array_loc (input_location
,
3662 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
3663 fndecl
, num_args
, args
);
3664 gfc_add_expr_to_block (&se
->pre
, tmp
);
3666 /* Free the temporary afterwards, if necessary. */
3667 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3668 len
, build_int_cst (TREE_TYPE (len
), 0));
3669 tmp
= gfc_call_free (var
);
3670 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3671 gfc_add_expr_to_block (&se
->post
, tmp
);
3674 se
->string_length
= len
;
3678 /* Get the minimum/maximum value of all the parameters.
3679 minmax (a1, a2, a3, ...)
3682 if (a2 .op. mvar || isnan (mvar))
3684 if (a3 .op. mvar || isnan (mvar))
3691 /* TODO: Mismatching types can occur when specific names are used.
3692 These should be handled during resolution. */
3694 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3702 gfc_actual_arglist
*argexpr
;
3703 unsigned int i
, nargs
;
3705 nargs
= gfc_intrinsic_argument_list_length (expr
);
3706 args
= XALLOCAVEC (tree
, nargs
);
3708 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
3709 type
= gfc_typenode_for_spec (&expr
->ts
);
3711 argexpr
= expr
->value
.function
.actual
;
3712 if (TREE_TYPE (args
[0]) != type
)
3713 args
[0] = convert (type
, args
[0]);
3714 /* Only evaluate the argument once. */
3715 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
3716 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3718 mvar
= gfc_create_var (type
, "M");
3719 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
3720 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
3726 /* Handle absent optional arguments by ignoring the comparison. */
3727 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
3728 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
3729 && TREE_CODE (val
) == INDIRECT_REF
)
3730 cond
= fold_build2_loc (input_location
,
3731 NE_EXPR
, logical_type_node
,
3732 TREE_OPERAND (val
, 0),
3733 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
3738 /* Only evaluate the argument once. */
3739 if (!VAR_P (val
) && !TREE_CONSTANT (val
))
3740 val
= gfc_evaluate_now (val
, &se
->pre
);
3743 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
3745 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
3746 convert (type
, val
), mvar
);
3748 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3749 __builtin_isnan might be made dependent on that module being loaded,
3750 to help performance of programs that don't rely on IEEE semantics. */
3751 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
3753 isnan
= build_call_expr_loc (input_location
,
3754 builtin_decl_explicit (BUILT_IN_ISNAN
),
3756 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3757 logical_type_node
, tmp
,
3758 fold_convert (logical_type_node
, isnan
));
3760 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
3761 build_empty_stmt (input_location
));
3763 if (cond
!= NULL_TREE
)
3764 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
3765 build_empty_stmt (input_location
));
3767 gfc_add_expr_to_block (&se
->pre
, tmp
);
3768 argexpr
= argexpr
->next
;
3774 /* Generate library calls for MIN and MAX intrinsics for character
3777 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
3780 tree var
, len
, fndecl
, tmp
, cond
, function
;
3783 nargs
= gfc_intrinsic_argument_list_length (expr
);
3784 args
= XALLOCAVEC (tree
, nargs
+ 4);
3785 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
3787 /* Create the result variables. */
3788 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3789 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3790 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3791 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3792 args
[2] = build_int_cst (integer_type_node
, op
);
3793 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3795 if (expr
->ts
.kind
== 1)
3796 function
= gfor_fndecl_string_minmax
;
3797 else if (expr
->ts
.kind
== 4)
3798 function
= gfor_fndecl_string_minmax_char4
;
3802 /* Make the function call. */
3803 fndecl
= build_addr (function
);
3804 tmp
= build_call_array_loc (input_location
,
3805 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3807 gfc_add_expr_to_block (&se
->pre
, tmp
);
3809 /* Free the temporary afterwards, if necessary. */
3810 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3811 len
, build_int_cst (TREE_TYPE (len
), 0));
3812 tmp
= gfc_call_free (var
);
3813 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3814 gfc_add_expr_to_block (&se
->post
, tmp
);
3817 se
->string_length
= len
;
3821 /* Create a symbol node for this intrinsic. The symbol from the frontend
3822 has the generic name. */
3825 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3829 /* TODO: Add symbols for intrinsic function to the global namespace. */
3830 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3831 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3834 sym
->attr
.external
= 1;
3835 sym
->attr
.function
= 1;
3836 sym
->attr
.always_explicit
= 1;
3837 sym
->attr
.proc
= PROC_INTRINSIC
;
3838 sym
->attr
.flavor
= FL_PROCEDURE
;
3842 sym
->attr
.dimension
= 1;
3843 sym
->as
= gfc_get_array_spec ();
3844 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3845 sym
->as
->rank
= expr
->rank
;
3848 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3849 ignore_optional
? expr
->value
.function
.actual
3855 /* Generate a call to an external intrinsic function. */
3857 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3860 vec
<tree
, va_gc
> *append_args
;
3862 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3865 gcc_assert (expr
->rank
> 0);
3867 gcc_assert (expr
->rank
== 0);
3869 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3871 /* Calls to libgfortran_matmul need to be appended special arguments,
3872 to be able to call the BLAS ?gemm functions if required and possible. */
3874 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3875 && sym
->ts
.type
!= BT_LOGICAL
)
3877 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3879 if (flag_external_blas
3880 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3881 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3885 if (sym
->ts
.type
== BT_REAL
)
3887 if (sym
->ts
.kind
== 4)
3888 gemm_fndecl
= gfor_fndecl_sgemm
;
3890 gemm_fndecl
= gfor_fndecl_dgemm
;
3894 if (sym
->ts
.kind
== 4)
3895 gemm_fndecl
= gfor_fndecl_cgemm
;
3897 gemm_fndecl
= gfor_fndecl_zgemm
;
3900 vec_alloc (append_args
, 3);
3901 append_args
->quick_push (build_int_cst (cint
, 1));
3902 append_args
->quick_push (build_int_cst (cint
,
3903 flag_blas_matmul_limit
));
3904 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3909 vec_alloc (append_args
, 3);
3910 append_args
->quick_push (build_int_cst (cint
, 0));
3911 append_args
->quick_push (build_int_cst (cint
, 0));
3912 append_args
->quick_push (null_pointer_node
);
3916 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3918 gfc_free_symbol (sym
);
3921 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3941 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3950 gfc_actual_arglist
*actual
;
3957 gfc_conv_intrinsic_funcall (se
, expr
);
3961 actual
= expr
->value
.function
.actual
;
3962 type
= gfc_typenode_for_spec (&expr
->ts
);
3963 /* Initialize the result. */
3964 resvar
= gfc_create_var (type
, "test");
3966 tmp
= convert (type
, boolean_true_node
);
3968 tmp
= convert (type
, boolean_false_node
);
3969 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3971 /* Walk the arguments. */
3972 arrayss
= gfc_walk_expr (actual
->expr
);
3973 gcc_assert (arrayss
!= gfc_ss_terminator
);
3975 /* Initialize the scalarizer. */
3976 gfc_init_loopinfo (&loop
);
3977 exit_label
= gfc_build_label_decl (NULL_TREE
);
3978 TREE_USED (exit_label
) = 1;
3979 gfc_add_ss_to_loop (&loop
, arrayss
);
3981 /* Initialize the loop. */
3982 gfc_conv_ss_startstride (&loop
);
3983 gfc_conv_loop_setup (&loop
, &expr
->where
);
3985 gfc_mark_ss_chain_used (arrayss
, 1);
3986 /* Generate the loop body. */
3987 gfc_start_scalarized_body (&loop
, &body
);
3989 /* If the condition matches then set the return value. */
3990 gfc_start_block (&block
);
3992 tmp
= convert (type
, boolean_false_node
);
3994 tmp
= convert (type
, boolean_true_node
);
3995 gfc_add_modify (&block
, resvar
, tmp
);
3997 /* And break out of the loop. */
3998 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3999 gfc_add_expr_to_block (&block
, tmp
);
4001 found
= gfc_finish_block (&block
);
4003 /* Check this element. */
4004 gfc_init_se (&arrayse
, NULL
);
4005 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4006 arrayse
.ss
= arrayss
;
4007 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4009 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4010 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
, arrayse
.expr
,
4011 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
4012 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
4013 gfc_add_expr_to_block (&body
, tmp
);
4014 gfc_add_block_to_block (&body
, &arrayse
.post
);
4016 gfc_trans_scalarizing_loops (&loop
, &body
);
4018 /* Add the exit label. */
4019 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4020 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4022 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4023 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4024 gfc_cleanup_loop (&loop
);
4029 /* COUNT(A) = Number of true elements in A. */
4031 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4038 gfc_actual_arglist
*actual
;
4044 gfc_conv_intrinsic_funcall (se
, expr
);
4048 actual
= expr
->value
.function
.actual
;
4050 type
= gfc_typenode_for_spec (&expr
->ts
);
4051 /* Initialize the result. */
4052 resvar
= gfc_create_var (type
, "count");
4053 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4055 /* Walk the arguments. */
4056 arrayss
= gfc_walk_expr (actual
->expr
);
4057 gcc_assert (arrayss
!= gfc_ss_terminator
);
4059 /* Initialize the scalarizer. */
4060 gfc_init_loopinfo (&loop
);
4061 gfc_add_ss_to_loop (&loop
, arrayss
);
4063 /* Initialize the loop. */
4064 gfc_conv_ss_startstride (&loop
);
4065 gfc_conv_loop_setup (&loop
, &expr
->where
);
4067 gfc_mark_ss_chain_used (arrayss
, 1);
4068 /* Generate the loop body. */
4069 gfc_start_scalarized_body (&loop
, &body
);
4071 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4072 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4073 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4075 gfc_init_se (&arrayse
, NULL
);
4076 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4077 arrayse
.ss
= arrayss
;
4078 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4079 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4080 build_empty_stmt (input_location
));
4082 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4083 gfc_add_expr_to_block (&body
, tmp
);
4084 gfc_add_block_to_block (&body
, &arrayse
.post
);
4086 gfc_trans_scalarizing_loops (&loop
, &body
);
4088 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4089 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4090 gfc_cleanup_loop (&loop
);
4096 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4097 struct and return the corresponding loopinfo. */
4099 static gfc_loopinfo
*
4100 enter_nested_loop (gfc_se
*se
)
4102 se
->ss
= se
->ss
->nested_ss
;
4103 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4105 return se
->ss
->loop
;
4109 /* Inline implementation of the sum and product intrinsics. */
4111 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4115 tree scale
= NULL_TREE
;
4120 gfc_loopinfo loop
, *ploop
;
4121 gfc_actual_arglist
*arg_array
, *arg_mask
;
4122 gfc_ss
*arrayss
= NULL
;
4123 gfc_ss
*maskss
= NULL
;
4127 gfc_expr
*arrayexpr
;
4132 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4138 type
= gfc_typenode_for_spec (&expr
->ts
);
4139 /* Initialize the result. */
4140 resvar
= gfc_create_var (type
, "val");
4145 scale
= gfc_create_var (type
, "scale");
4146 gfc_add_modify (&se
->pre
, scale
,
4147 gfc_build_const (type
, integer_one_node
));
4148 tmp
= gfc_build_const (type
, integer_zero_node
);
4150 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4151 tmp
= gfc_build_const (type
, integer_zero_node
);
4152 else if (op
== NE_EXPR
)
4154 tmp
= convert (type
, boolean_false_node
);
4155 else if (op
== BIT_AND_EXPR
)
4156 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4157 type
, integer_one_node
));
4159 tmp
= gfc_build_const (type
, integer_one_node
);
4161 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4163 arg_array
= expr
->value
.function
.actual
;
4165 arrayexpr
= arg_array
->expr
;
4167 if (op
== NE_EXPR
|| norm2
)
4168 /* PARITY and NORM2. */
4172 arg_mask
= arg_array
->next
->next
;
4173 gcc_assert (arg_mask
!= NULL
);
4174 maskexpr
= arg_mask
->expr
;
4177 if (expr
->rank
== 0)
4179 /* Walk the arguments. */
4180 arrayss
= gfc_walk_expr (arrayexpr
);
4181 gcc_assert (arrayss
!= gfc_ss_terminator
);
4183 if (maskexpr
&& maskexpr
->rank
> 0)
4185 maskss
= gfc_walk_expr (maskexpr
);
4186 gcc_assert (maskss
!= gfc_ss_terminator
);
4191 /* Initialize the scalarizer. */
4192 gfc_init_loopinfo (&loop
);
4193 gfc_add_ss_to_loop (&loop
, arrayss
);
4194 if (maskexpr
&& maskexpr
->rank
> 0)
4195 gfc_add_ss_to_loop (&loop
, maskss
);
4197 /* Initialize the loop. */
4198 gfc_conv_ss_startstride (&loop
);
4199 gfc_conv_loop_setup (&loop
, &expr
->where
);
4201 gfc_mark_ss_chain_used (arrayss
, 1);
4202 if (maskexpr
&& maskexpr
->rank
> 0)
4203 gfc_mark_ss_chain_used (maskss
, 1);
4208 /* All the work has been done in the parent loops. */
4209 ploop
= enter_nested_loop (se
);
4213 /* Generate the loop body. */
4214 gfc_start_scalarized_body (ploop
, &body
);
4216 /* If we have a mask, only add this element if the mask is set. */
4217 if (maskexpr
&& maskexpr
->rank
> 0)
4219 gfc_init_se (&maskse
, parent_se
);
4220 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4221 if (expr
->rank
== 0)
4223 gfc_conv_expr_val (&maskse
, maskexpr
);
4224 gfc_add_block_to_block (&body
, &maskse
.pre
);
4226 gfc_start_block (&block
);
4229 gfc_init_block (&block
);
4231 /* Do the actual summation/product. */
4232 gfc_init_se (&arrayse
, parent_se
);
4233 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4234 if (expr
->rank
== 0)
4235 arrayse
.ss
= arrayss
;
4236 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4237 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4241 /* if (x (i) != 0.0)
4247 result = 1.0 + result * val * val;
4253 result += val * val;
4256 tree res1
, res2
, cond
, absX
, val
;
4257 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4259 gfc_init_block (&ifblock1
);
4261 absX
= gfc_create_var (type
, "absX");
4262 gfc_add_modify (&ifblock1
, absX
,
4263 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4265 val
= gfc_create_var (type
, "val");
4266 gfc_add_expr_to_block (&ifblock1
, val
);
4268 gfc_init_block (&ifblock2
);
4269 gfc_add_modify (&ifblock2
, val
,
4270 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4272 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4273 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4274 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4275 gfc_build_const (type
, integer_one_node
));
4276 gfc_add_modify (&ifblock2
, resvar
, res1
);
4277 gfc_add_modify (&ifblock2
, scale
, absX
);
4278 res1
= gfc_finish_block (&ifblock2
);
4280 gfc_init_block (&ifblock3
);
4281 gfc_add_modify (&ifblock3
, val
,
4282 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4284 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4285 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4286 gfc_add_modify (&ifblock3
, resvar
, res2
);
4287 res2
= gfc_finish_block (&ifblock3
);
4289 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4291 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4292 gfc_add_expr_to_block (&ifblock1
, tmp
);
4293 tmp
= gfc_finish_block (&ifblock1
);
4295 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
4297 gfc_build_const (type
, integer_zero_node
));
4299 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4300 gfc_add_expr_to_block (&block
, tmp
);
4304 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4305 gfc_add_modify (&block
, resvar
, tmp
);
4308 gfc_add_block_to_block (&block
, &arrayse
.post
);
4310 if (maskexpr
&& maskexpr
->rank
> 0)
4312 /* We enclose the above in if (mask) {...} . */
4314 tmp
= gfc_finish_block (&block
);
4315 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4316 build_empty_stmt (input_location
));
4319 tmp
= gfc_finish_block (&block
);
4320 gfc_add_expr_to_block (&body
, tmp
);
4322 gfc_trans_scalarizing_loops (ploop
, &body
);
4324 /* For a scalar mask, enclose the loop in an if statement. */
4325 if (maskexpr
&& maskexpr
->rank
== 0)
4327 gfc_init_block (&block
);
4328 gfc_add_block_to_block (&block
, &ploop
->pre
);
4329 gfc_add_block_to_block (&block
, &ploop
->post
);
4330 tmp
= gfc_finish_block (&block
);
4334 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4335 build_empty_stmt (input_location
));
4336 gfc_advance_se_ss_chain (se
);
4340 gcc_assert (expr
->rank
== 0);
4341 gfc_init_se (&maskse
, NULL
);
4342 gfc_conv_expr_val (&maskse
, maskexpr
);
4343 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4344 build_empty_stmt (input_location
));
4347 gfc_add_expr_to_block (&block
, tmp
);
4348 gfc_add_block_to_block (&se
->pre
, &block
);
4349 gcc_assert (se
->post
.head
== NULL
);
4353 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4354 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4357 if (expr
->rank
== 0)
4358 gfc_cleanup_loop (ploop
);
4362 /* result = scale * sqrt(result). */
4364 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4365 resvar
= build_call_expr_loc (input_location
,
4367 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4374 /* Inline implementation of the dot_product intrinsic. This function
4375 is based on gfc_conv_intrinsic_arith (the previous function). */
4377 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4385 gfc_actual_arglist
*actual
;
4386 gfc_ss
*arrayss1
, *arrayss2
;
4387 gfc_se arrayse1
, arrayse2
;
4388 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4390 type
= gfc_typenode_for_spec (&expr
->ts
);
4392 /* Initialize the result. */
4393 resvar
= gfc_create_var (type
, "val");
4394 if (expr
->ts
.type
== BT_LOGICAL
)
4395 tmp
= build_int_cst (type
, 0);
4397 tmp
= gfc_build_const (type
, integer_zero_node
);
4399 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4401 /* Walk argument #1. */
4402 actual
= expr
->value
.function
.actual
;
4403 arrayexpr1
= actual
->expr
;
4404 arrayss1
= gfc_walk_expr (arrayexpr1
);
4405 gcc_assert (arrayss1
!= gfc_ss_terminator
);
4407 /* Walk argument #2. */
4408 actual
= actual
->next
;
4409 arrayexpr2
= actual
->expr
;
4410 arrayss2
= gfc_walk_expr (arrayexpr2
);
4411 gcc_assert (arrayss2
!= gfc_ss_terminator
);
4413 /* Initialize the scalarizer. */
4414 gfc_init_loopinfo (&loop
);
4415 gfc_add_ss_to_loop (&loop
, arrayss1
);
4416 gfc_add_ss_to_loop (&loop
, arrayss2
);
4418 /* Initialize the loop. */
4419 gfc_conv_ss_startstride (&loop
);
4420 gfc_conv_loop_setup (&loop
, &expr
->where
);
4422 gfc_mark_ss_chain_used (arrayss1
, 1);
4423 gfc_mark_ss_chain_used (arrayss2
, 1);
4425 /* Generate the loop body. */
4426 gfc_start_scalarized_body (&loop
, &body
);
4427 gfc_init_block (&block
);
4429 /* Make the tree expression for [conjg(]array1[)]. */
4430 gfc_init_se (&arrayse1
, NULL
);
4431 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
4432 arrayse1
.ss
= arrayss1
;
4433 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
4434 if (expr
->ts
.type
== BT_COMPLEX
)
4435 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
4437 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
4439 /* Make the tree expression for array2. */
4440 gfc_init_se (&arrayse2
, NULL
);
4441 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
4442 arrayse2
.ss
= arrayss2
;
4443 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
4444 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
4446 /* Do the actual product and sum. */
4447 if (expr
->ts
.type
== BT_LOGICAL
)
4449 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
4450 arrayse1
.expr
, arrayse2
.expr
);
4451 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
4455 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
4457 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
4459 gfc_add_modify (&block
, resvar
, tmp
);
4461 /* Finish up the loop block and the loop. */
4462 tmp
= gfc_finish_block (&block
);
4463 gfc_add_expr_to_block (&body
, tmp
);
4465 gfc_trans_scalarizing_loops (&loop
, &body
);
4466 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4467 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4468 gfc_cleanup_loop (&loop
);
4474 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4475 we need to handle. For performance reasons we sometimes create two
4476 loops instead of one, where the second one is much simpler.
4477 Examples for minloc intrinsic:
4478 1) Result is an array, a call is generated
4479 2) Array mask is used and NaNs need to be supported:
4485 if (pos == 0) pos = S + (1 - from);
4486 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4493 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4497 3) NaNs need to be supported, but it is known at compile time or cheaply
4498 at runtime whether array is nonempty or not:
4503 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4506 if (from <= to) pos = 1;
4510 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4514 4) NaNs aren't supported, array mask is used:
4515 limit = infinities_supported ? Infinity : huge (limit);
4519 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4525 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4529 5) Same without array mask:
4530 limit = infinities_supported ? Infinity : huge (limit);
4531 pos = (from <= to) ? 1 : 0;
4534 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4537 For 3) and 5), if mask is scalar, this all goes into a conditional,
4538 setting pos = 0; in the else branch. */
4541 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4545 stmtblock_t ifblock
;
4546 stmtblock_t elseblock
;
4557 gfc_actual_arglist
*actual
;
4562 gfc_expr
*arrayexpr
;
4567 actual
= expr
->value
.function
.actual
;
4569 /* The last argument, BACK, is passed by value. Ensure that
4570 by setting its name to %VAL. */
4571 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
4573 if (a
->next
== NULL
)
4579 gfc_conv_intrinsic_funcall (se
, expr
);
4583 arrayexpr
= actual
->expr
;
4585 /* Special case for character maxloc. Remove unneeded actual
4586 arguments, then call a library function. */
4588 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
4590 gfc_actual_arglist
*a
, *b
;
4595 if (b
->expr
== NULL
|| strcmp (b
->name
, "dim") == 0)
4599 gfc_free_actual_arglist (b
);
4604 gfc_conv_intrinsic_funcall (se
, expr
);
4608 /* Initialize the result. */
4609 pos
= gfc_create_var (gfc_array_index_type
, "pos");
4610 offset
= gfc_create_var (gfc_array_index_type
, "offset");
4611 type
= gfc_typenode_for_spec (&expr
->ts
);
4613 /* Walk the arguments. */
4614 arrayss
= gfc_walk_expr (arrayexpr
);
4615 gcc_assert (arrayss
!= gfc_ss_terminator
);
4617 actual
= actual
->next
->next
;
4618 gcc_assert (actual
);
4619 maskexpr
= actual
->expr
;
4621 if (maskexpr
&& maskexpr
->rank
!= 0)
4623 maskss
= gfc_walk_expr (maskexpr
);
4624 gcc_assert (maskss
!= gfc_ss_terminator
);
4629 if (gfc_array_size (arrayexpr
, &asize
))
4631 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4633 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4634 logical_type_node
, nonempty
,
4635 gfc_index_zero_node
);
4640 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
4641 switch (arrayexpr
->ts
.type
)
4644 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
4648 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
4649 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
4650 arrayexpr
->ts
.kind
);
4657 /* We start with the most negative possible value for MAXLOC, and the most
4658 positive possible value for MINLOC. The most negative possible value is
4659 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4660 possible value is HUGE in both cases. */
4662 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4663 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
4664 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
4665 build_int_cst (TREE_TYPE (tmp
), 1));
4667 gfc_add_modify (&se
->pre
, limit
, tmp
);
4669 /* Initialize the scalarizer. */
4670 gfc_init_loopinfo (&loop
);
4671 gfc_add_ss_to_loop (&loop
, arrayss
);
4673 gfc_add_ss_to_loop (&loop
, maskss
);
4675 /* Initialize the loop. */
4676 gfc_conv_ss_startstride (&loop
);
4678 /* The code generated can have more than one loop in sequence (see the
4679 comment at the function header). This doesn't work well with the
4680 scalarizer, which changes arrays' offset when the scalarization loops
4681 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4682 are currently inlined in the scalar case only (for which loop is of rank
4683 one). As there is no dependency to care about in that case, there is no
4684 temporary, so that we can use the scalarizer temporary code to handle
4685 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4686 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4688 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4689 should eventually go away. We could either create two loops properly,
4690 or find another way to save/restore the array offsets between the two
4691 loops (without conflicting with temporary management), or use a single
4692 loop minmaxloc implementation. See PR 31067. */
4693 loop
.temp_dim
= loop
.dimen
;
4694 gfc_conv_loop_setup (&loop
, &expr
->where
);
4696 gcc_assert (loop
.dimen
== 1);
4697 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
4698 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4699 loop
.from
[0], loop
.to
[0]);
4703 /* Initialize the position to zero, following Fortran 2003. We are free
4704 to do this because Fortran 95 allows the result of an entirely false
4705 mask to be processor dependent. If we know at compile time the array
4706 is non-empty and no MASK is used, we can initialize to 1 to simplify
4708 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
4709 gfc_add_modify (&loop
.pre
, pos
,
4710 fold_build3_loc (input_location
, COND_EXPR
,
4711 gfc_array_index_type
,
4712 nonempty
, gfc_index_one_node
,
4713 gfc_index_zero_node
));
4716 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
4717 lab1
= gfc_build_label_decl (NULL_TREE
);
4718 TREE_USED (lab1
) = 1;
4719 lab2
= gfc_build_label_decl (NULL_TREE
);
4720 TREE_USED (lab2
) = 1;
4723 /* An offset must be added to the loop
4724 counter to obtain the required position. */
4725 gcc_assert (loop
.from
[0]);
4727 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4728 gfc_index_one_node
, loop
.from
[0]);
4729 gfc_add_modify (&loop
.pre
, offset
, tmp
);
4731 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
4733 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
4734 /* Generate the loop body. */
4735 gfc_start_scalarized_body (&loop
, &body
);
4737 /* If we have a mask, only check this element if the mask is set. */
4740 gfc_init_se (&maskse
, NULL
);
4741 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4743 gfc_conv_expr_val (&maskse
, maskexpr
);
4744 gfc_add_block_to_block (&body
, &maskse
.pre
);
4746 gfc_start_block (&block
);
4749 gfc_init_block (&block
);
4751 /* Compare with the current limit. */
4752 gfc_init_se (&arrayse
, NULL
);
4753 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4754 arrayse
.ss
= arrayss
;
4755 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4756 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4758 /* We do the following if this is a more extreme value. */
4759 gfc_start_block (&ifblock
);
4761 /* Assign the value to the limit... */
4762 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4764 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
4766 stmtblock_t ifblock2
;
4769 gfc_start_block (&ifblock2
);
4770 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4771 loop
.loopvar
[0], offset
);
4772 gfc_add_modify (&ifblock2
, pos
, tmp
);
4773 ifbody2
= gfc_finish_block (&ifblock2
);
4774 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pos
,
4775 gfc_index_zero_node
);
4776 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
4777 build_empty_stmt (input_location
));
4778 gfc_add_expr_to_block (&block
, tmp
);
4781 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4782 loop
.loopvar
[0], offset
);
4783 gfc_add_modify (&ifblock
, pos
, tmp
);
4786 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
4788 ifbody
= gfc_finish_block (&ifblock
);
4790 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
4793 cond
= fold_build2_loc (input_location
,
4794 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4795 logical_type_node
, arrayse
.expr
, limit
);
4797 cond
= fold_build2_loc (input_location
, op
, logical_type_node
,
4798 arrayse
.expr
, limit
);
4800 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
4801 build_empty_stmt (input_location
));
4803 gfc_add_expr_to_block (&block
, ifbody
);
4807 /* We enclose the above in if (mask) {...}. */
4808 tmp
= gfc_finish_block (&block
);
4810 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4811 build_empty_stmt (input_location
));
4814 tmp
= gfc_finish_block (&block
);
4815 gfc_add_expr_to_block (&body
, tmp
);
4819 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4821 if (HONOR_NANS (DECL_MODE (limit
)))
4823 if (nonempty
!= NULL
)
4825 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
4826 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
4827 build_empty_stmt (input_location
));
4828 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
4832 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
4833 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
4835 /* If we have a mask, only check this element if the mask is set. */
4838 gfc_init_se (&maskse
, NULL
);
4839 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4841 gfc_conv_expr_val (&maskse
, maskexpr
);
4842 gfc_add_block_to_block (&body
, &maskse
.pre
);
4844 gfc_start_block (&block
);
4847 gfc_init_block (&block
);
4849 /* Compare with the current limit. */
4850 gfc_init_se (&arrayse
, NULL
);
4851 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4852 arrayse
.ss
= arrayss
;
4853 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4854 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4856 /* We do the following if this is a more extreme value. */
4857 gfc_start_block (&ifblock
);
4859 /* Assign the value to the limit... */
4860 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4862 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4863 loop
.loopvar
[0], offset
);
4864 gfc_add_modify (&ifblock
, pos
, tmp
);
4866 ifbody
= gfc_finish_block (&ifblock
);
4868 cond
= fold_build2_loc (input_location
, op
, logical_type_node
,
4869 arrayse
.expr
, limit
);
4871 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4872 build_empty_stmt (input_location
));
4873 gfc_add_expr_to_block (&block
, tmp
);
4877 /* We enclose the above in if (mask) {...}. */
4878 tmp
= gfc_finish_block (&block
);
4880 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4881 build_empty_stmt (input_location
));
4884 tmp
= gfc_finish_block (&block
);
4885 gfc_add_expr_to_block (&body
, tmp
);
4886 /* Avoid initializing loopvar[0] again, it should be left where
4887 it finished by the first loop. */
4888 loop
.from
[0] = loop
.loopvar
[0];
4891 gfc_trans_scalarizing_loops (&loop
, &body
);
4894 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4896 /* For a scalar mask, enclose the loop in an if statement. */
4897 if (maskexpr
&& maskss
== NULL
)
4899 gfc_init_se (&maskse
, NULL
);
4900 gfc_conv_expr_val (&maskse
, maskexpr
);
4901 gfc_init_block (&block
);
4902 gfc_add_block_to_block (&block
, &loop
.pre
);
4903 gfc_add_block_to_block (&block
, &loop
.post
);
4904 tmp
= gfc_finish_block (&block
);
4906 /* For the else part of the scalar mask, just initialize
4907 the pos variable the same way as above. */
4909 gfc_init_block (&elseblock
);
4910 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4911 elsetmp
= gfc_finish_block (&elseblock
);
4913 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4914 gfc_add_expr_to_block (&block
, tmp
);
4915 gfc_add_block_to_block (&se
->pre
, &block
);
4919 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4920 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4922 gfc_cleanup_loop (&loop
);
4924 se
->expr
= convert (type
, pos
);
4927 /* Emit code for minval or maxval intrinsic. There are many different cases
4928 we need to handle. For performance reasons we sometimes create two
4929 loops instead of one, where the second one is much simpler.
4930 Examples for minval intrinsic:
4931 1) Result is an array, a call is generated
4932 2) Array mask is used and NaNs need to be supported, rank 1:
4937 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4940 limit = nonempty ? NaN : huge (limit);
4942 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4943 3) NaNs need to be supported, but it is known at compile time or cheaply
4944 at runtime whether array is nonempty or not, rank 1:
4947 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4948 limit = (from <= to) ? NaN : huge (limit);
4950 while (S <= to) { limit = min (a[S], limit); S++; }
4951 4) Array mask is used and NaNs need to be supported, rank > 1:
4960 if (fast) limit = min (a[S1][S2], limit);
4963 if (a[S1][S2] <= limit) {
4974 limit = nonempty ? NaN : huge (limit);
4975 5) NaNs need to be supported, but it is known at compile time or cheaply
4976 at runtime whether array is nonempty or not, rank > 1:
4983 if (fast) limit = min (a[S1][S2], limit);
4985 if (a[S1][S2] <= limit) {
4995 limit = (nonempty_array) ? NaN : huge (limit);
4996 6) NaNs aren't supported, but infinities are. Array mask is used:
5001 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
5004 limit = nonempty ? limit : huge (limit);
5005 7) Same without array mask:
5008 while (S <= to) { limit = min (a[S], limit); S++; }
5009 limit = (from <= to) ? limit : huge (limit);
5010 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
5011 limit = huge (limit);
5013 while (S <= to) { limit = min (a[S], limit); S++); }
5015 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
5016 with array mask instead).
5017 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
5018 setting limit = huge (limit); in the else branch. */
5021 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5031 tree huge_cst
= NULL
, nan_cst
= NULL
;
5033 stmtblock_t block
, block2
;
5035 gfc_actual_arglist
*actual
;
5040 gfc_expr
*arrayexpr
;
5046 gfc_conv_intrinsic_funcall (se
, expr
);
5050 actual
= expr
->value
.function
.actual
;
5051 arrayexpr
= actual
->expr
;
5053 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5055 gfc_actual_arglist
*a2
, *a3
;
5056 a2
= actual
->next
; /* dim */
5057 a3
= a2
->next
; /* mask */
5058 if (a2
->expr
== NULL
|| expr
->rank
== 0)
5060 if (a3
->expr
== NULL
)
5061 actual
->next
= NULL
;
5067 gfc_free_actual_arglist (a2
);
5070 if (a3
->expr
== NULL
)
5073 gfc_free_actual_arglist (a3
);
5075 gfc_conv_intrinsic_funcall (se
, expr
);
5078 type
= gfc_typenode_for_spec (&expr
->ts
);
5079 /* Initialize the result. */
5080 limit
= gfc_create_var (type
, "limit");
5081 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
5082 switch (expr
->ts
.type
)
5085 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
5087 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5089 REAL_VALUE_TYPE real
;
5091 tmp
= build_real (type
, real
);
5095 if (HONOR_NANS (DECL_MODE (limit
)))
5096 nan_cst
= gfc_build_nan (type
, "");
5100 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
5107 /* We start with the most negative possible value for MAXVAL, and the most
5108 positive possible value for MINVAL. The most negative possible value is
5109 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5110 possible value is HUGE in both cases. */
5113 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5115 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
5116 TREE_TYPE (huge_cst
), huge_cst
);
5119 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
5120 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5121 tmp
, build_int_cst (type
, 1));
5123 gfc_add_modify (&se
->pre
, limit
, tmp
);
5125 /* Walk the arguments. */
5126 arrayss
= gfc_walk_expr (arrayexpr
);
5127 gcc_assert (arrayss
!= gfc_ss_terminator
);
5129 actual
= actual
->next
->next
;
5130 gcc_assert (actual
);
5131 maskexpr
= actual
->expr
;
5133 if (maskexpr
&& maskexpr
->rank
!= 0)
5135 maskss
= gfc_walk_expr (maskexpr
);
5136 gcc_assert (maskss
!= gfc_ss_terminator
);
5141 if (gfc_array_size (arrayexpr
, &asize
))
5143 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5145 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5146 logical_type_node
, nonempty
,
5147 gfc_index_zero_node
);
5152 /* Initialize the scalarizer. */
5153 gfc_init_loopinfo (&loop
);
5154 gfc_add_ss_to_loop (&loop
, arrayss
);
5156 gfc_add_ss_to_loop (&loop
, maskss
);
5158 /* Initialize the loop. */
5159 gfc_conv_ss_startstride (&loop
);
5161 /* The code generated can have more than one loop in sequence (see the
5162 comment at the function header). This doesn't work well with the
5163 scalarizer, which changes arrays' offset when the scalarization loops
5164 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5165 are currently inlined in the scalar case only. As there is no dependency
5166 to care about in that case, there is no temporary, so that we can use the
5167 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5168 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5169 gfc_trans_scalarized_loop_boundary even later to restore offset.
5170 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5171 should eventually go away. We could either create two loops properly,
5172 or find another way to save/restore the array offsets between the two
5173 loops (without conflicting with temporary management), or use a single
5174 loop minmaxval implementation. See PR 31067. */
5175 loop
.temp_dim
= loop
.dimen
;
5176 gfc_conv_loop_setup (&loop
, &expr
->where
);
5178 if (nonempty
== NULL
&& maskss
== NULL
5179 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5180 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5181 loop
.from
[0], loop
.to
[0]);
5182 nonempty_var
= NULL
;
5183 if (nonempty
== NULL
5184 && (HONOR_INFINITIES (DECL_MODE (limit
))
5185 || HONOR_NANS (DECL_MODE (limit
))))
5187 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
5188 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
5189 nonempty
= nonempty_var
;
5193 if (HONOR_NANS (DECL_MODE (limit
)))
5195 if (loop
.dimen
== 1)
5197 lab
= gfc_build_label_decl (NULL_TREE
);
5198 TREE_USED (lab
) = 1;
5202 fast
= gfc_create_var (logical_type_node
, "fast");
5203 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
5207 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5209 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5210 /* Generate the loop body. */
5211 gfc_start_scalarized_body (&loop
, &body
);
5213 /* If we have a mask, only add this element if the mask is set. */
5216 gfc_init_se (&maskse
, NULL
);
5217 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5219 gfc_conv_expr_val (&maskse
, maskexpr
);
5220 gfc_add_block_to_block (&body
, &maskse
.pre
);
5222 gfc_start_block (&block
);
5225 gfc_init_block (&block
);
5227 /* Compare with the current limit. */
5228 gfc_init_se (&arrayse
, NULL
);
5229 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5230 arrayse
.ss
= arrayss
;
5231 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5232 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5234 gfc_init_block (&block2
);
5237 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
5239 if (HONOR_NANS (DECL_MODE (limit
)))
5241 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5242 logical_type_node
, arrayse
.expr
, limit
);
5244 ifbody
= build1_v (GOTO_EXPR
, lab
);
5247 stmtblock_t ifblock
;
5249 gfc_init_block (&ifblock
);
5250 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5251 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
5252 ifbody
= gfc_finish_block (&ifblock
);
5254 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5255 build_empty_stmt (input_location
));
5256 gfc_add_expr_to_block (&block2
, tmp
);
5260 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5262 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5264 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5265 arrayse
.expr
, limit
);
5266 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5267 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5268 build_empty_stmt (input_location
));
5269 gfc_add_expr_to_block (&block2
, tmp
);
5273 tmp
= fold_build2_loc (input_location
,
5274 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5275 type
, arrayse
.expr
, limit
);
5276 gfc_add_modify (&block2
, limit
, tmp
);
5282 tree elsebody
= gfc_finish_block (&block2
);
5284 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5286 if (HONOR_NANS (DECL_MODE (limit
))
5287 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5289 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5290 arrayse
.expr
, limit
);
5291 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5292 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5293 build_empty_stmt (input_location
));
5297 tmp
= fold_build2_loc (input_location
,
5298 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5299 type
, arrayse
.expr
, limit
);
5300 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5302 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5303 gfc_add_expr_to_block (&block
, tmp
);
5306 gfc_add_block_to_block (&block
, &block2
);
5308 gfc_add_block_to_block (&block
, &arrayse
.post
);
5310 tmp
= gfc_finish_block (&block
);
5312 /* We enclose the above in if (mask) {...}. */
5313 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5314 build_empty_stmt (input_location
));
5315 gfc_add_expr_to_block (&body
, tmp
);
5319 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5321 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5323 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
5324 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
5326 /* If we have a mask, only add this element if the mask is set. */
5329 gfc_init_se (&maskse
, NULL
);
5330 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5332 gfc_conv_expr_val (&maskse
, maskexpr
);
5333 gfc_add_block_to_block (&body
, &maskse
.pre
);
5335 gfc_start_block (&block
);
5338 gfc_init_block (&block
);
5340 /* Compare with the current limit. */
5341 gfc_init_se (&arrayse
, NULL
);
5342 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5343 arrayse
.ss
= arrayss
;
5344 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5345 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5347 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5349 if (HONOR_NANS (DECL_MODE (limit
))
5350 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5352 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5353 arrayse
.expr
, limit
);
5354 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5355 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5356 build_empty_stmt (input_location
));
5357 gfc_add_expr_to_block (&block
, tmp
);
5361 tmp
= fold_build2_loc (input_location
,
5362 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5363 type
, arrayse
.expr
, limit
);
5364 gfc_add_modify (&block
, limit
, tmp
);
5367 gfc_add_block_to_block (&block
, &arrayse
.post
);
5369 tmp
= gfc_finish_block (&block
);
5371 /* We enclose the above in if (mask) {...}. */
5372 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5373 build_empty_stmt (input_location
));
5374 gfc_add_expr_to_block (&body
, tmp
);
5375 /* Avoid initializing loopvar[0] again, it should be left where
5376 it finished by the first loop. */
5377 loop
.from
[0] = loop
.loopvar
[0];
5379 gfc_trans_scalarizing_loops (&loop
, &body
);
5383 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5385 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5386 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
5388 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5390 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
5392 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
5394 gfc_add_modify (&loop
.pre
, limit
, tmp
);
5397 /* For a scalar mask, enclose the loop in an if statement. */
5398 if (maskexpr
&& maskss
== NULL
)
5402 gfc_init_se (&maskse
, NULL
);
5403 gfc_conv_expr_val (&maskse
, maskexpr
);
5404 gfc_init_block (&block
);
5405 gfc_add_block_to_block (&block
, &loop
.pre
);
5406 gfc_add_block_to_block (&block
, &loop
.post
);
5407 tmp
= gfc_finish_block (&block
);
5409 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5410 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
5412 else_stmt
= build_empty_stmt (input_location
);
5413 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
5414 gfc_add_expr_to_block (&block
, tmp
);
5415 gfc_add_block_to_block (&se
->pre
, &block
);
5419 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5420 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5423 gfc_cleanup_loop (&loop
);
5428 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5430 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
5436 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5437 type
= TREE_TYPE (args
[0]);
5439 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5440 build_int_cst (type
, 1), args
[1]);
5441 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
5442 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
5443 build_int_cst (type
, 0));
5444 type
= gfc_typenode_for_spec (&expr
->ts
);
5445 se
->expr
= convert (type
, tmp
);
5449 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5451 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5455 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5457 /* Convert both arguments to the unsigned type of the same size. */
5458 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
5459 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
5461 /* If they have unequal type size, convert to the larger one. */
5462 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
5463 > TYPE_PRECISION (TREE_TYPE (args
[1])))
5464 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
5465 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
5466 > TYPE_PRECISION (TREE_TYPE (args
[0])))
5467 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
5469 /* Now, we compare them. */
5470 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
5475 /* Generate code to perform the specified operation. */
5477 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5481 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5482 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
5488 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
5492 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5493 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5494 TREE_TYPE (arg
), arg
);
5497 /* Set or clear a single bit. */
5499 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
5506 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5507 type
= TREE_TYPE (args
[0]);
5509 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5510 build_int_cst (type
, 1), args
[1]);
5516 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
5518 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
5521 /* Extract a sequence of bits.
5522 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5524 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
5531 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5532 type
= TREE_TYPE (args
[0]);
5534 mask
= build_int_cst (type
, -1);
5535 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
5536 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
5538 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
5540 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
5544 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
5547 tree args
[2], type
, num_bits
, cond
;
5549 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5551 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5552 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5553 type
= TREE_TYPE (args
[0]);
5556 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
5558 gcc_assert (right_shift
);
5560 se
->expr
= fold_build2_loc (input_location
,
5561 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
5562 TREE_TYPE (args
[0]), args
[0], args
[1]);
5565 se
->expr
= fold_convert (type
, se
->expr
);
5567 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5568 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5570 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5571 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
5574 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5575 build_int_cst (type
, 0), se
->expr
);
5578 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5580 : ((shift >= 0) ? i << shift : i >> -shift)
5581 where all shifts are logical shifts. */
5583 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
5595 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5597 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5598 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5600 type
= TREE_TYPE (args
[0]);
5601 utype
= unsigned_type_for (type
);
5603 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
5606 /* Left shift if positive. */
5607 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
5609 /* Right shift if negative.
5610 We convert to an unsigned type because we want a logical shift.
5611 The standard doesn't define the case of shifting negative
5612 numbers, and we try to be compatible with other compilers, most
5613 notably g77, here. */
5614 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
5615 utype
, convert (utype
, args
[0]), width
));
5617 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
5618 build_int_cst (TREE_TYPE (args
[1]), 0));
5619 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
5621 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5622 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5624 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5625 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
5627 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5628 build_int_cst (type
, 0), tmp
);
5632 /* Circular shift. AKA rotate or barrel shift. */
5635 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
5643 unsigned int num_args
;
5645 num_args
= gfc_intrinsic_argument_list_length (expr
);
5646 args
= XALLOCAVEC (tree
, num_args
);
5648 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5652 /* Use a library function for the 3 parameter version. */
5653 tree int4type
= gfc_get_int_type (4);
5655 type
= TREE_TYPE (args
[0]);
5656 /* We convert the first argument to at least 4 bytes, and
5657 convert back afterwards. This removes the need for library
5658 functions for all argument sizes, and function will be
5659 aligned to at least 32 bits, so there's no loss. */
5660 if (expr
->ts
.kind
< 4)
5661 args
[0] = convert (int4type
, args
[0]);
5663 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5664 need loads of library functions. They cannot have values >
5665 BIT_SIZE (I) so the conversion is safe. */
5666 args
[1] = convert (int4type
, args
[1]);
5667 args
[2] = convert (int4type
, args
[2]);
5669 switch (expr
->ts
.kind
)
5674 tmp
= gfor_fndecl_math_ishftc4
;
5677 tmp
= gfor_fndecl_math_ishftc8
;
5680 tmp
= gfor_fndecl_math_ishftc16
;
5685 se
->expr
= build_call_expr_loc (input_location
,
5686 tmp
, 3, args
[0], args
[1], args
[2]);
5687 /* Convert the result back to the original type, if we extended
5688 the first argument's width above. */
5689 if (expr
->ts
.kind
< 4)
5690 se
->expr
= convert (type
, se
->expr
);
5694 type
= TREE_TYPE (args
[0]);
5696 /* Evaluate arguments only once. */
5697 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5698 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5700 /* Rotate left if positive. */
5701 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
5703 /* Rotate right if negative. */
5704 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
5706 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
5708 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
5709 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
5711 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
5713 /* Do nothing if shift == 0. */
5714 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
5716 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
5721 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5722 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5724 The conditional expression is necessary because the result of LEADZ(0)
5725 is defined, but the result of __builtin_clz(0) is undefined for most
5728 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5729 difference in bit size between the argument of LEADZ and the C int. */
5732 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
5744 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5745 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5747 /* Which variant of __builtin_clz* should we call? */
5748 if (argsize
<= INT_TYPE_SIZE
)
5750 arg_type
= unsigned_type_node
;
5751 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
5753 else if (argsize
<= LONG_TYPE_SIZE
)
5755 arg_type
= long_unsigned_type_node
;
5756 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
5758 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5760 arg_type
= long_long_unsigned_type_node
;
5761 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5765 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5766 arg_type
= gfc_build_uint_type (argsize
);
5770 /* Convert the actual argument twice: first, to the unsigned type of the
5771 same size; then, to the proper argument type for the built-in
5772 function. But the return type is of the default INTEGER kind. */
5773 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5774 arg
= fold_convert (arg_type
, arg
);
5775 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5776 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5778 /* Compute LEADZ for the case i .ne. 0. */
5781 s
= TYPE_PRECISION (arg_type
) - argsize
;
5782 tmp
= fold_convert (result_type
,
5783 build_call_expr_loc (input_location
, func
,
5785 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
5786 tmp
, build_int_cst (result_type
, s
));
5790 /* We end up here if the argument type is larger than 'long long'.
5791 We generate this code:
5793 if (x & (ULL_MAX << ULL_SIZE) != 0)
5794 return clzll ((unsigned long long) (x >> ULLSIZE));
5796 return ULL_SIZE + clzll ((unsigned long long) x);
5797 where ULL_MAX is the largest value that a ULL_MAX can hold
5798 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5799 is the bit-size of the long long type (64 in this example). */
5800 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5802 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5803 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5804 long_long_unsigned_type_node
,
5805 build_int_cst (long_long_unsigned_type_node
,
5808 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
5809 fold_convert (arg_type
, ullmax
), ullsize
);
5810 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
5812 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
5813 cond
, build_int_cst (arg_type
, 0));
5815 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5817 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5818 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5819 tmp1
= fold_convert (result_type
,
5820 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5822 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5823 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5824 tmp2
= fold_convert (result_type
,
5825 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5826 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5829 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5833 /* Build BIT_SIZE. */
5834 bit_size
= build_int_cst (result_type
, argsize
);
5836 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5837 arg
, build_int_cst (arg_type
, 0));
5838 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5843 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5845 The conditional expression is necessary because the result of TRAILZ(0)
5846 is defined, but the result of __builtin_ctz(0) is undefined for most
5850 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
5861 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5862 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5864 /* Which variant of __builtin_ctz* should we call? */
5865 if (argsize
<= INT_TYPE_SIZE
)
5867 arg_type
= unsigned_type_node
;
5868 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5870 else if (argsize
<= LONG_TYPE_SIZE
)
5872 arg_type
= long_unsigned_type_node
;
5873 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5875 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5877 arg_type
= long_long_unsigned_type_node
;
5878 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5882 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5883 arg_type
= gfc_build_uint_type (argsize
);
5887 /* Convert the actual argument twice: first, to the unsigned type of the
5888 same size; then, to the proper argument type for the built-in
5889 function. But the return type is of the default INTEGER kind. */
5890 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5891 arg
= fold_convert (arg_type
, arg
);
5892 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5893 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5895 /* Compute TRAILZ for the case i .ne. 0. */
5897 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5901 /* We end up here if the argument type is larger than 'long long'.
5902 We generate this code:
5904 if ((x & ULL_MAX) == 0)
5905 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5907 return ctzll ((unsigned long long) x);
5909 where ULL_MAX is the largest value that a ULL_MAX can hold
5910 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5911 is the bit-size of the long long type (64 in this example). */
5912 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5914 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5915 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5916 long_long_unsigned_type_node
,
5917 build_int_cst (long_long_unsigned_type_node
, 0));
5919 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5920 fold_convert (arg_type
, ullmax
));
5921 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
5922 build_int_cst (arg_type
, 0));
5924 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5926 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5927 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5928 tmp1
= fold_convert (result_type
,
5929 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5930 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5933 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5934 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5935 tmp2
= fold_convert (result_type
,
5936 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5938 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5942 /* Build BIT_SIZE. */
5943 bit_size
= build_int_cst (result_type
, argsize
);
5945 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5946 arg
, build_int_cst (arg_type
, 0));
5947 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5951 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5952 for types larger than "long long", we call the long long built-in for
5953 the lower and higher bits and combine the result. */
5956 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5964 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5965 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5966 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5968 /* Which variant of the builtin should we call? */
5969 if (argsize
<= INT_TYPE_SIZE
)
5971 arg_type
= unsigned_type_node
;
5972 func
= builtin_decl_explicit (parity
5974 : BUILT_IN_POPCOUNT
);
5976 else if (argsize
<= LONG_TYPE_SIZE
)
5978 arg_type
= long_unsigned_type_node
;
5979 func
= builtin_decl_explicit (parity
5981 : BUILT_IN_POPCOUNTL
);
5983 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5985 arg_type
= long_long_unsigned_type_node
;
5986 func
= builtin_decl_explicit (parity
5988 : BUILT_IN_POPCOUNTLL
);
5992 /* Our argument type is larger than 'long long', which mean none
5993 of the POPCOUNT builtins covers it. We thus call the 'long long'
5994 variant multiple times, and add the results. */
5995 tree utype
, arg2
, call1
, call2
;
5997 /* For now, we only cover the case where argsize is twice as large
5999 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6001 func
= builtin_decl_explicit (parity
6003 : BUILT_IN_POPCOUNTLL
);
6005 /* Convert it to an integer, and store into a variable. */
6006 utype
= gfc_build_uint_type (argsize
);
6007 arg
= fold_convert (utype
, arg
);
6008 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6010 /* Call the builtin twice. */
6011 call1
= build_call_expr_loc (input_location
, func
, 1,
6012 fold_convert (long_long_unsigned_type_node
,
6015 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
6016 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
6017 call2
= build_call_expr_loc (input_location
, func
, 1,
6018 fold_convert (long_long_unsigned_type_node
,
6021 /* Combine the results. */
6023 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
6026 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6032 /* Convert the actual argument twice: first, to the unsigned type of the
6033 same size; then, to the proper argument type for the built-in
6035 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6036 arg
= fold_convert (arg_type
, arg
);
6038 se
->expr
= fold_convert (result_type
,
6039 build_call_expr_loc (input_location
, func
, 1, arg
));
6043 /* Process an intrinsic with unspecified argument-types that has an optional
6044 argument (which could be of type character), e.g. EOSHIFT. For those, we
6045 need to append the string length of the optional argument if it is not
6046 present and the type is really character.
6047 primary specifies the position (starting at 1) of the non-optional argument
6048 specifying the type and optional gives the position of the optional
6049 argument in the arglist. */
6052 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
6053 unsigned primary
, unsigned optional
)
6055 gfc_actual_arglist
* prim_arg
;
6056 gfc_actual_arglist
* opt_arg
;
6058 gfc_actual_arglist
* arg
;
6060 vec
<tree
, va_gc
> *append_args
;
6062 /* Find the two arguments given as position. */
6066 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
6070 if (cur_pos
== primary
)
6072 if (cur_pos
== optional
)
6075 if (cur_pos
>= primary
&& cur_pos
>= optional
)
6078 gcc_assert (prim_arg
);
6079 gcc_assert (prim_arg
->expr
);
6080 gcc_assert (opt_arg
);
6082 /* If we do have type CHARACTER and the optional argument is really absent,
6083 append a dummy 0 as string length. */
6085 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
6089 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
6090 vec_alloc (append_args
, 1);
6091 append_args
->quick_push (dummy
);
6094 /* Build the call itself. */
6095 gcc_assert (!se
->ignore_optional
);
6096 sym
= gfc_get_symbol_for_expr (expr
, false);
6097 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6099 gfc_free_symbol (sym
);
6103 /* The length of a character string. */
6105 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
6114 gcc_assert (!se
->ss
);
6116 arg
= expr
->value
.function
.actual
->expr
;
6118 type
= gfc_typenode_for_spec (&expr
->ts
);
6119 switch (arg
->expr_type
)
6122 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
6126 /* Obtain the string length from the function used by
6127 trans-array.c(gfc_trans_array_constructor). */
6129 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
6133 if (arg
->ref
== NULL
6134 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6136 /* This doesn't catch all cases.
6137 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6138 and the surrounding thread. */
6139 sym
= arg
->symtree
->n
.sym
;
6140 decl
= gfc_get_symbol_decl (sym
);
6141 if (decl
== current_function_decl
&& sym
->attr
.function
6142 && (sym
->result
== sym
))
6143 decl
= gfc_get_fake_result_decl (sym
, 0);
6145 len
= sym
->ts
.u
.cl
->backend_decl
;
6153 /* Anybody stupid enough to do this deserves inefficient code. */
6154 gfc_init_se (&argse
, se
);
6156 gfc_conv_expr (&argse
, arg
);
6158 gfc_conv_expr_descriptor (&argse
, arg
);
6159 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6160 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6161 len
= argse
.string_length
;
6164 se
->expr
= convert (type
, len
);
6167 /* The length of a character string not including trailing blanks. */
6169 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6171 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6172 tree args
[2], type
, fndecl
;
6174 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6175 type
= gfc_typenode_for_spec (&expr
->ts
);
6178 fndecl
= gfor_fndecl_string_len_trim
;
6180 fndecl
= gfor_fndecl_string_len_trim_char4
;
6184 se
->expr
= build_call_expr_loc (input_location
,
6185 fndecl
, 2, args
[0], args
[1]);
6186 se
->expr
= convert (type
, se
->expr
);
6190 /* Returns the starting position of a substring within a string. */
6193 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6196 tree logical4_type_node
= gfc_get_logical_type (4);
6200 unsigned int num_args
;
6202 args
= XALLOCAVEC (tree
, 5);
6204 /* Get number of arguments; characters count double due to the
6205 string length argument. Kind= is not passed to the library
6206 and thus ignored. */
6207 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6212 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6213 type
= gfc_typenode_for_spec (&expr
->ts
);
6216 args
[4] = build_int_cst (logical4_type_node
, 0);
6218 args
[4] = convert (logical4_type_node
, args
[4]);
6220 fndecl
= build_addr (function
);
6221 se
->expr
= build_call_array_loc (input_location
,
6222 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6224 se
->expr
= convert (type
, se
->expr
);
6228 /* The ascii value for a single character. */
6230 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6232 tree args
[3], type
, pchartype
;
6235 nargs
= gfc_intrinsic_argument_list_length (expr
);
6236 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6237 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6238 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6239 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6240 type
= gfc_typenode_for_spec (&expr
->ts
);
6242 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6244 se
->expr
= convert (type
, se
->expr
);
6248 /* Intrinsic ISNAN calls __builtin_isnan. */
6251 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6255 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6256 se
->expr
= build_call_expr_loc (input_location
,
6257 builtin_decl_explicit (BUILT_IN_ISNAN
),
6259 STRIP_TYPE_NOPS (se
->expr
);
6260 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6264 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6265 their argument against a constant integer value. */
6268 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6272 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6273 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6274 gfc_typenode_for_spec (&expr
->ts
),
6275 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6280 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6283 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
6291 unsigned int num_args
;
6293 num_args
= gfc_intrinsic_argument_list_length (expr
);
6294 args
= XALLOCAVEC (tree
, num_args
);
6296 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6297 if (expr
->ts
.type
!= BT_CHARACTER
)
6305 /* We do the same as in the non-character case, but the argument
6306 list is different because of the string length arguments. We
6307 also have to set the string length for the result. */
6314 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
6316 se
->string_length
= len
;
6318 type
= TREE_TYPE (tsource
);
6319 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
6320 fold_convert (type
, fsource
));
6324 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6327 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
6329 tree args
[3], mask
, type
;
6331 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6332 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
6334 type
= TREE_TYPE (args
[0]);
6335 gcc_assert (TREE_TYPE (args
[1]) == type
);
6336 gcc_assert (TREE_TYPE (mask
) == type
);
6338 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
6339 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
6340 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6342 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
6347 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6348 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6351 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
6353 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
6356 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6357 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6359 type
= gfc_get_int_type (expr
->ts
.kind
);
6360 utype
= unsigned_type_for (type
);
6362 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
6363 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
6365 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
6366 build_int_cst (utype
, 0));
6370 /* Left-justified mask. */
6371 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
6373 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6374 fold_convert (utype
, res
));
6376 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6377 smaller than type width. */
6378 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6379 build_int_cst (TREE_TYPE (arg
), 0));
6380 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
6381 build_int_cst (utype
, 0), res
);
6385 /* Right-justified mask. */
6386 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6387 fold_convert (utype
, arg
));
6388 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
6390 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6391 strictly smaller than type width. */
6392 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6394 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
6395 cond
, allones
, res
);
6398 se
->expr
= fold_convert (type
, res
);
6402 /* FRACTION (s) is translated into:
6403 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6405 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
6407 tree arg
, type
, tmp
, res
, frexp
, cond
;
6409 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6411 type
= gfc_typenode_for_spec (&expr
->ts
);
6412 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6413 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6415 cond
= build_call_expr_loc (input_location
,
6416 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6419 tmp
= gfc_create_var (integer_type_node
, NULL
);
6420 res
= build_call_expr_loc (input_location
, frexp
, 2,
6421 fold_convert (type
, arg
),
6422 gfc_build_addr_expr (NULL_TREE
, tmp
));
6423 res
= fold_convert (type
, res
);
6425 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
6426 cond
, res
, gfc_build_nan (type
, ""));
6430 /* NEAREST (s, dir) is translated into
6431 tmp = copysign (HUGE_VAL, dir);
6432 return nextafter (s, tmp);
6435 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
6437 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
6439 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
6440 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
6442 type
= gfc_typenode_for_spec (&expr
->ts
);
6443 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6445 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
6446 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
6447 fold_convert (type
, args
[1]));
6448 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
6449 fold_convert (type
, args
[0]), tmp
);
6450 se
->expr
= fold_convert (type
, se
->expr
);
6454 /* SPACING (s) is translated into
6464 e = MAX_EXPR (e, emin);
6465 res = scalbn (1., e);
6469 where prec is the precision of s, gfc_real_kinds[k].digits,
6470 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6471 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6474 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
6476 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
6477 tree cond
, nan
, tmp
, frexp
, scalbn
;
6481 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6482 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
6483 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
6484 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
6486 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6487 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6489 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6490 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6492 type
= gfc_typenode_for_spec (&expr
->ts
);
6493 e
= gfc_create_var (integer_type_node
, NULL
);
6494 res
= gfc_create_var (type
, NULL
);
6497 /* Build the block for s /= 0. */
6498 gfc_start_block (&block
);
6499 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6500 gfc_build_addr_expr (NULL_TREE
, e
));
6501 gfc_add_expr_to_block (&block
, tmp
);
6503 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
6505 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
6506 integer_type_node
, tmp
, emin
));
6508 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
6509 build_real_from_int_cst (type
, integer_one_node
), e
);
6510 gfc_add_modify (&block
, res
, tmp
);
6512 /* Finish by building the IF statement for value zero. */
6513 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6514 build_real_from_int_cst (type
, integer_zero_node
));
6515 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
6516 gfc_finish_block (&block
));
6518 /* And deal with infinities and NaNs. */
6519 cond
= build_call_expr_loc (input_location
,
6520 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6522 nan
= gfc_build_nan (type
, "");
6523 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
6525 gfc_add_expr_to_block (&se
->pre
, tmp
);
6530 /* RRSPACING (s) is translated into
6539 x = scalbn (x, precision - e);
6546 where precision is gfc_real_kinds[k].digits. */
6549 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
6551 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
6555 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6556 prec
= gfc_real_kinds
[k
].digits
;
6558 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6559 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6560 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
6562 type
= gfc_typenode_for_spec (&expr
->ts
);
6563 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6564 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6566 e
= gfc_create_var (integer_type_node
, NULL
);
6567 x
= gfc_create_var (type
, NULL
);
6568 gfc_add_modify (&se
->pre
, x
,
6569 build_call_expr_loc (input_location
, fabs
, 1, arg
));
6572 gfc_start_block (&block
);
6573 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6574 gfc_build_addr_expr (NULL_TREE
, e
));
6575 gfc_add_expr_to_block (&block
, tmp
);
6577 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
6578 build_int_cst (integer_type_node
, prec
), e
);
6579 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
6580 gfc_add_modify (&block
, x
, tmp
);
6581 stmt
= gfc_finish_block (&block
);
6584 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
6585 build_real_from_int_cst (type
, integer_zero_node
));
6586 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
6588 /* And deal with infinities and NaNs. */
6589 cond
= build_call_expr_loc (input_location
,
6590 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6592 nan
= gfc_build_nan (type
, "");
6593 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
6595 gfc_add_expr_to_block (&se
->pre
, tmp
);
6596 se
->expr
= fold_convert (type
, x
);
6600 /* SCALE (s, i) is translated into scalbn (s, i). */
6602 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
6604 tree args
[2], type
, scalbn
;
6606 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6608 type
= gfc_typenode_for_spec (&expr
->ts
);
6609 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6610 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
6611 fold_convert (type
, args
[0]),
6612 fold_convert (integer_type_node
, args
[1]));
6613 se
->expr
= fold_convert (type
, se
->expr
);
6617 /* SET_EXPONENT (s, i) is translated into
6618 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6620 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
6622 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
6624 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6625 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6627 type
= gfc_typenode_for_spec (&expr
->ts
);
6628 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6629 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6631 tmp
= gfc_create_var (integer_type_node
, NULL
);
6632 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
6633 fold_convert (type
, args
[0]),
6634 gfc_build_addr_expr (NULL_TREE
, tmp
));
6635 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
6636 fold_convert (integer_type_node
, args
[1]));
6637 res
= fold_convert (type
, res
);
6639 /* Call to isfinite */
6640 cond
= build_call_expr_loc (input_location
,
6641 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6643 nan
= gfc_build_nan (type
, "");
6645 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6651 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
6653 gfc_actual_arglist
*actual
;
6660 gfc_init_se (&argse
, NULL
);
6661 actual
= expr
->value
.function
.actual
;
6663 if (actual
->expr
->ts
.type
== BT_CLASS
)
6664 gfc_add_class_array_ref (actual
->expr
);
6666 argse
.data_not_needed
= 1;
6667 if (gfc_is_class_array_function (actual
->expr
))
6669 /* For functions that return a class array conv_expr_descriptor is not
6670 able to get the descriptor right. Therefore this special case. */
6671 gfc_conv_expr_reference (&argse
, actual
->expr
);
6672 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6673 gfc_class_data_get (argse
.expr
));
6677 argse
.want_pointer
= 1;
6678 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
6680 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6681 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6682 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
6684 /* Build the call to size0. */
6685 fncall0
= build_call_expr_loc (input_location
,
6686 gfor_fndecl_size0
, 1, arg1
);
6688 actual
= actual
->next
;
6692 gfc_init_se (&argse
, NULL
);
6693 gfc_conv_expr_type (&argse
, actual
->expr
,
6694 gfc_array_index_type
);
6695 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6697 /* Unusually, for an intrinsic, size does not exclude
6698 an optional arg2, so we must test for it. */
6699 if (actual
->expr
->expr_type
== EXPR_VARIABLE
6700 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
6701 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
6704 /* Build the call to size1. */
6705 fncall1
= build_call_expr_loc (input_location
,
6706 gfor_fndecl_size1
, 2,
6709 gfc_init_se (&argse
, NULL
);
6710 argse
.want_pointer
= 1;
6711 argse
.data_not_needed
= 1;
6712 gfc_conv_expr (&argse
, actual
->expr
);
6713 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6714 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6715 argse
.expr
, null_pointer_node
);
6716 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6717 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
6718 pvoid_type_node
, tmp
, fncall1
, fncall0
);
6722 se
->expr
= NULL_TREE
;
6723 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6724 gfc_array_index_type
,
6725 argse
.expr
, gfc_index_one_node
);
6728 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
6730 argse
.expr
= gfc_index_zero_node
;
6731 se
->expr
= NULL_TREE
;
6736 if (se
->expr
== NULL_TREE
)
6738 tree ubound
, lbound
;
6740 arg1
= build_fold_indirect_ref_loc (input_location
,
6742 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
6743 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
6744 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6745 gfc_array_index_type
, ubound
, lbound
);
6746 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
6747 gfc_array_index_type
,
6748 se
->expr
, gfc_index_one_node
);
6749 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6750 gfc_array_index_type
, se
->expr
,
6751 gfc_index_zero_node
);
6754 type
= gfc_typenode_for_spec (&expr
->ts
);
6755 se
->expr
= convert (type
, se
->expr
);
6759 /* Helper function to compute the size of a character variable,
6760 excluding the terminating null characters. The result has
6761 gfc_array_index_type type. */
6764 size_of_string_in_bytes (int kind
, tree string_length
)
6767 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
6769 bytesize
= build_int_cst (gfc_array_index_type
,
6770 gfc_character_kinds
[i
].bit_size
/ 8);
6772 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6774 fold_convert (gfc_array_index_type
, string_length
));
6779 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
6791 gfc_init_se (&argse
, NULL
);
6792 arg
= expr
->value
.function
.actual
->expr
;
6794 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
6795 gfc_conv_expr_descriptor (&argse
, arg
);
6797 gfc_conv_expr_reference (&argse
, arg
);
6799 if (arg
->ts
.type
== BT_ASSUMED
)
6801 /* This only works if an array descriptor has been passed; thus, extract
6802 the size from the descriptor. */
6803 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
6804 == TYPE_PRECISION (size_type_node
));
6805 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
6806 tmp
= DECL_LANG_SPECIFIC (tmp
)
6807 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
6808 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
6809 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
6810 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6812 tmp
= gfc_conv_descriptor_dtype (tmp
);
6813 field
= gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
6814 GFC_DTYPE_ELEM_LEN
);
6815 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6816 tmp
, field
, NULL_TREE
);
6818 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
6820 else if (arg
->ts
.type
== BT_CLASS
)
6822 /* Conv_expr_descriptor returns a component_ref to _data component of the
6823 class object. The class object may be a non-pointer object, e.g.
6824 located on the stack, or a memory location pointed to, e.g. a
6825 parameter, i.e., an indirect_ref. */
6827 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
6828 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
6829 && GFC_DECL_CLASS (TREE_OPERAND (
6830 TREE_OPERAND (argse
.expr
, 0), 0)))
6831 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
6832 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6833 else if (arg
->rank
> 0
6835 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
6836 /* The scalarizer added an additional temp. To get the class' vptr
6837 one has to look at the original backend_decl. */
6838 byte_size
= gfc_class_vtab_size_get (
6839 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6841 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
6845 if (arg
->ts
.type
== BT_CHARACTER
)
6846 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6850 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6853 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6854 byte_size
= fold_convert (gfc_array_index_type
,
6855 size_in_bytes (byte_size
));
6860 se
->expr
= byte_size
;
6863 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
6864 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
6866 if (arg
->rank
== -1)
6868 tree cond
, loop_var
, exit_label
;
6871 tmp
= fold_convert (gfc_array_index_type
,
6872 gfc_conv_descriptor_rank (argse
.expr
));
6873 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
6874 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
6875 exit_label
= gfc_build_label_decl (NULL_TREE
);
6882 source_bytes = source_bytes * array.dim[i].extent;
6886 gfc_start_block (&body
);
6887 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6889 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6890 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6891 cond
, tmp
, build_empty_stmt (input_location
));
6892 gfc_add_expr_to_block (&body
, tmp
);
6894 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6895 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6896 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6897 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6898 gfc_array_index_type
, tmp
, source_bytes
);
6899 gfc_add_modify (&body
, source_bytes
, tmp
);
6901 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6902 gfc_array_index_type
, loop_var
,
6903 gfc_index_one_node
);
6904 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6906 tmp
= gfc_finish_block (&body
);
6908 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6910 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6912 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6913 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6917 /* Obtain the size of the array in bytes. */
6918 for (n
= 0; n
< arg
->rank
; n
++)
6921 idx
= gfc_rank_cst
[n
];
6922 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6923 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6924 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6925 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6926 gfc_array_index_type
, tmp
, source_bytes
);
6927 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6930 se
->expr
= source_bytes
;
6933 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6938 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6942 tree type
, result_type
, tmp
;
6944 arg
= expr
->value
.function
.actual
->expr
;
6946 gfc_init_se (&argse
, NULL
);
6947 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6951 if (arg
->ts
.type
== BT_CLASS
)
6953 gfc_add_vptr_component (arg
);
6954 gfc_add_size_component (arg
);
6955 gfc_conv_expr (&argse
, arg
);
6956 tmp
= fold_convert (result_type
, argse
.expr
);
6960 gfc_conv_expr_reference (&argse
, arg
);
6961 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6966 argse
.want_pointer
= 0;
6967 gfc_conv_expr_descriptor (&argse
, arg
);
6968 if (arg
->ts
.type
== BT_CLASS
)
6971 tmp
= gfc_class_vtab_size_get (
6972 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6974 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6975 tmp
= fold_convert (result_type
, tmp
);
6978 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6981 /* Obtain the argument's word length. */
6982 if (arg
->ts
.type
== BT_CHARACTER
)
6983 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6985 tmp
= size_in_bytes (type
);
6986 tmp
= fold_convert (result_type
, tmp
);
6989 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6990 build_int_cst (result_type
, BITS_PER_UNIT
));
6991 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6995 /* Intrinsic string comparison functions. */
6998 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
7002 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
7005 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
7006 expr
->value
.function
.actual
->expr
->ts
.kind
,
7008 se
->expr
= fold_build2_loc (input_location
, op
,
7009 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
7010 build_int_cst (TREE_TYPE (se
->expr
), 0));
7013 /* Generate a call to the adjustl/adjustr library function. */
7015 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
7023 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
7026 type
= TREE_TYPE (args
[2]);
7027 var
= gfc_conv_string_tmp (se
, type
, len
);
7030 tmp
= build_call_expr_loc (input_location
,
7031 fndecl
, 3, args
[0], args
[1], args
[2]);
7032 gfc_add_expr_to_block (&se
->pre
, tmp
);
7034 se
->string_length
= len
;
7038 /* Generate code for the TRANSFER intrinsic:
7040 DEST = TRANSFER (SOURCE, MOLD)
7042 typeof<DEST> = typeof<MOLD>
7047 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
7049 typeof<DEST> = typeof<MOLD>
7051 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
7052 sizeof (DEST(0) * SIZE). */
7054 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
7070 gfc_actual_arglist
*arg
;
7072 gfc_array_info
*info
;
7076 gfc_expr
*source_expr
, *mold_expr
;
7080 info
= &se
->ss
->info
->data
.array
;
7082 /* Convert SOURCE. The output from this stage is:-
7083 source_bytes = length of the source in bytes
7084 source = pointer to the source data. */
7085 arg
= expr
->value
.function
.actual
;
7086 source_expr
= arg
->expr
;
7088 /* Ensure double transfer through LOGICAL preserves all
7090 if (arg
->expr
->expr_type
== EXPR_FUNCTION
7091 && arg
->expr
->value
.function
.esym
== NULL
7092 && arg
->expr
->value
.function
.isym
!= NULL
7093 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
7094 && arg
->expr
->ts
.type
== BT_LOGICAL
7095 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
7096 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
7098 gfc_init_se (&argse
, NULL
);
7100 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7102 /* Obtain the pointer to source and the length of source in bytes. */
7103 if (arg
->expr
->rank
== 0)
7105 gfc_conv_expr_reference (&argse
, arg
->expr
);
7106 if (arg
->expr
->ts
.type
== BT_CLASS
)
7107 source
= gfc_class_data_get (argse
.expr
);
7109 source
= argse
.expr
;
7111 /* Obtain the source word length. */
7112 switch (arg
->expr
->ts
.type
)
7115 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7116 argse
.string_length
);
7119 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7122 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7124 tmp
= fold_convert (gfc_array_index_type
,
7125 size_in_bytes (source_type
));
7131 argse
.want_pointer
= 0;
7132 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7133 source
= gfc_conv_descriptor_data_get (argse
.expr
);
7134 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7136 /* Repack the source if not simply contiguous. */
7137 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
7139 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
7141 if (warn_array_temporaries
)
7142 gfc_warning (OPT_Warray_temporaries
,
7143 "Creating array temporary at %L", &expr
->where
);
7145 source
= build_call_expr_loc (input_location
,
7146 gfor_fndecl_in_pack
, 1, tmp
);
7147 source
= gfc_evaluate_now (source
, &argse
.pre
);
7149 /* Free the temporary. */
7150 gfc_start_block (&block
);
7151 tmp
= gfc_call_free (source
);
7152 gfc_add_expr_to_block (&block
, tmp
);
7153 stmt
= gfc_finish_block (&block
);
7155 /* Clean up if it was repacked. */
7156 gfc_init_block (&block
);
7157 tmp
= gfc_conv_array_data (argse
.expr
);
7158 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7160 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7161 build_empty_stmt (input_location
));
7162 gfc_add_expr_to_block (&block
, tmp
);
7163 gfc_add_block_to_block (&block
, &se
->post
);
7164 gfc_init_block (&se
->post
);
7165 gfc_add_block_to_block (&se
->post
, &block
);
7168 /* Obtain the source word length. */
7169 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7170 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7171 argse
.string_length
);
7173 tmp
= fold_convert (gfc_array_index_type
,
7174 size_in_bytes (source_type
));
7176 /* Obtain the size of the array in bytes. */
7177 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7178 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7181 idx
= gfc_rank_cst
[n
];
7182 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7183 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7184 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7185 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7186 gfc_array_index_type
, upper
, lower
);
7187 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7188 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7189 gfc_array_index_type
, extent
,
7190 gfc_index_one_node
);
7191 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7192 gfc_array_index_type
, tmp
, source_bytes
);
7196 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7197 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7198 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7200 /* Now convert MOLD. The outputs are:
7201 mold_type = the TREE type of MOLD
7202 dest_word_len = destination word length in bytes. */
7204 mold_expr
= arg
->expr
;
7206 gfc_init_se (&argse
, NULL
);
7208 scalar_mold
= arg
->expr
->rank
== 0;
7210 if (arg
->expr
->rank
== 0)
7212 gfc_conv_expr_reference (&argse
, arg
->expr
);
7213 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7218 gfc_init_se (&argse
, NULL
);
7219 argse
.want_pointer
= 0;
7220 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7221 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7224 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7225 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7227 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7229 /* If this TRANSFER is nested in another TRANSFER, use a type
7230 that preserves all bits. */
7231 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7232 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7235 /* Obtain the destination word length. */
7236 switch (arg
->expr
->ts
.type
)
7239 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7240 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7243 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7246 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7249 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7250 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7252 /* Finally convert SIZE, if it is present. */
7254 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7258 gfc_init_se (&argse
, NULL
);
7259 gfc_conv_expr_reference (&argse
, arg
->expr
);
7260 tmp
= convert (gfc_array_index_type
,
7261 build_fold_indirect_ref_loc (input_location
,
7263 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7264 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7269 /* Separate array and scalar results. */
7270 if (scalar_mold
&& tmp
== NULL_TREE
)
7271 goto scalar_transfer
;
7273 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7274 if (tmp
!= NULL_TREE
)
7275 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7276 tmp
, dest_word_len
);
7280 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
7281 gfc_add_modify (&se
->pre
, size_words
,
7282 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
7283 gfc_array_index_type
,
7284 size_bytes
, dest_word_len
));
7286 /* Evaluate the bounds of the result. If the loop range exists, we have
7287 to check if it is too large. If so, we modify loop->to be consistent
7288 with min(size, size(source)). Otherwise, size is made consistent with
7289 the loop range, so that the right number of bytes is transferred.*/
7290 n
= se
->loop
->order
[0];
7291 if (se
->loop
->to
[n
] != NULL_TREE
)
7293 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7294 se
->loop
->to
[n
], se
->loop
->from
[n
]);
7295 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7296 tmp
, gfc_index_one_node
);
7297 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7299 gfc_add_modify (&se
->pre
, size_words
, tmp
);
7300 gfc_add_modify (&se
->pre
, size_bytes
,
7301 fold_build2_loc (input_location
, MULT_EXPR
,
7302 gfc_array_index_type
,
7303 size_words
, dest_word_len
));
7304 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7305 size_words
, se
->loop
->from
[n
]);
7306 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7307 upper
, gfc_index_one_node
);
7311 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7312 size_words
, gfc_index_one_node
);
7313 se
->loop
->from
[n
] = gfc_index_zero_node
;
7316 se
->loop
->to
[n
] = upper
;
7318 /* Build a destination descriptor, using the pointer, source, as the
7320 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
7321 NULL_TREE
, false, true, false, &expr
->where
);
7323 /* Cast the pointer to the result. */
7324 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7325 tmp
= fold_convert (pvoid_type_node
, tmp
);
7327 /* Use memcpy to do the transfer. */
7329 = build_call_expr_loc (input_location
,
7330 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
7331 fold_convert (pvoid_type_node
, source
),
7332 fold_convert (size_type_node
,
7333 fold_build2_loc (input_location
,
7335 gfc_array_index_type
,
7338 gfc_add_expr_to_block (&se
->pre
, tmp
);
7340 se
->expr
= info
->descriptor
;
7341 if (expr
->ts
.type
== BT_CHARACTER
)
7342 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7346 /* Deal with scalar results. */
7348 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7349 dest_word_len
, source_bytes
);
7350 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7351 extent
, gfc_index_zero_node
);
7353 if (expr
->ts
.type
== BT_CHARACTER
)
7355 tree direct
, indirect
, free
;
7357 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
7358 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
7361 /* If source is longer than the destination, use a pointer to
7362 the source directly. */
7363 gfc_init_block (&block
);
7364 gfc_add_modify (&block
, tmpdecl
, ptr
);
7365 direct
= gfc_finish_block (&block
);
7367 /* Otherwise, allocate a string with the length of the destination
7368 and copy the source into it. */
7369 gfc_init_block (&block
);
7370 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
7371 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
7372 gfc_add_modify (&block
, tmpdecl
,
7373 fold_convert (TREE_TYPE (ptr
), tmp
));
7374 tmp
= build_call_expr_loc (input_location
,
7375 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7376 fold_convert (pvoid_type_node
, tmpdecl
),
7377 fold_convert (pvoid_type_node
, ptr
),
7378 fold_convert (size_type_node
, extent
));
7379 gfc_add_expr_to_block (&block
, tmp
);
7380 indirect
= gfc_finish_block (&block
);
7382 /* Wrap it up with the condition. */
7383 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
7384 dest_word_len
, source_bytes
);
7385 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
7386 gfc_add_expr_to_block (&se
->pre
, tmp
);
7388 /* Free the temporary string, if necessary. */
7389 free
= gfc_call_free (tmpdecl
);
7390 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7391 dest_word_len
, source_bytes
);
7392 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
7393 gfc_add_expr_to_block (&se
->post
, tmp
);
7396 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7400 tmpdecl
= gfc_create_var (mold_type
, "transfer");
7402 ptr
= convert (build_pointer_type (mold_type
), source
);
7404 /* For CLASS results, allocate the needed memory first. */
7405 if (mold_expr
->ts
.type
== BT_CLASS
)
7408 cdata
= gfc_class_data_get (tmpdecl
);
7409 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
7410 gfc_add_modify (&se
->pre
, cdata
, tmp
);
7413 /* Use memcpy to do the transfer. */
7414 if (mold_expr
->ts
.type
== BT_CLASS
)
7415 tmp
= gfc_class_data_get (tmpdecl
);
7417 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
7419 tmp
= build_call_expr_loc (input_location
,
7420 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7421 fold_convert (pvoid_type_node
, tmp
),
7422 fold_convert (pvoid_type_node
, ptr
),
7423 fold_convert (size_type_node
, extent
));
7424 gfc_add_expr_to_block (&se
->pre
, tmp
);
7426 /* For CLASS results, set the _vptr. */
7427 if (mold_expr
->ts
.type
== BT_CLASS
)
7431 vptr
= gfc_class_vptr_get (tmpdecl
);
7432 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
7434 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7435 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
7443 /* Generate a call to caf_is_present. */
7446 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
7448 tree caf_reference
, caf_decl
, token
, image_index
;
7450 /* Compile the reference chain. */
7451 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
7452 gcc_assert (caf_reference
!= NULL_TREE
);
7454 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
7455 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
7456 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
7457 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
7458 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
7461 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
7462 3, token
, image_index
, caf_reference
);
7466 /* Test whether this ref-chain refs this image only. */
7469 caf_this_image_ref (gfc_ref
*ref
)
7471 for ( ; ref
; ref
= ref
->next
)
7472 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
7473 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
7479 /* Generate code for the ALLOCATED intrinsic.
7480 Generate inline code that directly check the address of the argument. */
7483 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
7485 gfc_actual_arglist
*arg1
;
7488 symbol_attribute caf_attr
;
7490 gfc_init_se (&arg1se
, NULL
);
7491 arg1
= expr
->value
.function
.actual
;
7493 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7495 /* Make sure that class array expressions have both a _data
7496 component reference and an array reference.... */
7497 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
7498 gfc_add_class_array_ref (arg1
->expr
);
7499 /* .... whilst scalars only need the _data component. */
7501 gfc_add_data_component (arg1
->expr
);
7504 /* When arg1 references an allocatable component in a coarray, then call
7505 the caf-library function caf_is_present (). */
7506 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
7507 && arg1
->expr
->value
.function
.isym
7508 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
7509 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
7511 gfc_clear_attr (&caf_attr
);
7512 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
7513 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
7514 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
7517 if (arg1
->expr
->rank
== 0)
7519 /* Allocatable scalar. */
7520 arg1se
.want_pointer
= 1;
7521 gfc_conv_expr (&arg1se
, arg1
->expr
);
7526 /* Allocatable array. */
7527 arg1se
.descriptor_only
= 1;
7528 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7529 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7532 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
7533 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7535 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7539 /* Generate code for the ASSOCIATED intrinsic.
7540 If both POINTER and TARGET are arrays, generate a call to library function
7541 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7542 In other cases, generate inline code that directly compare the address of
7543 POINTER with the address of TARGET. */
7546 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
7548 gfc_actual_arglist
*arg1
;
7549 gfc_actual_arglist
*arg2
;
7554 tree nonzero_charlen
;
7555 tree nonzero_arraylen
;
7559 gfc_init_se (&arg1se
, NULL
);
7560 gfc_init_se (&arg2se
, NULL
);
7561 arg1
= expr
->value
.function
.actual
;
7564 /* Check whether the expression is a scalar or not; we cannot use
7565 arg1->expr->rank as it can be nonzero for proc pointers. */
7566 ss
= gfc_walk_expr (arg1
->expr
);
7567 scalar
= ss
== gfc_ss_terminator
;
7569 gfc_free_ss_chain (ss
);
7573 /* No optional target. */
7576 /* A pointer to a scalar. */
7577 arg1se
.want_pointer
= 1;
7578 gfc_conv_expr (&arg1se
, arg1
->expr
);
7579 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7580 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7581 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7583 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7585 tmp2
= gfc_class_data_get (arg1se
.expr
);
7586 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7587 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7594 /* A pointer to an array. */
7595 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7596 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7598 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7599 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7600 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
7601 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
7606 /* An optional target. */
7607 if (arg2
->expr
->ts
.type
== BT_CLASS
)
7608 gfc_add_data_component (arg2
->expr
);
7610 nonzero_charlen
= NULL_TREE
;
7611 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
7612 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
7614 arg1
->expr
->ts
.u
.cl
->backend_decl
,
7616 (TREE_TYPE (arg1
->expr
->ts
.u
.cl
->backend_decl
)));
7619 /* A pointer to a scalar. */
7620 arg1se
.want_pointer
= 1;
7621 gfc_conv_expr (&arg1se
, arg1
->expr
);
7622 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7623 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7624 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7626 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7627 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
7629 arg2se
.want_pointer
= 1;
7630 gfc_conv_expr (&arg2se
, arg2
->expr
);
7631 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7632 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
7633 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
7635 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7636 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7637 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7638 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7639 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7640 arg1se
.expr
, arg2se
.expr
);
7641 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7642 arg1se
.expr
, null_pointer_node
);
7643 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7644 logical_type_node
, tmp
, tmp2
);
7648 /* An array pointer of zero length is not associated if target is
7650 arg1se
.descriptor_only
= 1;
7651 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
7652 if (arg1
->expr
->rank
== -1)
7654 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
7655 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7656 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
7659 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
7660 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
7661 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
7662 logical_type_node
, tmp
,
7663 build_int_cst (TREE_TYPE (tmp
), 0));
7665 /* A pointer to an array, call library function _gfor_associated. */
7666 arg1se
.want_pointer
= 1;
7667 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7669 arg2se
.want_pointer
= 1;
7670 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
7671 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7672 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7673 se
->expr
= build_call_expr_loc (input_location
,
7674 gfor_fndecl_associated
, 2,
7675 arg1se
.expr
, arg2se
.expr
);
7676 se
->expr
= convert (logical_type_node
, se
->expr
);
7677 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7678 logical_type_node
, se
->expr
,
7682 /* If target is present zero character length pointers cannot
7684 if (nonzero_charlen
!= NULL_TREE
)
7685 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7687 se
->expr
, nonzero_charlen
);
7690 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7694 /* Generate code for the SAME_TYPE_AS intrinsic.
7695 Generate inline code that directly checks the vindices. */
7698 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
7703 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
7705 gfc_init_se (&se1
, NULL
);
7706 gfc_init_se (&se2
, NULL
);
7708 a
= expr
->value
.function
.actual
->expr
;
7709 b
= expr
->value
.function
.actual
->next
->expr
;
7711 if (UNLIMITED_POLY (a
))
7713 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
7714 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7715 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7718 if (UNLIMITED_POLY (b
))
7720 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
7721 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7722 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7725 if (a
->ts
.type
== BT_CLASS
)
7727 gfc_add_vptr_component (a
);
7728 gfc_add_hash_component (a
);
7730 else if (a
->ts
.type
== BT_DERIVED
)
7731 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7732 a
->ts
.u
.derived
->hash_value
);
7734 if (b
->ts
.type
== BT_CLASS
)
7736 gfc_add_vptr_component (b
);
7737 gfc_add_hash_component (b
);
7739 else if (b
->ts
.type
== BT_DERIVED
)
7740 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7741 b
->ts
.u
.derived
->hash_value
);
7743 gfc_conv_expr (&se1
, a
);
7744 gfc_conv_expr (&se2
, b
);
7746 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
7747 logical_type_node
, se1
.expr
,
7748 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
7751 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7752 logical_type_node
, conda
, tmp
);
7755 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7756 logical_type_node
, condb
, tmp
);
7758 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7762 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
7765 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
7769 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7770 se
->expr
= build_call_expr_loc (input_location
,
7771 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
7772 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7776 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
7779 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
7783 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7785 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
7786 type
= gfc_get_int_type (4);
7787 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
7789 /* Convert it to the required type. */
7790 type
= gfc_typenode_for_spec (&expr
->ts
);
7791 se
->expr
= build_call_expr_loc (input_location
,
7792 gfor_fndecl_si_kind
, 1, arg
);
7793 se
->expr
= fold_convert (type
, se
->expr
);
7797 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
7800 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
7802 gfc_actual_arglist
*actual
;
7805 vec
<tree
, va_gc
> *args
= NULL
;
7807 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
7809 gfc_init_se (&argse
, se
);
7811 /* Pass a NULL pointer for an absent arg. */
7812 if (actual
->expr
== NULL
)
7813 argse
.expr
= null_pointer_node
;
7819 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
7821 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
7822 ts
.type
= BT_INTEGER
;
7823 ts
.kind
= gfc_c_int_kind
;
7824 gfc_convert_type (actual
->expr
, &ts
, 2);
7826 gfc_conv_expr_reference (&argse
, actual
->expr
);
7829 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7830 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7831 vec_safe_push (args
, argse
.expr
);
7834 /* Convert it to the required type. */
7835 type
= gfc_typenode_for_spec (&expr
->ts
);
7836 se
->expr
= build_call_expr_loc_vec (input_location
,
7837 gfor_fndecl_sr_kind
, args
);
7838 se
->expr
= fold_convert (type
, se
->expr
);
7842 /* Generate code for TRIM (A) intrinsic function. */
7845 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
7855 unsigned int num_args
;
7857 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
7858 args
= XALLOCAVEC (tree
, num_args
);
7860 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
7861 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
7862 len
= gfc_create_var (gfc_charlen_type_node
, "len");
7864 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
7865 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
7868 if (expr
->ts
.kind
== 1)
7869 function
= gfor_fndecl_string_trim
;
7870 else if (expr
->ts
.kind
== 4)
7871 function
= gfor_fndecl_string_trim_char4
;
7875 fndecl
= build_addr (function
);
7876 tmp
= build_call_array_loc (input_location
,
7877 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7879 gfc_add_expr_to_block (&se
->pre
, tmp
);
7881 /* Free the temporary afterwards, if necessary. */
7882 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7883 len
, build_int_cst (TREE_TYPE (len
), 0));
7884 tmp
= gfc_call_free (var
);
7885 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
7886 gfc_add_expr_to_block (&se
->post
, tmp
);
7889 se
->string_length
= len
;
7893 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
7896 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
7898 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
7899 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
7901 stmtblock_t block
, body
;
7904 /* We store in charsize the size of a character. */
7905 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
7906 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
7908 /* Get the arguments. */
7909 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7910 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
7912 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
7913 ncopies_type
= TREE_TYPE (ncopies
);
7915 /* Check that NCOPIES is not negative. */
7916 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
7917 build_int_cst (ncopies_type
, 0));
7918 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7919 "Argument NCOPIES of REPEAT intrinsic is negative "
7920 "(its value is %ld)",
7921 fold_convert (long_integer_type_node
, ncopies
));
7923 /* If the source length is zero, any non negative value of NCOPIES
7924 is valid, and nothing happens. */
7925 n
= gfc_create_var (ncopies_type
, "ncopies");
7926 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
7928 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
7929 build_int_cst (ncopies_type
, 0), ncopies
);
7930 gfc_add_modify (&se
->pre
, n
, tmp
);
7933 /* Check that ncopies is not too large: ncopies should be less than
7934 (or equal to) MAX / slen, where MAX is the maximal integer of
7935 the gfc_charlen_type_node type. If slen == 0, we need a special
7936 case to avoid the division by zero. */
7937 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
7938 fold_convert (sizetype
,
7939 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
7941 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
7942 ? sizetype
: ncopies_type
;
7943 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7944 fold_convert (largest
, ncopies
),
7945 fold_convert (largest
, max
));
7946 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
7948 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
7949 logical_false_node
, cond
);
7950 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7951 "Argument NCOPIES of REPEAT intrinsic is too large");
7953 /* Compute the destination length. */
7954 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7955 fold_convert (gfc_charlen_type_node
, slen
),
7956 fold_convert (gfc_charlen_type_node
, ncopies
));
7957 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
7958 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
7960 /* Generate the code to do the repeat operation:
7961 for (i = 0; i < ncopies; i++)
7962 memmove (dest + (i * slen * size), src, slen*size); */
7963 gfc_start_block (&block
);
7964 count
= gfc_create_var (sizetype
, "count");
7965 gfc_add_modify (&block
, count
, size_zero_node
);
7966 exit_label
= gfc_build_label_decl (NULL_TREE
);
7968 /* Start the loop body. */
7969 gfc_start_block (&body
);
7971 /* Exit the loop if count >= ncopies. */
7972 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
7973 fold_convert (sizetype
, ncopies
));
7974 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7975 TREE_USED (exit_label
) = 1;
7976 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7977 build_empty_stmt (input_location
));
7978 gfc_add_expr_to_block (&body
, tmp
);
7980 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7981 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
7983 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
7985 tmp
= fold_build_pointer_plus_loc (input_location
,
7986 fold_convert (pvoid_type_node
, dest
), tmp
);
7987 tmp
= build_call_expr_loc (input_location
,
7988 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7990 fold_build2_loc (input_location
, MULT_EXPR
,
7991 size_type_node
, slen
, size
));
7992 gfc_add_expr_to_block (&body
, tmp
);
7994 /* Increment count. */
7995 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
7996 count
, size_one_node
);
7997 gfc_add_modify (&body
, count
, tmp
);
7999 /* Build the loop. */
8000 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
8001 gfc_add_expr_to_block (&block
, tmp
);
8003 /* Add the exit label. */
8004 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8005 gfc_add_expr_to_block (&block
, tmp
);
8007 /* Finish the block. */
8008 tmp
= gfc_finish_block (&block
);
8009 gfc_add_expr_to_block (&se
->pre
, tmp
);
8011 /* Set the result value. */
8013 se
->string_length
= dlen
;
8017 /* Generate code for the IARGC intrinsic. */
8020 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
8026 /* Call the library function. This always returns an INTEGER(4). */
8027 fndecl
= gfor_fndecl_iargc
;
8028 tmp
= build_call_expr_loc (input_location
,
8031 /* Convert it to the required type. */
8032 type
= gfc_typenode_for_spec (&expr
->ts
);
8033 tmp
= fold_convert (type
, tmp
);
8039 /* The loc intrinsic returns the address of its argument as
8040 gfc_index_integer_kind integer. */
8043 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
8048 gcc_assert (!se
->ss
);
8050 arg_expr
= expr
->value
.function
.actual
->expr
;
8051 if (arg_expr
->rank
== 0)
8053 if (arg_expr
->ts
.type
== BT_CLASS
)
8054 gfc_add_data_component (arg_expr
);
8055 gfc_conv_expr_reference (se
, arg_expr
);
8058 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
8059 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
8061 /* Create a temporary variable for loc return value. Without this,
8062 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
8063 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
8064 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
8065 se
->expr
= temp_var
;
8069 /* The following routine generates code for the intrinsic
8070 functions from the ISO_C_BINDING module:
8076 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
8078 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
8080 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
8082 if (arg
->expr
->rank
== 0)
8083 gfc_conv_expr_reference (se
, arg
->expr
);
8084 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
8085 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
8088 gfc_conv_expr_descriptor (se
, arg
->expr
);
8089 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
8092 /* TODO -- the following two lines shouldn't be necessary, but if
8093 they're removed, a bug is exposed later in the code path.
8094 This workaround was thus introduced, but will have to be
8095 removed; please see PR 35150 for details about the issue. */
8096 se
->expr
= convert (pvoid_type_node
, se
->expr
);
8097 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
8099 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
8100 gfc_conv_expr_reference (se
, arg
->expr
);
8101 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
8106 /* Build the addr_expr for the first argument. The argument is
8107 already an *address* so we don't need to set want_pointer in
8109 gfc_init_se (&arg1se
, NULL
);
8110 gfc_conv_expr (&arg1se
, arg
->expr
);
8111 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8112 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8114 /* See if we were given two arguments. */
8115 if (arg
->next
->expr
== NULL
)
8116 /* Only given one arg so generate a null and do a
8117 not-equal comparison against the first arg. */
8118 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8120 fold_convert (TREE_TYPE (arg1se
.expr
),
8121 null_pointer_node
));
8127 /* Given two arguments so build the arg2se from second arg. */
8128 gfc_init_se (&arg2se
, NULL
);
8129 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
8130 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8131 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8133 /* Generate test to compare that the two args are equal. */
8134 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8135 arg1se
.expr
, arg2se
.expr
);
8136 /* Generate test to ensure that the first arg is not null. */
8137 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
8139 arg1se
.expr
, null_pointer_node
);
8141 /* Finally, the generated test must check that both arg1 is not
8142 NULL and that it is equal to the second arg. */
8143 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8145 not_null_expr
, eq_expr
);
8153 /* The following routine generates code for the intrinsic
8154 subroutines from the ISO_C_BINDING module:
8156 * C_F_PROCPOINTER. */
8159 conv_isocbinding_subroutine (gfc_code
*code
)
8166 tree desc
, dim
, tmp
, stride
, offset
;
8167 stmtblock_t body
, block
;
8169 gfc_actual_arglist
*arg
= code
->ext
.actual
;
8171 gfc_init_se (&se
, NULL
);
8172 gfc_init_se (&cptrse
, NULL
);
8173 gfc_conv_expr (&cptrse
, arg
->expr
);
8174 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
8175 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
8177 gfc_init_se (&fptrse
, NULL
);
8178 if (arg
->next
->expr
->rank
== 0)
8180 fptrse
.want_pointer
= 1;
8181 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
8182 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
8183 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
8184 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8185 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
8186 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
8188 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8189 TREE_TYPE (fptrse
.expr
),
8191 fold_convert (TREE_TYPE (fptrse
.expr
),
8193 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
8194 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8195 return gfc_finish_block (&se
.pre
);
8198 gfc_start_block (&block
);
8200 /* Get the descriptor of the Fortran pointer. */
8201 fptrse
.descriptor_only
= 1;
8202 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
8203 gfc_add_block_to_block (&block
, &fptrse
.pre
);
8206 /* Set the span field. */
8207 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
8208 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8209 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
8211 /* Set data value, dtype, and offset. */
8212 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
8213 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
8214 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
8215 gfc_get_dtype (TREE_TYPE (desc
)));
8217 /* Start scalarization of the bounds, using the shape argument. */
8219 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
8220 gcc_assert (shape_ss
!= gfc_ss_terminator
);
8221 gfc_init_se (&shapese
, NULL
);
8223 gfc_init_loopinfo (&loop
);
8224 gfc_add_ss_to_loop (&loop
, shape_ss
);
8225 gfc_conv_ss_startstride (&loop
);
8226 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
8227 gfc_mark_ss_chain_used (shape_ss
, 1);
8229 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
8230 shapese
.ss
= shape_ss
;
8232 stride
= gfc_create_var (gfc_array_index_type
, "stride");
8233 offset
= gfc_create_var (gfc_array_index_type
, "offset");
8234 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
8235 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8238 gfc_start_scalarized_body (&loop
, &body
);
8240 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8241 loop
.loopvar
[0], loop
.from
[0]);
8243 /* Set bounds and stride. */
8244 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
8245 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
8247 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
8248 gfc_add_block_to_block (&body
, &shapese
.pre
);
8249 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
8250 gfc_add_block_to_block (&body
, &shapese
.post
);
8252 /* Calculate offset. */
8253 gfc_add_modify (&body
, offset
,
8254 fold_build2_loc (input_location
, PLUS_EXPR
,
8255 gfc_array_index_type
, offset
, stride
));
8256 /* Update stride. */
8257 gfc_add_modify (&body
, stride
,
8258 fold_build2_loc (input_location
, MULT_EXPR
,
8259 gfc_array_index_type
, stride
,
8260 fold_convert (gfc_array_index_type
,
8262 /* Finish scalarization loop. */
8263 gfc_trans_scalarizing_loops (&loop
, &body
);
8264 gfc_add_block_to_block (&block
, &loop
.pre
);
8265 gfc_add_block_to_block (&block
, &loop
.post
);
8266 gfc_add_block_to_block (&block
, &fptrse
.post
);
8267 gfc_cleanup_loop (&loop
);
8269 gfc_add_modify (&block
, offset
,
8270 fold_build1_loc (input_location
, NEGATE_EXPR
,
8271 gfc_array_index_type
, offset
));
8272 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
8274 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
8275 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8276 return gfc_finish_block (&se
.pre
);
8280 /* Save and restore floating-point state. */
8283 gfc_save_fp_state (stmtblock_t
*block
)
8285 tree type
, fpstate
, tmp
;
8287 type
= build_array_type (char_type_node
,
8288 build_range_type (size_type_node
, size_zero_node
,
8289 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
8290 fpstate
= gfc_create_var (type
, "fpstate");
8291 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
8293 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
8295 gfc_add_expr_to_block (block
, tmp
);
8302 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
8306 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
8308 gfc_add_expr_to_block (block
, tmp
);
8312 /* Generate code for arguments of IEEE functions. */
8315 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
8318 gfc_actual_arglist
*actual
;
8323 actual
= expr
->value
.function
.actual
;
8324 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
8326 gcc_assert (actual
);
8329 gfc_init_se (&argse
, se
);
8330 gfc_conv_expr_val (&argse
, e
);
8332 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8333 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8334 argarray
[arg
] = argse
.expr
;
8339 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8340 and IEEE_UNORDERED, which translate directly to GCC type-generic
8344 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
8345 enum built_in_function code
, int nargs
)
8348 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
8350 conv_ieee_function_args (se
, expr
, args
, nargs
);
8351 se
->expr
= build_call_expr_loc_array (input_location
,
8352 builtin_decl_explicit (code
),
8354 STRIP_TYPE_NOPS (se
->expr
);
8355 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8359 /* Generate code for IEEE_IS_NORMAL intrinsic:
8360 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8363 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
8365 tree arg
, isnormal
, iszero
;
8367 /* Convert arg, evaluate it only once. */
8368 conv_ieee_function_args (se
, expr
, &arg
, 1);
8369 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8371 isnormal
= build_call_expr_loc (input_location
,
8372 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
8374 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
8375 build_real_from_int_cst (TREE_TYPE (arg
),
8376 integer_zero_node
));
8377 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8378 logical_type_node
, isnormal
, iszero
);
8379 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8383 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8384 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8387 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
8389 tree arg
, signbit
, isnan
;
8391 /* Convert arg, evaluate it only once. */
8392 conv_ieee_function_args (se
, expr
, &arg
, 1);
8393 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8395 isnan
= build_call_expr_loc (input_location
,
8396 builtin_decl_explicit (BUILT_IN_ISNAN
),
8398 STRIP_TYPE_NOPS (isnan
);
8400 signbit
= build_call_expr_loc (input_location
,
8401 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8403 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8404 signbit
, integer_zero_node
);
8406 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8407 logical_type_node
, signbit
,
8408 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
8409 TREE_TYPE(isnan
), isnan
));
8411 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8415 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8418 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
8419 enum built_in_function code
)
8421 tree arg
, decl
, call
, fpstate
;
8424 conv_ieee_function_args (se
, expr
, &arg
, 1);
8425 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
8426 decl
= builtin_decl_for_precision (code
, argprec
);
8428 /* Save floating-point state. */
8429 fpstate
= gfc_save_fp_state (&se
->pre
);
8431 /* Make the function call. */
8432 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
8433 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
8435 /* Restore floating-point state. */
8436 gfc_restore_fp_state (&se
->post
, fpstate
);
8440 /* Generate code for IEEE_REM. */
8443 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
8445 tree args
[2], decl
, call
, fpstate
;
8448 conv_ieee_function_args (se
, expr
, args
, 2);
8450 /* If arguments have unequal size, convert them to the larger. */
8451 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
8452 > TYPE_PRECISION (TREE_TYPE (args
[1])))
8453 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8454 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
8455 > TYPE_PRECISION (TREE_TYPE (args
[0])))
8456 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
8458 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8459 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
8461 /* Save floating-point state. */
8462 fpstate
= gfc_save_fp_state (&se
->pre
);
8464 /* Make the function call. */
8465 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8466 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8468 /* Restore floating-point state. */
8469 gfc_restore_fp_state (&se
->post
, fpstate
);
8473 /* Generate code for IEEE_NEXT_AFTER. */
8476 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
8478 tree args
[2], decl
, call
, fpstate
;
8481 conv_ieee_function_args (se
, expr
, args
, 2);
8483 /* Result has the characteristics of first argument. */
8484 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8485 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8486 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
8488 /* Save floating-point state. */
8489 fpstate
= gfc_save_fp_state (&se
->pre
);
8491 /* Make the function call. */
8492 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8493 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8495 /* Restore floating-point state. */
8496 gfc_restore_fp_state (&se
->post
, fpstate
);
8500 /* Generate code for IEEE_SCALB. */
8503 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
8505 tree args
[2], decl
, call
, huge
, type
;
8508 conv_ieee_function_args (se
, expr
, args
, 2);
8510 /* Result has the characteristics of first argument. */
8511 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8512 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
8514 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
8516 /* We need to fold the integer into the range of a C int. */
8517 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
8518 type
= TREE_TYPE (args
[1]);
8520 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
8521 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
8523 huge
= fold_convert (type
, huge
);
8524 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
8526 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
8527 fold_build1_loc (input_location
, NEGATE_EXPR
,
8531 args
[1] = fold_convert (integer_type_node
, args
[1]);
8533 /* Make the function call. */
8534 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8535 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8539 /* Generate code for IEEE_COPY_SIGN. */
8542 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
8544 tree args
[2], decl
, sign
;
8547 conv_ieee_function_args (se
, expr
, args
, 2);
8549 /* Get the sign of the second argument. */
8550 sign
= build_call_expr_loc (input_location
,
8551 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8553 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8554 sign
, integer_zero_node
);
8556 /* Create a value of one, with the right sign. */
8557 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
8559 fold_build1_loc (input_location
, NEGATE_EXPR
,
8563 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
8565 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8566 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
8568 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8572 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8576 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
8578 const char *name
= expr
->value
.function
.name
;
8580 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8582 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
8583 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
8584 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
8585 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
8586 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
8587 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
8588 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
8589 conv_intrinsic_ieee_is_normal (se
, expr
);
8590 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
8591 conv_intrinsic_ieee_is_negative (se
, expr
);
8592 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
8593 conv_intrinsic_ieee_copy_sign (se
, expr
);
8594 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
8595 conv_intrinsic_ieee_scalb (se
, expr
);
8596 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
8597 conv_intrinsic_ieee_next_after (se
, expr
);
8598 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
8599 conv_intrinsic_ieee_rem (se
, expr
);
8600 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
8601 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
8602 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
8603 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
8605 /* It is not among the functions we translate directly. We return
8606 false, so a library function call is emitted. */
8615 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8618 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
8620 tree arg
, res
, restype
;
8622 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8623 arg
= fold_convert (size_type_node
, arg
);
8624 res
= build_call_expr_loc (input_location
,
8625 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
8626 restype
= gfc_typenode_for_spec (&expr
->ts
);
8627 se
->expr
= fold_convert (restype
, res
);
8631 /* Generate code for an intrinsic function. Some map directly to library
8632 calls, others get special handling. In some cases the name of the function
8633 used depends on the type specifiers. */
8636 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
8642 name
= &expr
->value
.function
.name
[2];
8646 lib
= gfc_is_intrinsic_libcall (expr
);
8650 se
->ignore_optional
= 1;
8652 switch (expr
->value
.function
.isym
->id
)
8654 case GFC_ISYM_EOSHIFT
:
8656 case GFC_ISYM_RESHAPE
:
8657 /* For all of those the first argument specifies the type and the
8658 third is optional. */
8659 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
8662 case GFC_ISYM_MINLOC
:
8663 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8666 case GFC_ISYM_MAXLOC
:
8667 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8671 gfc_conv_intrinsic_funcall (se
, expr
);
8679 switch (expr
->value
.function
.isym
->id
)
8684 case GFC_ISYM_REPEAT
:
8685 gfc_conv_intrinsic_repeat (se
, expr
);
8689 gfc_conv_intrinsic_trim (se
, expr
);
8692 case GFC_ISYM_SC_KIND
:
8693 gfc_conv_intrinsic_sc_kind (se
, expr
);
8696 case GFC_ISYM_SI_KIND
:
8697 gfc_conv_intrinsic_si_kind (se
, expr
);
8700 case GFC_ISYM_SR_KIND
:
8701 gfc_conv_intrinsic_sr_kind (se
, expr
);
8704 case GFC_ISYM_EXPONENT
:
8705 gfc_conv_intrinsic_exponent (se
, expr
);
8709 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8711 fndecl
= gfor_fndecl_string_scan
;
8713 fndecl
= gfor_fndecl_string_scan_char4
;
8717 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8720 case GFC_ISYM_VERIFY
:
8721 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8723 fndecl
= gfor_fndecl_string_verify
;
8725 fndecl
= gfor_fndecl_string_verify_char4
;
8729 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8732 case GFC_ISYM_ALLOCATED
:
8733 gfc_conv_allocated (se
, expr
);
8736 case GFC_ISYM_ASSOCIATED
:
8737 gfc_conv_associated(se
, expr
);
8740 case GFC_ISYM_SAME_TYPE_AS
:
8741 gfc_conv_same_type_as (se
, expr
);
8745 gfc_conv_intrinsic_abs (se
, expr
);
8748 case GFC_ISYM_ADJUSTL
:
8749 if (expr
->ts
.kind
== 1)
8750 fndecl
= gfor_fndecl_adjustl
;
8751 else if (expr
->ts
.kind
== 4)
8752 fndecl
= gfor_fndecl_adjustl_char4
;
8756 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8759 case GFC_ISYM_ADJUSTR
:
8760 if (expr
->ts
.kind
== 1)
8761 fndecl
= gfor_fndecl_adjustr
;
8762 else if (expr
->ts
.kind
== 4)
8763 fndecl
= gfor_fndecl_adjustr_char4
;
8767 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8770 case GFC_ISYM_AIMAG
:
8771 gfc_conv_intrinsic_imagpart (se
, expr
);
8775 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
8779 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
8782 case GFC_ISYM_ANINT
:
8783 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
8787 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8791 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
8794 case GFC_ISYM_BTEST
:
8795 gfc_conv_intrinsic_btest (se
, expr
);
8799 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
8803 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
8807 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
8811 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
8814 case GFC_ISYM_C_ASSOCIATED
:
8815 case GFC_ISYM_C_FUNLOC
:
8816 case GFC_ISYM_C_LOC
:
8817 conv_isocbinding_function (se
, expr
);
8820 case GFC_ISYM_ACHAR
:
8822 gfc_conv_intrinsic_char (se
, expr
);
8825 case GFC_ISYM_CONVERSION
:
8827 case GFC_ISYM_LOGICAL
:
8829 gfc_conv_intrinsic_conversion (se
, expr
);
8832 /* Integer conversions are handled separately to make sure we get the
8833 correct rounding mode. */
8838 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
8842 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
8845 case GFC_ISYM_CEILING
:
8846 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
8849 case GFC_ISYM_FLOOR
:
8850 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
8854 gfc_conv_intrinsic_mod (se
, expr
, 0);
8857 case GFC_ISYM_MODULO
:
8858 gfc_conv_intrinsic_mod (se
, expr
, 1);
8861 case GFC_ISYM_CAF_GET
:
8862 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
8866 case GFC_ISYM_CMPLX
:
8867 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
8870 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
8871 gfc_conv_intrinsic_iargc (se
, expr
);
8874 case GFC_ISYM_COMPLEX
:
8875 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
8878 case GFC_ISYM_CONJG
:
8879 gfc_conv_intrinsic_conjg (se
, expr
);
8882 case GFC_ISYM_COUNT
:
8883 gfc_conv_intrinsic_count (se
, expr
);
8886 case GFC_ISYM_CTIME
:
8887 gfc_conv_intrinsic_ctime (se
, expr
);
8891 gfc_conv_intrinsic_dim (se
, expr
);
8894 case GFC_ISYM_DOT_PRODUCT
:
8895 gfc_conv_intrinsic_dot_product (se
, expr
);
8898 case GFC_ISYM_DPROD
:
8899 gfc_conv_intrinsic_dprod (se
, expr
);
8902 case GFC_ISYM_DSHIFTL
:
8903 gfc_conv_intrinsic_dshift (se
, expr
, true);
8906 case GFC_ISYM_DSHIFTR
:
8907 gfc_conv_intrinsic_dshift (se
, expr
, false);
8910 case GFC_ISYM_FDATE
:
8911 gfc_conv_intrinsic_fdate (se
, expr
);
8914 case GFC_ISYM_FRACTION
:
8915 gfc_conv_intrinsic_fraction (se
, expr
);
8919 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
8923 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8927 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
8930 case GFC_ISYM_IBCLR
:
8931 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
8934 case GFC_ISYM_IBITS
:
8935 gfc_conv_intrinsic_ibits (se
, expr
);
8938 case GFC_ISYM_IBSET
:
8939 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
8942 case GFC_ISYM_IACHAR
:
8943 case GFC_ISYM_ICHAR
:
8944 /* We assume ASCII character sequence. */
8945 gfc_conv_intrinsic_ichar (se
, expr
);
8948 case GFC_ISYM_IARGC
:
8949 gfc_conv_intrinsic_iargc (se
, expr
);
8953 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8956 case GFC_ISYM_INDEX
:
8957 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8959 fndecl
= gfor_fndecl_string_index
;
8961 fndecl
= gfor_fndecl_string_index_char4
;
8965 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8969 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8972 case GFC_ISYM_IPARITY
:
8973 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
8976 case GFC_ISYM_IS_IOSTAT_END
:
8977 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
8980 case GFC_ISYM_IS_IOSTAT_EOR
:
8981 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
8984 case GFC_ISYM_ISNAN
:
8985 gfc_conv_intrinsic_isnan (se
, expr
);
8988 case GFC_ISYM_LSHIFT
:
8989 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8992 case GFC_ISYM_RSHIFT
:
8993 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8996 case GFC_ISYM_SHIFTA
:
8997 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9000 case GFC_ISYM_SHIFTL
:
9001 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9004 case GFC_ISYM_SHIFTR
:
9005 gfc_conv_intrinsic_shift (se
, expr
, true, false);
9008 case GFC_ISYM_ISHFT
:
9009 gfc_conv_intrinsic_ishft (se
, expr
);
9012 case GFC_ISYM_ISHFTC
:
9013 gfc_conv_intrinsic_ishftc (se
, expr
);
9016 case GFC_ISYM_LEADZ
:
9017 gfc_conv_intrinsic_leadz (se
, expr
);
9020 case GFC_ISYM_TRAILZ
:
9021 gfc_conv_intrinsic_trailz (se
, expr
);
9024 case GFC_ISYM_POPCNT
:
9025 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
9028 case GFC_ISYM_POPPAR
:
9029 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
9032 case GFC_ISYM_LBOUND
:
9033 gfc_conv_intrinsic_bound (se
, expr
, 0);
9036 case GFC_ISYM_LCOBOUND
:
9037 conv_intrinsic_cobound (se
, expr
);
9040 case GFC_ISYM_TRANSPOSE
:
9041 /* The scalarizer has already been set up for reversed dimension access
9042 order ; now we just get the argument value normally. */
9043 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
9047 gfc_conv_intrinsic_len (se
, expr
);
9050 case GFC_ISYM_LEN_TRIM
:
9051 gfc_conv_intrinsic_len_trim (se
, expr
);
9055 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
9059 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
9063 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
9067 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
9070 case GFC_ISYM_MALLOC
:
9071 gfc_conv_intrinsic_malloc (se
, expr
);
9074 case GFC_ISYM_MASKL
:
9075 gfc_conv_intrinsic_mask (se
, expr
, 1);
9078 case GFC_ISYM_MASKR
:
9079 gfc_conv_intrinsic_mask (se
, expr
, 0);
9083 if (expr
->ts
.type
== BT_CHARACTER
)
9084 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
9086 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
9089 case GFC_ISYM_MAXLOC
:
9090 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9093 case GFC_ISYM_MAXVAL
:
9094 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
9097 case GFC_ISYM_MERGE
:
9098 gfc_conv_intrinsic_merge (se
, expr
);
9101 case GFC_ISYM_MERGE_BITS
:
9102 gfc_conv_intrinsic_merge_bits (se
, expr
);
9106 if (expr
->ts
.type
== BT_CHARACTER
)
9107 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
9109 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
9112 case GFC_ISYM_MINLOC
:
9113 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9116 case GFC_ISYM_MINVAL
:
9117 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
9120 case GFC_ISYM_NEAREST
:
9121 gfc_conv_intrinsic_nearest (se
, expr
);
9124 case GFC_ISYM_NORM2
:
9125 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
9129 gfc_conv_intrinsic_not (se
, expr
);
9133 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9136 case GFC_ISYM_PARITY
:
9137 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
9140 case GFC_ISYM_PRESENT
:
9141 gfc_conv_intrinsic_present (se
, expr
);
9144 case GFC_ISYM_PRODUCT
:
9145 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
9149 gfc_conv_intrinsic_rank (se
, expr
);
9152 case GFC_ISYM_RRSPACING
:
9153 gfc_conv_intrinsic_rrspacing (se
, expr
);
9156 case GFC_ISYM_SET_EXPONENT
:
9157 gfc_conv_intrinsic_set_exponent (se
, expr
);
9160 case GFC_ISYM_SCALE
:
9161 gfc_conv_intrinsic_scale (se
, expr
);
9165 gfc_conv_intrinsic_sign (se
, expr
);
9169 gfc_conv_intrinsic_size (se
, expr
);
9172 case GFC_ISYM_SIZEOF
:
9173 case GFC_ISYM_C_SIZEOF
:
9174 gfc_conv_intrinsic_sizeof (se
, expr
);
9177 case GFC_ISYM_STORAGE_SIZE
:
9178 gfc_conv_intrinsic_storage_size (se
, expr
);
9181 case GFC_ISYM_SPACING
:
9182 gfc_conv_intrinsic_spacing (se
, expr
);
9185 case GFC_ISYM_STRIDE
:
9186 conv_intrinsic_stride (se
, expr
);
9190 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
9193 case GFC_ISYM_TRANSFER
:
9194 if (se
->ss
&& se
->ss
->info
->useflags
)
9195 /* Access the previously obtained result. */
9196 gfc_conv_tmp_array_ref (se
);
9198 gfc_conv_intrinsic_transfer (se
, expr
);
9201 case GFC_ISYM_TTYNAM
:
9202 gfc_conv_intrinsic_ttynam (se
, expr
);
9205 case GFC_ISYM_UBOUND
:
9206 gfc_conv_intrinsic_bound (se
, expr
, 1);
9209 case GFC_ISYM_UCOBOUND
:
9210 conv_intrinsic_cobound (se
, expr
);
9214 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9218 gfc_conv_intrinsic_loc (se
, expr
);
9221 case GFC_ISYM_THIS_IMAGE
:
9222 /* For num_images() == 1, handle as LCOBOUND. */
9223 if (expr
->value
.function
.actual
->expr
9224 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
9225 conv_intrinsic_cobound (se
, expr
);
9227 trans_this_image (se
, expr
);
9230 case GFC_ISYM_IMAGE_INDEX
:
9231 trans_image_index (se
, expr
);
9234 case GFC_ISYM_IMAGE_STATUS
:
9235 conv_intrinsic_image_status (se
, expr
);
9238 case GFC_ISYM_NUM_IMAGES
:
9239 trans_num_images (se
, expr
);
9242 case GFC_ISYM_ACCESS
:
9243 case GFC_ISYM_CHDIR
:
9244 case GFC_ISYM_CHMOD
:
9245 case GFC_ISYM_DTIME
:
9246 case GFC_ISYM_ETIME
:
9247 case GFC_ISYM_EXTENDS_TYPE_OF
:
9249 case GFC_ISYM_FGETC
:
9252 case GFC_ISYM_FPUTC
:
9253 case GFC_ISYM_FSTAT
:
9254 case GFC_ISYM_FTELL
:
9255 case GFC_ISYM_GETCWD
:
9256 case GFC_ISYM_GETGID
:
9257 case GFC_ISYM_GETPID
:
9258 case GFC_ISYM_GETUID
:
9259 case GFC_ISYM_HOSTNM
:
9261 case GFC_ISYM_IERRNO
:
9262 case GFC_ISYM_IRAND
:
9263 case GFC_ISYM_ISATTY
:
9266 case GFC_ISYM_LSTAT
:
9267 case GFC_ISYM_MATMUL
:
9268 case GFC_ISYM_MCLOCK
:
9269 case GFC_ISYM_MCLOCK8
:
9271 case GFC_ISYM_RENAME
:
9272 case GFC_ISYM_SECOND
:
9273 case GFC_ISYM_SECNDS
:
9274 case GFC_ISYM_SIGNAL
:
9276 case GFC_ISYM_SYMLNK
:
9277 case GFC_ISYM_SYSTEM
:
9279 case GFC_ISYM_TIME8
:
9280 case GFC_ISYM_UMASK
:
9281 case GFC_ISYM_UNLINK
:
9283 gfc_conv_intrinsic_funcall (se
, expr
);
9286 case GFC_ISYM_EOSHIFT
:
9288 case GFC_ISYM_RESHAPE
:
9289 /* For those, expr->rank should always be >0 and thus the if above the
9290 switch should have matched. */
9295 gfc_conv_intrinsic_lib_function (se
, expr
);
9302 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
9304 gfc_ss
*arg_ss
, *tmp_ss
;
9305 gfc_actual_arglist
*arg
;
9307 arg
= expr
->value
.function
.actual
;
9309 gcc_assert (arg
->expr
);
9311 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
9312 gcc_assert (arg_ss
!= gfc_ss_terminator
);
9314 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
9316 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
9317 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
9319 gcc_assert (tmp_ss
->dimen
== 2);
9321 /* We just invert dimensions. */
9322 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
9325 /* Stop when tmp_ss points to the last valid element of the chain... */
9326 if (tmp_ss
->next
== gfc_ss_terminator
)
9330 /* ... so that we can attach the rest of the chain to it. */
9337 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9338 This has the side effect of reversing the nested list, so there is no
9339 need to call gfc_reverse_ss on it (the given list is assumed not to be
9343 nest_loop_dimension (gfc_ss
*ss
, int dim
)
9346 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
9347 gfc_loopinfo
*new_loop
;
9349 gcc_assert (ss
!= gfc_ss_terminator
);
9351 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
9353 new_ss
= gfc_get_ss ();
9354 new_ss
->next
= prev_ss
;
9355 new_ss
->parent
= ss
;
9356 new_ss
->info
= ss
->info
;
9357 new_ss
->info
->refcount
++;
9360 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
9361 && ss
->info
->type
!= GFC_SS_REFERENCE
);
9364 new_ss
->dim
[0] = ss
->dim
[dim
];
9366 gcc_assert (dim
< ss
->dimen
);
9368 ss_dim
= --ss
->dimen
;
9369 for (i
= dim
; i
< ss_dim
; i
++)
9370 ss
->dim
[i
] = ss
->dim
[i
+ 1];
9372 ss
->dim
[ss_dim
] = 0;
9378 ss
->nested_ss
->parent
= new_ss
;
9379 new_ss
->nested_ss
= ss
->nested_ss
;
9381 ss
->nested_ss
= new_ss
;
9384 new_loop
= gfc_get_loopinfo ();
9385 gfc_init_loopinfo (new_loop
);
9387 gcc_assert (prev_ss
!= NULL
);
9388 gcc_assert (prev_ss
!= gfc_ss_terminator
);
9389 gfc_add_ss_to_loop (new_loop
, prev_ss
);
9390 return new_ss
->parent
;
9394 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9395 is to be inlined. */
9398 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
9400 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
9401 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
9403 bool scalar_mask
= false;
9405 /* The rank of the result will be determined later. */
9406 arg1
= expr
->value
.function
.actual
;
9409 gcc_assert (arg3
!= NULL
);
9411 if (expr
->rank
== 0)
9414 tmp_ss
= gfc_ss_terminator
;
9420 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
9421 if (mask_ss
== tmp_ss
)
9427 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
9428 gcc_assert (array_ss
!= tmp_ss
);
9430 /* Odd thing: If the mask is scalar, it is used by the frontend after
9431 the array (to make an if around the nested loop). Thus it shall
9432 be after array_ss once the gfc_ss list is reversed. */
9434 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
9438 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9440 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
9441 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
9449 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
9452 switch (expr
->value
.function
.isym
->id
)
9454 case GFC_ISYM_PRODUCT
:
9456 return walk_inline_intrinsic_arith (ss
, expr
);
9458 case GFC_ISYM_TRANSPOSE
:
9459 return walk_inline_intrinsic_transpose (ss
, expr
);
9468 /* This generates code to execute before entering the scalarization loop.
9469 Currently does nothing. */
9472 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
9474 switch (ss
->info
->expr
->value
.function
.isym
->id
)
9476 case GFC_ISYM_UBOUND
:
9477 case GFC_ISYM_LBOUND
:
9478 case GFC_ISYM_UCOBOUND
:
9479 case GFC_ISYM_LCOBOUND
:
9480 case GFC_ISYM_THIS_IMAGE
:
9489 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9490 are expanded into code inside the scalarization loop. */
9493 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
9495 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
9496 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
9498 /* The two argument version returns a scalar. */
9499 if (expr
->value
.function
.actual
->next
->expr
)
9502 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
9506 /* Walk an intrinsic array libcall. */
9509 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
9511 gcc_assert (expr
->rank
> 0);
9512 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9516 /* Return whether the function call expression EXPR will be expanded
9517 inline by gfc_conv_intrinsic_function. */
9520 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
9522 gfc_actual_arglist
*args
;
9524 if (!expr
->value
.function
.isym
)
9527 switch (expr
->value
.function
.isym
->id
)
9529 case GFC_ISYM_PRODUCT
:
9531 /* Disable inline expansion if code size matters. */
9535 args
= expr
->value
.function
.actual
;
9536 /* We need to be able to subset the SUM argument at compile-time. */
9537 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
9542 case GFC_ISYM_TRANSPOSE
:
9551 /* Returns nonzero if the specified intrinsic function call maps directly to
9552 an external library call. Should only be used for functions that return
9556 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
9558 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
9559 gcc_assert (expr
->rank
> 0);
9561 if (gfc_inline_intrinsic_function_p (expr
))
9564 switch (expr
->value
.function
.isym
->id
)
9568 case GFC_ISYM_COUNT
:
9572 case GFC_ISYM_IPARITY
:
9573 case GFC_ISYM_MATMUL
:
9574 case GFC_ISYM_MAXLOC
:
9575 case GFC_ISYM_MAXVAL
:
9576 case GFC_ISYM_MINLOC
:
9577 case GFC_ISYM_MINVAL
:
9578 case GFC_ISYM_NORM2
:
9579 case GFC_ISYM_PARITY
:
9580 case GFC_ISYM_PRODUCT
:
9582 case GFC_ISYM_SHAPE
:
9583 case GFC_ISYM_SPREAD
:
9585 /* Ignore absent optional parameters. */
9588 case GFC_ISYM_CSHIFT
:
9589 case GFC_ISYM_EOSHIFT
:
9590 case GFC_ISYM_FAILED_IMAGES
:
9591 case GFC_ISYM_STOPPED_IMAGES
:
9593 case GFC_ISYM_RESHAPE
:
9594 case GFC_ISYM_UNPACK
:
9595 /* Pass absent optional parameters. */
9603 /* Walk an intrinsic function. */
9605 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
9606 gfc_intrinsic_sym
* isym
)
9610 if (isym
->elemental
)
9611 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9612 NULL
, GFC_SS_SCALAR
);
9614 if (expr
->rank
== 0)
9617 if (gfc_inline_intrinsic_function_p (expr
))
9618 return walk_inline_intrinsic_function (ss
, expr
);
9620 if (gfc_is_intrinsic_libcall (expr
))
9621 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9623 /* Special cases. */
9626 case GFC_ISYM_LBOUND
:
9627 case GFC_ISYM_LCOBOUND
:
9628 case GFC_ISYM_UBOUND
:
9629 case GFC_ISYM_UCOBOUND
:
9630 case GFC_ISYM_THIS_IMAGE
:
9631 return gfc_walk_intrinsic_bound (ss
, expr
);
9633 case GFC_ISYM_TRANSFER
:
9634 case GFC_ISYM_CAF_GET
:
9635 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9638 /* This probably meant someone forgot to add an intrinsic to the above
9639 list(s) when they implemented it, or something's gone horribly
9647 conv_co_collective (gfc_code
*code
)
9650 stmtblock_t block
, post_block
;
9651 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
9652 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
9654 gfc_start_block (&block
);
9655 gfc_init_block (&post_block
);
9657 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
9659 opr_expr
= code
->ext
.actual
->next
->expr
;
9660 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
9661 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9662 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
9667 image_idx_expr
= code
->ext
.actual
->next
->expr
;
9668 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9669 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9675 gfc_init_se (&argse
, NULL
);
9676 gfc_conv_expr (&argse
, stat_expr
);
9677 gfc_add_block_to_block (&block
, &argse
.pre
);
9678 gfc_add_block_to_block (&post_block
, &argse
.post
);
9680 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
9681 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
9683 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9686 stat
= null_pointer_node
;
9688 /* Early exit for GFC_FCOARRAY_SINGLE. */
9689 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9691 if (stat
!= NULL_TREE
)
9692 gfc_add_modify (&block
, stat
,
9693 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
9694 return gfc_finish_block (&block
);
9697 /* Handle the array. */
9698 gfc_init_se (&argse
, NULL
);
9699 if (code
->ext
.actual
->expr
->rank
== 0)
9701 symbol_attribute attr
;
9702 gfc_clear_attr (&attr
);
9703 gfc_init_se (&argse
, NULL
);
9704 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9705 gfc_add_block_to_block (&block
, &argse
.pre
);
9706 gfc_add_block_to_block (&post_block
, &argse
.post
);
9707 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
9708 array
= gfc_build_addr_expr (NULL_TREE
, array
);
9712 argse
.want_pointer
= 1;
9713 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
9716 gfc_add_block_to_block (&block
, &argse
.pre
);
9717 gfc_add_block_to_block (&post_block
, &argse
.post
);
9719 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
9720 strlen
= argse
.string_length
;
9722 strlen
= integer_zero_node
;
9727 gfc_init_se (&argse
, NULL
);
9728 gfc_conv_expr (&argse
, image_idx_expr
);
9729 gfc_add_block_to_block (&block
, &argse
.pre
);
9730 gfc_add_block_to_block (&post_block
, &argse
.post
);
9731 image_index
= fold_convert (integer_type_node
, argse
.expr
);
9734 image_index
= integer_zero_node
;
9739 gfc_init_se (&argse
, NULL
);
9740 gfc_conv_expr (&argse
, errmsg_expr
);
9741 gfc_add_block_to_block (&block
, &argse
.pre
);
9742 gfc_add_block_to_block (&post_block
, &argse
.post
);
9743 errmsg
= argse
.expr
;
9744 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
9748 errmsg
= null_pointer_node
;
9749 errmsg_len
= integer_zero_node
;
9752 /* Generate the function call. */
9753 switch (code
->resolved_isym
->id
)
9755 case GFC_ISYM_CO_BROADCAST
:
9756 fndecl
= gfor_fndecl_co_broadcast
;
9758 case GFC_ISYM_CO_MAX
:
9759 fndecl
= gfor_fndecl_co_max
;
9761 case GFC_ISYM_CO_MIN
:
9762 fndecl
= gfor_fndecl_co_min
;
9764 case GFC_ISYM_CO_REDUCE
:
9765 fndecl
= gfor_fndecl_co_reduce
;
9767 case GFC_ISYM_CO_SUM
:
9768 fndecl
= gfor_fndecl_co_sum
;
9774 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
9775 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
9776 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
9777 image_index
, stat
, errmsg
, errmsg_len
);
9778 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
9779 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
9780 stat
, errmsg
, strlen
, errmsg_len
);
9783 tree opr
, opr_flags
;
9785 // FIXME: Handle TS29113's bind(C) strings with descriptor.
9787 if (gfc_is_proc_ptr_comp (opr_expr
))
9789 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
9790 opr_flag_int
= sym
->attr
.dimension
9791 || (sym
->ts
.type
== BT_CHARACTER
9792 && !sym
->attr
.is_bind_c
)
9793 ? GFC_CAF_BYREF
: 0;
9794 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9795 && !sym
->attr
.is_bind_c
9796 ? GFC_CAF_HIDDENLEN
: 0;
9797 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
9801 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
9802 ? GFC_CAF_BYREF
: 0;
9803 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9804 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
9805 ? GFC_CAF_HIDDENLEN
: 0;
9806 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
9807 ? GFC_CAF_ARG_VALUE
: 0;
9809 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
9810 gfc_conv_expr (&argse
, opr_expr
);
9812 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
9813 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
9816 gfc_add_expr_to_block (&block
, fndecl
);
9817 gfc_add_block_to_block (&block
, &post_block
);
9819 return gfc_finish_block (&block
);
9824 conv_intrinsic_atomic_op (gfc_code
*code
)
9827 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
9828 stmtblock_t block
, post_block
;
9829 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9830 gfc_expr
*stat_expr
;
9831 built_in_function fn
;
9833 if (atom_expr
->expr_type
== EXPR_FUNCTION
9834 && atom_expr
->value
.function
.isym
9835 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9836 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9838 gfc_start_block (&block
);
9839 gfc_init_block (&post_block
);
9841 gfc_init_se (&argse
, NULL
);
9842 argse
.want_pointer
= 1;
9843 gfc_conv_expr (&argse
, atom_expr
);
9844 gfc_add_block_to_block (&block
, &argse
.pre
);
9845 gfc_add_block_to_block (&post_block
, &argse
.post
);
9848 gfc_init_se (&argse
, NULL
);
9849 if (flag_coarray
== GFC_FCOARRAY_LIB
9850 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9851 argse
.want_pointer
= 1;
9852 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9853 gfc_add_block_to_block (&block
, &argse
.pre
);
9854 gfc_add_block_to_block (&post_block
, &argse
.post
);
9857 switch (code
->resolved_isym
->id
)
9859 case GFC_ISYM_ATOMIC_ADD
:
9860 case GFC_ISYM_ATOMIC_AND
:
9861 case GFC_ISYM_ATOMIC_DEF
:
9862 case GFC_ISYM_ATOMIC_OR
:
9863 case GFC_ISYM_ATOMIC_XOR
:
9864 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9865 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9866 old
= null_pointer_node
;
9869 gfc_init_se (&argse
, NULL
);
9870 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9871 argse
.want_pointer
= 1;
9872 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9873 gfc_add_block_to_block (&block
, &argse
.pre
);
9874 gfc_add_block_to_block (&post_block
, &argse
.post
);
9876 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9880 if (stat_expr
!= NULL
)
9882 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
9883 gfc_init_se (&argse
, NULL
);
9884 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9885 argse
.want_pointer
= 1;
9886 gfc_conv_expr_val (&argse
, stat_expr
);
9887 gfc_add_block_to_block (&block
, &argse
.pre
);
9888 gfc_add_block_to_block (&post_block
, &argse
.post
);
9891 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9892 stat
= null_pointer_node
;
9894 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9896 tree image_index
, caf_decl
, offset
, token
;
9899 switch (code
->resolved_isym
->id
)
9901 case GFC_ISYM_ATOMIC_ADD
:
9902 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9903 op
= (int) GFC_CAF_ATOMIC_ADD
;
9905 case GFC_ISYM_ATOMIC_AND
:
9906 case GFC_ISYM_ATOMIC_FETCH_AND
:
9907 op
= (int) GFC_CAF_ATOMIC_AND
;
9909 case GFC_ISYM_ATOMIC_OR
:
9910 case GFC_ISYM_ATOMIC_FETCH_OR
:
9911 op
= (int) GFC_CAF_ATOMIC_OR
;
9913 case GFC_ISYM_ATOMIC_XOR
:
9914 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9915 op
= (int) GFC_CAF_ATOMIC_XOR
;
9917 case GFC_ISYM_ATOMIC_DEF
:
9918 op
= 0; /* Unused. */
9924 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9925 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9926 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9928 if (gfc_is_coindexed (atom_expr
))
9929 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9931 image_index
= integer_zero_node
;
9933 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9935 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9936 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
9937 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9940 gfc_init_se (&argse
, NULL
);
9941 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
9944 gfc_add_block_to_block (&block
, &argse
.pre
);
9945 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
9946 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
9947 token
, offset
, image_index
, value
, stat
,
9948 build_int_cst (integer_type_node
,
9949 (int) atom_expr
->ts
.type
),
9950 build_int_cst (integer_type_node
,
9951 (int) atom_expr
->ts
.kind
));
9953 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
9954 build_int_cst (integer_type_node
, op
),
9955 token
, offset
, image_index
, value
, old
, stat
,
9956 build_int_cst (integer_type_node
,
9957 (int) atom_expr
->ts
.type
),
9958 build_int_cst (integer_type_node
,
9959 (int) atom_expr
->ts
.kind
));
9961 gfc_add_expr_to_block (&block
, tmp
);
9962 gfc_add_block_to_block (&block
, &argse
.post
);
9963 gfc_add_block_to_block (&block
, &post_block
);
9964 return gfc_finish_block (&block
);
9968 switch (code
->resolved_isym
->id
)
9970 case GFC_ISYM_ATOMIC_ADD
:
9971 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9972 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
9974 case GFC_ISYM_ATOMIC_AND
:
9975 case GFC_ISYM_ATOMIC_FETCH_AND
:
9976 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
9978 case GFC_ISYM_ATOMIC_DEF
:
9979 fn
= BUILT_IN_ATOMIC_STORE_N
;
9981 case GFC_ISYM_ATOMIC_OR
:
9982 case GFC_ISYM_ATOMIC_FETCH_OR
:
9983 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
9985 case GFC_ISYM_ATOMIC_XOR
:
9986 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9987 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
9993 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9994 fn
= (built_in_function
) ((int) fn
9995 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9997 tmp
= builtin_decl_explicit (fn
);
9998 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
9999 tmp
= builtin_decl_explicit (fn
);
10001 switch (code
->resolved_isym
->id
)
10003 case GFC_ISYM_ATOMIC_ADD
:
10004 case GFC_ISYM_ATOMIC_AND
:
10005 case GFC_ISYM_ATOMIC_DEF
:
10006 case GFC_ISYM_ATOMIC_OR
:
10007 case GFC_ISYM_ATOMIC_XOR
:
10008 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10009 fold_convert (itype
, value
),
10010 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10011 gfc_add_expr_to_block (&block
, tmp
);
10014 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10015 fold_convert (itype
, value
),
10016 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10017 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
10021 if (stat
!= NULL_TREE
)
10022 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10023 gfc_add_block_to_block (&block
, &post_block
);
10024 return gfc_finish_block (&block
);
10029 conv_intrinsic_atomic_ref (gfc_code
*code
)
10032 tree tmp
, atom
, value
, stat
= NULL_TREE
;
10033 stmtblock_t block
, post_block
;
10034 built_in_function fn
;
10035 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
10037 if (atom_expr
->expr_type
== EXPR_FUNCTION
10038 && atom_expr
->value
.function
.isym
10039 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10040 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10042 gfc_start_block (&block
);
10043 gfc_init_block (&post_block
);
10044 gfc_init_se (&argse
, NULL
);
10045 argse
.want_pointer
= 1;
10046 gfc_conv_expr (&argse
, atom_expr
);
10047 gfc_add_block_to_block (&block
, &argse
.pre
);
10048 gfc_add_block_to_block (&post_block
, &argse
.post
);
10051 gfc_init_se (&argse
, NULL
);
10052 if (flag_coarray
== GFC_FCOARRAY_LIB
10053 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10054 argse
.want_pointer
= 1;
10055 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10056 gfc_add_block_to_block (&block
, &argse
.pre
);
10057 gfc_add_block_to_block (&post_block
, &argse
.post
);
10058 value
= argse
.expr
;
10061 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
10063 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10065 gfc_init_se (&argse
, NULL
);
10066 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10067 argse
.want_pointer
= 1;
10068 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10069 gfc_add_block_to_block (&block
, &argse
.pre
);
10070 gfc_add_block_to_block (&post_block
, &argse
.post
);
10073 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10074 stat
= null_pointer_node
;
10076 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10078 tree image_index
, caf_decl
, offset
, token
;
10079 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
10081 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10082 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10083 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10085 if (gfc_is_coindexed (atom_expr
))
10086 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10088 image_index
= integer_zero_node
;
10090 gfc_init_se (&argse
, NULL
);
10091 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10093 gfc_add_block_to_block (&block
, &argse
.pre
);
10095 /* Different type, need type conversion. */
10096 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10098 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10099 orig_value
= value
;
10100 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
10103 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
10104 token
, offset
, image_index
, value
, stat
,
10105 build_int_cst (integer_type_node
,
10106 (int) atom_expr
->ts
.type
),
10107 build_int_cst (integer_type_node
,
10108 (int) atom_expr
->ts
.kind
));
10109 gfc_add_expr_to_block (&block
, tmp
);
10110 if (vardecl
!= NULL_TREE
)
10111 gfc_add_modify (&block
, orig_value
,
10112 fold_convert (TREE_TYPE (orig_value
), vardecl
));
10113 gfc_add_block_to_block (&block
, &argse
.post
);
10114 gfc_add_block_to_block (&block
, &post_block
);
10115 return gfc_finish_block (&block
);
10118 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10119 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
10120 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10122 tmp
= builtin_decl_explicit (fn
);
10123 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
10124 build_int_cst (integer_type_node
,
10125 MEMMODEL_RELAXED
));
10126 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
10128 if (stat
!= NULL_TREE
)
10129 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10130 gfc_add_block_to_block (&block
, &post_block
);
10131 return gfc_finish_block (&block
);
10136 conv_intrinsic_atomic_cas (gfc_code
*code
)
10139 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
10140 stmtblock_t block
, post_block
;
10141 built_in_function fn
;
10142 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10144 if (atom_expr
->expr_type
== EXPR_FUNCTION
10145 && atom_expr
->value
.function
.isym
10146 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10147 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10149 gfc_init_block (&block
);
10150 gfc_init_block (&post_block
);
10151 gfc_init_se (&argse
, NULL
);
10152 argse
.want_pointer
= 1;
10153 gfc_conv_expr (&argse
, atom_expr
);
10156 gfc_init_se (&argse
, NULL
);
10157 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10158 argse
.want_pointer
= 1;
10159 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10160 gfc_add_block_to_block (&block
, &argse
.pre
);
10161 gfc_add_block_to_block (&post_block
, &argse
.post
);
10164 gfc_init_se (&argse
, NULL
);
10165 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10166 argse
.want_pointer
= 1;
10167 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10168 gfc_add_block_to_block (&block
, &argse
.pre
);
10169 gfc_add_block_to_block (&post_block
, &argse
.post
);
10172 gfc_init_se (&argse
, NULL
);
10173 if (flag_coarray
== GFC_FCOARRAY_LIB
10174 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
10175 == atom_expr
->ts
.kind
)
10176 argse
.want_pointer
= 1;
10177 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
10178 gfc_add_block_to_block (&block
, &argse
.pre
);
10179 gfc_add_block_to_block (&post_block
, &argse
.post
);
10180 new_val
= argse
.expr
;
10183 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
10185 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
10187 gfc_init_se (&argse
, NULL
);
10188 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10189 argse
.want_pointer
= 1;
10190 gfc_conv_expr_val (&argse
,
10191 code
->ext
.actual
->next
->next
->next
->next
->expr
);
10192 gfc_add_block_to_block (&block
, &argse
.pre
);
10193 gfc_add_block_to_block (&post_block
, &argse
.post
);
10196 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10197 stat
= null_pointer_node
;
10199 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10201 tree image_index
, caf_decl
, offset
, token
;
10203 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10204 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10205 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10207 if (gfc_is_coindexed (atom_expr
))
10208 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10210 image_index
= integer_zero_node
;
10212 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
10214 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
10215 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
10216 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10219 /* Convert a constant to a pointer. */
10220 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
10222 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
10223 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
10224 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10227 gfc_init_se (&argse
, NULL
);
10228 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10230 gfc_add_block_to_block (&block
, &argse
.pre
);
10232 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
10233 token
, offset
, image_index
, old
, comp
, new_val
,
10234 stat
, build_int_cst (integer_type_node
,
10235 (int) atom_expr
->ts
.type
),
10236 build_int_cst (integer_type_node
,
10237 (int) atom_expr
->ts
.kind
));
10238 gfc_add_expr_to_block (&block
, tmp
);
10239 gfc_add_block_to_block (&block
, &argse
.post
);
10240 gfc_add_block_to_block (&block
, &post_block
);
10241 return gfc_finish_block (&block
);
10244 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10245 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10246 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10248 tmp
= builtin_decl_explicit (fn
);
10250 gfc_add_modify (&block
, old
, comp
);
10251 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
10252 gfc_build_addr_expr (NULL
, old
),
10253 fold_convert (TREE_TYPE (old
), new_val
),
10254 boolean_false_node
,
10255 build_int_cst (NULL
, MEMMODEL_RELAXED
),
10256 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10257 gfc_add_expr_to_block (&block
, tmp
);
10259 if (stat
!= NULL_TREE
)
10260 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10261 gfc_add_block_to_block (&block
, &post_block
);
10262 return gfc_finish_block (&block
);
10266 conv_intrinsic_event_query (gfc_code
*code
)
10269 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
10270 tree count
= NULL_TREE
, count2
= NULL_TREE
;
10272 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
10274 if (code
->ext
.actual
->next
->next
->expr
)
10276 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10278 gfc_init_se (&argse
, NULL
);
10279 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10282 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10283 stat
= null_pointer_node
;
10285 if (code
->ext
.actual
->next
->expr
)
10287 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
10288 gfc_init_se (&argse
, NULL
);
10289 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
10290 count
= argse
.expr
;
10293 gfc_start_block (&se
.pre
);
10294 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10296 tree tmp
, token
, image_index
;
10297 tree index
= size_zero_node
;
10299 if (event_expr
->expr_type
== EXPR_FUNCTION
10300 && event_expr
->value
.function
.isym
10301 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10302 event_expr
= event_expr
->value
.function
.actual
->expr
;
10304 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
10306 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10307 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
10308 != INTMOD_ISO_FORTRAN_ENV
10309 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
10310 != ISOFORTRAN_EVENT_TYPE
)
10312 gfc_error ("Sorry, the event component of derived type at %L is not "
10313 "yet supported", &event_expr
->where
);
10317 if (gfc_is_coindexed (event_expr
))
10319 gfc_error ("The event variable at %L shall not be coindexed",
10320 &event_expr
->where
);
10324 image_index
= integer_zero_node
;
10326 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10329 /* For arrays, obtain the array index. */
10330 if (gfc_expr_attr (event_expr
).dimension
)
10332 tree desc
, tmp
, extent
, lbound
, ubound
;
10333 gfc_array_ref
*ar
, ar2
;
10336 /* TODO: Extend this, once DT components are supported. */
10337 ar
= &event_expr
->ref
->u
.ar
;
10339 memset (ar
, '\0', sizeof (*ar
));
10341 ar
->type
= AR_FULL
;
10343 gfc_init_se (&argse
, NULL
);
10344 argse
.descriptor_only
= 1;
10345 gfc_conv_expr_descriptor (&argse
, event_expr
);
10346 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
10350 extent
= integer_one_node
;
10351 for (i
= 0; i
< ar
->dimen
; i
++)
10353 gfc_init_se (&argse
, NULL
);
10354 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
10355 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
10356 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
10357 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10358 integer_type_node
, argse
.expr
,
10359 fold_convert(integer_type_node
, lbound
));
10360 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10361 integer_type_node
, extent
, tmp
);
10362 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
10363 integer_type_node
, index
, tmp
);
10364 if (i
< ar
->dimen
- 1)
10366 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
10367 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10368 tmp
= fold_convert (integer_type_node
, tmp
);
10369 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
10370 integer_type_node
, extent
, tmp
);
10375 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
10378 count
= gfc_create_var (integer_type_node
, "count");
10381 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
10384 stat
= gfc_create_var (integer_type_node
, "stat");
10387 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
10388 token
, index
, image_index
, count
10389 ? gfc_build_addr_expr (NULL
, count
) : count
,
10390 stat
!= null_pointer_node
10391 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
10392 gfc_add_expr_to_block (&se
.pre
, tmp
);
10394 if (count2
!= NULL_TREE
)
10395 gfc_add_modify (&se
.pre
, count2
,
10396 fold_convert (TREE_TYPE (count2
), count
));
10398 if (stat2
!= NULL_TREE
)
10399 gfc_add_modify (&se
.pre
, stat2
,
10400 fold_convert (TREE_TYPE (stat2
), stat
));
10402 return gfc_finish_block (&se
.pre
);
10405 gfc_init_se (&argse
, NULL
);
10406 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
10407 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
10409 if (stat
!= NULL_TREE
)
10410 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10412 return gfc_finish_block (&se
.pre
);
10416 conv_intrinsic_move_alloc (gfc_code
*code
)
10419 gfc_expr
*from_expr
, *to_expr
;
10420 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
10421 gfc_se from_se
, to_se
;
10425 gfc_start_block (&block
);
10427 from_expr
= code
->ext
.actual
->expr
;
10428 to_expr
= code
->ext
.actual
->next
->expr
;
10430 gfc_init_se (&from_se
, NULL
);
10431 gfc_init_se (&to_se
, NULL
);
10433 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
10434 || to_expr
->ts
.type
== BT_CLASS
);
10435 coarray
= gfc_get_corank (from_expr
) != 0;
10437 if (from_expr
->rank
== 0 && !coarray
)
10439 if (from_expr
->ts
.type
!= BT_CLASS
)
10440 from_expr2
= from_expr
;
10443 from_expr2
= gfc_copy_expr (from_expr
);
10444 gfc_add_data_component (from_expr2
);
10447 if (to_expr
->ts
.type
!= BT_CLASS
)
10448 to_expr2
= to_expr
;
10451 to_expr2
= gfc_copy_expr (to_expr
);
10452 gfc_add_data_component (to_expr2
);
10455 from_se
.want_pointer
= 1;
10456 to_se
.want_pointer
= 1;
10457 gfc_conv_expr (&from_se
, from_expr2
);
10458 gfc_conv_expr (&to_se
, to_expr2
);
10459 gfc_add_block_to_block (&block
, &from_se
.pre
);
10460 gfc_add_block_to_block (&block
, &to_se
.pre
);
10462 /* Deallocate "to". */
10463 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10464 true, to_expr
, to_expr
->ts
);
10465 gfc_add_expr_to_block (&block
, tmp
);
10467 /* Assign (_data) pointers. */
10468 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10469 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
10471 /* Set "from" to NULL. */
10472 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10473 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
10475 gfc_add_block_to_block (&block
, &from_se
.post
);
10476 gfc_add_block_to_block (&block
, &to_se
.post
);
10479 if (to_expr
->ts
.type
== BT_CLASS
)
10483 gfc_free_expr (to_expr2
);
10484 gfc_init_se (&to_se
, NULL
);
10485 to_se
.want_pointer
= 1;
10486 gfc_add_vptr_component (to_expr
);
10487 gfc_conv_expr (&to_se
, to_expr
);
10489 if (from_expr
->ts
.type
== BT_CLASS
)
10491 if (UNLIMITED_POLY (from_expr
))
10495 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10499 gfc_free_expr (from_expr2
);
10500 gfc_init_se (&from_se
, NULL
);
10501 from_se
.want_pointer
= 1;
10502 gfc_add_vptr_component (from_expr
);
10503 gfc_conv_expr (&from_se
, from_expr
);
10504 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10505 fold_convert (TREE_TYPE (to_se
.expr
),
10508 /* Reset _vptr component to declared type. */
10510 /* Unlimited polymorphic. */
10511 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10512 fold_convert (TREE_TYPE (from_se
.expr
),
10513 null_pointer_node
));
10516 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10517 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10518 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10523 vtab
= gfc_find_vtab (&from_expr
->ts
);
10525 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10526 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10527 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10531 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10533 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10534 fold_convert (TREE_TYPE (to_se
.string_length
),
10535 from_se
.string_length
));
10536 if (from_expr
->ts
.deferred
)
10537 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10538 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10541 return gfc_finish_block (&block
);
10544 /* Update _vptr component. */
10545 if (to_expr
->ts
.type
== BT_CLASS
)
10549 to_se
.want_pointer
= 1;
10550 to_expr2
= gfc_copy_expr (to_expr
);
10551 gfc_add_vptr_component (to_expr2
);
10552 gfc_conv_expr (&to_se
, to_expr2
);
10554 if (from_expr
->ts
.type
== BT_CLASS
)
10556 if (UNLIMITED_POLY (from_expr
))
10560 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10564 from_se
.want_pointer
= 1;
10565 from_expr2
= gfc_copy_expr (from_expr
);
10566 gfc_add_vptr_component (from_expr2
);
10567 gfc_conv_expr (&from_se
, from_expr2
);
10568 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10569 fold_convert (TREE_TYPE (to_se
.expr
),
10572 /* Reset _vptr component to declared type. */
10574 /* Unlimited polymorphic. */
10575 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10576 fold_convert (TREE_TYPE (from_se
.expr
),
10577 null_pointer_node
));
10580 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10581 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10582 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10587 vtab
= gfc_find_vtab (&from_expr
->ts
);
10589 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10590 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10591 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10594 gfc_free_expr (to_expr2
);
10595 gfc_init_se (&to_se
, NULL
);
10597 if (from_expr
->ts
.type
== BT_CLASS
)
10599 gfc_free_expr (from_expr2
);
10600 gfc_init_se (&from_se
, NULL
);
10605 /* Deallocate "to". */
10606 if (from_expr
->rank
== 0)
10608 to_se
.want_coarray
= 1;
10609 from_se
.want_coarray
= 1;
10611 gfc_conv_expr_descriptor (&to_se
, to_expr
);
10612 gfc_conv_expr_descriptor (&from_se
, from_expr
);
10614 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10615 is an image control "statement", cf. IR F08/0040 in 12-006A. */
10616 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10620 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10621 NULL_TREE
, NULL_TREE
, true, to_expr
,
10622 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
10623 gfc_add_expr_to_block (&block
, tmp
);
10625 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10626 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10627 logical_type_node
, tmp
,
10628 fold_convert (TREE_TYPE (tmp
),
10629 null_pointer_node
));
10630 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
10631 3, null_pointer_node
, null_pointer_node
,
10632 build_int_cst (integer_type_node
, 0));
10634 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
10635 tmp
, build_empty_stmt (input_location
));
10636 gfc_add_expr_to_block (&block
, tmp
);
10640 if (to_expr
->ts
.type
== BT_DERIVED
10641 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
10643 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
10644 to_se
.expr
, to_expr
->rank
);
10645 gfc_add_expr_to_block (&block
, tmp
);
10648 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10649 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10650 NULL_TREE
, true, to_expr
,
10651 GFC_CAF_COARRAY_NOCOARRAY
);
10652 gfc_add_expr_to_block (&block
, tmp
);
10655 /* Move the pointer and update the array descriptor data. */
10656 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
10658 /* Set "from" to NULL. */
10659 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
10660 gfc_add_modify_loc (input_location
, &block
, tmp
,
10661 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
10664 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10666 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10667 fold_convert (TREE_TYPE (to_se
.string_length
),
10668 from_se
.string_length
));
10669 if (from_expr
->ts
.deferred
)
10670 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10671 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10674 return gfc_finish_block (&block
);
10679 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
10683 gcc_assert (code
->resolved_isym
);
10685 switch (code
->resolved_isym
->id
)
10687 case GFC_ISYM_MOVE_ALLOC
:
10688 res
= conv_intrinsic_move_alloc (code
);
10691 case GFC_ISYM_ATOMIC_CAS
:
10692 res
= conv_intrinsic_atomic_cas (code
);
10695 case GFC_ISYM_ATOMIC_ADD
:
10696 case GFC_ISYM_ATOMIC_AND
:
10697 case GFC_ISYM_ATOMIC_DEF
:
10698 case GFC_ISYM_ATOMIC_OR
:
10699 case GFC_ISYM_ATOMIC_XOR
:
10700 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10701 case GFC_ISYM_ATOMIC_FETCH_AND
:
10702 case GFC_ISYM_ATOMIC_FETCH_OR
:
10703 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10704 res
= conv_intrinsic_atomic_op (code
);
10707 case GFC_ISYM_ATOMIC_REF
:
10708 res
= conv_intrinsic_atomic_ref (code
);
10711 case GFC_ISYM_EVENT_QUERY
:
10712 res
= conv_intrinsic_event_query (code
);
10715 case GFC_ISYM_C_F_POINTER
:
10716 case GFC_ISYM_C_F_PROCPOINTER
:
10717 res
= conv_isocbinding_subroutine (code
);
10720 case GFC_ISYM_CAF_SEND
:
10721 res
= conv_caf_send (code
);
10724 case GFC_ISYM_CO_BROADCAST
:
10725 case GFC_ISYM_CO_MIN
:
10726 case GFC_ISYM_CO_MAX
:
10727 case GFC_ISYM_CO_REDUCE
:
10728 case GFC_ISYM_CO_SUM
:
10729 res
= conv_co_collective (code
);
10732 case GFC_ISYM_FREE
:
10733 res
= conv_intrinsic_free (code
);
10736 case GFC_ISYM_SYSTEM_CLOCK
:
10737 res
= conv_intrinsic_system_clock (code
);
10748 #include "gt-fortran-trans-intrinsic.h"