1 /* Intrinsic translation
2 Copyright (C) 2002-2016 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "tree-nested.h"
35 #include "stor-layout.h"
36 #include "toplev.h" /* For rest_of_decl_compilation. */
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 #include "dependency.h" /* For CAF array alias analysis. */
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 /* This maps Fortran intrinsic math functions to external library or GCC
46 typedef struct GTY(()) gfc_intrinsic_map_t
{
47 /* The explicit enum is required to work around inadequacies in the
48 garbage collection/gengtype parsing mechanism. */
51 /* Enum value from the "language-independent", aka C-centric, part
52 of gcc, or END_BUILTINS of no such value set. */
53 enum built_in_function float_built_in
;
54 enum built_in_function double_built_in
;
55 enum built_in_function long_double_built_in
;
56 enum built_in_function complex_float_built_in
;
57 enum built_in_function complex_double_built_in
;
58 enum built_in_function complex_long_double_built_in
;
60 /* True if the naming pattern is to prepend "c" for complex and
61 append "f" for kind=4. False if the naming pattern is to
62 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
65 /* True if a complex version of the function exists. */
66 bool complex_available
;
68 /* True if the function should be marked const. */
71 /* The base library name of this function. */
74 /* Cache decls created for the various operand types. */
86 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
87 defines complex variants of all of the entries in mathbuiltins.def
89 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
90 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
91 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
92 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
93 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
95 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
96 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
97 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
98 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
99 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
101 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
102 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
107 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
108 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
109 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
115 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
116 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
117 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
118 #include "mathbuiltins.def"
120 /* Functions in libgfortran. */
121 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
124 LIB_FUNCTION (NONE
, NULL
, false)
129 #undef DEFINE_MATH_BUILTIN
130 #undef DEFINE_MATH_BUILTIN_C
133 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
136 /* Find the correct variant of a given builtin from its argument. */
138 builtin_decl_for_precision (enum built_in_function base_built_in
,
141 enum built_in_function i
= END_BUILTINS
;
143 gfc_intrinsic_map_t
*m
;
144 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
147 if (precision
== TYPE_PRECISION (float_type_node
))
148 i
= m
->float_built_in
;
149 else if (precision
== TYPE_PRECISION (double_type_node
))
150 i
= m
->double_built_in
;
151 else if (precision
== TYPE_PRECISION (long_double_type_node
))
152 i
= m
->long_double_built_in
;
153 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
155 /* Special treatment, because it is not exactly a built-in, but
156 a library function. */
157 return m
->real16_decl
;
160 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
165 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
168 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
170 if (gfc_real_kinds
[i
].c_float128
)
172 /* For __float128, the story is a bit different, because we return
173 a decl to a library function rather than a built-in. */
174 gfc_intrinsic_map_t
*m
;
175 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
178 return m
->real16_decl
;
181 return builtin_decl_for_precision (double_built_in
,
182 gfc_real_kinds
[i
].mode_precision
);
186 /* Evaluate the arguments to an intrinsic function. The value
187 of NARGS may be less than the actual number of arguments in EXPR
188 to allow optional "KIND" arguments that are not included in the
189 generated code to be ignored. */
192 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
193 tree
*argarray
, int nargs
)
195 gfc_actual_arglist
*actual
;
197 gfc_intrinsic_arg
*formal
;
201 formal
= expr
->value
.function
.isym
->formal
;
202 actual
= expr
->value
.function
.actual
;
204 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
205 actual
= actual
->next
,
206 formal
= formal
? formal
->next
: NULL
)
210 /* Skip omitted optional arguments. */
217 /* Evaluate the parameter. This will substitute scalarized
218 references automatically. */
219 gfc_init_se (&argse
, se
);
221 if (e
->ts
.type
== BT_CHARACTER
)
223 gfc_conv_expr (&argse
, e
);
224 gfc_conv_string_parameter (&argse
);
225 argarray
[curr_arg
++] = argse
.string_length
;
226 gcc_assert (curr_arg
< nargs
);
229 gfc_conv_expr_val (&argse
, e
);
231 /* If an optional argument is itself an optional dummy argument,
232 check its presence and substitute a null if absent. */
233 if (e
->expr_type
== EXPR_VARIABLE
234 && e
->symtree
->n
.sym
->attr
.optional
237 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
239 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
240 gfc_add_block_to_block (&se
->post
, &argse
.post
);
241 argarray
[curr_arg
] = argse
.expr
;
245 /* Count the number of actual arguments to the intrinsic function EXPR
246 including any "hidden" string length arguments. */
249 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
252 gfc_actual_arglist
*actual
;
254 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
259 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
269 /* Conversions between different types are output by the frontend as
270 intrinsic functions. We implement these directly with inline code. */
273 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
279 nargs
= gfc_intrinsic_argument_list_length (expr
);
280 args
= XALLOCAVEC (tree
, nargs
);
282 /* Evaluate all the arguments passed. Whilst we're only interested in the
283 first one here, there are other parts of the front-end that assume this
284 and will trigger an ICE if it's not the case. */
285 type
= gfc_typenode_for_spec (&expr
->ts
);
286 gcc_assert (expr
->value
.function
.actual
->expr
);
287 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
289 /* Conversion between character kinds involves a call to a library
291 if (expr
->ts
.type
== BT_CHARACTER
)
293 tree fndecl
, var
, addr
, tmp
;
295 if (expr
->ts
.kind
== 1
296 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
297 fndecl
= gfor_fndecl_convert_char4_to_char1
;
298 else if (expr
->ts
.kind
== 4
299 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
300 fndecl
= gfor_fndecl_convert_char1_to_char4
;
304 /* Create the variable storing the converted value. */
305 type
= gfc_get_pchar_type (expr
->ts
.kind
);
306 var
= gfc_create_var (type
, "str");
307 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
309 /* Call the library function that will perform the conversion. */
310 gcc_assert (nargs
>= 2);
311 tmp
= build_call_expr_loc (input_location
,
312 fndecl
, 3, addr
, args
[0], args
[1]);
313 gfc_add_expr_to_block (&se
->pre
, tmp
);
315 /* Free the temporary afterwards. */
316 tmp
= gfc_call_free (var
);
317 gfc_add_expr_to_block (&se
->post
, tmp
);
320 se
->string_length
= args
[0];
325 /* Conversion from complex to non-complex involves taking the real
326 component of the value. */
327 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
328 && expr
->ts
.type
!= BT_COMPLEX
)
332 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
333 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
337 se
->expr
= convert (type
, args
[0]);
340 /* This is needed because the gcc backend only implements
341 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
342 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
343 Similarly for CEILING. */
346 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
353 argtype
= TREE_TYPE (arg
);
354 arg
= gfc_evaluate_now (arg
, pblock
);
356 intval
= convert (type
, arg
);
357 intval
= gfc_evaluate_now (intval
, pblock
);
359 tmp
= convert (argtype
, intval
);
360 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
361 boolean_type_node
, tmp
, arg
);
363 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
364 intval
, build_int_cst (type
, 1));
365 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
370 /* Round to nearest integer, away from zero. */
373 build_round_expr (tree arg
, tree restype
)
377 int argprec
, resprec
;
379 argtype
= TREE_TYPE (arg
);
380 argprec
= TYPE_PRECISION (argtype
);
381 resprec
= TYPE_PRECISION (restype
);
383 /* Depending on the type of the result, choose the int intrinsic
384 (iround, available only as a builtin, therefore cannot use it for
385 __float128), long int intrinsic (lround family) or long long
386 intrinsic (llround). We might also need to convert the result
388 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
389 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
390 else if (resprec
<= LONG_TYPE_SIZE
)
391 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
392 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
393 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
397 return fold_convert (restype
, build_call_expr_loc (input_location
,
402 /* Convert a real to an integer using a specific rounding mode.
403 Ideally we would just build the corresponding GENERIC node,
404 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
407 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
408 enum rounding_mode op
)
413 return build_fixbound_expr (pblock
, arg
, type
, 0);
416 return build_fixbound_expr (pblock
, arg
, type
, 1);
419 return build_round_expr (arg
, type
);
422 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
430 /* Round a real value using the specified rounding mode.
431 We use a temporary integer of that same kind size as the result.
432 Values larger than those that can be represented by this kind are
433 unchanged, as they will not be accurate enough to represent the
435 huge = HUGE (KIND (a))
436 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
440 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
452 kind
= expr
->ts
.kind
;
453 nargs
= gfc_intrinsic_argument_list_length (expr
);
456 /* We have builtin functions for some cases. */
460 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
464 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
471 /* Evaluate the argument. */
472 gcc_assert (expr
->value
.function
.actual
->expr
);
473 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
475 /* Use a builtin function if one exists. */
476 if (decl
!= NULL_TREE
)
478 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
482 /* This code is probably redundant, but we'll keep it lying around just
484 type
= gfc_typenode_for_spec (&expr
->ts
);
485 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
487 /* Test if the value is too large to handle sensibly. */
488 gfc_set_model_kind (kind
);
490 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
491 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
492 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
493 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
496 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
497 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
498 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
500 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
502 itype
= gfc_get_int_type (kind
);
504 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
505 tmp
= convert (type
, tmp
);
506 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
512 /* Convert to an integer using the specified rounding mode. */
515 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
521 nargs
= gfc_intrinsic_argument_list_length (expr
);
522 args
= XALLOCAVEC (tree
, nargs
);
524 /* Evaluate the argument, we process all arguments even though we only
525 use the first one for code generation purposes. */
526 type
= gfc_typenode_for_spec (&expr
->ts
);
527 gcc_assert (expr
->value
.function
.actual
->expr
);
528 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
530 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
532 /* Conversion to a different integer kind. */
533 se
->expr
= convert (type
, args
[0]);
537 /* Conversion from complex to non-complex involves taking the real
538 component of the value. */
539 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
540 && expr
->ts
.type
!= BT_COMPLEX
)
544 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
545 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
549 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
554 /* Get the imaginary component of a value. */
557 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
561 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
562 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
563 TREE_TYPE (TREE_TYPE (arg
)), arg
);
567 /* Get the complex conjugate of a value. */
570 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
574 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
575 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
581 define_quad_builtin (const char *name
, tree type
, bool is_const
)
584 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
587 /* Mark the decl as external. */
588 DECL_EXTERNAL (fndecl
) = 1;
589 TREE_PUBLIC (fndecl
) = 1;
591 /* Mark it __attribute__((const)). */
592 TREE_READONLY (fndecl
) = is_const
;
594 rest_of_decl_compilation (fndecl
, 1, 0);
601 /* Initialize function decls for library functions. The external functions
602 are created as required. Builtin functions are added here. */
605 gfc_build_intrinsic_lib_fndecls (void)
607 gfc_intrinsic_map_t
*m
;
608 tree quad_decls
[END_BUILTINS
+ 1];
610 if (gfc_real16_is_float128
)
612 /* If we have soft-float types, we create the decls for their
613 C99-like library functions. For now, we only handle __float128
614 q-suffixed functions. */
616 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
617 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
619 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
621 type
= gfc_float128_type_node
;
622 complex_type
= gfc_complex_float128_type_node
;
623 /* type (*) (type) */
624 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
626 func_iround
= build_function_type_list (integer_type_node
,
628 /* long (*) (type) */
629 func_lround
= build_function_type_list (long_integer_type_node
,
631 /* long long (*) (type) */
632 func_llround
= build_function_type_list (long_long_integer_type_node
,
634 /* type (*) (type, type) */
635 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
636 /* type (*) (type, &int) */
638 = build_function_type_list (type
,
640 build_pointer_type (integer_type_node
),
642 /* type (*) (type, int) */
643 func_scalbn
= build_function_type_list (type
,
644 type
, integer_type_node
, NULL_TREE
);
645 /* type (*) (complex type) */
646 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
647 /* complex type (*) (complex type, complex type) */
649 = build_function_type_list (complex_type
,
650 complex_type
, complex_type
, NULL_TREE
);
652 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
653 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
654 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
656 /* Only these built-ins are actually needed here. These are used directly
657 from the code, when calling builtin_decl_for_precision() or
658 builtin_decl_for_float_type(). The others are all constructed by
659 gfc_get_intrinsic_lib_fndecl(). */
660 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
661 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
663 #include "mathbuiltins.def"
667 #undef DEFINE_MATH_BUILTIN
668 #undef DEFINE_MATH_BUILTIN_C
670 /* There is one built-in we defined manually, because it gets called
671 with builtin_decl_for_precision() or builtin_decl_for_float_type()
672 even though it is not an OTHER_BUILTIN: it is SQRT. */
673 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
677 /* Add GCC builtin functions. */
678 for (m
= gfc_intrinsic_map
;
679 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
681 if (m
->float_built_in
!= END_BUILTINS
)
682 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
683 if (m
->complex_float_built_in
!= END_BUILTINS
)
684 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
685 if (m
->double_built_in
!= END_BUILTINS
)
686 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
687 if (m
->complex_double_built_in
!= END_BUILTINS
)
688 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
690 /* If real(kind=10) exists, it is always long double. */
691 if (m
->long_double_built_in
!= END_BUILTINS
)
692 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
693 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
695 = builtin_decl_explicit (m
->complex_long_double_built_in
);
697 if (!gfc_real16_is_float128
)
699 if (m
->long_double_built_in
!= END_BUILTINS
)
700 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
701 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
703 = builtin_decl_explicit (m
->complex_long_double_built_in
);
705 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m
->real16_decl
= quad_decls
[m
->double_built_in
];
712 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
714 /* Same thing for the complex ones. */
715 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
721 /* Create a fndecl for a simple intrinsic library function. */
724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
727 vec
<tree
, va_gc
> *argtypes
;
729 gfc_actual_arglist
*actual
;
732 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
735 if (ts
->type
== BT_REAL
)
740 pdecl
= &m
->real4_decl
;
743 pdecl
= &m
->real8_decl
;
746 pdecl
= &m
->real10_decl
;
749 pdecl
= &m
->real16_decl
;
755 else if (ts
->type
== BT_COMPLEX
)
757 gcc_assert (m
->complex_available
);
762 pdecl
= &m
->complex4_decl
;
765 pdecl
= &m
->complex8_decl
;
768 pdecl
= &m
->complex10_decl
;
771 pdecl
= &m
->complex16_decl
;
785 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
786 if (gfc_real_kinds
[n
].c_float
)
787 snprintf (name
, sizeof (name
), "%s%s%s",
788 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
789 else if (gfc_real_kinds
[n
].c_double
)
790 snprintf (name
, sizeof (name
), "%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
792 else if (gfc_real_kinds
[n
].c_long_double
)
793 snprintf (name
, sizeof (name
), "%s%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
795 else if (gfc_real_kinds
[n
].c_float128
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
803 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
804 ts
->type
== BT_COMPLEX
? 'c' : 'r',
809 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
811 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
812 vec_safe_push (argtypes
, type
);
814 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
815 fndecl
= build_decl (input_location
,
816 FUNCTION_DECL
, get_identifier (name
), type
);
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl
) = 1;
820 TREE_PUBLIC (fndecl
) = 1;
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl
) = m
->is_constant
;
825 rest_of_decl_compilation (fndecl
, 1, 0);
832 /* Convert an intrinsic function into an external or builtin call. */
835 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
837 gfc_intrinsic_map_t
*m
;
841 unsigned int num_args
;
844 id
= expr
->value
.function
.isym
->id
;
845 /* Find the entry for this function. */
846 for (m
= gfc_intrinsic_map
;
847 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
853 if (m
->id
== GFC_ISYM_NONE
)
855 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
856 expr
->value
.function
.name
, id
);
859 /* Get the decl and generate the call. */
860 num_args
= gfc_intrinsic_argument_list_length (expr
);
861 args
= XALLOCAVEC (tree
, num_args
);
863 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
864 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
865 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
867 fndecl
= build_addr (fndecl
);
868 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
877 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
878 tree a
, tree b
, stmtblock_t
* target
)
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
887 /* Compare the two string lengths. */
888 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
890 /* Output the runtime-check. */
891 name
= gfc_build_cstring_const (intr_name
);
892 name
= gfc_build_addr_expr (pchar_type_node
, name
);
893 gfc_trans_runtime_check (true, false, cond
, target
, where
,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node
, a
),
896 fold_convert (long_integer_type_node
, b
), name
);
900 /* The EXPONENT(X) intrinsic function is translated into
902 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
903 so that if X is a NaN or infinity, the result is HUGE(0).
907 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
909 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
912 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
913 expr
->value
.function
.actual
->expr
->ts
.kind
);
915 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
916 arg
= gfc_evaluate_now (arg
, &se
->pre
);
918 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
919 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
920 cond
= build_call_expr_loc (input_location
,
921 builtin_decl_explicit (BUILT_IN_ISFINITE
),
924 res
= gfc_create_var (integer_type_node
, NULL
);
925 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
926 gfc_build_addr_expr (NULL_TREE
, res
));
927 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
929 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
932 type
= gfc_typenode_for_spec (&expr
->ts
);
933 se
->expr
= fold_convert (type
, se
->expr
);
937 /* Fill in the following structure
938 struct caf_vector_t {
939 size_t nvec; // size of the vector
946 ptrdiff_t lower_bound;
947 ptrdiff_t upper_bound;
954 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
955 tree lower
, tree upper
, tree stride
,
956 tree vector
, int kind
, tree nvec
)
958 tree field
, type
, tmp
;
960 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
961 type
= TREE_TYPE (desc
);
963 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
964 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
965 desc
, field
, NULL_TREE
);
966 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
969 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
970 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
971 desc
, field
, NULL_TREE
);
972 type
= TREE_TYPE (desc
);
974 /* Access the inner struct. */
975 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
976 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
977 desc
, field
, NULL_TREE
);
978 type
= TREE_TYPE (desc
);
980 if (vector
!= NULL_TREE
)
982 /* Set vector and kind. */
983 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
984 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
985 desc
, field
, NULL_TREE
);
986 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
987 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
988 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
989 desc
, field
, NULL_TREE
);
990 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
994 /* Set dim.lower/upper/stride. */
995 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
996 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
997 desc
, field
, NULL_TREE
);
998 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1000 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1001 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1002 desc
, field
, NULL_TREE
);
1003 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1005 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1006 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1007 desc
, field
, NULL_TREE
);
1008 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1014 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1017 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1018 tree lbound
, ubound
, tmp
;
1021 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1023 for (i
= 0; i
< ar
->dimen
; i
++)
1024 switch (ar
->dimen_type
[i
])
1029 gfc_init_se (&argse
, NULL
);
1030 gfc_conv_expr (&argse
, ar
->end
[i
]);
1031 gfc_add_block_to_block (block
, &argse
.pre
);
1032 upper
= gfc_evaluate_now (argse
.expr
, block
);
1035 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1038 gfc_init_se (&argse
, NULL
);
1039 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1040 gfc_add_block_to_block (block
, &argse
.pre
);
1041 stride
= gfc_evaluate_now (argse
.expr
, block
);
1044 stride
= gfc_index_one_node
;
1050 gfc_init_se (&argse
, NULL
);
1051 gfc_conv_expr (&argse
, ar
->start
[i
]);
1052 gfc_add_block_to_block (block
, &argse
.pre
);
1053 lower
= gfc_evaluate_now (argse
.expr
, block
);
1056 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1057 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1060 stride
= gfc_index_one_node
;
1063 nvec
= size_zero_node
;
1064 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1069 gfc_init_se (&argse
, NULL
);
1070 argse
.descriptor_only
= 1;
1071 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1072 gfc_add_block_to_block (block
, &argse
.pre
);
1073 vector
= argse
.expr
;
1074 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1075 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1076 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1077 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1078 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1079 TREE_TYPE (nvec
), nvec
, tmp
);
1080 lower
= gfc_index_zero_node
;
1081 upper
= gfc_index_zero_node
;
1082 stride
= gfc_index_zero_node
;
1083 vector
= gfc_conv_descriptor_data_get (vector
);
1084 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1085 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1090 return gfc_build_addr_expr (NULL_TREE
, var
);
1095 compute_component_offset (tree field
, tree type
)
1098 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1099 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1101 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1102 DECL_FIELD_BIT_OFFSET (field
),
1104 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1107 return DECL_FIELD_OFFSET (field
);
1112 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1114 gfc_ref
*ref
= expr
->ref
, *last_comp_ref
;
1115 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1116 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1117 start
, end
, stride
, vector
, nvec
;
1119 bool ref_static_array
= false;
1120 tree last_component_ref_tree
= NULL_TREE
;
1125 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1126 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
;
1129 /* Prevent uninit-warning. */
1130 reference_type
= NULL_TREE
;
1132 /* Skip refs upto the first coarray-ref. */
1133 last_comp_ref
= NULL
;
1134 while (ref
&& (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
== 0))
1136 /* Remember the type of components skipped. */
1137 if (ref
->type
== REF_COMPONENT
)
1138 last_comp_ref
= ref
;
1141 /* When a component was skipped, get the type information of the last
1142 component ref, else get the type from the symbol. */
1145 last_type
= gfc_typenode_for_spec (&last_comp_ref
->u
.c
.component
->ts
);
1146 last_type_n
= last_comp_ref
->u
.c
.component
->ts
.type
;
1150 last_type
= gfc_typenode_for_spec (&expr
->symtree
->n
.sym
->ts
);
1151 last_type_n
= expr
->symtree
->n
.sym
->ts
.type
;
1156 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0
1157 && ref
->u
.ar
.dimen
== 0)
1159 /* Skip pure coindexes. */
1163 tmp
= gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1164 reference_type
= TREE_TYPE (tmp
);
1166 if (caf_ref
== NULL_TREE
)
1169 /* Construct the chain of refs. */
1170 if (prev_caf_ref
!= NULL_TREE
)
1172 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1173 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1174 TREE_TYPE (field
), prev_caf_ref
, field
,
1176 gfc_add_modify (block
, tmp2
, gfc_build_addr_expr (TREE_TYPE (field
),
1184 last_type
= gfc_typenode_for_spec (&ref
->u
.c
.component
->ts
);
1185 last_type_n
= ref
->u
.c
.component
->ts
.type
;
1186 /* Set the type of the ref. */
1187 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1188 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1189 TREE_TYPE (field
), prev_caf_ref
, field
,
1191 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1192 GFC_CAF_REF_COMPONENT
));
1194 /* Ref the c in union u. */
1195 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1196 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1197 TREE_TYPE (field
), prev_caf_ref
, field
,
1199 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 0);
1200 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1201 TREE_TYPE (field
), tmp
, field
,
1204 /* Set the offset. */
1205 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1206 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1207 TREE_TYPE (field
), inner_struct
, field
,
1209 /* Computing the offset is somewhat harder. The bit_offset has to be
1210 taken into account. When the bit_offset in the field_decl is non-
1211 null, divide it by the bitsize_unit and add it to the regular
1213 tmp2
= compute_component_offset (ref
->u
.c
.component
->backend_decl
,
1215 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1217 /* Set caf_token_offset. */
1218 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 1);
1219 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1220 TREE_TYPE (field
), inner_struct
, field
,
1222 if (ref
->u
.c
.component
->attr
.allocatable
1223 && ref
->u
.c
.component
->attr
.dimension
)
1225 tree arr_desc_token_offset
;
1226 /* Get the token from the descriptor. */
1227 arr_desc_token_offset
= gfc_advance_chain (
1228 TYPE_FIELDS (TREE_TYPE (ref
->u
.c
.component
->backend_decl
)),
1229 4 /* CAF_TOKEN_FIELD */);
1230 arr_desc_token_offset
1231 = compute_component_offset (arr_desc_token_offset
,
1233 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
,
1234 TREE_TYPE (tmp2
), tmp2
,
1235 arr_desc_token_offset
);
1237 else if (ref
->u
.c
.component
->caf_token
)
1238 tmp2
= compute_component_offset (ref
->u
.c
.component
->caf_token
,
1241 tmp2
= integer_zero_node
;
1242 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1244 /* Remember whether this ref was to a non-allocatable/non-pointer
1245 component so the next array ref can be tailored correctly. */
1246 ref_static_array
= !ref
->u
.c
.component
->attr
.allocatable
;
1247 last_component_ref_tree
= ref_static_array
1248 ? ref
->u
.c
.component
->backend_decl
: NULL_TREE
;
1251 if (ref_static_array
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
)
1252 ref_static_array
= false;
1253 /* Set the type of the ref. */
1254 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1255 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1256 TREE_TYPE (field
), prev_caf_ref
, field
,
1258 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1260 ? GFC_CAF_REF_STATIC_ARRAY
1261 : GFC_CAF_REF_ARRAY
));
1263 /* Ref the a in union u. */
1264 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1265 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1266 TREE_TYPE (field
), prev_caf_ref
, field
,
1268 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 1);
1269 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1270 TREE_TYPE (field
), tmp
, field
,
1273 /* Set the static_array_type in a for static arrays. */
1274 if (ref_static_array
)
1276 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)),
1278 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1279 TREE_TYPE (field
), inner_struct
, field
,
1281 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (tmp
),
1284 /* Ref the mode in the inner_struct. */
1285 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1286 mode
= fold_build3_loc (input_location
, COMPONENT_REF
,
1287 TREE_TYPE (field
), inner_struct
, field
,
1289 /* Ref the dim in the inner_struct. */
1290 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 2);
1291 dim_array
= fold_build3_loc (input_location
, COMPONENT_REF
,
1292 TREE_TYPE (field
), inner_struct
, field
,
1294 for (i
= 0; i
< ref
->u
.ar
.dimen
; ++i
)
1297 dim
= gfc_build_array_ref (dim_array
, gfc_rank_cst
[i
], NULL_TREE
);
1298 dim_type
= TREE_TYPE (dim
);
1299 mode_rhs
= start
= end
= stride
= NULL_TREE
;
1300 switch (ref
->u
.ar
.dimen_type
[i
])
1303 if (ref
->u
.ar
.end
[i
])
1305 gfc_init_se (&se
, NULL
);
1306 gfc_conv_expr (&se
, ref
->u
.ar
.end
[i
]);
1307 gfc_add_block_to_block (block
, &se
.pre
);
1308 if (ref_static_array
)
1310 /* Make the index zero-based, when reffing a static
1313 gfc_init_se (&se
, NULL
);
1314 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1315 gfc_add_block_to_block (block
, &se
.pre
);
1316 se
.expr
= fold_build2 (MINUS_EXPR
,
1317 gfc_array_index_type
,
1319 gfc_array_index_type
,
1322 end
= gfc_evaluate_now (fold_convert (
1323 gfc_array_index_type
,
1327 else if (ref_static_array
)
1328 end
= fold_build2 (MINUS_EXPR
,
1329 gfc_array_index_type
,
1330 gfc_conv_array_ubound (
1331 last_component_ref_tree
, i
),
1332 gfc_conv_array_lbound (
1333 last_component_ref_tree
, i
));
1337 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1338 GFC_CAF_ARR_REF_OPEN_END
);
1340 if (ref
->u
.ar
.stride
[i
])
1342 gfc_init_se (&se
, NULL
);
1343 gfc_conv_expr (&se
, ref
->u
.ar
.stride
[i
]);
1344 gfc_add_block_to_block (block
, &se
.pre
);
1345 stride
= gfc_evaluate_now (fold_convert (
1346 gfc_array_index_type
,
1349 if (ref_static_array
)
1351 /* Make the index zero-based, when reffing a static
1353 stride
= fold_build2 (MULT_EXPR
,
1354 gfc_array_index_type
,
1355 gfc_conv_array_stride (
1356 last_component_ref_tree
,
1359 gcc_assert (end
!= NULL_TREE
);
1360 /* Multiply with the product of array's stride and
1361 the step of the ref to a virtual upper bound.
1362 We can not compute the actual upper bound here or
1363 the caflib would compute the extend
1365 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1366 end
, gfc_conv_array_stride (
1367 last_component_ref_tree
,
1369 end
= gfc_evaluate_now (end
, block
);
1370 stride
= gfc_evaluate_now (stride
, block
);
1373 else if (ref_static_array
)
1375 stride
= gfc_conv_array_stride (last_component_ref_tree
,
1377 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1379 end
= gfc_evaluate_now (end
, block
);
1382 /* Always set a ref stride of one to make caflib's
1384 stride
= gfc_index_one_node
;
1388 if (ref
->u
.ar
.start
[i
])
1390 gfc_init_se (&se
, NULL
);
1391 gfc_conv_expr (&se
, ref
->u
.ar
.start
[i
]);
1392 gfc_add_block_to_block (block
, &se
.pre
);
1393 if (ref_static_array
)
1395 /* Make the index zero-based, when reffing a static
1397 start
= fold_convert (gfc_array_index_type
, se
.expr
);
1398 gfc_init_se (&se
, NULL
);
1399 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1400 gfc_add_block_to_block (block
, &se
.pre
);
1401 se
.expr
= fold_build2 (MINUS_EXPR
,
1402 gfc_array_index_type
,
1403 start
, fold_convert (
1404 gfc_array_index_type
,
1406 /* Multiply with the stride. */
1407 se
.expr
= fold_build2 (MULT_EXPR
,
1408 gfc_array_index_type
,
1410 gfc_conv_array_stride (
1411 last_component_ref_tree
,
1414 start
= gfc_evaluate_now (fold_convert (
1415 gfc_array_index_type
,
1418 if (mode_rhs
== NULL_TREE
)
1419 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1420 ref
->u
.ar
.dimen_type
[i
]
1422 ? GFC_CAF_ARR_REF_SINGLE
1423 : GFC_CAF_ARR_REF_RANGE
);
1425 else if (ref_static_array
)
1427 start
= integer_zero_node
;
1428 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1429 ref
->u
.ar
.start
[i
] == NULL
1430 ? GFC_CAF_ARR_REF_FULL
1431 : GFC_CAF_ARR_REF_RANGE
);
1433 else if (end
== NULL_TREE
)
1434 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1435 GFC_CAF_ARR_REF_FULL
);
1437 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1438 GFC_CAF_ARR_REF_OPEN_START
);
1440 /* Ref the s in dim. */
1441 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 0);
1442 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1443 TREE_TYPE (field
), dim
, field
,
1446 /* Set start in s. */
1447 if (start
!= NULL_TREE
)
1449 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1451 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1452 TREE_TYPE (field
), tmp
, field
,
1454 gfc_add_modify (block
, tmp2
,
1455 fold_convert (TREE_TYPE (tmp2
), start
));
1459 if (end
!= NULL_TREE
)
1461 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1463 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1464 TREE_TYPE (field
), tmp
, field
,
1466 gfc_add_modify (block
, tmp2
,
1467 fold_convert (TREE_TYPE (tmp2
), end
));
1471 if (stride
!= NULL_TREE
)
1473 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1475 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1476 TREE_TYPE (field
), tmp
, field
,
1478 gfc_add_modify (block
, tmp2
,
1479 fold_convert (TREE_TYPE (tmp2
), stride
));
1483 /* TODO: In case of static array. */
1484 gcc_assert (!ref_static_array
);
1485 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1486 GFC_CAF_ARR_REF_VECTOR
);
1487 gfc_init_se (&se
, NULL
);
1488 se
.descriptor_only
= 1;
1489 gfc_conv_expr_descriptor (&se
, ref
->u
.ar
.start
[i
]);
1490 gfc_add_block_to_block (block
, &se
.pre
);
1492 tmp
= gfc_conv_descriptor_lbound_get (vector
,
1494 tmp2
= gfc_conv_descriptor_ubound_get (vector
,
1496 nvec
= gfc_conv_array_extent_dim (tmp
, tmp2
, NULL
);
1497 tmp
= gfc_conv_descriptor_stride_get (vector
,
1499 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1500 TREE_TYPE (nvec
), nvec
, tmp
);
1501 vector
= gfc_conv_descriptor_data_get (vector
);
1503 /* Ref the v in dim. */
1504 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 1);
1505 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1506 TREE_TYPE (field
), dim
, field
,
1509 /* Set vector in v. */
1510 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 0);
1511 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1512 TREE_TYPE (field
), tmp
, field
,
1514 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1517 /* Set nvec in v. */
1518 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 1);
1519 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1520 TREE_TYPE (field
), tmp
, field
,
1522 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1525 /* Set kind in v. */
1526 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 2);
1527 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1528 TREE_TYPE (field
), tmp
, field
,
1530 gfc_add_modify (block
, tmp2
, build_int_cst (integer_type_node
,
1531 ref
->u
.ar
.start
[i
]->ts
.kind
));
1536 /* Set the mode for dim i. */
1537 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1538 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
),
1542 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1543 if (i
< GFC_MAX_DIMENSIONS
)
1545 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1546 gfc_add_modify (block
, tmp
,
1547 build_int_cst (unsigned_char_type_node
,
1548 GFC_CAF_ARR_REF_NONE
));
1555 /* Set the size of the current type. */
1556 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 2);
1557 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1558 prev_caf_ref
, field
, NULL_TREE
);
1559 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1560 TYPE_SIZE_UNIT (last_type
)));
1565 if (prev_caf_ref
!= NULL_TREE
)
1567 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1568 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1569 prev_caf_ref
, field
, NULL_TREE
);
1570 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1571 null_pointer_node
));
1573 return caf_ref
!= NULL_TREE
? gfc_build_addr_expr (NULL_TREE
, caf_ref
)
1577 /* Get data from a remote coarray. */
1580 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1581 tree may_require_tmp
, bool may_realloc
,
1582 symbol_attribute
*caf_attr
)
1584 gfc_expr
*array_expr
, *tmp_stat
;
1586 tree caf_decl
, token
, offset
, image_index
, tmp
;
1587 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
1589 symbol_attribute caf_attr_store
;
1591 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1593 if (se
->ss
&& se
->ss
->info
->useflags
)
1595 /* Access the previously obtained result. */
1596 gfc_conv_tmp_array_ref (se
);
1600 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1601 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1602 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1604 if (caf_attr
== NULL
)
1606 caf_attr_store
= gfc_caf_attr (array_expr
);
1607 caf_attr
= &caf_attr_store
;
1613 vec
= null_pointer_node
;
1614 tmp_stat
= gfc_find_stat_co (expr
);
1619 gfc_init_se (&stat_se
, NULL
);
1620 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1621 stat
= stat_se
.expr
;
1622 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1623 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1626 stat
= null_pointer_node
;
1628 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1629 is reallocatable or the right-hand side has allocatable components. */
1630 if (caf_attr
->alloc_comp
|| may_realloc
)
1632 /* Get using caf_get_by_ref. */
1633 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, array_expr
);
1635 if (caf_reference
!= NULL_TREE
)
1637 if (lhs
== NULL_TREE
)
1639 if (array_expr
->ts
.type
== BT_CHARACTER
)
1640 gfc_init_se (&argse
, NULL
);
1641 if (array_expr
->rank
== 0)
1643 symbol_attribute attr
;
1644 gfc_clear_attr (&attr
);
1645 if (array_expr
->ts
.type
== BT_CHARACTER
)
1647 res_var
= gfc_conv_string_tmp (se
,
1648 build_pointer_type (type
),
1649 array_expr
->ts
.u
.cl
->backend_decl
);
1650 argse
.string_length
= array_expr
->ts
.u
.cl
->backend_decl
;
1653 res_var
= gfc_create_var (type
, "caf_res");
1654 dst_var
= gfc_conv_scalar_to_descriptor (se
, res_var
, attr
);
1655 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1659 /* Create temporary. */
1660 if (array_expr
->ts
.type
== BT_CHARACTER
)
1661 gfc_conv_expr_descriptor (&argse
, array_expr
);
1662 may_realloc
= gfc_trans_create_temp_array (&se
->pre
,
1669 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1670 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1673 tmp
= gfc_conv_descriptor_data_get (res_var
);
1674 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
,
1675 NULL_TREE
, NULL_TREE
,
1678 gfc_add_expr_to_block (&se
->post
, tmp
);
1683 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1684 if (lhs_kind
== NULL_TREE
)
1687 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1688 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1689 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1690 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1692 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1695 /* No overlap possible as we have generated a temporary. */
1696 if (lhs
== NULL_TREE
)
1697 may_require_tmp
= boolean_false_node
;
1699 /* It guarantees memory consistency within the same segment. */
1700 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1701 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1702 gfc_build_string_const (1, ""), NULL_TREE
,
1703 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1705 ASM_VOLATILE_P (tmp
) = 1;
1706 gfc_add_expr_to_block (&se
->pre
, tmp
);
1708 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1709 9, token
, image_index
, dst_var
,
1710 caf_reference
, lhs_kind
, kind
,
1712 may_realloc
? boolean_true_node
:
1716 gfc_add_expr_to_block (&se
->pre
, tmp
);
1719 gfc_advance_se_ss_chain (se
);
1722 if (array_expr
->ts
.type
== BT_CHARACTER
)
1723 se
->string_length
= argse
.string_length
;
1729 gfc_init_se (&argse
, NULL
);
1730 if (array_expr
->rank
== 0)
1732 symbol_attribute attr
;
1734 gfc_clear_attr (&attr
);
1735 gfc_conv_expr (&argse
, array_expr
);
1737 if (lhs
== NULL_TREE
)
1739 gfc_clear_attr (&attr
);
1740 if (array_expr
->ts
.type
== BT_CHARACTER
)
1741 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1742 argse
.string_length
);
1744 res_var
= gfc_create_var (type
, "caf_res");
1745 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1746 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1748 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1749 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1753 /* If has_vector, pass descriptor for whole array and the
1754 vector bounds separately. */
1755 gfc_array_ref
*ar
, ar2
;
1756 bool has_vector
= false;
1758 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1761 ar
= gfc_find_array_ref (expr
);
1763 memset (ar
, '\0', sizeof (*ar
));
1767 gfc_conv_expr_descriptor (&argse
, array_expr
);
1768 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1769 has the wrong type if component references are done. */
1770 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1771 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1776 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1780 if (lhs
== NULL_TREE
)
1782 /* Create temporary. */
1783 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1784 if (se
->loop
->to
[n
] == NULL_TREE
)
1786 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1788 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1791 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1792 NULL_TREE
, false, true, false,
1793 &array_expr
->where
);
1794 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1795 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1797 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1800 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1801 if (lhs_kind
== NULL_TREE
)
1804 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1805 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1807 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1808 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1809 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1810 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1811 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1814 /* No overlap possible as we have generated a temporary. */
1815 if (lhs
== NULL_TREE
)
1816 may_require_tmp
= boolean_false_node
;
1818 /* It guarantees memory consistency within the same segment. */
1819 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1820 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1821 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1822 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1823 ASM_VOLATILE_P (tmp
) = 1;
1824 gfc_add_expr_to_block (&se
->pre
, tmp
);
1826 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1827 token
, offset
, image_index
, argse
.expr
, vec
,
1828 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1830 gfc_add_expr_to_block (&se
->pre
, tmp
);
1833 gfc_advance_se_ss_chain (se
);
1836 if (array_expr
->ts
.type
== BT_CHARACTER
)
1837 se
->string_length
= argse
.string_length
;
1841 /* Send data to a remote coarray. */
1844 conv_caf_send (gfc_code
*code
) {
1845 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
;
1846 gfc_se lhs_se
, rhs_se
;
1848 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1849 tree may_require_tmp
, src_stat
, dst_stat
;
1850 tree lhs_type
= NULL_TREE
;
1851 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1852 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1854 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1856 lhs_expr
= code
->ext
.actual
->expr
;
1857 rhs_expr
= code
->ext
.actual
->next
->expr
;
1858 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1859 ? boolean_false_node
: boolean_true_node
;
1860 gfc_init_block (&block
);
1862 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1863 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1864 src_stat
= dst_stat
= null_pointer_node
;
1867 gfc_init_se (&lhs_se
, NULL
);
1868 if (lhs_expr
->rank
== 0)
1870 symbol_attribute attr
;
1871 gfc_clear_attr (&attr
);
1872 gfc_conv_expr (&lhs_se
, lhs_expr
);
1873 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1874 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1875 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1877 else if (lhs_caf_attr
.alloc_comp
&& lhs_caf_attr
.codimension
)
1879 lhs_se
.want_pointer
= 1;
1880 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1881 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1882 has the wrong type if component references are done. */
1883 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1884 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1885 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1886 gfc_get_dtype_rank_type (
1887 gfc_has_vector_subscript (lhs_expr
)
1888 ? gfc_find_array_ref (lhs_expr
)->dimen
1894 /* If has_vector, pass descriptor for whole array and the
1895 vector bounds separately. */
1896 gfc_array_ref
*ar
, ar2
;
1897 bool has_vector
= false;
1899 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1902 ar
= gfc_find_array_ref (lhs_expr
);
1904 memset (ar
, '\0', sizeof (*ar
));
1908 lhs_se
.want_pointer
= 1;
1909 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1910 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1911 has the wrong type if component references are done. */
1912 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1913 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1914 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1915 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1920 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1925 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1927 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1928 temporary and a loop. */
1929 if (!gfc_is_coindexed (lhs_expr
) && !lhs_caf_attr
.codimension
)
1931 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
1932 gcc_assert (gfc_is_coindexed (rhs_expr
));
1933 gfc_init_se (&rhs_se
, NULL
);
1934 if (lhs_expr
->rank
== 0 && gfc_expr_attr (lhs_expr
).allocatable
)
1937 gfc_init_se (&scal_se
, NULL
);
1938 scal_se
.want_pointer
= 1;
1939 gfc_conv_expr (&scal_se
, lhs_expr
);
1940 /* Ensure scalar on lhs is allocated. */
1941 gfc_add_block_to_block (&block
, &scal_se
.pre
);
1943 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
1945 gfc_typenode_for_spec (&lhs_expr
->ts
)),
1947 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, scal_se
.expr
,
1949 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1950 tmp
, gfc_finish_block (&scal_se
.pre
),
1951 build_empty_stmt (input_location
));
1952 gfc_add_expr_to_block (&block
, tmp
);
1955 lhs_may_realloc
= lhs_may_realloc
1956 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
1957 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1958 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1959 may_require_tmp
, lhs_may_realloc
,
1961 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1962 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1963 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1964 return gfc_finish_block (&block
);
1967 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1969 /* Obtain token, offset and image index for the LHS. */
1970 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1971 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1972 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1973 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1975 if (lhs_caf_attr
.alloc_comp
)
1976 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
1979 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
1984 gfc_init_se (&rhs_se
, NULL
);
1985 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1986 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1987 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1988 if (rhs_expr
->rank
== 0)
1990 symbol_attribute attr
;
1991 gfc_clear_attr (&attr
);
1992 gfc_conv_expr (&rhs_se
, rhs_expr
);
1993 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
1994 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
1996 else if (rhs_caf_attr
.alloc_comp
&& rhs_caf_attr
.codimension
)
1999 rhs_se
.want_pointer
= 1;
2000 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2001 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2002 has the wrong type if component references are done. */
2003 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2004 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2005 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2006 gfc_get_dtype_rank_type (
2007 gfc_has_vector_subscript (rhs_expr
)
2008 ? gfc_find_array_ref (rhs_expr
)->dimen
2014 /* If has_vector, pass descriptor for whole array and the
2015 vector bounds separately. */
2016 gfc_array_ref
*ar
, ar2
;
2017 bool has_vector
= false;
2020 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2023 ar
= gfc_find_array_ref (rhs_expr
);
2025 memset (ar
, '\0', sizeof (*ar
));
2029 rhs_se
.want_pointer
= 1;
2030 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2031 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2032 has the wrong type if component references are done. */
2033 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2034 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2035 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2036 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2041 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2046 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2048 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2050 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2055 gfc_init_se (&stat_se
, NULL
);
2056 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2057 dst_stat
= stat_se
.expr
;
2058 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2059 gfc_add_block_to_block (&block
, &stat_se
.post
);
2062 if (!gfc_is_coindexed (rhs_expr
) && !rhs_caf_attr
.codimension
)
2064 if (lhs_caf_attr
.alloc_comp
)
2066 tree reference
, dst_realloc
;
2067 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2068 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2069 : boolean_false_node
;
2070 tmp
= build_call_expr_loc (input_location
,
2071 gfor_fndecl_caf_send_by_ref
,
2072 9, token
, image_index
, rhs_se
.expr
,
2073 reference
, lhs_kind
, rhs_kind
,
2074 may_require_tmp
, dst_realloc
, src_stat
);
2077 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 10,
2078 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2079 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2080 may_require_tmp
, src_stat
);
2084 tree rhs_token
, rhs_offset
, rhs_image_index
;
2086 /* It guarantees memory consistency within the same segment. */
2087 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2088 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2089 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2090 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2091 ASM_VOLATILE_P (tmp
) = 1;
2092 gfc_add_expr_to_block (&block
, tmp
);
2094 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2095 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2096 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2097 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2099 if (rhs_caf_attr
.alloc_comp
)
2101 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2106 gfc_init_se (&stat_se
, NULL
);
2107 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2108 src_stat
= stat_se
.expr
;
2109 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2110 gfc_add_block_to_block (&block
, &stat_se
.post
);
2113 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2115 tree lhs_reference
, rhs_reference
;
2116 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2117 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2118 tmp
= build_call_expr_loc (input_location
,
2119 gfor_fndecl_caf_sendget_by_ref
, 11,
2120 token
, image_index
, lhs_reference
,
2121 rhs_token
, rhs_image_index
, rhs_reference
,
2122 lhs_kind
, rhs_kind
, may_require_tmp
,
2123 dst_stat
, src_stat
);
2127 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2129 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2130 14, token
, offset
, image_index
,
2131 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2132 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2133 rhs_kind
, may_require_tmp
, src_stat
);
2136 gfc_add_expr_to_block (&block
, tmp
);
2137 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2138 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2140 /* It guarantees memory consistency within the same segment. */
2141 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2142 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2143 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2144 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2145 ASM_VOLATILE_P (tmp
) = 1;
2146 gfc_add_expr_to_block (&block
, tmp
);
2148 return gfc_finish_block (&block
);
2153 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2156 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2157 lbound
, ubound
, extent
, ml
;
2160 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2162 if (expr
->value
.function
.actual
->expr
2163 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2164 distance
= expr
->value
.function
.actual
->expr
;
2166 /* The case -fcoarray=single is handled elsewhere. */
2167 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2169 /* Argument-free version: THIS_IMAGE(). */
2170 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2174 gfc_init_se (&argse
, NULL
);
2175 gfc_conv_expr_val (&argse
, distance
);
2176 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2177 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2178 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2181 tmp
= integer_zero_node
;
2182 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2184 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2189 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2191 type
= gfc_get_int_type (gfc_default_integer_kind
);
2192 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2193 rank
= expr
->value
.function
.actual
->expr
->rank
;
2195 /* Obtain the descriptor of the COARRAY. */
2196 gfc_init_se (&argse
, NULL
);
2197 argse
.want_coarray
= 1;
2198 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2199 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2200 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2205 /* Create an implicit second parameter from the loop variable. */
2206 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2207 gcc_assert (corank
> 0);
2208 gcc_assert (se
->loop
->dimen
== 1);
2209 gcc_assert (se
->ss
->info
->expr
== expr
);
2211 dim_arg
= se
->loop
->loopvar
[0];
2212 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2213 gfc_array_index_type
, dim_arg
,
2214 build_int_cst (TREE_TYPE (dim_arg
), 1));
2215 gfc_advance_se_ss_chain (se
);
2219 /* Use the passed DIM= argument. */
2220 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2221 gfc_init_se (&argse
, NULL
);
2222 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2223 gfc_array_index_type
);
2224 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2225 dim_arg
= argse
.expr
;
2227 if (INTEGER_CST_P (dim_arg
))
2229 if (wi::ltu_p (dim_arg
, 1)
2230 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2231 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2232 "dimension index", expr
->value
.function
.isym
->name
,
2235 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2237 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2238 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2240 build_int_cst (TREE_TYPE (dim_arg
), 1));
2241 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2242 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2244 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2245 boolean_type_node
, cond
, tmp
);
2246 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2251 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2252 one always has a dim_arg argument.
2254 m = this_image() - 1
2257 sub(1) = m + lcobound(corank)
2261 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2264 extent = gfc_extent(i)
2272 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2273 : m + lcobound(corank)
2276 /* this_image () - 1. */
2277 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2279 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2280 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2283 /* sub(1) = m + lcobound(corank). */
2284 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2285 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2287 lbound
= fold_convert (type
, lbound
);
2288 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2294 m
= gfc_create_var (type
, NULL
);
2295 ml
= gfc_create_var (type
, NULL
);
2296 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2297 min_var
= gfc_create_var (integer_type_node
, NULL
);
2299 /* m = this_image () - 1. */
2300 gfc_add_modify (&se
->pre
, m
, tmp
);
2302 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2303 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2304 fold_convert (integer_type_node
, dim_arg
),
2305 build_int_cst (integer_type_node
, rank
- 1));
2306 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2307 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2309 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2312 tmp
= build_int_cst (integer_type_node
, rank
);
2313 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2315 exit_label
= gfc_build_label_decl (NULL_TREE
);
2316 TREE_USED (exit_label
) = 1;
2319 gfc_init_block (&loop
);
2322 gfc_add_modify (&loop
, ml
, m
);
2325 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2326 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2327 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2328 extent
= fold_convert (type
, extent
);
2331 gfc_add_modify (&loop
, m
,
2332 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2335 /* Exit condition: if (i >= min_var) goto exit_label. */
2336 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
2338 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2339 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2340 build_empty_stmt (input_location
));
2341 gfc_add_expr_to_block (&loop
, tmp
);
2343 /* Increment loop variable: i++. */
2344 gfc_add_modify (&loop
, loop_var
,
2345 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2347 build_int_cst (integer_type_node
, 1)));
2349 /* Making the loop... actually loop! */
2350 tmp
= gfc_finish_block (&loop
);
2351 tmp
= build1_v (LOOP_EXPR
, tmp
);
2352 gfc_add_expr_to_block (&se
->pre
, tmp
);
2354 /* The exit label. */
2355 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2356 gfc_add_expr_to_block (&se
->pre
, tmp
);
2358 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2359 : m + lcobound(corank) */
2361 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
2362 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2364 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2365 fold_build2_loc (input_location
, PLUS_EXPR
,
2366 gfc_array_index_type
, dim_arg
,
2367 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2368 lbound
= fold_convert (type
, lbound
);
2370 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2371 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2373 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2375 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2376 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2382 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2384 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2386 gfc_se argse
, subse
;
2387 int rank
, corank
, codim
;
2389 type
= gfc_get_int_type (gfc_default_integer_kind
);
2390 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2391 rank
= expr
->value
.function
.actual
->expr
->rank
;
2393 /* Obtain the descriptor of the COARRAY. */
2394 gfc_init_se (&argse
, NULL
);
2395 argse
.want_coarray
= 1;
2396 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2397 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2398 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2401 /* Obtain a handle to the SUB argument. */
2402 gfc_init_se (&subse
, NULL
);
2403 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2404 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2405 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2406 subdesc
= build_fold_indirect_ref_loc (input_location
,
2407 gfc_conv_descriptor_data_get (subse
.expr
));
2409 /* Fortran 2008 does not require that the values remain in the cobounds,
2410 thus we need explicitly check this - and return 0 if they are exceeded. */
2412 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2413 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2414 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2415 fold_convert (gfc_array_index_type
, tmp
),
2418 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2420 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2421 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2422 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2423 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2424 fold_convert (gfc_array_index_type
, tmp
),
2426 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2427 boolean_type_node
, invalid_bound
, cond
);
2428 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2429 fold_convert (gfc_array_index_type
, tmp
),
2431 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2432 boolean_type_node
, invalid_bound
, cond
);
2435 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2437 /* See Fortran 2008, C.10 for the following algorithm. */
2439 /* coindex = sub(corank) - lcobound(n). */
2440 coindex
= fold_convert (gfc_array_index_type
,
2441 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2443 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2444 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2445 fold_convert (gfc_array_index_type
, coindex
),
2448 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2450 tree extent
, ubound
;
2452 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2453 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2454 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2455 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2457 /* coindex *= extent. */
2458 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2459 gfc_array_index_type
, coindex
, extent
);
2461 /* coindex += sub(codim). */
2462 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2463 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2464 gfc_array_index_type
, coindex
,
2465 fold_convert (gfc_array_index_type
, tmp
));
2467 /* coindex -= lbound(codim). */
2468 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2469 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2470 gfc_array_index_type
, coindex
, lbound
);
2473 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2474 fold_convert(type
, coindex
),
2475 build_int_cst (type
, 1));
2477 /* Return 0 if "coindex" exceeds num_images(). */
2479 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2480 num_images
= build_int_cst (type
, 1);
2483 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2485 build_int_cst (integer_type_node
, -1));
2486 num_images
= fold_convert (type
, tmp
);
2489 tmp
= gfc_create_var (type
, NULL
);
2490 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2492 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
2494 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
2496 fold_convert (boolean_type_node
, invalid_bound
));
2497 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2498 build_int_cst (type
, 0), tmp
);
2503 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2505 tree tmp
, distance
, failed
;
2508 if (expr
->value
.function
.actual
->expr
)
2510 gfc_init_se (&argse
, NULL
);
2511 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2512 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2513 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2514 distance
= fold_convert (integer_type_node
, argse
.expr
);
2517 distance
= integer_zero_node
;
2519 if (expr
->value
.function
.actual
->next
->expr
)
2521 gfc_init_se (&argse
, NULL
);
2522 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2523 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2524 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2525 failed
= fold_convert (integer_type_node
, argse
.expr
);
2528 failed
= build_int_cst (integer_type_node
, -1);
2530 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2532 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2537 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2541 gfc_init_se (&argse
, NULL
);
2542 argse
.data_not_needed
= 1;
2543 argse
.descriptor_only
= 1;
2545 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2546 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2547 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2549 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2553 /* Evaluate a single upper or lower bound. */
2554 /* TODO: bound intrinsic generates way too much unnecessary code. */
2557 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2559 gfc_actual_arglist
*arg
;
2560 gfc_actual_arglist
*arg2
;
2565 tree cond
, cond1
, cond3
, cond4
, size
;
2569 gfc_array_spec
* as
;
2570 bool assumed_rank_lb_one
;
2572 arg
= expr
->value
.function
.actual
;
2577 /* Create an implicit second parameter from the loop variable. */
2578 gcc_assert (!arg2
->expr
);
2579 gcc_assert (se
->loop
->dimen
== 1);
2580 gcc_assert (se
->ss
->info
->expr
== expr
);
2581 gfc_advance_se_ss_chain (se
);
2582 bound
= se
->loop
->loopvar
[0];
2583 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2584 gfc_array_index_type
, bound
,
2589 /* use the passed argument. */
2590 gcc_assert (arg2
->expr
);
2591 gfc_init_se (&argse
, NULL
);
2592 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2593 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2595 /* Convert from one based to zero based. */
2596 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2597 gfc_array_index_type
, bound
,
2598 gfc_index_one_node
);
2601 /* TODO: don't re-evaluate the descriptor on each iteration. */
2602 /* Get a descriptor for the first parameter. */
2603 gfc_init_se (&argse
, NULL
);
2604 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2605 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2606 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2610 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2612 if (INTEGER_CST_P (bound
))
2614 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2615 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2616 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
2617 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2618 "dimension index", upper
? "UBOUND" : "LBOUND",
2622 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
2624 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2626 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2627 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2628 bound
, build_int_cst (TREE_TYPE (bound
), 0));
2629 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2630 tmp
= gfc_conv_descriptor_rank (desc
);
2632 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
2633 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2634 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
2635 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2636 boolean_type_node
, cond
, tmp
);
2637 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2642 /* Take care of the lbound shift for assumed-rank arrays, which are
2643 nonallocatable and nonpointers. Those has a lbound of 1. */
2644 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
2645 && ((arg
->expr
->ts
.type
!= BT_CLASS
2646 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
2647 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
2648 || (arg
->expr
->ts
.type
== BT_CLASS
2649 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
2650 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
2652 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2653 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2655 /* 13.14.53: Result value for LBOUND
2657 Case (i): For an array section or for an array expression other than a
2658 whole array or array structure component, LBOUND(ARRAY, DIM)
2659 has the value 1. For a whole array or array structure
2660 component, LBOUND(ARRAY, DIM) has the value:
2661 (a) equal to the lower bound for subscript DIM of ARRAY if
2662 dimension DIM of ARRAY does not have extent zero
2663 or if ARRAY is an assumed-size array of rank DIM,
2666 13.14.113: Result value for UBOUND
2668 Case (i): For an array section or for an array expression other than a
2669 whole array or array structure component, UBOUND(ARRAY, DIM)
2670 has the value equal to the number of elements in the given
2671 dimension; otherwise, it has a value equal to the upper bound
2672 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2673 not have size zero and has value zero if dimension DIM has
2676 if (!upper
&& assumed_rank_lb_one
)
2677 se
->expr
= gfc_index_one_node
;
2680 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
2682 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2684 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2685 stride
, gfc_index_zero_node
);
2686 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2687 boolean_type_node
, cond3
, cond1
);
2688 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2689 stride
, gfc_index_zero_node
);
2694 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2695 boolean_type_node
, cond3
, cond4
);
2696 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2697 gfc_index_one_node
, lbound
);
2698 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2699 boolean_type_node
, cond4
, cond5
);
2701 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2702 boolean_type_node
, cond
, cond5
);
2704 if (assumed_rank_lb_one
)
2706 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2707 gfc_array_index_type
, ubound
, lbound
);
2708 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2709 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2714 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2715 gfc_array_index_type
, cond
,
2716 tmp
, gfc_index_zero_node
);
2720 if (as
->type
== AS_ASSUMED_SIZE
)
2721 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2722 bound
, build_int_cst (TREE_TYPE (bound
),
2723 arg
->expr
->rank
- 1));
2725 cond
= boolean_false_node
;
2727 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2728 boolean_type_node
, cond3
, cond4
);
2729 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2730 boolean_type_node
, cond
, cond1
);
2732 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2733 gfc_array_index_type
, cond
,
2734 lbound
, gfc_index_one_node
);
2741 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2742 gfc_array_index_type
, ubound
, lbound
);
2743 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2744 gfc_array_index_type
, size
,
2745 gfc_index_one_node
);
2746 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2747 gfc_array_index_type
, se
->expr
,
2748 gfc_index_zero_node
);
2751 se
->expr
= gfc_index_one_node
;
2754 type
= gfc_typenode_for_spec (&expr
->ts
);
2755 se
->expr
= convert (type
, se
->expr
);
2760 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2762 gfc_actual_arglist
*arg
;
2763 gfc_actual_arglist
*arg2
;
2765 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2769 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2770 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2771 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2773 arg
= expr
->value
.function
.actual
;
2776 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2777 corank
= gfc_get_corank (arg
->expr
);
2779 gfc_init_se (&argse
, NULL
);
2780 argse
.want_coarray
= 1;
2782 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2783 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2784 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2789 /* Create an implicit second parameter from the loop variable. */
2790 gcc_assert (!arg2
->expr
);
2791 gcc_assert (corank
> 0);
2792 gcc_assert (se
->loop
->dimen
== 1);
2793 gcc_assert (se
->ss
->info
->expr
== expr
);
2795 bound
= se
->loop
->loopvar
[0];
2796 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2797 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2798 gfc_advance_se_ss_chain (se
);
2802 /* use the passed argument. */
2803 gcc_assert (arg2
->expr
);
2804 gfc_init_se (&argse
, NULL
);
2805 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2806 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2809 if (INTEGER_CST_P (bound
))
2811 if (wi::ltu_p (bound
, 1)
2812 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2813 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2814 "dimension index", expr
->value
.function
.isym
->name
,
2817 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2819 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2820 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2821 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2822 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2823 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2825 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2826 boolean_type_node
, cond
, tmp
);
2827 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2832 /* Subtract 1 to get to zero based and add dimensions. */
2833 switch (arg
->expr
->rank
)
2836 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2837 gfc_array_index_type
, bound
,
2838 gfc_index_one_node
);
2842 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2843 gfc_array_index_type
, bound
,
2844 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2848 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2850 /* Handle UCOBOUND with special handling of the last codimension. */
2851 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2853 /* Last codimension: For -fcoarray=single just return
2854 the lcobound - otherwise add
2855 ceiling (real (num_images ()) / real (size)) - 1
2856 = (num_images () + size - 1) / size - 1
2857 = (num_images - 1) / size(),
2858 where size is the product of the extent of all but the last
2861 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2865 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2866 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2867 2, integer_zero_node
,
2868 build_int_cst (integer_type_node
, -1));
2869 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2870 gfc_array_index_type
,
2871 fold_convert (gfc_array_index_type
, tmp
),
2872 build_int_cst (gfc_array_index_type
, 1));
2873 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2874 gfc_array_index_type
, tmp
,
2875 fold_convert (gfc_array_index_type
, cosize
));
2876 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2877 gfc_array_index_type
, resbound
, tmp
);
2879 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2881 /* ubound = lbound + num_images() - 1. */
2882 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2883 2, integer_zero_node
,
2884 build_int_cst (integer_type_node
, -1));
2885 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2886 gfc_array_index_type
,
2887 fold_convert (gfc_array_index_type
, tmp
),
2888 build_int_cst (gfc_array_index_type
, 1));
2889 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2890 gfc_array_index_type
, resbound
, tmp
);
2895 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2897 build_int_cst (TREE_TYPE (bound
),
2898 arg
->expr
->rank
+ corank
- 1));
2900 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2901 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2902 gfc_array_index_type
, cond
,
2903 resbound
, resbound2
);
2906 se
->expr
= resbound
;
2909 se
->expr
= resbound
;
2911 type
= gfc_typenode_for_spec (&expr
->ts
);
2912 se
->expr
= convert (type
, se
->expr
);
2917 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2919 gfc_actual_arglist
*array_arg
;
2920 gfc_actual_arglist
*dim_arg
;
2924 array_arg
= expr
->value
.function
.actual
;
2925 dim_arg
= array_arg
->next
;
2927 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2929 gfc_init_se (&argse
, NULL
);
2930 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2931 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2932 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2935 gcc_assert (dim_arg
->expr
);
2936 gfc_init_se (&argse
, NULL
);
2937 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2938 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2939 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2940 argse
.expr
, gfc_index_one_node
);
2941 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2946 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2950 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2952 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
2956 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
2961 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
2962 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
2971 /* Create a complex value from one or two real components. */
2974 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
2980 unsigned int num_args
;
2982 num_args
= gfc_intrinsic_argument_list_length (expr
);
2983 args
= XALLOCAVEC (tree
, num_args
);
2985 type
= gfc_typenode_for_spec (&expr
->ts
);
2986 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2987 real
= convert (TREE_TYPE (type
), args
[0]);
2989 imag
= convert (TREE_TYPE (type
), args
[1]);
2990 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
2992 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2993 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
2994 imag
= convert (TREE_TYPE (type
), imag
);
2997 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
2999 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3003 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3004 MODULO(A, P) = A - FLOOR (A / P) * P
3006 The obvious algorithms above are numerically instable for large
3007 arguments, hence these intrinsics are instead implemented via calls
3008 to the fmod family of functions. It is the responsibility of the
3009 user to ensure that the second argument is non-zero. */
3012 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3022 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3024 switch (expr
->ts
.type
)
3027 /* Integer case is easy, we've got a builtin op. */
3028 type
= TREE_TYPE (args
[0]);
3031 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3034 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3040 /* Check if we have a builtin fmod. */
3041 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3043 /* The builtin should always be available. */
3044 gcc_assert (fmod
!= NULL_TREE
);
3046 tmp
= build_addr (fmod
);
3047 se
->expr
= build_call_array_loc (input_location
,
3048 TREE_TYPE (TREE_TYPE (fmod
)),
3053 type
= TREE_TYPE (args
[0]);
3055 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3056 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3059 modulo = arg - floor (arg/arg2) * arg2
3061 In order to calculate the result accurately, we use the fmod
3062 function as follows.
3064 res = fmod (arg, arg2);
3067 if ((arg < 0) xor (arg2 < 0))
3071 res = copysign (0., arg2);
3073 => As two nested ternary exprs:
3075 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3076 : copysign (0., arg2);
3080 zero
= gfc_build_const (type
, integer_zero_node
);
3081 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3082 if (!flag_signed_zeros
)
3084 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3086 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3088 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3089 boolean_type_node
, test
, test2
);
3090 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3092 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3093 boolean_type_node
, test
, test2
);
3094 test
= gfc_evaluate_now (test
, &se
->pre
);
3095 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3096 fold_build2_loc (input_location
,
3098 type
, tmp
, args
[1]),
3103 tree expr1
, copysign
, cscall
;
3104 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3106 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3108 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3110 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3111 boolean_type_node
, test
, test2
);
3112 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3113 fold_build2_loc (input_location
,
3115 type
, tmp
, args
[1]),
3117 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3119 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3121 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3131 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3132 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3133 where the right shifts are logical (i.e. 0's are shifted in).
3134 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3135 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3137 DSHIFTL(I,J,BITSIZE) = J
3139 DSHIFTR(I,J,BITSIZE) = I. */
3142 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3144 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3145 tree args
[3], cond
, tmp
;
3148 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3150 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3151 type
= TREE_TYPE (args
[0]);
3152 bitsize
= TYPE_PRECISION (type
);
3153 utype
= unsigned_type_for (type
);
3154 stype
= TREE_TYPE (args
[2]);
3156 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3157 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3158 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3160 /* The generic case. */
3161 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3162 build_int_cst (stype
, bitsize
), shift
);
3163 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3164 arg1
, dshiftl
? shift
: tmp
);
3166 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3167 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3168 right
= fold_convert (type
, right
);
3170 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3172 /* Special cases. */
3173 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
3174 build_int_cst (stype
, 0));
3175 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3176 dshiftl
? arg1
: arg2
, res
);
3178 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
3179 build_int_cst (stype
, bitsize
));
3180 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3181 dshiftl
? arg2
: arg1
, res
);
3187 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3190 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3198 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3199 type
= TREE_TYPE (args
[0]);
3201 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3202 val
= gfc_evaluate_now (val
, &se
->pre
);
3204 zero
= gfc_build_const (type
, integer_zero_node
);
3205 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
3206 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3210 /* SIGN(A, B) is absolute value of A times sign of B.
3211 The real value versions use library functions to ensure the correct
3212 handling of negative zero. Integer case implemented as:
3213 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3217 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3223 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3224 if (expr
->ts
.type
== BT_REAL
)
3228 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3229 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3231 /* We explicitly have to ignore the minus sign. We do so by using
3232 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3234 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3237 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3238 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3240 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3241 TREE_TYPE (args
[0]), cond
,
3242 build_call_expr_loc (input_location
, abs
, 1,
3244 build_call_expr_loc (input_location
, tmp
, 2,
3248 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3253 /* Having excluded floating point types, we know we are now dealing
3254 with signed integer types. */
3255 type
= TREE_TYPE (args
[0]);
3257 /* Args[0] is used multiple times below. */
3258 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3260 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3261 the signs of A and B are the same, and of all ones if they differ. */
3262 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3263 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3264 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3265 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3267 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3268 is all ones (i.e. -1). */
3269 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3270 fold_build2_loc (input_location
, PLUS_EXPR
,
3271 type
, args
[0], tmp
), tmp
);
3275 /* Test for the presence of an optional argument. */
3278 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3282 arg
= expr
->value
.function
.actual
->expr
;
3283 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3284 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3285 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3289 /* Calculate the double precision product of two single precision values. */
3292 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3297 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3299 /* Convert the args to double precision before multiplying. */
3300 type
= gfc_typenode_for_spec (&expr
->ts
);
3301 args
[0] = convert (type
, args
[0]);
3302 args
[1] = convert (type
, args
[1]);
3303 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3308 /* Return a length one character string containing an ascii character. */
3311 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3316 unsigned int num_args
;
3318 num_args
= gfc_intrinsic_argument_list_length (expr
);
3319 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3321 type
= gfc_get_char_type (expr
->ts
.kind
);
3322 var
= gfc_create_var (type
, "char");
3324 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3325 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3326 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3327 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3332 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3340 unsigned int num_args
;
3342 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3343 args
= XALLOCAVEC (tree
, num_args
);
3345 var
= gfc_create_var (pchar_type_node
, "pstr");
3346 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3348 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3349 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3350 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3352 fndecl
= build_addr (gfor_fndecl_ctime
);
3353 tmp
= build_call_array_loc (input_location
,
3354 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3355 fndecl
, num_args
, args
);
3356 gfc_add_expr_to_block (&se
->pre
, tmp
);
3358 /* Free the temporary afterwards, if necessary. */
3359 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3360 len
, build_int_cst (TREE_TYPE (len
), 0));
3361 tmp
= gfc_call_free (var
);
3362 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3363 gfc_add_expr_to_block (&se
->post
, tmp
);
3366 se
->string_length
= len
;
3371 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3379 unsigned int num_args
;
3381 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3382 args
= XALLOCAVEC (tree
, num_args
);
3384 var
= gfc_create_var (pchar_type_node
, "pstr");
3385 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3387 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3388 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3389 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3391 fndecl
= build_addr (gfor_fndecl_fdate
);
3392 tmp
= build_call_array_loc (input_location
,
3393 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3394 fndecl
, num_args
, args
);
3395 gfc_add_expr_to_block (&se
->pre
, tmp
);
3397 /* Free the temporary afterwards, if necessary. */
3398 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3399 len
, build_int_cst (TREE_TYPE (len
), 0));
3400 tmp
= gfc_call_free (var
);
3401 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3402 gfc_add_expr_to_block (&se
->post
, tmp
);
3405 se
->string_length
= len
;
3409 /* Generate a direct call to free() for the FREE subroutine. */
3412 conv_intrinsic_free (gfc_code
*code
)
3418 gfc_init_se (&argse
, NULL
);
3419 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3420 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3422 gfc_init_block (&block
);
3423 call
= build_call_expr_loc (input_location
,
3424 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3425 gfc_add_expr_to_block (&block
, call
);
3426 return gfc_finish_block (&block
);
3430 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3434 conv_intrinsic_system_clock (gfc_code
*code
)
3437 gfc_se count_se
, count_rate_se
, count_max_se
;
3438 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3442 gfc_expr
*count
= code
->ext
.actual
->expr
;
3443 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3444 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3446 /* Evaluate our arguments. */
3449 gfc_init_se (&count_se
, NULL
);
3450 gfc_conv_expr (&count_se
, count
);
3455 gfc_init_se (&count_rate_se
, NULL
);
3456 gfc_conv_expr (&count_rate_se
, count_rate
);
3461 gfc_init_se (&count_max_se
, NULL
);
3462 gfc_conv_expr (&count_max_se
, count_max
);
3465 /* Find the smallest kind found of the arguments. */
3467 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3468 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3470 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3473 /* Prepare temporary variables. */
3478 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3479 else if (least
== 4)
3480 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3481 else if (count
->ts
.kind
== 1)
3482 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3485 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3492 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3493 else if (least
== 4)
3494 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3496 arg2
= integer_zero_node
;
3502 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3503 else if (least
== 4)
3504 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3506 arg3
= integer_zero_node
;
3509 /* Make the function call. */
3510 gfc_init_block (&block
);
3516 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3517 : null_pointer_node
;
3518 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3519 : null_pointer_node
;
3520 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3521 : null_pointer_node
;
3526 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3527 : null_pointer_node
;
3528 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3529 : null_pointer_node
;
3530 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3531 : null_pointer_node
;
3538 tmp
= build_call_expr_loc (input_location
,
3539 gfor_fndecl_system_clock4
, 3,
3540 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3541 : null_pointer_node
,
3542 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3543 : null_pointer_node
,
3544 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3545 : null_pointer_node
);
3546 gfc_add_expr_to_block (&block
, tmp
);
3548 /* Handle kind>=8, 10, or 16 arguments */
3551 tmp
= build_call_expr_loc (input_location
,
3552 gfor_fndecl_system_clock8
, 3,
3553 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3554 : null_pointer_node
,
3555 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3556 : null_pointer_node
,
3557 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3558 : null_pointer_node
);
3559 gfc_add_expr_to_block (&block
, tmp
);
3563 /* And store values back if needed. */
3564 if (arg1
&& arg1
!= count_se
.expr
)
3565 gfc_add_modify (&block
, count_se
.expr
,
3566 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
3567 if (arg2
&& arg2
!= count_rate_se
.expr
)
3568 gfc_add_modify (&block
, count_rate_se
.expr
,
3569 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
3570 if (arg3
&& arg3
!= count_max_se
.expr
)
3571 gfc_add_modify (&block
, count_max_se
.expr
,
3572 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
3574 return gfc_finish_block (&block
);
3578 /* Return a character string containing the tty name. */
3581 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
3589 unsigned int num_args
;
3591 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3592 args
= XALLOCAVEC (tree
, num_args
);
3594 var
= gfc_create_var (pchar_type_node
, "pstr");
3595 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3597 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3598 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3599 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3601 fndecl
= build_addr (gfor_fndecl_ttynam
);
3602 tmp
= build_call_array_loc (input_location
,
3603 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
3604 fndecl
, num_args
, args
);
3605 gfc_add_expr_to_block (&se
->pre
, tmp
);
3607 /* Free the temporary afterwards, if necessary. */
3608 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3609 len
, build_int_cst (TREE_TYPE (len
), 0));
3610 tmp
= gfc_call_free (var
);
3611 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3612 gfc_add_expr_to_block (&se
->post
, tmp
);
3615 se
->string_length
= len
;
3619 /* Get the minimum/maximum value of all the parameters.
3620 minmax (a1, a2, a3, ...)
3623 if (a2 .op. mvar || isnan (mvar))
3625 if (a3 .op. mvar || isnan (mvar))
3632 /* TODO: Mismatching types can occur when specific names are used.
3633 These should be handled during resolution. */
3635 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3643 gfc_actual_arglist
*argexpr
;
3644 unsigned int i
, nargs
;
3646 nargs
= gfc_intrinsic_argument_list_length (expr
);
3647 args
= XALLOCAVEC (tree
, nargs
);
3649 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
3650 type
= gfc_typenode_for_spec (&expr
->ts
);
3652 argexpr
= expr
->value
.function
.actual
;
3653 if (TREE_TYPE (args
[0]) != type
)
3654 args
[0] = convert (type
, args
[0]);
3655 /* Only evaluate the argument once. */
3656 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
3657 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3659 mvar
= gfc_create_var (type
, "M");
3660 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
3661 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
3667 /* Handle absent optional arguments by ignoring the comparison. */
3668 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
3669 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
3670 && TREE_CODE (val
) == INDIRECT_REF
)
3671 cond
= fold_build2_loc (input_location
,
3672 NE_EXPR
, boolean_type_node
,
3673 TREE_OPERAND (val
, 0),
3674 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
3679 /* Only evaluate the argument once. */
3680 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
3681 val
= gfc_evaluate_now (val
, &se
->pre
);
3684 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
3686 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3687 convert (type
, val
), mvar
);
3689 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3690 __builtin_isnan might be made dependent on that module being loaded,
3691 to help performance of programs that don't rely on IEEE semantics. */
3692 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
3694 isnan
= build_call_expr_loc (input_location
,
3695 builtin_decl_explicit (BUILT_IN_ISNAN
),
3697 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3698 boolean_type_node
, tmp
,
3699 fold_convert (boolean_type_node
, isnan
));
3701 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
3702 build_empty_stmt (input_location
));
3704 if (cond
!= NULL_TREE
)
3705 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
3706 build_empty_stmt (input_location
));
3708 gfc_add_expr_to_block (&se
->pre
, tmp
);
3709 argexpr
= argexpr
->next
;
3715 /* Generate library calls for MIN and MAX intrinsics for character
3718 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
3721 tree var
, len
, fndecl
, tmp
, cond
, function
;
3724 nargs
= gfc_intrinsic_argument_list_length (expr
);
3725 args
= XALLOCAVEC (tree
, nargs
+ 4);
3726 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
3728 /* Create the result variables. */
3729 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3730 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3731 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3732 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3733 args
[2] = build_int_cst (integer_type_node
, op
);
3734 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3736 if (expr
->ts
.kind
== 1)
3737 function
= gfor_fndecl_string_minmax
;
3738 else if (expr
->ts
.kind
== 4)
3739 function
= gfor_fndecl_string_minmax_char4
;
3743 /* Make the function call. */
3744 fndecl
= build_addr (function
);
3745 tmp
= build_call_array_loc (input_location
,
3746 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3748 gfc_add_expr_to_block (&se
->pre
, tmp
);
3750 /* Free the temporary afterwards, if necessary. */
3751 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3752 len
, build_int_cst (TREE_TYPE (len
), 0));
3753 tmp
= gfc_call_free (var
);
3754 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3755 gfc_add_expr_to_block (&se
->post
, tmp
);
3758 se
->string_length
= len
;
3762 /* Create a symbol node for this intrinsic. The symbol from the frontend
3763 has the generic name. */
3766 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3770 /* TODO: Add symbols for intrinsic function to the global namespace. */
3771 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3772 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3775 sym
->attr
.external
= 1;
3776 sym
->attr
.function
= 1;
3777 sym
->attr
.always_explicit
= 1;
3778 sym
->attr
.proc
= PROC_INTRINSIC
;
3779 sym
->attr
.flavor
= FL_PROCEDURE
;
3783 sym
->attr
.dimension
= 1;
3784 sym
->as
= gfc_get_array_spec ();
3785 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3786 sym
->as
->rank
= expr
->rank
;
3789 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3790 ignore_optional
? expr
->value
.function
.actual
3796 /* Generate a call to an external intrinsic function. */
3798 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3801 vec
<tree
, va_gc
> *append_args
;
3803 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3806 gcc_assert (expr
->rank
> 0);
3808 gcc_assert (expr
->rank
== 0);
3810 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3812 /* Calls to libgfortran_matmul need to be appended special arguments,
3813 to be able to call the BLAS ?gemm functions if required and possible. */
3815 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3816 && sym
->ts
.type
!= BT_LOGICAL
)
3818 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3820 if (flag_external_blas
3821 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3822 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3826 if (sym
->ts
.type
== BT_REAL
)
3828 if (sym
->ts
.kind
== 4)
3829 gemm_fndecl
= gfor_fndecl_sgemm
;
3831 gemm_fndecl
= gfor_fndecl_dgemm
;
3835 if (sym
->ts
.kind
== 4)
3836 gemm_fndecl
= gfor_fndecl_cgemm
;
3838 gemm_fndecl
= gfor_fndecl_zgemm
;
3841 vec_alloc (append_args
, 3);
3842 append_args
->quick_push (build_int_cst (cint
, 1));
3843 append_args
->quick_push (build_int_cst (cint
,
3844 flag_blas_matmul_limit
));
3845 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3850 vec_alloc (append_args
, 3);
3851 append_args
->quick_push (build_int_cst (cint
, 0));
3852 append_args
->quick_push (build_int_cst (cint
, 0));
3853 append_args
->quick_push (null_pointer_node
);
3857 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3859 gfc_free_symbol (sym
);
3862 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3882 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3891 gfc_actual_arglist
*actual
;
3898 gfc_conv_intrinsic_funcall (se
, expr
);
3902 actual
= expr
->value
.function
.actual
;
3903 type
= gfc_typenode_for_spec (&expr
->ts
);
3904 /* Initialize the result. */
3905 resvar
= gfc_create_var (type
, "test");
3907 tmp
= convert (type
, boolean_true_node
);
3909 tmp
= convert (type
, boolean_false_node
);
3910 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3912 /* Walk the arguments. */
3913 arrayss
= gfc_walk_expr (actual
->expr
);
3914 gcc_assert (arrayss
!= gfc_ss_terminator
);
3916 /* Initialize the scalarizer. */
3917 gfc_init_loopinfo (&loop
);
3918 exit_label
= gfc_build_label_decl (NULL_TREE
);
3919 TREE_USED (exit_label
) = 1;
3920 gfc_add_ss_to_loop (&loop
, arrayss
);
3922 /* Initialize the loop. */
3923 gfc_conv_ss_startstride (&loop
);
3924 gfc_conv_loop_setup (&loop
, &expr
->where
);
3926 gfc_mark_ss_chain_used (arrayss
, 1);
3927 /* Generate the loop body. */
3928 gfc_start_scalarized_body (&loop
, &body
);
3930 /* If the condition matches then set the return value. */
3931 gfc_start_block (&block
);
3933 tmp
= convert (type
, boolean_false_node
);
3935 tmp
= convert (type
, boolean_true_node
);
3936 gfc_add_modify (&block
, resvar
, tmp
);
3938 /* And break out of the loop. */
3939 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3940 gfc_add_expr_to_block (&block
, tmp
);
3942 found
= gfc_finish_block (&block
);
3944 /* Check this element. */
3945 gfc_init_se (&arrayse
, NULL
);
3946 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3947 arrayse
.ss
= arrayss
;
3948 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3950 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3951 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3952 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3953 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3954 gfc_add_expr_to_block (&body
, tmp
);
3955 gfc_add_block_to_block (&body
, &arrayse
.post
);
3957 gfc_trans_scalarizing_loops (&loop
, &body
);
3959 /* Add the exit label. */
3960 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3961 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3963 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3964 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3965 gfc_cleanup_loop (&loop
);
3970 /* COUNT(A) = Number of true elements in A. */
3972 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
3979 gfc_actual_arglist
*actual
;
3985 gfc_conv_intrinsic_funcall (se
, expr
);
3989 actual
= expr
->value
.function
.actual
;
3991 type
= gfc_typenode_for_spec (&expr
->ts
);
3992 /* Initialize the result. */
3993 resvar
= gfc_create_var (type
, "count");
3994 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
3996 /* Walk the arguments. */
3997 arrayss
= gfc_walk_expr (actual
->expr
);
3998 gcc_assert (arrayss
!= gfc_ss_terminator
);
4000 /* Initialize the scalarizer. */
4001 gfc_init_loopinfo (&loop
);
4002 gfc_add_ss_to_loop (&loop
, arrayss
);
4004 /* Initialize the loop. */
4005 gfc_conv_ss_startstride (&loop
);
4006 gfc_conv_loop_setup (&loop
, &expr
->where
);
4008 gfc_mark_ss_chain_used (arrayss
, 1);
4009 /* Generate the loop body. */
4010 gfc_start_scalarized_body (&loop
, &body
);
4012 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4013 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4014 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4016 gfc_init_se (&arrayse
, NULL
);
4017 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4018 arrayse
.ss
= arrayss
;
4019 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4020 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4021 build_empty_stmt (input_location
));
4023 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4024 gfc_add_expr_to_block (&body
, tmp
);
4025 gfc_add_block_to_block (&body
, &arrayse
.post
);
4027 gfc_trans_scalarizing_loops (&loop
, &body
);
4029 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4030 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4031 gfc_cleanup_loop (&loop
);
4037 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4038 struct and return the corresponding loopinfo. */
4040 static gfc_loopinfo
*
4041 enter_nested_loop (gfc_se
*se
)
4043 se
->ss
= se
->ss
->nested_ss
;
4044 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4046 return se
->ss
->loop
;
4050 /* Inline implementation of the sum and product intrinsics. */
4052 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4056 tree scale
= NULL_TREE
;
4061 gfc_loopinfo loop
, *ploop
;
4062 gfc_actual_arglist
*arg_array
, *arg_mask
;
4063 gfc_ss
*arrayss
= NULL
;
4064 gfc_ss
*maskss
= NULL
;
4068 gfc_expr
*arrayexpr
;
4073 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4079 type
= gfc_typenode_for_spec (&expr
->ts
);
4080 /* Initialize the result. */
4081 resvar
= gfc_create_var (type
, "val");
4086 scale
= gfc_create_var (type
, "scale");
4087 gfc_add_modify (&se
->pre
, scale
,
4088 gfc_build_const (type
, integer_one_node
));
4089 tmp
= gfc_build_const (type
, integer_zero_node
);
4091 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4092 tmp
= gfc_build_const (type
, integer_zero_node
);
4093 else if (op
== NE_EXPR
)
4095 tmp
= convert (type
, boolean_false_node
);
4096 else if (op
== BIT_AND_EXPR
)
4097 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4098 type
, integer_one_node
));
4100 tmp
= gfc_build_const (type
, integer_one_node
);
4102 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4104 arg_array
= expr
->value
.function
.actual
;
4106 arrayexpr
= arg_array
->expr
;
4108 if (op
== NE_EXPR
|| norm2
)
4109 /* PARITY and NORM2. */
4113 arg_mask
= arg_array
->next
->next
;
4114 gcc_assert (arg_mask
!= NULL
);
4115 maskexpr
= arg_mask
->expr
;
4118 if (expr
->rank
== 0)
4120 /* Walk the arguments. */
4121 arrayss
= gfc_walk_expr (arrayexpr
);
4122 gcc_assert (arrayss
!= gfc_ss_terminator
);
4124 if (maskexpr
&& maskexpr
->rank
> 0)
4126 maskss
= gfc_walk_expr (maskexpr
);
4127 gcc_assert (maskss
!= gfc_ss_terminator
);
4132 /* Initialize the scalarizer. */
4133 gfc_init_loopinfo (&loop
);
4134 gfc_add_ss_to_loop (&loop
, arrayss
);
4135 if (maskexpr
&& maskexpr
->rank
> 0)
4136 gfc_add_ss_to_loop (&loop
, maskss
);
4138 /* Initialize the loop. */
4139 gfc_conv_ss_startstride (&loop
);
4140 gfc_conv_loop_setup (&loop
, &expr
->where
);
4142 gfc_mark_ss_chain_used (arrayss
, 1);
4143 if (maskexpr
&& maskexpr
->rank
> 0)
4144 gfc_mark_ss_chain_used (maskss
, 1);
4149 /* All the work has been done in the parent loops. */
4150 ploop
= enter_nested_loop (se
);
4154 /* Generate the loop body. */
4155 gfc_start_scalarized_body (ploop
, &body
);
4157 /* If we have a mask, only add this element if the mask is set. */
4158 if (maskexpr
&& maskexpr
->rank
> 0)
4160 gfc_init_se (&maskse
, parent_se
);
4161 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4162 if (expr
->rank
== 0)
4164 gfc_conv_expr_val (&maskse
, maskexpr
);
4165 gfc_add_block_to_block (&body
, &maskse
.pre
);
4167 gfc_start_block (&block
);
4170 gfc_init_block (&block
);
4172 /* Do the actual summation/product. */
4173 gfc_init_se (&arrayse
, parent_se
);
4174 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4175 if (expr
->rank
== 0)
4176 arrayse
.ss
= arrayss
;
4177 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4178 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4182 /* if (x (i) != 0.0)
4188 result = 1.0 + result * val * val;
4194 result += val * val;
4197 tree res1
, res2
, cond
, absX
, val
;
4198 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4200 gfc_init_block (&ifblock1
);
4202 absX
= gfc_create_var (type
, "absX");
4203 gfc_add_modify (&ifblock1
, absX
,
4204 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4206 val
= gfc_create_var (type
, "val");
4207 gfc_add_expr_to_block (&ifblock1
, val
);
4209 gfc_init_block (&ifblock2
);
4210 gfc_add_modify (&ifblock2
, val
,
4211 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4213 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4214 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4215 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4216 gfc_build_const (type
, integer_one_node
));
4217 gfc_add_modify (&ifblock2
, resvar
, res1
);
4218 gfc_add_modify (&ifblock2
, scale
, absX
);
4219 res1
= gfc_finish_block (&ifblock2
);
4221 gfc_init_block (&ifblock3
);
4222 gfc_add_modify (&ifblock3
, val
,
4223 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4225 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4226 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4227 gfc_add_modify (&ifblock3
, resvar
, res2
);
4228 res2
= gfc_finish_block (&ifblock3
);
4230 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
4232 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4233 gfc_add_expr_to_block (&ifblock1
, tmp
);
4234 tmp
= gfc_finish_block (&ifblock1
);
4236 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4238 gfc_build_const (type
, integer_zero_node
));
4240 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4241 gfc_add_expr_to_block (&block
, tmp
);
4245 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4246 gfc_add_modify (&block
, resvar
, tmp
);
4249 gfc_add_block_to_block (&block
, &arrayse
.post
);
4251 if (maskexpr
&& maskexpr
->rank
> 0)
4253 /* We enclose the above in if (mask) {...} . */
4255 tmp
= gfc_finish_block (&block
);
4256 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4257 build_empty_stmt (input_location
));
4260 tmp
= gfc_finish_block (&block
);
4261 gfc_add_expr_to_block (&body
, tmp
);
4263 gfc_trans_scalarizing_loops (ploop
, &body
);
4265 /* For a scalar mask, enclose the loop in an if statement. */
4266 if (maskexpr
&& maskexpr
->rank
== 0)
4268 gfc_init_block (&block
);
4269 gfc_add_block_to_block (&block
, &ploop
->pre
);
4270 gfc_add_block_to_block (&block
, &ploop
->post
);
4271 tmp
= gfc_finish_block (&block
);
4275 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4276 build_empty_stmt (input_location
));
4277 gfc_advance_se_ss_chain (se
);
4281 gcc_assert (expr
->rank
== 0);
4282 gfc_init_se (&maskse
, NULL
);
4283 gfc_conv_expr_val (&maskse
, maskexpr
);
4284 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4285 build_empty_stmt (input_location
));
4288 gfc_add_expr_to_block (&block
, tmp
);
4289 gfc_add_block_to_block (&se
->pre
, &block
);
4290 gcc_assert (se
->post
.head
== NULL
);
4294 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4295 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4298 if (expr
->rank
== 0)
4299 gfc_cleanup_loop (ploop
);
4303 /* result = scale * sqrt(result). */
4305 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4306 resvar
= build_call_expr_loc (input_location
,
4308 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4315 /* Inline implementation of the dot_product intrinsic. This function
4316 is based on gfc_conv_intrinsic_arith (the previous function). */
4318 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4326 gfc_actual_arglist
*actual
;
4327 gfc_ss
*arrayss1
, *arrayss2
;
4328 gfc_se arrayse1
, arrayse2
;
4329 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4331 type
= gfc_typenode_for_spec (&expr
->ts
);
4333 /* Initialize the result. */
4334 resvar
= gfc_create_var (type
, "val");
4335 if (expr
->ts
.type
== BT_LOGICAL
)
4336 tmp
= build_int_cst (type
, 0);
4338 tmp
= gfc_build_const (type
, integer_zero_node
);
4340 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4342 /* Walk argument #1. */
4343 actual
= expr
->value
.function
.actual
;
4344 arrayexpr1
= actual
->expr
;
4345 arrayss1
= gfc_walk_expr (arrayexpr1
);
4346 gcc_assert (arrayss1
!= gfc_ss_terminator
);
4348 /* Walk argument #2. */
4349 actual
= actual
->next
;
4350 arrayexpr2
= actual
->expr
;
4351 arrayss2
= gfc_walk_expr (arrayexpr2
);
4352 gcc_assert (arrayss2
!= gfc_ss_terminator
);
4354 /* Initialize the scalarizer. */
4355 gfc_init_loopinfo (&loop
);
4356 gfc_add_ss_to_loop (&loop
, arrayss1
);
4357 gfc_add_ss_to_loop (&loop
, arrayss2
);
4359 /* Initialize the loop. */
4360 gfc_conv_ss_startstride (&loop
);
4361 gfc_conv_loop_setup (&loop
, &expr
->where
);
4363 gfc_mark_ss_chain_used (arrayss1
, 1);
4364 gfc_mark_ss_chain_used (arrayss2
, 1);
4366 /* Generate the loop body. */
4367 gfc_start_scalarized_body (&loop
, &body
);
4368 gfc_init_block (&block
);
4370 /* Make the tree expression for [conjg(]array1[)]. */
4371 gfc_init_se (&arrayse1
, NULL
);
4372 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
4373 arrayse1
.ss
= arrayss1
;
4374 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
4375 if (expr
->ts
.type
== BT_COMPLEX
)
4376 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
4378 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
4380 /* Make the tree expression for array2. */
4381 gfc_init_se (&arrayse2
, NULL
);
4382 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
4383 arrayse2
.ss
= arrayss2
;
4384 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
4385 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
4387 /* Do the actual product and sum. */
4388 if (expr
->ts
.type
== BT_LOGICAL
)
4390 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
4391 arrayse1
.expr
, arrayse2
.expr
);
4392 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
4396 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
4398 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
4400 gfc_add_modify (&block
, resvar
, tmp
);
4402 /* Finish up the loop block and the loop. */
4403 tmp
= gfc_finish_block (&block
);
4404 gfc_add_expr_to_block (&body
, tmp
);
4406 gfc_trans_scalarizing_loops (&loop
, &body
);
4407 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4408 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4409 gfc_cleanup_loop (&loop
);
4415 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4416 we need to handle. For performance reasons we sometimes create two
4417 loops instead of one, where the second one is much simpler.
4418 Examples for minloc intrinsic:
4419 1) Result is an array, a call is generated
4420 2) Array mask is used and NaNs need to be supported:
4426 if (pos == 0) pos = S + (1 - from);
4427 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4434 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4438 3) NaNs need to be supported, but it is known at compile time or cheaply
4439 at runtime whether array is nonempty or not:
4444 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4447 if (from <= to) pos = 1;
4451 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4455 4) NaNs aren't supported, array mask is used:
4456 limit = infinities_supported ? Infinity : huge (limit);
4460 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4466 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4470 5) Same without array mask:
4471 limit = infinities_supported ? Infinity : huge (limit);
4472 pos = (from <= to) ? 1 : 0;
4475 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4478 For 3) and 5), if mask is scalar, this all goes into a conditional,
4479 setting pos = 0; in the else branch. */
4482 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4486 stmtblock_t ifblock
;
4487 stmtblock_t elseblock
;
4498 gfc_actual_arglist
*actual
;
4503 gfc_expr
*arrayexpr
;
4510 gfc_conv_intrinsic_funcall (se
, expr
);
4514 /* Initialize the result. */
4515 pos
= gfc_create_var (gfc_array_index_type
, "pos");
4516 offset
= gfc_create_var (gfc_array_index_type
, "offset");
4517 type
= gfc_typenode_for_spec (&expr
->ts
);
4519 /* Walk the arguments. */
4520 actual
= expr
->value
.function
.actual
;
4521 arrayexpr
= actual
->expr
;
4522 arrayss
= gfc_walk_expr (arrayexpr
);
4523 gcc_assert (arrayss
!= gfc_ss_terminator
);
4525 actual
= actual
->next
->next
;
4526 gcc_assert (actual
);
4527 maskexpr
= actual
->expr
;
4529 if (maskexpr
&& maskexpr
->rank
!= 0)
4531 maskss
= gfc_walk_expr (maskexpr
);
4532 gcc_assert (maskss
!= gfc_ss_terminator
);
4537 if (gfc_array_size (arrayexpr
, &asize
))
4539 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4541 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4542 boolean_type_node
, nonempty
,
4543 gfc_index_zero_node
);
4548 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
4549 switch (arrayexpr
->ts
.type
)
4552 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
4556 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
4557 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
4558 arrayexpr
->ts
.kind
);
4565 /* We start with the most negative possible value for MAXLOC, and the most
4566 positive possible value for MINLOC. The most negative possible value is
4567 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4568 possible value is HUGE in both cases. */
4570 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4571 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
4572 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
4573 build_int_cst (TREE_TYPE (tmp
), 1));
4575 gfc_add_modify (&se
->pre
, limit
, tmp
);
4577 /* Initialize the scalarizer. */
4578 gfc_init_loopinfo (&loop
);
4579 gfc_add_ss_to_loop (&loop
, arrayss
);
4581 gfc_add_ss_to_loop (&loop
, maskss
);
4583 /* Initialize the loop. */
4584 gfc_conv_ss_startstride (&loop
);
4586 /* The code generated can have more than one loop in sequence (see the
4587 comment at the function header). This doesn't work well with the
4588 scalarizer, which changes arrays' offset when the scalarization loops
4589 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4590 are currently inlined in the scalar case only (for which loop is of rank
4591 one). As there is no dependency to care about in that case, there is no
4592 temporary, so that we can use the scalarizer temporary code to handle
4593 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4594 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4596 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4597 should eventually go away. We could either create two loops properly,
4598 or find another way to save/restore the array offsets between the two
4599 loops (without conflicting with temporary management), or use a single
4600 loop minmaxloc implementation. See PR 31067. */
4601 loop
.temp_dim
= loop
.dimen
;
4602 gfc_conv_loop_setup (&loop
, &expr
->where
);
4604 gcc_assert (loop
.dimen
== 1);
4605 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
4606 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4607 loop
.from
[0], loop
.to
[0]);
4611 /* Initialize the position to zero, following Fortran 2003. We are free
4612 to do this because Fortran 95 allows the result of an entirely false
4613 mask to be processor dependent. If we know at compile time the array
4614 is non-empty and no MASK is used, we can initialize to 1 to simplify
4616 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
4617 gfc_add_modify (&loop
.pre
, pos
,
4618 fold_build3_loc (input_location
, COND_EXPR
,
4619 gfc_array_index_type
,
4620 nonempty
, gfc_index_one_node
,
4621 gfc_index_zero_node
));
4624 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
4625 lab1
= gfc_build_label_decl (NULL_TREE
);
4626 TREE_USED (lab1
) = 1;
4627 lab2
= gfc_build_label_decl (NULL_TREE
);
4628 TREE_USED (lab2
) = 1;
4631 /* An offset must be added to the loop
4632 counter to obtain the required position. */
4633 gcc_assert (loop
.from
[0]);
4635 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4636 gfc_index_one_node
, loop
.from
[0]);
4637 gfc_add_modify (&loop
.pre
, offset
, tmp
);
4639 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
4641 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
4642 /* Generate the loop body. */
4643 gfc_start_scalarized_body (&loop
, &body
);
4645 /* If we have a mask, only check this element if the mask is set. */
4648 gfc_init_se (&maskse
, NULL
);
4649 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4651 gfc_conv_expr_val (&maskse
, maskexpr
);
4652 gfc_add_block_to_block (&body
, &maskse
.pre
);
4654 gfc_start_block (&block
);
4657 gfc_init_block (&block
);
4659 /* Compare with the current limit. */
4660 gfc_init_se (&arrayse
, NULL
);
4661 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4662 arrayse
.ss
= arrayss
;
4663 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4664 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4666 /* We do the following if this is a more extreme value. */
4667 gfc_start_block (&ifblock
);
4669 /* Assign the value to the limit... */
4670 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4672 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
4674 stmtblock_t ifblock2
;
4677 gfc_start_block (&ifblock2
);
4678 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4679 loop
.loopvar
[0], offset
);
4680 gfc_add_modify (&ifblock2
, pos
, tmp
);
4681 ifbody2
= gfc_finish_block (&ifblock2
);
4682 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
4683 gfc_index_zero_node
);
4684 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
4685 build_empty_stmt (input_location
));
4686 gfc_add_expr_to_block (&block
, tmp
);
4689 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4690 loop
.loopvar
[0], offset
);
4691 gfc_add_modify (&ifblock
, pos
, tmp
);
4694 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
4696 ifbody
= gfc_finish_block (&ifblock
);
4698 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
4701 cond
= fold_build2_loc (input_location
,
4702 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4703 boolean_type_node
, arrayse
.expr
, limit
);
4705 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4706 arrayse
.expr
, limit
);
4708 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
4709 build_empty_stmt (input_location
));
4711 gfc_add_expr_to_block (&block
, ifbody
);
4715 /* We enclose the above in if (mask) {...}. */
4716 tmp
= gfc_finish_block (&block
);
4718 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4719 build_empty_stmt (input_location
));
4722 tmp
= gfc_finish_block (&block
);
4723 gfc_add_expr_to_block (&body
, tmp
);
4727 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4729 if (HONOR_NANS (DECL_MODE (limit
)))
4731 if (nonempty
!= NULL
)
4733 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
4734 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
4735 build_empty_stmt (input_location
));
4736 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
4740 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
4741 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
4743 /* If we have a mask, only check this element if the mask is set. */
4746 gfc_init_se (&maskse
, NULL
);
4747 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4749 gfc_conv_expr_val (&maskse
, maskexpr
);
4750 gfc_add_block_to_block (&body
, &maskse
.pre
);
4752 gfc_start_block (&block
);
4755 gfc_init_block (&block
);
4757 /* Compare with the current limit. */
4758 gfc_init_se (&arrayse
, NULL
);
4759 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4760 arrayse
.ss
= arrayss
;
4761 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4762 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4764 /* We do the following if this is a more extreme value. */
4765 gfc_start_block (&ifblock
);
4767 /* Assign the value to the limit... */
4768 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4770 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4771 loop
.loopvar
[0], offset
);
4772 gfc_add_modify (&ifblock
, pos
, tmp
);
4774 ifbody
= gfc_finish_block (&ifblock
);
4776 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4777 arrayse
.expr
, limit
);
4779 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4780 build_empty_stmt (input_location
));
4781 gfc_add_expr_to_block (&block
, tmp
);
4785 /* We enclose the above in if (mask) {...}. */
4786 tmp
= gfc_finish_block (&block
);
4788 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4789 build_empty_stmt (input_location
));
4792 tmp
= gfc_finish_block (&block
);
4793 gfc_add_expr_to_block (&body
, tmp
);
4794 /* Avoid initializing loopvar[0] again, it should be left where
4795 it finished by the first loop. */
4796 loop
.from
[0] = loop
.loopvar
[0];
4799 gfc_trans_scalarizing_loops (&loop
, &body
);
4802 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4804 /* For a scalar mask, enclose the loop in an if statement. */
4805 if (maskexpr
&& maskss
== NULL
)
4807 gfc_init_se (&maskse
, NULL
);
4808 gfc_conv_expr_val (&maskse
, maskexpr
);
4809 gfc_init_block (&block
);
4810 gfc_add_block_to_block (&block
, &loop
.pre
);
4811 gfc_add_block_to_block (&block
, &loop
.post
);
4812 tmp
= gfc_finish_block (&block
);
4814 /* For the else part of the scalar mask, just initialize
4815 the pos variable the same way as above. */
4817 gfc_init_block (&elseblock
);
4818 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4819 elsetmp
= gfc_finish_block (&elseblock
);
4821 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4822 gfc_add_expr_to_block (&block
, tmp
);
4823 gfc_add_block_to_block (&se
->pre
, &block
);
4827 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4828 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4830 gfc_cleanup_loop (&loop
);
4832 se
->expr
= convert (type
, pos
);
4835 /* Emit code for minval or maxval intrinsic. There are many different cases
4836 we need to handle. For performance reasons we sometimes create two
4837 loops instead of one, where the second one is much simpler.
4838 Examples for minval intrinsic:
4839 1) Result is an array, a call is generated
4840 2) Array mask is used and NaNs need to be supported, rank 1:
4845 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4848 limit = nonempty ? NaN : huge (limit);
4850 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4851 3) NaNs need to be supported, but it is known at compile time or cheaply
4852 at runtime whether array is nonempty or not, rank 1:
4855 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4856 limit = (from <= to) ? NaN : huge (limit);
4858 while (S <= to) { limit = min (a[S], limit); S++; }
4859 4) Array mask is used and NaNs need to be supported, rank > 1:
4868 if (fast) limit = min (a[S1][S2], limit);
4871 if (a[S1][S2] <= limit) {
4882 limit = nonempty ? NaN : huge (limit);
4883 5) NaNs need to be supported, but it is known at compile time or cheaply
4884 at runtime whether array is nonempty or not, rank > 1:
4891 if (fast) limit = min (a[S1][S2], limit);
4893 if (a[S1][S2] <= limit) {
4903 limit = (nonempty_array) ? NaN : huge (limit);
4904 6) NaNs aren't supported, but infinities are. Array mask is used:
4909 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4912 limit = nonempty ? limit : huge (limit);
4913 7) Same without array mask:
4916 while (S <= to) { limit = min (a[S], limit); S++; }
4917 limit = (from <= to) ? limit : huge (limit);
4918 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4919 limit = huge (limit);
4921 while (S <= to) { limit = min (a[S], limit); S++); }
4923 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4924 with array mask instead).
4925 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4926 setting limit = huge (limit); in the else branch. */
4929 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4939 tree huge_cst
= NULL
, nan_cst
= NULL
;
4941 stmtblock_t block
, block2
;
4943 gfc_actual_arglist
*actual
;
4948 gfc_expr
*arrayexpr
;
4954 gfc_conv_intrinsic_funcall (se
, expr
);
4958 type
= gfc_typenode_for_spec (&expr
->ts
);
4959 /* Initialize the result. */
4960 limit
= gfc_create_var (type
, "limit");
4961 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
4962 switch (expr
->ts
.type
)
4965 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
4967 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4969 REAL_VALUE_TYPE real
;
4971 tmp
= build_real (type
, real
);
4975 if (HONOR_NANS (DECL_MODE (limit
)))
4976 nan_cst
= gfc_build_nan (type
, "");
4980 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
4987 /* We start with the most negative possible value for MAXVAL, and the most
4988 positive possible value for MINVAL. The most negative possible value is
4989 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4990 possible value is HUGE in both cases. */
4993 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4995 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
4996 TREE_TYPE (huge_cst
), huge_cst
);
4999 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
5000 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5001 tmp
, build_int_cst (type
, 1));
5003 gfc_add_modify (&se
->pre
, limit
, tmp
);
5005 /* Walk the arguments. */
5006 actual
= expr
->value
.function
.actual
;
5007 arrayexpr
= actual
->expr
;
5008 arrayss
= gfc_walk_expr (arrayexpr
);
5009 gcc_assert (arrayss
!= gfc_ss_terminator
);
5011 actual
= actual
->next
->next
;
5012 gcc_assert (actual
);
5013 maskexpr
= actual
->expr
;
5015 if (maskexpr
&& maskexpr
->rank
!= 0)
5017 maskss
= gfc_walk_expr (maskexpr
);
5018 gcc_assert (maskss
!= gfc_ss_terminator
);
5023 if (gfc_array_size (arrayexpr
, &asize
))
5025 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5027 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5028 boolean_type_node
, nonempty
,
5029 gfc_index_zero_node
);
5034 /* Initialize the scalarizer. */
5035 gfc_init_loopinfo (&loop
);
5036 gfc_add_ss_to_loop (&loop
, arrayss
);
5038 gfc_add_ss_to_loop (&loop
, maskss
);
5040 /* Initialize the loop. */
5041 gfc_conv_ss_startstride (&loop
);
5043 /* The code generated can have more than one loop in sequence (see the
5044 comment at the function header). This doesn't work well with the
5045 scalarizer, which changes arrays' offset when the scalarization loops
5046 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5047 are currently inlined in the scalar case only. As there is no dependency
5048 to care about in that case, there is no temporary, so that we can use the
5049 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5050 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5051 gfc_trans_scalarized_loop_boundary even later to restore offset.
5052 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5053 should eventually go away. We could either create two loops properly,
5054 or find another way to save/restore the array offsets between the two
5055 loops (without conflicting with temporary management), or use a single
5056 loop minmaxval implementation. See PR 31067. */
5057 loop
.temp_dim
= loop
.dimen
;
5058 gfc_conv_loop_setup (&loop
, &expr
->where
);
5060 if (nonempty
== NULL
&& maskss
== NULL
5061 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5062 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5063 loop
.from
[0], loop
.to
[0]);
5064 nonempty_var
= NULL
;
5065 if (nonempty
== NULL
5066 && (HONOR_INFINITIES (DECL_MODE (limit
))
5067 || HONOR_NANS (DECL_MODE (limit
))))
5069 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
5070 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
5071 nonempty
= nonempty_var
;
5075 if (HONOR_NANS (DECL_MODE (limit
)))
5077 if (loop
.dimen
== 1)
5079 lab
= gfc_build_label_decl (NULL_TREE
);
5080 TREE_USED (lab
) = 1;
5084 fast
= gfc_create_var (boolean_type_node
, "fast");
5085 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
5089 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5091 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5092 /* Generate the loop body. */
5093 gfc_start_scalarized_body (&loop
, &body
);
5095 /* If we have a mask, only add this element if the mask is set. */
5098 gfc_init_se (&maskse
, NULL
);
5099 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5101 gfc_conv_expr_val (&maskse
, maskexpr
);
5102 gfc_add_block_to_block (&body
, &maskse
.pre
);
5104 gfc_start_block (&block
);
5107 gfc_init_block (&block
);
5109 /* Compare with the current limit. */
5110 gfc_init_se (&arrayse
, NULL
);
5111 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5112 arrayse
.ss
= arrayss
;
5113 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5114 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5116 gfc_init_block (&block2
);
5119 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
5121 if (HONOR_NANS (DECL_MODE (limit
)))
5123 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5124 boolean_type_node
, arrayse
.expr
, limit
);
5126 ifbody
= build1_v (GOTO_EXPR
, lab
);
5129 stmtblock_t ifblock
;
5131 gfc_init_block (&ifblock
);
5132 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5133 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
5134 ifbody
= gfc_finish_block (&ifblock
);
5136 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5137 build_empty_stmt (input_location
));
5138 gfc_add_expr_to_block (&block2
, tmp
);
5142 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5144 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5146 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5147 arrayse
.expr
, limit
);
5148 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5149 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5150 build_empty_stmt (input_location
));
5151 gfc_add_expr_to_block (&block2
, tmp
);
5155 tmp
= fold_build2_loc (input_location
,
5156 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5157 type
, arrayse
.expr
, limit
);
5158 gfc_add_modify (&block2
, limit
, tmp
);
5164 tree elsebody
= gfc_finish_block (&block2
);
5166 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5168 if (HONOR_NANS (DECL_MODE (limit
))
5169 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5171 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5172 arrayse
.expr
, limit
);
5173 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5174 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5175 build_empty_stmt (input_location
));
5179 tmp
= fold_build2_loc (input_location
,
5180 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5181 type
, arrayse
.expr
, limit
);
5182 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5184 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5185 gfc_add_expr_to_block (&block
, tmp
);
5188 gfc_add_block_to_block (&block
, &block2
);
5190 gfc_add_block_to_block (&block
, &arrayse
.post
);
5192 tmp
= gfc_finish_block (&block
);
5194 /* We enclose the above in if (mask) {...}. */
5195 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5196 build_empty_stmt (input_location
));
5197 gfc_add_expr_to_block (&body
, tmp
);
5201 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5203 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5205 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
5206 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
5208 /* If we have a mask, only add this element if the mask is set. */
5211 gfc_init_se (&maskse
, NULL
);
5212 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5214 gfc_conv_expr_val (&maskse
, maskexpr
);
5215 gfc_add_block_to_block (&body
, &maskse
.pre
);
5217 gfc_start_block (&block
);
5220 gfc_init_block (&block
);
5222 /* Compare with the current limit. */
5223 gfc_init_se (&arrayse
, NULL
);
5224 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5225 arrayse
.ss
= arrayss
;
5226 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5227 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5229 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5231 if (HONOR_NANS (DECL_MODE (limit
))
5232 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5234 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5235 arrayse
.expr
, limit
);
5236 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5237 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5238 build_empty_stmt (input_location
));
5239 gfc_add_expr_to_block (&block
, tmp
);
5243 tmp
= fold_build2_loc (input_location
,
5244 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5245 type
, arrayse
.expr
, limit
);
5246 gfc_add_modify (&block
, limit
, tmp
);
5249 gfc_add_block_to_block (&block
, &arrayse
.post
);
5251 tmp
= gfc_finish_block (&block
);
5253 /* We enclose the above in if (mask) {...}. */
5254 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5255 build_empty_stmt (input_location
));
5256 gfc_add_expr_to_block (&body
, tmp
);
5257 /* Avoid initializing loopvar[0] again, it should be left where
5258 it finished by the first loop. */
5259 loop
.from
[0] = loop
.loopvar
[0];
5261 gfc_trans_scalarizing_loops (&loop
, &body
);
5265 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5267 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5268 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
5270 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5272 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
5274 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
5276 gfc_add_modify (&loop
.pre
, limit
, tmp
);
5279 /* For a scalar mask, enclose the loop in an if statement. */
5280 if (maskexpr
&& maskss
== NULL
)
5284 gfc_init_se (&maskse
, NULL
);
5285 gfc_conv_expr_val (&maskse
, maskexpr
);
5286 gfc_init_block (&block
);
5287 gfc_add_block_to_block (&block
, &loop
.pre
);
5288 gfc_add_block_to_block (&block
, &loop
.post
);
5289 tmp
= gfc_finish_block (&block
);
5291 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5292 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
5294 else_stmt
= build_empty_stmt (input_location
);
5295 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
5296 gfc_add_expr_to_block (&block
, tmp
);
5297 gfc_add_block_to_block (&se
->pre
, &block
);
5301 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5302 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5305 gfc_cleanup_loop (&loop
);
5310 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5312 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
5318 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5319 type
= TREE_TYPE (args
[0]);
5321 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5322 build_int_cst (type
, 1), args
[1]);
5323 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
5324 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5325 build_int_cst (type
, 0));
5326 type
= gfc_typenode_for_spec (&expr
->ts
);
5327 se
->expr
= convert (type
, tmp
);
5331 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5333 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5337 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5339 /* Convert both arguments to the unsigned type of the same size. */
5340 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
5341 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
5343 /* If they have unequal type size, convert to the larger one. */
5344 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
5345 > TYPE_PRECISION (TREE_TYPE (args
[1])))
5346 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
5347 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
5348 > TYPE_PRECISION (TREE_TYPE (args
[0])))
5349 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
5351 /* Now, we compare them. */
5352 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5357 /* Generate code to perform the specified operation. */
5359 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5363 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5364 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
5370 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
5374 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5375 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5376 TREE_TYPE (arg
), arg
);
5379 /* Set or clear a single bit. */
5381 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
5388 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5389 type
= TREE_TYPE (args
[0]);
5391 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5392 build_int_cst (type
, 1), args
[1]);
5398 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
5400 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
5403 /* Extract a sequence of bits.
5404 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5406 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
5413 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5414 type
= TREE_TYPE (args
[0]);
5416 mask
= build_int_cst (type
, -1);
5417 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
5418 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
5420 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
5422 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
5426 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
5429 tree args
[2], type
, num_bits
, cond
;
5431 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5433 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5434 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5435 type
= TREE_TYPE (args
[0]);
5438 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
5440 gcc_assert (right_shift
);
5442 se
->expr
= fold_build2_loc (input_location
,
5443 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
5444 TREE_TYPE (args
[0]), args
[0], args
[1]);
5447 se
->expr
= fold_convert (type
, se
->expr
);
5449 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5450 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5452 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5453 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5456 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5457 build_int_cst (type
, 0), se
->expr
);
5460 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5462 : ((shift >= 0) ? i << shift : i >> -shift)
5463 where all shifts are logical shifts. */
5465 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
5477 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5479 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5480 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5482 type
= TREE_TYPE (args
[0]);
5483 utype
= unsigned_type_for (type
);
5485 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
5488 /* Left shift if positive. */
5489 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
5491 /* Right shift if negative.
5492 We convert to an unsigned type because we want a logical shift.
5493 The standard doesn't define the case of shifting negative
5494 numbers, and we try to be compatible with other compilers, most
5495 notably g77, here. */
5496 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
5497 utype
, convert (utype
, args
[0]), width
));
5499 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
5500 build_int_cst (TREE_TYPE (args
[1]), 0));
5501 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
5503 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5504 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5506 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5507 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
5509 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5510 build_int_cst (type
, 0), tmp
);
5514 /* Circular shift. AKA rotate or barrel shift. */
5517 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
5525 unsigned int num_args
;
5527 num_args
= gfc_intrinsic_argument_list_length (expr
);
5528 args
= XALLOCAVEC (tree
, num_args
);
5530 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5534 /* Use a library function for the 3 parameter version. */
5535 tree int4type
= gfc_get_int_type (4);
5537 type
= TREE_TYPE (args
[0]);
5538 /* We convert the first argument to at least 4 bytes, and
5539 convert back afterwards. This removes the need for library
5540 functions for all argument sizes, and function will be
5541 aligned to at least 32 bits, so there's no loss. */
5542 if (expr
->ts
.kind
< 4)
5543 args
[0] = convert (int4type
, args
[0]);
5545 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5546 need loads of library functions. They cannot have values >
5547 BIT_SIZE (I) so the conversion is safe. */
5548 args
[1] = convert (int4type
, args
[1]);
5549 args
[2] = convert (int4type
, args
[2]);
5551 switch (expr
->ts
.kind
)
5556 tmp
= gfor_fndecl_math_ishftc4
;
5559 tmp
= gfor_fndecl_math_ishftc8
;
5562 tmp
= gfor_fndecl_math_ishftc16
;
5567 se
->expr
= build_call_expr_loc (input_location
,
5568 tmp
, 3, args
[0], args
[1], args
[2]);
5569 /* Convert the result back to the original type, if we extended
5570 the first argument's width above. */
5571 if (expr
->ts
.kind
< 4)
5572 se
->expr
= convert (type
, se
->expr
);
5576 type
= TREE_TYPE (args
[0]);
5578 /* Evaluate arguments only once. */
5579 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5580 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5582 /* Rotate left if positive. */
5583 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
5585 /* Rotate right if negative. */
5586 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
5588 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
5590 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
5591 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
5593 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
5595 /* Do nothing if shift == 0. */
5596 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
5598 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
5603 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5604 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5606 The conditional expression is necessary because the result of LEADZ(0)
5607 is defined, but the result of __builtin_clz(0) is undefined for most
5610 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5611 difference in bit size between the argument of LEADZ and the C int. */
5614 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
5626 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5627 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5629 /* Which variant of __builtin_clz* should we call? */
5630 if (argsize
<= INT_TYPE_SIZE
)
5632 arg_type
= unsigned_type_node
;
5633 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
5635 else if (argsize
<= LONG_TYPE_SIZE
)
5637 arg_type
= long_unsigned_type_node
;
5638 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
5640 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5642 arg_type
= long_long_unsigned_type_node
;
5643 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5647 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5648 arg_type
= gfc_build_uint_type (argsize
);
5652 /* Convert the actual argument twice: first, to the unsigned type of the
5653 same size; then, to the proper argument type for the built-in
5654 function. But the return type is of the default INTEGER kind. */
5655 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5656 arg
= fold_convert (arg_type
, arg
);
5657 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5658 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5660 /* Compute LEADZ for the case i .ne. 0. */
5663 s
= TYPE_PRECISION (arg_type
) - argsize
;
5664 tmp
= fold_convert (result_type
,
5665 build_call_expr_loc (input_location
, func
,
5667 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
5668 tmp
, build_int_cst (result_type
, s
));
5672 /* We end up here if the argument type is larger than 'long long'.
5673 We generate this code:
5675 if (x & (ULL_MAX << ULL_SIZE) != 0)
5676 return clzll ((unsigned long long) (x >> ULLSIZE));
5678 return ULL_SIZE + clzll ((unsigned long long) x);
5679 where ULL_MAX is the largest value that a ULL_MAX can hold
5680 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5681 is the bit-size of the long long type (64 in this example). */
5682 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5684 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5685 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5686 long_long_unsigned_type_node
,
5687 build_int_cst (long_long_unsigned_type_node
,
5690 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
5691 fold_convert (arg_type
, ullmax
), ullsize
);
5692 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
5694 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5695 cond
, build_int_cst (arg_type
, 0));
5697 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5699 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5700 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5701 tmp1
= fold_convert (result_type
,
5702 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5704 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5705 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5706 tmp2
= fold_convert (result_type
,
5707 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5708 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5711 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5715 /* Build BIT_SIZE. */
5716 bit_size
= build_int_cst (result_type
, argsize
);
5718 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5719 arg
, build_int_cst (arg_type
, 0));
5720 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5725 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5727 The conditional expression is necessary because the result of TRAILZ(0)
5728 is defined, but the result of __builtin_ctz(0) is undefined for most
5732 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
5743 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5744 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5746 /* Which variant of __builtin_ctz* should we call? */
5747 if (argsize
<= INT_TYPE_SIZE
)
5749 arg_type
= unsigned_type_node
;
5750 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5752 else if (argsize
<= LONG_TYPE_SIZE
)
5754 arg_type
= long_unsigned_type_node
;
5755 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5757 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5759 arg_type
= long_long_unsigned_type_node
;
5760 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5764 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5765 arg_type
= gfc_build_uint_type (argsize
);
5769 /* Convert the actual argument twice: first, to the unsigned type of the
5770 same size; then, to the proper argument type for the built-in
5771 function. But the return type is of the default INTEGER kind. */
5772 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5773 arg
= fold_convert (arg_type
, arg
);
5774 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5775 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5777 /* Compute TRAILZ for the case i .ne. 0. */
5779 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5783 /* We end up here if the argument type is larger than 'long long'.
5784 We generate this code:
5786 if ((x & ULL_MAX) == 0)
5787 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5789 return ctzll ((unsigned long long) x);
5791 where ULL_MAX is the largest value that a ULL_MAX can hold
5792 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5793 is the bit-size of the long long type (64 in this example). */
5794 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5796 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5797 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5798 long_long_unsigned_type_node
,
5799 build_int_cst (long_long_unsigned_type_node
, 0));
5801 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5802 fold_convert (arg_type
, ullmax
));
5803 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
5804 build_int_cst (arg_type
, 0));
5806 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5808 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5809 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5810 tmp1
= fold_convert (result_type
,
5811 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5812 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5815 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5816 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5817 tmp2
= fold_convert (result_type
,
5818 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5820 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5824 /* Build BIT_SIZE. */
5825 bit_size
= build_int_cst (result_type
, argsize
);
5827 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5828 arg
, build_int_cst (arg_type
, 0));
5829 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5833 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5834 for types larger than "long long", we call the long long built-in for
5835 the lower and higher bits and combine the result. */
5838 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5846 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5847 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5848 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5850 /* Which variant of the builtin should we call? */
5851 if (argsize
<= INT_TYPE_SIZE
)
5853 arg_type
= unsigned_type_node
;
5854 func
= builtin_decl_explicit (parity
5856 : BUILT_IN_POPCOUNT
);
5858 else if (argsize
<= LONG_TYPE_SIZE
)
5860 arg_type
= long_unsigned_type_node
;
5861 func
= builtin_decl_explicit (parity
5863 : BUILT_IN_POPCOUNTL
);
5865 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5867 arg_type
= long_long_unsigned_type_node
;
5868 func
= builtin_decl_explicit (parity
5870 : BUILT_IN_POPCOUNTLL
);
5874 /* Our argument type is larger than 'long long', which mean none
5875 of the POPCOUNT builtins covers it. We thus call the 'long long'
5876 variant multiple times, and add the results. */
5877 tree utype
, arg2
, call1
, call2
;
5879 /* For now, we only cover the case where argsize is twice as large
5881 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5883 func
= builtin_decl_explicit (parity
5885 : BUILT_IN_POPCOUNTLL
);
5887 /* Convert it to an integer, and store into a variable. */
5888 utype
= gfc_build_uint_type (argsize
);
5889 arg
= fold_convert (utype
, arg
);
5890 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5892 /* Call the builtin twice. */
5893 call1
= build_call_expr_loc (input_location
, func
, 1,
5894 fold_convert (long_long_unsigned_type_node
,
5897 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5898 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5899 call2
= build_call_expr_loc (input_location
, func
, 1,
5900 fold_convert (long_long_unsigned_type_node
,
5903 /* Combine the results. */
5905 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5908 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5914 /* Convert the actual argument twice: first, to the unsigned type of the
5915 same size; then, to the proper argument type for the built-in
5917 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5918 arg
= fold_convert (arg_type
, arg
);
5920 se
->expr
= fold_convert (result_type
,
5921 build_call_expr_loc (input_location
, func
, 1, arg
));
5925 /* Process an intrinsic with unspecified argument-types that has an optional
5926 argument (which could be of type character), e.g. EOSHIFT. For those, we
5927 need to append the string length of the optional argument if it is not
5928 present and the type is really character.
5929 primary specifies the position (starting at 1) of the non-optional argument
5930 specifying the type and optional gives the position of the optional
5931 argument in the arglist. */
5934 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5935 unsigned primary
, unsigned optional
)
5937 gfc_actual_arglist
* prim_arg
;
5938 gfc_actual_arglist
* opt_arg
;
5940 gfc_actual_arglist
* arg
;
5942 vec
<tree
, va_gc
> *append_args
;
5944 /* Find the two arguments given as position. */
5948 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5952 if (cur_pos
== primary
)
5954 if (cur_pos
== optional
)
5957 if (cur_pos
>= primary
&& cur_pos
>= optional
)
5960 gcc_assert (prim_arg
);
5961 gcc_assert (prim_arg
->expr
);
5962 gcc_assert (opt_arg
);
5964 /* If we do have type CHARACTER and the optional argument is really absent,
5965 append a dummy 0 as string length. */
5967 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
5971 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
5972 vec_alloc (append_args
, 1);
5973 append_args
->quick_push (dummy
);
5976 /* Build the call itself. */
5977 gcc_assert (!se
->ignore_optional
);
5978 sym
= gfc_get_symbol_for_expr (expr
, false);
5979 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5981 gfc_free_symbol (sym
);
5985 /* The length of a character string. */
5987 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
5996 gcc_assert (!se
->ss
);
5998 arg
= expr
->value
.function
.actual
->expr
;
6000 type
= gfc_typenode_for_spec (&expr
->ts
);
6001 switch (arg
->expr_type
)
6004 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
6008 /* Obtain the string length from the function used by
6009 trans-array.c(gfc_trans_array_constructor). */
6011 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
6015 if (arg
->ref
== NULL
6016 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6018 /* This doesn't catch all cases.
6019 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6020 and the surrounding thread. */
6021 sym
= arg
->symtree
->n
.sym
;
6022 decl
= gfc_get_symbol_decl (sym
);
6023 if (decl
== current_function_decl
&& sym
->attr
.function
6024 && (sym
->result
== sym
))
6025 decl
= gfc_get_fake_result_decl (sym
, 0);
6027 len
= sym
->ts
.u
.cl
->backend_decl
;
6035 /* Anybody stupid enough to do this deserves inefficient code. */
6036 gfc_init_se (&argse
, se
);
6038 gfc_conv_expr (&argse
, arg
);
6040 gfc_conv_expr_descriptor (&argse
, arg
);
6041 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6042 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6043 len
= argse
.string_length
;
6046 se
->expr
= convert (type
, len
);
6049 /* The length of a character string not including trailing blanks. */
6051 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6053 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6054 tree args
[2], type
, fndecl
;
6056 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6057 type
= gfc_typenode_for_spec (&expr
->ts
);
6060 fndecl
= gfor_fndecl_string_len_trim
;
6062 fndecl
= gfor_fndecl_string_len_trim_char4
;
6066 se
->expr
= build_call_expr_loc (input_location
,
6067 fndecl
, 2, args
[0], args
[1]);
6068 se
->expr
= convert (type
, se
->expr
);
6072 /* Returns the starting position of a substring within a string. */
6075 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6078 tree logical4_type_node
= gfc_get_logical_type (4);
6082 unsigned int num_args
;
6084 args
= XALLOCAVEC (tree
, 5);
6086 /* Get number of arguments; characters count double due to the
6087 string length argument. Kind= is not passed to the library
6088 and thus ignored. */
6089 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6094 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6095 type
= gfc_typenode_for_spec (&expr
->ts
);
6098 args
[4] = build_int_cst (logical4_type_node
, 0);
6100 args
[4] = convert (logical4_type_node
, args
[4]);
6102 fndecl
= build_addr (function
);
6103 se
->expr
= build_call_array_loc (input_location
,
6104 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6106 se
->expr
= convert (type
, se
->expr
);
6110 /* The ascii value for a single character. */
6112 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6114 tree args
[3], type
, pchartype
;
6117 nargs
= gfc_intrinsic_argument_list_length (expr
);
6118 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6119 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6120 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6121 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6122 type
= gfc_typenode_for_spec (&expr
->ts
);
6124 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6126 se
->expr
= convert (type
, se
->expr
);
6130 /* Intrinsic ISNAN calls __builtin_isnan. */
6133 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6137 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6138 se
->expr
= build_call_expr_loc (input_location
,
6139 builtin_decl_explicit (BUILT_IN_ISNAN
),
6141 STRIP_TYPE_NOPS (se
->expr
);
6142 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6146 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6147 their argument against a constant integer value. */
6150 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6154 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6155 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6156 gfc_typenode_for_spec (&expr
->ts
),
6157 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6162 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6165 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
6173 unsigned int num_args
;
6175 num_args
= gfc_intrinsic_argument_list_length (expr
);
6176 args
= XALLOCAVEC (tree
, num_args
);
6178 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6179 if (expr
->ts
.type
!= BT_CHARACTER
)
6187 /* We do the same as in the non-character case, but the argument
6188 list is different because of the string length arguments. We
6189 also have to set the string length for the result. */
6196 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
6198 se
->string_length
= len
;
6200 type
= TREE_TYPE (tsource
);
6201 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
6202 fold_convert (type
, fsource
));
6206 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6209 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
6211 tree args
[3], mask
, type
;
6213 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6214 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
6216 type
= TREE_TYPE (args
[0]);
6217 gcc_assert (TREE_TYPE (args
[1]) == type
);
6218 gcc_assert (TREE_TYPE (mask
) == type
);
6220 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
6221 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
6222 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6224 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
6229 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6230 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6233 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
6235 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
6238 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6239 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6241 type
= gfc_get_int_type (expr
->ts
.kind
);
6242 utype
= unsigned_type_for (type
);
6244 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
6245 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
6247 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
6248 build_int_cst (utype
, 0));
6252 /* Left-justified mask. */
6253 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
6255 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6256 fold_convert (utype
, res
));
6258 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6259 smaller than type width. */
6260 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
6261 build_int_cst (TREE_TYPE (arg
), 0));
6262 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
6263 build_int_cst (utype
, 0), res
);
6267 /* Right-justified mask. */
6268 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6269 fold_convert (utype
, arg
));
6270 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
6272 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6273 strictly smaller than type width. */
6274 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6276 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
6277 cond
, allones
, res
);
6280 se
->expr
= fold_convert (type
, res
);
6284 /* FRACTION (s) is translated into:
6285 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6287 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
6289 tree arg
, type
, tmp
, res
, frexp
, cond
;
6291 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6293 type
= gfc_typenode_for_spec (&expr
->ts
);
6294 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6295 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6297 cond
= build_call_expr_loc (input_location
,
6298 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6301 tmp
= gfc_create_var (integer_type_node
, NULL
);
6302 res
= build_call_expr_loc (input_location
, frexp
, 2,
6303 fold_convert (type
, arg
),
6304 gfc_build_addr_expr (NULL_TREE
, tmp
));
6305 res
= fold_convert (type
, res
);
6307 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
6308 cond
, res
, gfc_build_nan (type
, ""));
6312 /* NEAREST (s, dir) is translated into
6313 tmp = copysign (HUGE_VAL, dir);
6314 return nextafter (s, tmp);
6317 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
6319 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
6321 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
6322 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
6324 type
= gfc_typenode_for_spec (&expr
->ts
);
6325 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6327 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
6328 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
6329 fold_convert (type
, args
[1]));
6330 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
6331 fold_convert (type
, args
[0]), tmp
);
6332 se
->expr
= fold_convert (type
, se
->expr
);
6336 /* SPACING (s) is translated into
6346 e = MAX_EXPR (e, emin);
6347 res = scalbn (1., e);
6351 where prec is the precision of s, gfc_real_kinds[k].digits,
6352 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6353 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6356 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
6358 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
6359 tree cond
, nan
, tmp
, frexp
, scalbn
;
6363 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6364 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
6365 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
6366 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
6368 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6369 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6371 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6372 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6374 type
= gfc_typenode_for_spec (&expr
->ts
);
6375 e
= gfc_create_var (integer_type_node
, NULL
);
6376 res
= gfc_create_var (type
, NULL
);
6379 /* Build the block for s /= 0. */
6380 gfc_start_block (&block
);
6381 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6382 gfc_build_addr_expr (NULL_TREE
, e
));
6383 gfc_add_expr_to_block (&block
, tmp
);
6385 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
6387 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
6388 integer_type_node
, tmp
, emin
));
6390 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
6391 build_real_from_int_cst (type
, integer_one_node
), e
);
6392 gfc_add_modify (&block
, res
, tmp
);
6394 /* Finish by building the IF statement for value zero. */
6395 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
6396 build_real_from_int_cst (type
, integer_zero_node
));
6397 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
6398 gfc_finish_block (&block
));
6400 /* And deal with infinities and NaNs. */
6401 cond
= build_call_expr_loc (input_location
,
6402 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6404 nan
= gfc_build_nan (type
, "");
6405 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
6407 gfc_add_expr_to_block (&se
->pre
, tmp
);
6412 /* RRSPACING (s) is translated into
6421 x = scalbn (x, precision - e);
6428 where precision is gfc_real_kinds[k].digits. */
6431 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
6433 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
6437 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6438 prec
= gfc_real_kinds
[k
].digits
;
6440 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6441 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6442 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
6444 type
= gfc_typenode_for_spec (&expr
->ts
);
6445 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6446 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6448 e
= gfc_create_var (integer_type_node
, NULL
);
6449 x
= gfc_create_var (type
, NULL
);
6450 gfc_add_modify (&se
->pre
, x
,
6451 build_call_expr_loc (input_location
, fabs
, 1, arg
));
6454 gfc_start_block (&block
);
6455 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6456 gfc_build_addr_expr (NULL_TREE
, e
));
6457 gfc_add_expr_to_block (&block
, tmp
);
6459 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
6460 build_int_cst (integer_type_node
, prec
), e
);
6461 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
6462 gfc_add_modify (&block
, x
, tmp
);
6463 stmt
= gfc_finish_block (&block
);
6466 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
6467 build_real_from_int_cst (type
, integer_zero_node
));
6468 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
6470 /* And deal with infinities and NaNs. */
6471 cond
= build_call_expr_loc (input_location
,
6472 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6474 nan
= gfc_build_nan (type
, "");
6475 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
6477 gfc_add_expr_to_block (&se
->pre
, tmp
);
6478 se
->expr
= fold_convert (type
, x
);
6482 /* SCALE (s, i) is translated into scalbn (s, i). */
6484 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
6486 tree args
[2], type
, scalbn
;
6488 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6490 type
= gfc_typenode_for_spec (&expr
->ts
);
6491 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6492 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
6493 fold_convert (type
, args
[0]),
6494 fold_convert (integer_type_node
, args
[1]));
6495 se
->expr
= fold_convert (type
, se
->expr
);
6499 /* SET_EXPONENT (s, i) is translated into
6500 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6502 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
6504 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
6506 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6507 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6509 type
= gfc_typenode_for_spec (&expr
->ts
);
6510 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6511 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6513 tmp
= gfc_create_var (integer_type_node
, NULL
);
6514 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
6515 fold_convert (type
, args
[0]),
6516 gfc_build_addr_expr (NULL_TREE
, tmp
));
6517 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
6518 fold_convert (integer_type_node
, args
[1]));
6519 res
= fold_convert (type
, res
);
6521 /* Call to isfinite */
6522 cond
= build_call_expr_loc (input_location
,
6523 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6525 nan
= gfc_build_nan (type
, "");
6527 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6533 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
6535 gfc_actual_arglist
*actual
;
6542 gfc_init_se (&argse
, NULL
);
6543 actual
= expr
->value
.function
.actual
;
6545 if (actual
->expr
->ts
.type
== BT_CLASS
)
6546 gfc_add_class_array_ref (actual
->expr
);
6548 argse
.data_not_needed
= 1;
6549 if (gfc_is_alloc_class_array_function (actual
->expr
))
6551 /* For functions that return a class array conv_expr_descriptor is not
6552 able to get the descriptor right. Therefore this special case. */
6553 gfc_conv_expr_reference (&argse
, actual
->expr
);
6554 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6555 gfc_class_data_get (argse
.expr
));
6559 argse
.want_pointer
= 1;
6560 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
6562 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6563 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6564 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
6566 /* Build the call to size0. */
6567 fncall0
= build_call_expr_loc (input_location
,
6568 gfor_fndecl_size0
, 1, arg1
);
6570 actual
= actual
->next
;
6574 gfc_init_se (&argse
, NULL
);
6575 gfc_conv_expr_type (&argse
, actual
->expr
,
6576 gfc_array_index_type
);
6577 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6579 /* Unusually, for an intrinsic, size does not exclude
6580 an optional arg2, so we must test for it. */
6581 if (actual
->expr
->expr_type
== EXPR_VARIABLE
6582 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
6583 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
6586 /* Build the call to size1. */
6587 fncall1
= build_call_expr_loc (input_location
,
6588 gfor_fndecl_size1
, 2,
6591 gfc_init_se (&argse
, NULL
);
6592 argse
.want_pointer
= 1;
6593 argse
.data_not_needed
= 1;
6594 gfc_conv_expr (&argse
, actual
->expr
);
6595 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6596 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6597 argse
.expr
, null_pointer_node
);
6598 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6599 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
6600 pvoid_type_node
, tmp
, fncall1
, fncall0
);
6604 se
->expr
= NULL_TREE
;
6605 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6606 gfc_array_index_type
,
6607 argse
.expr
, gfc_index_one_node
);
6610 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
6612 argse
.expr
= gfc_index_zero_node
;
6613 se
->expr
= NULL_TREE
;
6618 if (se
->expr
== NULL_TREE
)
6620 tree ubound
, lbound
;
6622 arg1
= build_fold_indirect_ref_loc (input_location
,
6624 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
6625 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
6626 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6627 gfc_array_index_type
, ubound
, lbound
);
6628 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
6629 gfc_array_index_type
,
6630 se
->expr
, gfc_index_one_node
);
6631 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6632 gfc_array_index_type
, se
->expr
,
6633 gfc_index_zero_node
);
6636 type
= gfc_typenode_for_spec (&expr
->ts
);
6637 se
->expr
= convert (type
, se
->expr
);
6641 /* Helper function to compute the size of a character variable,
6642 excluding the terminating null characters. The result has
6643 gfc_array_index_type type. */
6646 size_of_string_in_bytes (int kind
, tree string_length
)
6649 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
6651 bytesize
= build_int_cst (gfc_array_index_type
,
6652 gfc_character_kinds
[i
].bit_size
/ 8);
6654 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6656 fold_convert (gfc_array_index_type
, string_length
));
6661 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
6672 gfc_init_se (&argse
, NULL
);
6673 arg
= expr
->value
.function
.actual
->expr
;
6675 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
6676 gfc_conv_expr_descriptor (&argse
, arg
);
6678 gfc_conv_expr_reference (&argse
, arg
);
6680 if (arg
->ts
.type
== BT_ASSUMED
)
6682 /* This only works if an array descriptor has been passed; thus, extract
6683 the size from the descriptor. */
6684 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
6685 == TYPE_PRECISION (size_type_node
));
6686 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
6687 tmp
= DECL_LANG_SPECIFIC (tmp
)
6688 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
6689 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
6690 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
6691 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6692 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
6693 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
6694 build_int_cst (TREE_TYPE (tmp
),
6695 GFC_DTYPE_SIZE_SHIFT
));
6696 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
6698 else if (arg
->ts
.type
== BT_CLASS
)
6700 /* Conv_expr_descriptor returns a component_ref to _data component of the
6701 class object. The class object may be a non-pointer object, e.g.
6702 located on the stack, or a memory location pointed to, e.g. a
6703 parameter, i.e., an indirect_ref. */
6705 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
6706 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
6707 && GFC_DECL_CLASS (TREE_OPERAND (
6708 TREE_OPERAND (argse
.expr
, 0), 0)))
6709 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
6710 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6711 else if (arg
->rank
> 0)
6712 /* The scalarizer added an additional temp. To get the class' vptr
6713 one has to look at the original backend_decl. */
6714 byte_size
= gfc_class_vtab_size_get (
6715 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6717 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
6721 if (arg
->ts
.type
== BT_CHARACTER
)
6722 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6726 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6729 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6730 byte_size
= fold_convert (gfc_array_index_type
,
6731 size_in_bytes (byte_size
));
6736 se
->expr
= byte_size
;
6739 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
6740 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
6742 if (arg
->rank
== -1)
6744 tree cond
, loop_var
, exit_label
;
6747 tmp
= fold_convert (gfc_array_index_type
,
6748 gfc_conv_descriptor_rank (argse
.expr
));
6749 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
6750 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
6751 exit_label
= gfc_build_label_decl (NULL_TREE
);
6758 source_bytes = source_bytes * array.dim[i].extent;
6762 gfc_start_block (&body
);
6763 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6765 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6766 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6767 cond
, tmp
, build_empty_stmt (input_location
));
6768 gfc_add_expr_to_block (&body
, tmp
);
6770 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6771 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6772 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6773 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6774 gfc_array_index_type
, tmp
, source_bytes
);
6775 gfc_add_modify (&body
, source_bytes
, tmp
);
6777 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6778 gfc_array_index_type
, loop_var
,
6779 gfc_index_one_node
);
6780 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6782 tmp
= gfc_finish_block (&body
);
6784 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6786 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6788 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6789 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6793 /* Obtain the size of the array in bytes. */
6794 for (n
= 0; n
< arg
->rank
; n
++)
6797 idx
= gfc_rank_cst
[n
];
6798 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6799 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6800 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6801 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6802 gfc_array_index_type
, tmp
, source_bytes
);
6803 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6806 se
->expr
= source_bytes
;
6809 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6814 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6818 tree type
, result_type
, tmp
;
6820 arg
= expr
->value
.function
.actual
->expr
;
6822 gfc_init_se (&argse
, NULL
);
6823 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6827 if (arg
->ts
.type
== BT_CLASS
)
6829 gfc_add_vptr_component (arg
);
6830 gfc_add_size_component (arg
);
6831 gfc_conv_expr (&argse
, arg
);
6832 tmp
= fold_convert (result_type
, argse
.expr
);
6836 gfc_conv_expr_reference (&argse
, arg
);
6837 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6842 argse
.want_pointer
= 0;
6843 gfc_conv_expr_descriptor (&argse
, arg
);
6844 if (arg
->ts
.type
== BT_CLASS
)
6847 tmp
= gfc_class_vtab_size_get (
6848 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6850 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6851 tmp
= fold_convert (result_type
, tmp
);
6854 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6857 /* Obtain the argument's word length. */
6858 if (arg
->ts
.type
== BT_CHARACTER
)
6859 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6861 tmp
= size_in_bytes (type
);
6862 tmp
= fold_convert (result_type
, tmp
);
6865 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6866 build_int_cst (result_type
, BITS_PER_UNIT
));
6867 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6871 /* Intrinsic string comparison functions. */
6874 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6878 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6881 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6882 expr
->value
.function
.actual
->expr
->ts
.kind
,
6884 se
->expr
= fold_build2_loc (input_location
, op
,
6885 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6886 build_int_cst (TREE_TYPE (se
->expr
), 0));
6889 /* Generate a call to the adjustl/adjustr library function. */
6891 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6899 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6902 type
= TREE_TYPE (args
[2]);
6903 var
= gfc_conv_string_tmp (se
, type
, len
);
6906 tmp
= build_call_expr_loc (input_location
,
6907 fndecl
, 3, args
[0], args
[1], args
[2]);
6908 gfc_add_expr_to_block (&se
->pre
, tmp
);
6910 se
->string_length
= len
;
6914 /* Generate code for the TRANSFER intrinsic:
6916 DEST = TRANSFER (SOURCE, MOLD)
6918 typeof<DEST> = typeof<MOLD>
6923 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6925 typeof<DEST> = typeof<MOLD>
6927 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6928 sizeof (DEST(0) * SIZE). */
6930 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6946 gfc_actual_arglist
*arg
;
6948 gfc_array_info
*info
;
6952 gfc_expr
*source_expr
, *mold_expr
;
6956 info
= &se
->ss
->info
->data
.array
;
6958 /* Convert SOURCE. The output from this stage is:-
6959 source_bytes = length of the source in bytes
6960 source = pointer to the source data. */
6961 arg
= expr
->value
.function
.actual
;
6962 source_expr
= arg
->expr
;
6964 /* Ensure double transfer through LOGICAL preserves all
6966 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6967 && arg
->expr
->value
.function
.esym
== NULL
6968 && arg
->expr
->value
.function
.isym
!= NULL
6969 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6970 && arg
->expr
->ts
.type
== BT_LOGICAL
6971 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6972 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6974 gfc_init_se (&argse
, NULL
);
6976 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6978 /* Obtain the pointer to source and the length of source in bytes. */
6979 if (arg
->expr
->rank
== 0)
6981 gfc_conv_expr_reference (&argse
, arg
->expr
);
6982 if (arg
->expr
->ts
.type
== BT_CLASS
)
6983 source
= gfc_class_data_get (argse
.expr
);
6985 source
= argse
.expr
;
6987 /* Obtain the source word length. */
6988 switch (arg
->expr
->ts
.type
)
6991 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6992 argse
.string_length
);
6995 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6998 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7000 tmp
= fold_convert (gfc_array_index_type
,
7001 size_in_bytes (source_type
));
7007 argse
.want_pointer
= 0;
7008 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7009 source
= gfc_conv_descriptor_data_get (argse
.expr
);
7010 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7012 /* Repack the source if not simply contiguous. */
7013 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
7015 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
7017 if (warn_array_temporaries
)
7018 gfc_warning (OPT_Warray_temporaries
,
7019 "Creating array temporary at %L", &expr
->where
);
7021 source
= build_call_expr_loc (input_location
,
7022 gfor_fndecl_in_pack
, 1, tmp
);
7023 source
= gfc_evaluate_now (source
, &argse
.pre
);
7025 /* Free the temporary. */
7026 gfc_start_block (&block
);
7027 tmp
= gfc_call_free (source
);
7028 gfc_add_expr_to_block (&block
, tmp
);
7029 stmt
= gfc_finish_block (&block
);
7031 /* Clean up if it was repacked. */
7032 gfc_init_block (&block
);
7033 tmp
= gfc_conv_array_data (argse
.expr
);
7034 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7036 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7037 build_empty_stmt (input_location
));
7038 gfc_add_expr_to_block (&block
, tmp
);
7039 gfc_add_block_to_block (&block
, &se
->post
);
7040 gfc_init_block (&se
->post
);
7041 gfc_add_block_to_block (&se
->post
, &block
);
7044 /* Obtain the source word length. */
7045 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7046 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7047 argse
.string_length
);
7049 tmp
= fold_convert (gfc_array_index_type
,
7050 size_in_bytes (source_type
));
7052 /* Obtain the size of the array in bytes. */
7053 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7054 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7057 idx
= gfc_rank_cst
[n
];
7058 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7059 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7060 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7061 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7062 gfc_array_index_type
, upper
, lower
);
7063 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7064 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7065 gfc_array_index_type
, extent
,
7066 gfc_index_one_node
);
7067 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7068 gfc_array_index_type
, tmp
, source_bytes
);
7072 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7073 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7074 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7076 /* Now convert MOLD. The outputs are:
7077 mold_type = the TREE type of MOLD
7078 dest_word_len = destination word length in bytes. */
7080 mold_expr
= arg
->expr
;
7082 gfc_init_se (&argse
, NULL
);
7084 scalar_mold
= arg
->expr
->rank
== 0;
7086 if (arg
->expr
->rank
== 0)
7088 gfc_conv_expr_reference (&argse
, arg
->expr
);
7089 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7094 gfc_init_se (&argse
, NULL
);
7095 argse
.want_pointer
= 0;
7096 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7097 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7100 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7101 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7103 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7105 /* If this TRANSFER is nested in another TRANSFER, use a type
7106 that preserves all bits. */
7107 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7108 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7111 /* Obtain the destination word length. */
7112 switch (arg
->expr
->ts
.type
)
7115 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7116 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7119 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7122 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7125 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7126 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7128 /* Finally convert SIZE, if it is present. */
7130 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7134 gfc_init_se (&argse
, NULL
);
7135 gfc_conv_expr_reference (&argse
, arg
->expr
);
7136 tmp
= convert (gfc_array_index_type
,
7137 build_fold_indirect_ref_loc (input_location
,
7139 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7140 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7145 /* Separate array and scalar results. */
7146 if (scalar_mold
&& tmp
== NULL_TREE
)
7147 goto scalar_transfer
;
7149 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7150 if (tmp
!= NULL_TREE
)
7151 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7152 tmp
, dest_word_len
);
7156 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
7157 gfc_add_modify (&se
->pre
, size_words
,
7158 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
7159 gfc_array_index_type
,
7160 size_bytes
, dest_word_len
));
7162 /* Evaluate the bounds of the result. If the loop range exists, we have
7163 to check if it is too large. If so, we modify loop->to be consistent
7164 with min(size, size(source)). Otherwise, size is made consistent with
7165 the loop range, so that the right number of bytes is transferred.*/
7166 n
= se
->loop
->order
[0];
7167 if (se
->loop
->to
[n
] != NULL_TREE
)
7169 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7170 se
->loop
->to
[n
], se
->loop
->from
[n
]);
7171 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7172 tmp
, gfc_index_one_node
);
7173 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7175 gfc_add_modify (&se
->pre
, size_words
, tmp
);
7176 gfc_add_modify (&se
->pre
, size_bytes
,
7177 fold_build2_loc (input_location
, MULT_EXPR
,
7178 gfc_array_index_type
,
7179 size_words
, dest_word_len
));
7180 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7181 size_words
, se
->loop
->from
[n
]);
7182 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7183 upper
, gfc_index_one_node
);
7187 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7188 size_words
, gfc_index_one_node
);
7189 se
->loop
->from
[n
] = gfc_index_zero_node
;
7192 se
->loop
->to
[n
] = upper
;
7194 /* Build a destination descriptor, using the pointer, source, as the
7196 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
7197 NULL_TREE
, false, true, false, &expr
->where
);
7199 /* Cast the pointer to the result. */
7200 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7201 tmp
= fold_convert (pvoid_type_node
, tmp
);
7203 /* Use memcpy to do the transfer. */
7205 = build_call_expr_loc (input_location
,
7206 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
7207 fold_convert (pvoid_type_node
, source
),
7208 fold_convert (size_type_node
,
7209 fold_build2_loc (input_location
,
7211 gfc_array_index_type
,
7214 gfc_add_expr_to_block (&se
->pre
, tmp
);
7216 se
->expr
= info
->descriptor
;
7217 if (expr
->ts
.type
== BT_CHARACTER
)
7218 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7222 /* Deal with scalar results. */
7224 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7225 dest_word_len
, source_bytes
);
7226 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7227 extent
, gfc_index_zero_node
);
7229 if (expr
->ts
.type
== BT_CHARACTER
)
7231 tree direct
, indirect
, free
;
7233 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
7234 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
7237 /* If source is longer than the destination, use a pointer to
7238 the source directly. */
7239 gfc_init_block (&block
);
7240 gfc_add_modify (&block
, tmpdecl
, ptr
);
7241 direct
= gfc_finish_block (&block
);
7243 /* Otherwise, allocate a string with the length of the destination
7244 and copy the source into it. */
7245 gfc_init_block (&block
);
7246 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
7247 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
7248 gfc_add_modify (&block
, tmpdecl
,
7249 fold_convert (TREE_TYPE (ptr
), tmp
));
7250 tmp
= build_call_expr_loc (input_location
,
7251 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7252 fold_convert (pvoid_type_node
, tmpdecl
),
7253 fold_convert (pvoid_type_node
, ptr
),
7254 fold_convert (size_type_node
, extent
));
7255 gfc_add_expr_to_block (&block
, tmp
);
7256 indirect
= gfc_finish_block (&block
);
7258 /* Wrap it up with the condition. */
7259 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
7260 dest_word_len
, source_bytes
);
7261 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
7262 gfc_add_expr_to_block (&se
->pre
, tmp
);
7264 /* Free the temporary string, if necessary. */
7265 free
= gfc_call_free (tmpdecl
);
7266 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7267 dest_word_len
, source_bytes
);
7268 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
7269 gfc_add_expr_to_block (&se
->post
, tmp
);
7272 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7276 tmpdecl
= gfc_create_var (mold_type
, "transfer");
7278 ptr
= convert (build_pointer_type (mold_type
), source
);
7280 /* For CLASS results, allocate the needed memory first. */
7281 if (mold_expr
->ts
.type
== BT_CLASS
)
7284 cdata
= gfc_class_data_get (tmpdecl
);
7285 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
7286 gfc_add_modify (&se
->pre
, cdata
, tmp
);
7289 /* Use memcpy to do the transfer. */
7290 if (mold_expr
->ts
.type
== BT_CLASS
)
7291 tmp
= gfc_class_data_get (tmpdecl
);
7293 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
7295 tmp
= build_call_expr_loc (input_location
,
7296 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7297 fold_convert (pvoid_type_node
, tmp
),
7298 fold_convert (pvoid_type_node
, ptr
),
7299 fold_convert (size_type_node
, extent
));
7300 gfc_add_expr_to_block (&se
->pre
, tmp
);
7302 /* For CLASS results, set the _vptr. */
7303 if (mold_expr
->ts
.type
== BT_CLASS
)
7307 vptr
= gfc_class_vptr_get (tmpdecl
);
7308 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
7310 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7311 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
7319 /* Generate code for the ALLOCATED intrinsic.
7320 Generate inline code that directly check the address of the argument. */
7323 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
7325 gfc_actual_arglist
*arg1
;
7329 gfc_init_se (&arg1se
, NULL
);
7330 arg1
= expr
->value
.function
.actual
;
7332 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7334 /* Make sure that class array expressions have both a _data
7335 component reference and an array reference.... */
7336 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
7337 gfc_add_class_array_ref (arg1
->expr
);
7338 /* .... whilst scalars only need the _data component. */
7340 gfc_add_data_component (arg1
->expr
);
7343 if (arg1
->expr
->rank
== 0)
7345 /* Allocatable scalar. */
7346 arg1se
.want_pointer
= 1;
7347 gfc_conv_expr (&arg1se
, arg1
->expr
);
7352 /* Allocatable array. */
7353 arg1se
.descriptor_only
= 1;
7354 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7355 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7358 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
7359 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7360 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7364 /* Generate code for the ASSOCIATED intrinsic.
7365 If both POINTER and TARGET are arrays, generate a call to library function
7366 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7367 In other cases, generate inline code that directly compare the address of
7368 POINTER with the address of TARGET. */
7371 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
7373 gfc_actual_arglist
*arg1
;
7374 gfc_actual_arglist
*arg2
;
7379 tree nonzero_charlen
;
7380 tree nonzero_arraylen
;
7384 gfc_init_se (&arg1se
, NULL
);
7385 gfc_init_se (&arg2se
, NULL
);
7386 arg1
= expr
->value
.function
.actual
;
7389 /* Check whether the expression is a scalar or not; we cannot use
7390 arg1->expr->rank as it can be nonzero for proc pointers. */
7391 ss
= gfc_walk_expr (arg1
->expr
);
7392 scalar
= ss
== gfc_ss_terminator
;
7394 gfc_free_ss_chain (ss
);
7398 /* No optional target. */
7401 /* A pointer to a scalar. */
7402 arg1se
.want_pointer
= 1;
7403 gfc_conv_expr (&arg1se
, arg1
->expr
);
7404 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7405 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7406 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7408 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7410 tmp2
= gfc_class_data_get (arg1se
.expr
);
7411 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7412 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7419 /* A pointer to an array. */
7420 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7421 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7423 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7424 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7425 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
7426 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
7431 /* An optional target. */
7432 if (arg2
->expr
->ts
.type
== BT_CLASS
)
7433 gfc_add_data_component (arg2
->expr
);
7435 nonzero_charlen
= NULL_TREE
;
7436 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
7437 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
7439 arg1
->expr
->ts
.u
.cl
->backend_decl
,
7443 /* A pointer to a scalar. */
7444 arg1se
.want_pointer
= 1;
7445 gfc_conv_expr (&arg1se
, arg1
->expr
);
7446 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7447 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7448 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7450 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7451 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
7453 arg2se
.want_pointer
= 1;
7454 gfc_conv_expr (&arg2se
, arg2
->expr
);
7455 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7456 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
7457 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
7459 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7460 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7461 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7462 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7463 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7464 arg1se
.expr
, arg2se
.expr
);
7465 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7466 arg1se
.expr
, null_pointer_node
);
7467 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7468 boolean_type_node
, tmp
, tmp2
);
7472 /* An array pointer of zero length is not associated if target is
7474 arg1se
.descriptor_only
= 1;
7475 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
7476 if (arg1
->expr
->rank
== -1)
7478 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
7479 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7480 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
7483 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
7484 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
7485 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
7486 boolean_type_node
, tmp
,
7487 build_int_cst (TREE_TYPE (tmp
), 0));
7489 /* A pointer to an array, call library function _gfor_associated. */
7490 arg1se
.want_pointer
= 1;
7491 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7493 arg2se
.want_pointer
= 1;
7494 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
7495 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7496 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7497 se
->expr
= build_call_expr_loc (input_location
,
7498 gfor_fndecl_associated
, 2,
7499 arg1se
.expr
, arg2se
.expr
);
7500 se
->expr
= convert (boolean_type_node
, se
->expr
);
7501 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7502 boolean_type_node
, se
->expr
,
7506 /* If target is present zero character length pointers cannot
7508 if (nonzero_charlen
!= NULL_TREE
)
7509 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7511 se
->expr
, nonzero_charlen
);
7514 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7518 /* Generate code for the SAME_TYPE_AS intrinsic.
7519 Generate inline code that directly checks the vindices. */
7522 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
7527 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
7529 gfc_init_se (&se1
, NULL
);
7530 gfc_init_se (&se2
, NULL
);
7532 a
= expr
->value
.function
.actual
->expr
;
7533 b
= expr
->value
.function
.actual
->next
->expr
;
7535 if (UNLIMITED_POLY (a
))
7537 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
7538 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7539 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7542 if (UNLIMITED_POLY (b
))
7544 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
7545 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7546 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7549 if (a
->ts
.type
== BT_CLASS
)
7551 gfc_add_vptr_component (a
);
7552 gfc_add_hash_component (a
);
7554 else if (a
->ts
.type
== BT_DERIVED
)
7555 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7556 a
->ts
.u
.derived
->hash_value
);
7558 if (b
->ts
.type
== BT_CLASS
)
7560 gfc_add_vptr_component (b
);
7561 gfc_add_hash_component (b
);
7563 else if (b
->ts
.type
== BT_DERIVED
)
7564 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7565 b
->ts
.u
.derived
->hash_value
);
7567 gfc_conv_expr (&se1
, a
);
7568 gfc_conv_expr (&se2
, b
);
7570 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
7571 boolean_type_node
, se1
.expr
,
7572 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
7575 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7576 boolean_type_node
, conda
, tmp
);
7579 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7580 boolean_type_node
, condb
, tmp
);
7582 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7586 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
7589 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
7593 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7594 se
->expr
= build_call_expr_loc (input_location
,
7595 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
7596 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7600 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
7603 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
7607 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7609 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
7610 type
= gfc_get_int_type (4);
7611 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
7613 /* Convert it to the required type. */
7614 type
= gfc_typenode_for_spec (&expr
->ts
);
7615 se
->expr
= build_call_expr_loc (input_location
,
7616 gfor_fndecl_si_kind
, 1, arg
);
7617 se
->expr
= fold_convert (type
, se
->expr
);
7621 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
7624 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
7626 gfc_actual_arglist
*actual
;
7629 vec
<tree
, va_gc
> *args
= NULL
;
7631 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
7633 gfc_init_se (&argse
, se
);
7635 /* Pass a NULL pointer for an absent arg. */
7636 if (actual
->expr
== NULL
)
7637 argse
.expr
= null_pointer_node
;
7643 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
7645 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
7646 ts
.type
= BT_INTEGER
;
7647 ts
.kind
= gfc_c_int_kind
;
7648 gfc_convert_type (actual
->expr
, &ts
, 2);
7650 gfc_conv_expr_reference (&argse
, actual
->expr
);
7653 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7654 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7655 vec_safe_push (args
, argse
.expr
);
7658 /* Convert it to the required type. */
7659 type
= gfc_typenode_for_spec (&expr
->ts
);
7660 se
->expr
= build_call_expr_loc_vec (input_location
,
7661 gfor_fndecl_sr_kind
, args
);
7662 se
->expr
= fold_convert (type
, se
->expr
);
7666 /* Generate code for TRIM (A) intrinsic function. */
7669 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
7679 unsigned int num_args
;
7681 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
7682 args
= XALLOCAVEC (tree
, num_args
);
7684 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
7685 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
7686 len
= gfc_create_var (gfc_charlen_type_node
, "len");
7688 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
7689 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
7692 if (expr
->ts
.kind
== 1)
7693 function
= gfor_fndecl_string_trim
;
7694 else if (expr
->ts
.kind
== 4)
7695 function
= gfor_fndecl_string_trim_char4
;
7699 fndecl
= build_addr (function
);
7700 tmp
= build_call_array_loc (input_location
,
7701 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7703 gfc_add_expr_to_block (&se
->pre
, tmp
);
7705 /* Free the temporary afterwards, if necessary. */
7706 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7707 len
, build_int_cst (TREE_TYPE (len
), 0));
7708 tmp
= gfc_call_free (var
);
7709 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
7710 gfc_add_expr_to_block (&se
->post
, tmp
);
7713 se
->string_length
= len
;
7717 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
7720 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
7722 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
7723 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
7725 stmtblock_t block
, body
;
7728 /* We store in charsize the size of a character. */
7729 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
7730 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
7732 /* Get the arguments. */
7733 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7734 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
7736 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
7737 ncopies_type
= TREE_TYPE (ncopies
);
7739 /* Check that NCOPIES is not negative. */
7740 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
7741 build_int_cst (ncopies_type
, 0));
7742 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7743 "Argument NCOPIES of REPEAT intrinsic is negative "
7744 "(its value is %ld)",
7745 fold_convert (long_integer_type_node
, ncopies
));
7747 /* If the source length is zero, any non negative value of NCOPIES
7748 is valid, and nothing happens. */
7749 n
= gfc_create_var (ncopies_type
, "ncopies");
7750 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7751 build_int_cst (size_type_node
, 0));
7752 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
7753 build_int_cst (ncopies_type
, 0), ncopies
);
7754 gfc_add_modify (&se
->pre
, n
, tmp
);
7757 /* Check that ncopies is not too large: ncopies should be less than
7758 (or equal to) MAX / slen, where MAX is the maximal integer of
7759 the gfc_charlen_type_node type. If slen == 0, we need a special
7760 case to avoid the division by zero. */
7761 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
7762 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
7763 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
7764 fold_convert (size_type_node
, max
), slen
);
7765 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
7766 ? size_type_node
: ncopies_type
;
7767 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7768 fold_convert (largest
, ncopies
),
7769 fold_convert (largest
, max
));
7770 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7771 build_int_cst (size_type_node
, 0));
7772 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
7773 boolean_false_node
, cond
);
7774 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7775 "Argument NCOPIES of REPEAT intrinsic is too large");
7777 /* Compute the destination length. */
7778 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7779 fold_convert (gfc_charlen_type_node
, slen
),
7780 fold_convert (gfc_charlen_type_node
, ncopies
));
7781 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
7782 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
7784 /* Generate the code to do the repeat operation:
7785 for (i = 0; i < ncopies; i++)
7786 memmove (dest + (i * slen * size), src, slen*size); */
7787 gfc_start_block (&block
);
7788 count
= gfc_create_var (ncopies_type
, "count");
7789 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
7790 exit_label
= gfc_build_label_decl (NULL_TREE
);
7792 /* Start the loop body. */
7793 gfc_start_block (&body
);
7795 /* Exit the loop if count >= ncopies. */
7796 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
7798 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7799 TREE_USED (exit_label
) = 1;
7800 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7801 build_empty_stmt (input_location
));
7802 gfc_add_expr_to_block (&body
, tmp
);
7804 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7805 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7806 fold_convert (gfc_charlen_type_node
, slen
),
7807 fold_convert (gfc_charlen_type_node
, count
));
7808 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7809 tmp
, fold_convert (gfc_charlen_type_node
, size
));
7810 tmp
= fold_build_pointer_plus_loc (input_location
,
7811 fold_convert (pvoid_type_node
, dest
), tmp
);
7812 tmp
= build_call_expr_loc (input_location
,
7813 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7815 fold_build2_loc (input_location
, MULT_EXPR
,
7816 size_type_node
, slen
,
7817 fold_convert (size_type_node
,
7819 gfc_add_expr_to_block (&body
, tmp
);
7821 /* Increment count. */
7822 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
7823 count
, build_int_cst (TREE_TYPE (count
), 1));
7824 gfc_add_modify (&body
, count
, tmp
);
7826 /* Build the loop. */
7827 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7828 gfc_add_expr_to_block (&block
, tmp
);
7830 /* Add the exit label. */
7831 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7832 gfc_add_expr_to_block (&block
, tmp
);
7834 /* Finish the block. */
7835 tmp
= gfc_finish_block (&block
);
7836 gfc_add_expr_to_block (&se
->pre
, tmp
);
7838 /* Set the result value. */
7840 se
->string_length
= dlen
;
7844 /* Generate code for the IARGC intrinsic. */
7847 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
7853 /* Call the library function. This always returns an INTEGER(4). */
7854 fndecl
= gfor_fndecl_iargc
;
7855 tmp
= build_call_expr_loc (input_location
,
7858 /* Convert it to the required type. */
7859 type
= gfc_typenode_for_spec (&expr
->ts
);
7860 tmp
= fold_convert (type
, tmp
);
7866 /* The loc intrinsic returns the address of its argument as
7867 gfc_index_integer_kind integer. */
7870 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7875 gcc_assert (!se
->ss
);
7877 arg_expr
= expr
->value
.function
.actual
->expr
;
7878 if (arg_expr
->rank
== 0)
7880 if (arg_expr
->ts
.type
== BT_CLASS
)
7881 gfc_add_data_component (arg_expr
);
7882 gfc_conv_expr_reference (se
, arg_expr
);
7885 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7886 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7888 /* Create a temporary variable for loc return value. Without this,
7889 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7890 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7891 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7892 se
->expr
= temp_var
;
7896 /* The following routine generates code for the intrinsic
7897 functions from the ISO_C_BINDING module:
7903 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7905 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7907 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7909 if (arg
->expr
->rank
== 0)
7910 gfc_conv_expr_reference (se
, arg
->expr
);
7911 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
7912 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7915 gfc_conv_expr_descriptor (se
, arg
->expr
);
7916 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7919 /* TODO -- the following two lines shouldn't be necessary, but if
7920 they're removed, a bug is exposed later in the code path.
7921 This workaround was thus introduced, but will have to be
7922 removed; please see PR 35150 for details about the issue. */
7923 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7924 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7926 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7927 gfc_conv_expr_reference (se
, arg
->expr
);
7928 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7933 /* Build the addr_expr for the first argument. The argument is
7934 already an *address* so we don't need to set want_pointer in
7936 gfc_init_se (&arg1se
, NULL
);
7937 gfc_conv_expr (&arg1se
, arg
->expr
);
7938 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7939 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7941 /* See if we were given two arguments. */
7942 if (arg
->next
->expr
== NULL
)
7943 /* Only given one arg so generate a null and do a
7944 not-equal comparison against the first arg. */
7945 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7947 fold_convert (TREE_TYPE (arg1se
.expr
),
7948 null_pointer_node
));
7954 /* Given two arguments so build the arg2se from second arg. */
7955 gfc_init_se (&arg2se
, NULL
);
7956 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
7957 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7958 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7960 /* Generate test to compare that the two args are equal. */
7961 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7962 arg1se
.expr
, arg2se
.expr
);
7963 /* Generate test to ensure that the first arg is not null. */
7964 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
7966 arg1se
.expr
, null_pointer_node
);
7968 /* Finally, the generated test must check that both arg1 is not
7969 NULL and that it is equal to the second arg. */
7970 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7972 not_null_expr
, eq_expr
);
7980 /* The following routine generates code for the intrinsic
7981 subroutines from the ISO_C_BINDING module:
7983 * C_F_PROCPOINTER. */
7986 conv_isocbinding_subroutine (gfc_code
*code
)
7993 tree desc
, dim
, tmp
, stride
, offset
;
7994 stmtblock_t body
, block
;
7996 gfc_actual_arglist
*arg
= code
->ext
.actual
;
7998 gfc_init_se (&se
, NULL
);
7999 gfc_init_se (&cptrse
, NULL
);
8000 gfc_conv_expr (&cptrse
, arg
->expr
);
8001 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
8002 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
8004 gfc_init_se (&fptrse
, NULL
);
8005 if (arg
->next
->expr
->rank
== 0)
8007 fptrse
.want_pointer
= 1;
8008 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
8009 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
8010 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
8011 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8012 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
8013 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
8015 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8016 TREE_TYPE (fptrse
.expr
),
8018 fold_convert (TREE_TYPE (fptrse
.expr
),
8020 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
8021 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8022 return gfc_finish_block (&se
.pre
);
8025 gfc_start_block (&block
);
8027 /* Get the descriptor of the Fortran pointer. */
8028 fptrse
.descriptor_only
= 1;
8029 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
8030 gfc_add_block_to_block (&block
, &fptrse
.pre
);
8033 /* Set data value, dtype, and offset. */
8034 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
8035 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
8036 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
8037 gfc_get_dtype (TREE_TYPE (desc
)));
8039 /* Start scalarization of the bounds, using the shape argument. */
8041 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
8042 gcc_assert (shape_ss
!= gfc_ss_terminator
);
8043 gfc_init_se (&shapese
, NULL
);
8045 gfc_init_loopinfo (&loop
);
8046 gfc_add_ss_to_loop (&loop
, shape_ss
);
8047 gfc_conv_ss_startstride (&loop
);
8048 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
8049 gfc_mark_ss_chain_used (shape_ss
, 1);
8051 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
8052 shapese
.ss
= shape_ss
;
8054 stride
= gfc_create_var (gfc_array_index_type
, "stride");
8055 offset
= gfc_create_var (gfc_array_index_type
, "offset");
8056 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
8057 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8060 gfc_start_scalarized_body (&loop
, &body
);
8062 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8063 loop
.loopvar
[0], loop
.from
[0]);
8065 /* Set bounds and stride. */
8066 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
8067 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
8069 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
8070 gfc_add_block_to_block (&body
, &shapese
.pre
);
8071 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
8072 gfc_add_block_to_block (&body
, &shapese
.post
);
8074 /* Calculate offset. */
8075 gfc_add_modify (&body
, offset
,
8076 fold_build2_loc (input_location
, PLUS_EXPR
,
8077 gfc_array_index_type
, offset
, stride
));
8078 /* Update stride. */
8079 gfc_add_modify (&body
, stride
,
8080 fold_build2_loc (input_location
, MULT_EXPR
,
8081 gfc_array_index_type
, stride
,
8082 fold_convert (gfc_array_index_type
,
8084 /* Finish scalarization loop. */
8085 gfc_trans_scalarizing_loops (&loop
, &body
);
8086 gfc_add_block_to_block (&block
, &loop
.pre
);
8087 gfc_add_block_to_block (&block
, &loop
.post
);
8088 gfc_add_block_to_block (&block
, &fptrse
.post
);
8089 gfc_cleanup_loop (&loop
);
8091 gfc_add_modify (&block
, offset
,
8092 fold_build1_loc (input_location
, NEGATE_EXPR
,
8093 gfc_array_index_type
, offset
));
8094 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
8096 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
8097 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8098 return gfc_finish_block (&se
.pre
);
8102 /* Save and restore floating-point state. */
8105 gfc_save_fp_state (stmtblock_t
*block
)
8107 tree type
, fpstate
, tmp
;
8109 type
= build_array_type (char_type_node
,
8110 build_range_type (size_type_node
, size_zero_node
,
8111 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
8112 fpstate
= gfc_create_var (type
, "fpstate");
8113 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
8115 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
8117 gfc_add_expr_to_block (block
, tmp
);
8124 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
8128 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
8130 gfc_add_expr_to_block (block
, tmp
);
8134 /* Generate code for arguments of IEEE functions. */
8137 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
8140 gfc_actual_arglist
*actual
;
8145 actual
= expr
->value
.function
.actual
;
8146 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
8148 gcc_assert (actual
);
8151 gfc_init_se (&argse
, se
);
8152 gfc_conv_expr_val (&argse
, e
);
8154 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8155 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8156 argarray
[arg
] = argse
.expr
;
8161 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8162 and IEEE_UNORDERED, which translate directly to GCC type-generic
8166 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
8167 enum built_in_function code
, int nargs
)
8170 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
8172 conv_ieee_function_args (se
, expr
, args
, nargs
);
8173 se
->expr
= build_call_expr_loc_array (input_location
,
8174 builtin_decl_explicit (code
),
8176 STRIP_TYPE_NOPS (se
->expr
);
8177 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8181 /* Generate code for IEEE_IS_NORMAL intrinsic:
8182 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8185 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
8187 tree arg
, isnormal
, iszero
;
8189 /* Convert arg, evaluate it only once. */
8190 conv_ieee_function_args (se
, expr
, &arg
, 1);
8191 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8193 isnormal
= build_call_expr_loc (input_location
,
8194 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
8196 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
8197 build_real_from_int_cst (TREE_TYPE (arg
),
8198 integer_zero_node
));
8199 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8200 boolean_type_node
, isnormal
, iszero
);
8201 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8205 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8206 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8209 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
8211 tree arg
, signbit
, isnan
;
8213 /* Convert arg, evaluate it only once. */
8214 conv_ieee_function_args (se
, expr
, &arg
, 1);
8215 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8217 isnan
= build_call_expr_loc (input_location
,
8218 builtin_decl_explicit (BUILT_IN_ISNAN
),
8220 STRIP_TYPE_NOPS (isnan
);
8222 signbit
= build_call_expr_loc (input_location
,
8223 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8225 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8226 signbit
, integer_zero_node
);
8228 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8229 boolean_type_node
, signbit
,
8230 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
8231 TREE_TYPE(isnan
), isnan
));
8233 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8237 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8240 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
8241 enum built_in_function code
)
8243 tree arg
, decl
, call
, fpstate
;
8246 conv_ieee_function_args (se
, expr
, &arg
, 1);
8247 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
8248 decl
= builtin_decl_for_precision (code
, argprec
);
8250 /* Save floating-point state. */
8251 fpstate
= gfc_save_fp_state (&se
->pre
);
8253 /* Make the function call. */
8254 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
8255 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
8257 /* Restore floating-point state. */
8258 gfc_restore_fp_state (&se
->post
, fpstate
);
8262 /* Generate code for IEEE_REM. */
8265 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
8267 tree args
[2], decl
, call
, fpstate
;
8270 conv_ieee_function_args (se
, expr
, args
, 2);
8272 /* If arguments have unequal size, convert them to the larger. */
8273 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
8274 > TYPE_PRECISION (TREE_TYPE (args
[1])))
8275 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8276 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
8277 > TYPE_PRECISION (TREE_TYPE (args
[0])))
8278 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
8280 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8281 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
8283 /* Save floating-point state. */
8284 fpstate
= gfc_save_fp_state (&se
->pre
);
8286 /* Make the function call. */
8287 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8288 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8290 /* Restore floating-point state. */
8291 gfc_restore_fp_state (&se
->post
, fpstate
);
8295 /* Generate code for IEEE_NEXT_AFTER. */
8298 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
8300 tree args
[2], decl
, call
, fpstate
;
8303 conv_ieee_function_args (se
, expr
, args
, 2);
8305 /* Result has the characteristics of first argument. */
8306 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8307 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8308 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
8310 /* Save floating-point state. */
8311 fpstate
= gfc_save_fp_state (&se
->pre
);
8313 /* Make the function call. */
8314 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8315 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8317 /* Restore floating-point state. */
8318 gfc_restore_fp_state (&se
->post
, fpstate
);
8322 /* Generate code for IEEE_SCALB. */
8325 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
8327 tree args
[2], decl
, call
, huge
, type
;
8330 conv_ieee_function_args (se
, expr
, args
, 2);
8332 /* Result has the characteristics of first argument. */
8333 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8334 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
8336 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
8338 /* We need to fold the integer into the range of a C int. */
8339 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
8340 type
= TREE_TYPE (args
[1]);
8342 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
8343 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
8345 huge
= fold_convert (type
, huge
);
8346 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
8348 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
8349 fold_build1_loc (input_location
, NEGATE_EXPR
,
8353 args
[1] = fold_convert (integer_type_node
, args
[1]);
8355 /* Make the function call. */
8356 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8357 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8361 /* Generate code for IEEE_COPY_SIGN. */
8364 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
8366 tree args
[2], decl
, sign
;
8369 conv_ieee_function_args (se
, expr
, args
, 2);
8371 /* Get the sign of the second argument. */
8372 sign
= build_call_expr_loc (input_location
,
8373 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8375 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8376 sign
, integer_zero_node
);
8378 /* Create a value of one, with the right sign. */
8379 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
8381 fold_build1_loc (input_location
, NEGATE_EXPR
,
8385 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
8387 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8388 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
8390 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8394 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8398 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
8400 const char *name
= expr
->value
.function
.name
;
8402 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8404 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
8405 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
8406 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
8407 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
8408 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
8409 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
8410 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
8411 conv_intrinsic_ieee_is_normal (se
, expr
);
8412 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
8413 conv_intrinsic_ieee_is_negative (se
, expr
);
8414 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
8415 conv_intrinsic_ieee_copy_sign (se
, expr
);
8416 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
8417 conv_intrinsic_ieee_scalb (se
, expr
);
8418 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
8419 conv_intrinsic_ieee_next_after (se
, expr
);
8420 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
8421 conv_intrinsic_ieee_rem (se
, expr
);
8422 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
8423 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
8424 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
8425 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
8427 /* It is not among the functions we translate directly. We return
8428 false, so a library function call is emitted. */
8437 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8440 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
8442 tree arg
, res
, restype
;
8444 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8445 arg
= fold_convert (size_type_node
, arg
);
8446 res
= build_call_expr_loc (input_location
,
8447 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
8448 restype
= gfc_typenode_for_spec (&expr
->ts
);
8449 se
->expr
= fold_convert (restype
, res
);
8453 /* Generate code for an intrinsic function. Some map directly to library
8454 calls, others get special handling. In some cases the name of the function
8455 used depends on the type specifiers. */
8458 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
8464 name
= &expr
->value
.function
.name
[2];
8468 lib
= gfc_is_intrinsic_libcall (expr
);
8472 se
->ignore_optional
= 1;
8474 switch (expr
->value
.function
.isym
->id
)
8476 case GFC_ISYM_EOSHIFT
:
8478 case GFC_ISYM_RESHAPE
:
8479 /* For all of those the first argument specifies the type and the
8480 third is optional. */
8481 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
8485 gfc_conv_intrinsic_funcall (se
, expr
);
8493 switch (expr
->value
.function
.isym
->id
)
8498 case GFC_ISYM_REPEAT
:
8499 gfc_conv_intrinsic_repeat (se
, expr
);
8503 gfc_conv_intrinsic_trim (se
, expr
);
8506 case GFC_ISYM_SC_KIND
:
8507 gfc_conv_intrinsic_sc_kind (se
, expr
);
8510 case GFC_ISYM_SI_KIND
:
8511 gfc_conv_intrinsic_si_kind (se
, expr
);
8514 case GFC_ISYM_SR_KIND
:
8515 gfc_conv_intrinsic_sr_kind (se
, expr
);
8518 case GFC_ISYM_EXPONENT
:
8519 gfc_conv_intrinsic_exponent (se
, expr
);
8523 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8525 fndecl
= gfor_fndecl_string_scan
;
8527 fndecl
= gfor_fndecl_string_scan_char4
;
8531 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8534 case GFC_ISYM_VERIFY
:
8535 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8537 fndecl
= gfor_fndecl_string_verify
;
8539 fndecl
= gfor_fndecl_string_verify_char4
;
8543 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8546 case GFC_ISYM_ALLOCATED
:
8547 gfc_conv_allocated (se
, expr
);
8550 case GFC_ISYM_ASSOCIATED
:
8551 gfc_conv_associated(se
, expr
);
8554 case GFC_ISYM_SAME_TYPE_AS
:
8555 gfc_conv_same_type_as (se
, expr
);
8559 gfc_conv_intrinsic_abs (se
, expr
);
8562 case GFC_ISYM_ADJUSTL
:
8563 if (expr
->ts
.kind
== 1)
8564 fndecl
= gfor_fndecl_adjustl
;
8565 else if (expr
->ts
.kind
== 4)
8566 fndecl
= gfor_fndecl_adjustl_char4
;
8570 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8573 case GFC_ISYM_ADJUSTR
:
8574 if (expr
->ts
.kind
== 1)
8575 fndecl
= gfor_fndecl_adjustr
;
8576 else if (expr
->ts
.kind
== 4)
8577 fndecl
= gfor_fndecl_adjustr_char4
;
8581 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8584 case GFC_ISYM_AIMAG
:
8585 gfc_conv_intrinsic_imagpart (se
, expr
);
8589 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
8593 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
8596 case GFC_ISYM_ANINT
:
8597 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
8601 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8605 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
8608 case GFC_ISYM_BTEST
:
8609 gfc_conv_intrinsic_btest (se
, expr
);
8613 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
8617 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
8621 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
8625 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
8628 case GFC_ISYM_C_ASSOCIATED
:
8629 case GFC_ISYM_C_FUNLOC
:
8630 case GFC_ISYM_C_LOC
:
8631 conv_isocbinding_function (se
, expr
);
8634 case GFC_ISYM_ACHAR
:
8636 gfc_conv_intrinsic_char (se
, expr
);
8639 case GFC_ISYM_CONVERSION
:
8641 case GFC_ISYM_LOGICAL
:
8643 gfc_conv_intrinsic_conversion (se
, expr
);
8646 /* Integer conversions are handled separately to make sure we get the
8647 correct rounding mode. */
8652 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
8656 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
8659 case GFC_ISYM_CEILING
:
8660 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
8663 case GFC_ISYM_FLOOR
:
8664 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
8668 gfc_conv_intrinsic_mod (se
, expr
, 0);
8671 case GFC_ISYM_MODULO
:
8672 gfc_conv_intrinsic_mod (se
, expr
, 1);
8675 case GFC_ISYM_CAF_GET
:
8676 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
8680 case GFC_ISYM_CMPLX
:
8681 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
8684 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
8685 gfc_conv_intrinsic_iargc (se
, expr
);
8688 case GFC_ISYM_COMPLEX
:
8689 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
8692 case GFC_ISYM_CONJG
:
8693 gfc_conv_intrinsic_conjg (se
, expr
);
8696 case GFC_ISYM_COUNT
:
8697 gfc_conv_intrinsic_count (se
, expr
);
8700 case GFC_ISYM_CTIME
:
8701 gfc_conv_intrinsic_ctime (se
, expr
);
8705 gfc_conv_intrinsic_dim (se
, expr
);
8708 case GFC_ISYM_DOT_PRODUCT
:
8709 gfc_conv_intrinsic_dot_product (se
, expr
);
8712 case GFC_ISYM_DPROD
:
8713 gfc_conv_intrinsic_dprod (se
, expr
);
8716 case GFC_ISYM_DSHIFTL
:
8717 gfc_conv_intrinsic_dshift (se
, expr
, true);
8720 case GFC_ISYM_DSHIFTR
:
8721 gfc_conv_intrinsic_dshift (se
, expr
, false);
8724 case GFC_ISYM_FDATE
:
8725 gfc_conv_intrinsic_fdate (se
, expr
);
8728 case GFC_ISYM_FRACTION
:
8729 gfc_conv_intrinsic_fraction (se
, expr
);
8733 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
8737 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8741 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
8744 case GFC_ISYM_IBCLR
:
8745 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
8748 case GFC_ISYM_IBITS
:
8749 gfc_conv_intrinsic_ibits (se
, expr
);
8752 case GFC_ISYM_IBSET
:
8753 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
8756 case GFC_ISYM_IACHAR
:
8757 case GFC_ISYM_ICHAR
:
8758 /* We assume ASCII character sequence. */
8759 gfc_conv_intrinsic_ichar (se
, expr
);
8762 case GFC_ISYM_IARGC
:
8763 gfc_conv_intrinsic_iargc (se
, expr
);
8767 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8770 case GFC_ISYM_INDEX
:
8771 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8773 fndecl
= gfor_fndecl_string_index
;
8775 fndecl
= gfor_fndecl_string_index_char4
;
8779 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8783 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8786 case GFC_ISYM_IPARITY
:
8787 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
8790 case GFC_ISYM_IS_IOSTAT_END
:
8791 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
8794 case GFC_ISYM_IS_IOSTAT_EOR
:
8795 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
8798 case GFC_ISYM_ISNAN
:
8799 gfc_conv_intrinsic_isnan (se
, expr
);
8802 case GFC_ISYM_LSHIFT
:
8803 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8806 case GFC_ISYM_RSHIFT
:
8807 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8810 case GFC_ISYM_SHIFTA
:
8811 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8814 case GFC_ISYM_SHIFTL
:
8815 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8818 case GFC_ISYM_SHIFTR
:
8819 gfc_conv_intrinsic_shift (se
, expr
, true, false);
8822 case GFC_ISYM_ISHFT
:
8823 gfc_conv_intrinsic_ishft (se
, expr
);
8826 case GFC_ISYM_ISHFTC
:
8827 gfc_conv_intrinsic_ishftc (se
, expr
);
8830 case GFC_ISYM_LEADZ
:
8831 gfc_conv_intrinsic_leadz (se
, expr
);
8834 case GFC_ISYM_TRAILZ
:
8835 gfc_conv_intrinsic_trailz (se
, expr
);
8838 case GFC_ISYM_POPCNT
:
8839 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
8842 case GFC_ISYM_POPPAR
:
8843 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
8846 case GFC_ISYM_LBOUND
:
8847 gfc_conv_intrinsic_bound (se
, expr
, 0);
8850 case GFC_ISYM_LCOBOUND
:
8851 conv_intrinsic_cobound (se
, expr
);
8854 case GFC_ISYM_TRANSPOSE
:
8855 /* The scalarizer has already been set up for reversed dimension access
8856 order ; now we just get the argument value normally. */
8857 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
8861 gfc_conv_intrinsic_len (se
, expr
);
8864 case GFC_ISYM_LEN_TRIM
:
8865 gfc_conv_intrinsic_len_trim (se
, expr
);
8869 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
8873 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
8877 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
8881 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
8884 case GFC_ISYM_MALLOC
:
8885 gfc_conv_intrinsic_malloc (se
, expr
);
8888 case GFC_ISYM_MASKL
:
8889 gfc_conv_intrinsic_mask (se
, expr
, 1);
8892 case GFC_ISYM_MASKR
:
8893 gfc_conv_intrinsic_mask (se
, expr
, 0);
8897 if (expr
->ts
.type
== BT_CHARACTER
)
8898 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
8900 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
8903 case GFC_ISYM_MAXLOC
:
8904 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8907 case GFC_ISYM_MAXVAL
:
8908 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
8911 case GFC_ISYM_MERGE
:
8912 gfc_conv_intrinsic_merge (se
, expr
);
8915 case GFC_ISYM_MERGE_BITS
:
8916 gfc_conv_intrinsic_merge_bits (se
, expr
);
8920 if (expr
->ts
.type
== BT_CHARACTER
)
8921 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
8923 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
8926 case GFC_ISYM_MINLOC
:
8927 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8930 case GFC_ISYM_MINVAL
:
8931 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
8934 case GFC_ISYM_NEAREST
:
8935 gfc_conv_intrinsic_nearest (se
, expr
);
8938 case GFC_ISYM_NORM2
:
8939 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
8943 gfc_conv_intrinsic_not (se
, expr
);
8947 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8950 case GFC_ISYM_PARITY
:
8951 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
8954 case GFC_ISYM_PRESENT
:
8955 gfc_conv_intrinsic_present (se
, expr
);
8958 case GFC_ISYM_PRODUCT
:
8959 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
8963 gfc_conv_intrinsic_rank (se
, expr
);
8966 case GFC_ISYM_RRSPACING
:
8967 gfc_conv_intrinsic_rrspacing (se
, expr
);
8970 case GFC_ISYM_SET_EXPONENT
:
8971 gfc_conv_intrinsic_set_exponent (se
, expr
);
8974 case GFC_ISYM_SCALE
:
8975 gfc_conv_intrinsic_scale (se
, expr
);
8979 gfc_conv_intrinsic_sign (se
, expr
);
8983 gfc_conv_intrinsic_size (se
, expr
);
8986 case GFC_ISYM_SIZEOF
:
8987 case GFC_ISYM_C_SIZEOF
:
8988 gfc_conv_intrinsic_sizeof (se
, expr
);
8991 case GFC_ISYM_STORAGE_SIZE
:
8992 gfc_conv_intrinsic_storage_size (se
, expr
);
8995 case GFC_ISYM_SPACING
:
8996 gfc_conv_intrinsic_spacing (se
, expr
);
8999 case GFC_ISYM_STRIDE
:
9000 conv_intrinsic_stride (se
, expr
);
9004 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
9007 case GFC_ISYM_TRANSFER
:
9008 if (se
->ss
&& se
->ss
->info
->useflags
)
9009 /* Access the previously obtained result. */
9010 gfc_conv_tmp_array_ref (se
);
9012 gfc_conv_intrinsic_transfer (se
, expr
);
9015 case GFC_ISYM_TTYNAM
:
9016 gfc_conv_intrinsic_ttynam (se
, expr
);
9019 case GFC_ISYM_UBOUND
:
9020 gfc_conv_intrinsic_bound (se
, expr
, 1);
9023 case GFC_ISYM_UCOBOUND
:
9024 conv_intrinsic_cobound (se
, expr
);
9028 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9032 gfc_conv_intrinsic_loc (se
, expr
);
9035 case GFC_ISYM_THIS_IMAGE
:
9036 /* For num_images() == 1, handle as LCOBOUND. */
9037 if (expr
->value
.function
.actual
->expr
9038 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
9039 conv_intrinsic_cobound (se
, expr
);
9041 trans_this_image (se
, expr
);
9044 case GFC_ISYM_IMAGE_INDEX
:
9045 trans_image_index (se
, expr
);
9048 case GFC_ISYM_NUM_IMAGES
:
9049 trans_num_images (se
, expr
);
9052 case GFC_ISYM_ACCESS
:
9053 case GFC_ISYM_CHDIR
:
9054 case GFC_ISYM_CHMOD
:
9055 case GFC_ISYM_DTIME
:
9056 case GFC_ISYM_ETIME
:
9057 case GFC_ISYM_EXTENDS_TYPE_OF
:
9059 case GFC_ISYM_FGETC
:
9062 case GFC_ISYM_FPUTC
:
9063 case GFC_ISYM_FSTAT
:
9064 case GFC_ISYM_FTELL
:
9065 case GFC_ISYM_GETCWD
:
9066 case GFC_ISYM_GETGID
:
9067 case GFC_ISYM_GETPID
:
9068 case GFC_ISYM_GETUID
:
9069 case GFC_ISYM_HOSTNM
:
9071 case GFC_ISYM_IERRNO
:
9072 case GFC_ISYM_IRAND
:
9073 case GFC_ISYM_ISATTY
:
9076 case GFC_ISYM_LSTAT
:
9077 case GFC_ISYM_MATMUL
:
9078 case GFC_ISYM_MCLOCK
:
9079 case GFC_ISYM_MCLOCK8
:
9081 case GFC_ISYM_RENAME
:
9082 case GFC_ISYM_SECOND
:
9083 case GFC_ISYM_SECNDS
:
9084 case GFC_ISYM_SIGNAL
:
9086 case GFC_ISYM_SYMLNK
:
9087 case GFC_ISYM_SYSTEM
:
9089 case GFC_ISYM_TIME8
:
9090 case GFC_ISYM_UMASK
:
9091 case GFC_ISYM_UNLINK
:
9093 gfc_conv_intrinsic_funcall (se
, expr
);
9096 case GFC_ISYM_EOSHIFT
:
9098 case GFC_ISYM_RESHAPE
:
9099 /* For those, expr->rank should always be >0 and thus the if above the
9100 switch should have matched. */
9105 gfc_conv_intrinsic_lib_function (se
, expr
);
9112 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
9114 gfc_ss
*arg_ss
, *tmp_ss
;
9115 gfc_actual_arglist
*arg
;
9117 arg
= expr
->value
.function
.actual
;
9119 gcc_assert (arg
->expr
);
9121 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
9122 gcc_assert (arg_ss
!= gfc_ss_terminator
);
9124 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
9126 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
9127 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
9129 gcc_assert (tmp_ss
->dimen
== 2);
9131 /* We just invert dimensions. */
9132 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
9135 /* Stop when tmp_ss points to the last valid element of the chain... */
9136 if (tmp_ss
->next
== gfc_ss_terminator
)
9140 /* ... so that we can attach the rest of the chain to it. */
9147 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9148 This has the side effect of reversing the nested list, so there is no
9149 need to call gfc_reverse_ss on it (the given list is assumed not to be
9153 nest_loop_dimension (gfc_ss
*ss
, int dim
)
9156 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
9157 gfc_loopinfo
*new_loop
;
9159 gcc_assert (ss
!= gfc_ss_terminator
);
9161 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
9163 new_ss
= gfc_get_ss ();
9164 new_ss
->next
= prev_ss
;
9165 new_ss
->parent
= ss
;
9166 new_ss
->info
= ss
->info
;
9167 new_ss
->info
->refcount
++;
9170 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
9171 && ss
->info
->type
!= GFC_SS_REFERENCE
);
9174 new_ss
->dim
[0] = ss
->dim
[dim
];
9176 gcc_assert (dim
< ss
->dimen
);
9178 ss_dim
= --ss
->dimen
;
9179 for (i
= dim
; i
< ss_dim
; i
++)
9180 ss
->dim
[i
] = ss
->dim
[i
+ 1];
9182 ss
->dim
[ss_dim
] = 0;
9188 ss
->nested_ss
->parent
= new_ss
;
9189 new_ss
->nested_ss
= ss
->nested_ss
;
9191 ss
->nested_ss
= new_ss
;
9194 new_loop
= gfc_get_loopinfo ();
9195 gfc_init_loopinfo (new_loop
);
9197 gcc_assert (prev_ss
!= NULL
);
9198 gcc_assert (prev_ss
!= gfc_ss_terminator
);
9199 gfc_add_ss_to_loop (new_loop
, prev_ss
);
9200 return new_ss
->parent
;
9204 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9205 is to be inlined. */
9208 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
9210 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
9211 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
9213 bool scalar_mask
= false;
9215 /* The rank of the result will be determined later. */
9216 arg1
= expr
->value
.function
.actual
;
9219 gcc_assert (arg3
!= NULL
);
9221 if (expr
->rank
== 0)
9224 tmp_ss
= gfc_ss_terminator
;
9230 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
9231 if (mask_ss
== tmp_ss
)
9237 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
9238 gcc_assert (array_ss
!= tmp_ss
);
9240 /* Odd thing: If the mask is scalar, it is used by the frontend after
9241 the array (to make an if around the nested loop). Thus it shall
9242 be after array_ss once the gfc_ss list is reversed. */
9244 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
9248 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9250 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
9251 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
9259 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
9262 switch (expr
->value
.function
.isym
->id
)
9264 case GFC_ISYM_PRODUCT
:
9266 return walk_inline_intrinsic_arith (ss
, expr
);
9268 case GFC_ISYM_TRANSPOSE
:
9269 return walk_inline_intrinsic_transpose (ss
, expr
);
9278 /* This generates code to execute before entering the scalarization loop.
9279 Currently does nothing. */
9282 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
9284 switch (ss
->info
->expr
->value
.function
.isym
->id
)
9286 case GFC_ISYM_UBOUND
:
9287 case GFC_ISYM_LBOUND
:
9288 case GFC_ISYM_UCOBOUND
:
9289 case GFC_ISYM_LCOBOUND
:
9290 case GFC_ISYM_THIS_IMAGE
:
9299 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9300 are expanded into code inside the scalarization loop. */
9303 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
9305 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
9306 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
9308 /* The two argument version returns a scalar. */
9309 if (expr
->value
.function
.actual
->next
->expr
)
9312 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
9316 /* Walk an intrinsic array libcall. */
9319 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
9321 gcc_assert (expr
->rank
> 0);
9322 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9326 /* Return whether the function call expression EXPR will be expanded
9327 inline by gfc_conv_intrinsic_function. */
9330 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
9332 gfc_actual_arglist
*args
;
9334 if (!expr
->value
.function
.isym
)
9337 switch (expr
->value
.function
.isym
->id
)
9339 case GFC_ISYM_PRODUCT
:
9341 /* Disable inline expansion if code size matters. */
9345 args
= expr
->value
.function
.actual
;
9346 /* We need to be able to subset the SUM argument at compile-time. */
9347 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
9352 case GFC_ISYM_TRANSPOSE
:
9361 /* Returns nonzero if the specified intrinsic function call maps directly to
9362 an external library call. Should only be used for functions that return
9366 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
9368 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
9369 gcc_assert (expr
->rank
> 0);
9371 if (gfc_inline_intrinsic_function_p (expr
))
9374 switch (expr
->value
.function
.isym
->id
)
9378 case GFC_ISYM_COUNT
:
9382 case GFC_ISYM_IPARITY
:
9383 case GFC_ISYM_MATMUL
:
9384 case GFC_ISYM_MAXLOC
:
9385 case GFC_ISYM_MAXVAL
:
9386 case GFC_ISYM_MINLOC
:
9387 case GFC_ISYM_MINVAL
:
9388 case GFC_ISYM_NORM2
:
9389 case GFC_ISYM_PARITY
:
9390 case GFC_ISYM_PRODUCT
:
9392 case GFC_ISYM_SHAPE
:
9393 case GFC_ISYM_SPREAD
:
9395 /* Ignore absent optional parameters. */
9398 case GFC_ISYM_RESHAPE
:
9399 case GFC_ISYM_CSHIFT
:
9400 case GFC_ISYM_EOSHIFT
:
9402 case GFC_ISYM_UNPACK
:
9403 /* Pass absent optional parameters. */
9411 /* Walk an intrinsic function. */
9413 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
9414 gfc_intrinsic_sym
* isym
)
9418 if (isym
->elemental
)
9419 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9420 NULL
, GFC_SS_SCALAR
);
9422 if (expr
->rank
== 0)
9425 if (gfc_inline_intrinsic_function_p (expr
))
9426 return walk_inline_intrinsic_function (ss
, expr
);
9428 if (gfc_is_intrinsic_libcall (expr
))
9429 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9431 /* Special cases. */
9434 case GFC_ISYM_LBOUND
:
9435 case GFC_ISYM_LCOBOUND
:
9436 case GFC_ISYM_UBOUND
:
9437 case GFC_ISYM_UCOBOUND
:
9438 case GFC_ISYM_THIS_IMAGE
:
9439 return gfc_walk_intrinsic_bound (ss
, expr
);
9441 case GFC_ISYM_TRANSFER
:
9442 case GFC_ISYM_CAF_GET
:
9443 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9446 /* This probably meant someone forgot to add an intrinsic to the above
9447 list(s) when they implemented it, or something's gone horribly
9455 conv_co_collective (gfc_code
*code
)
9458 stmtblock_t block
, post_block
;
9459 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
9460 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
9462 gfc_start_block (&block
);
9463 gfc_init_block (&post_block
);
9465 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
9467 opr_expr
= code
->ext
.actual
->next
->expr
;
9468 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
9469 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9470 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
9475 image_idx_expr
= code
->ext
.actual
->next
->expr
;
9476 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9477 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9483 gfc_init_se (&argse
, NULL
);
9484 gfc_conv_expr (&argse
, stat_expr
);
9485 gfc_add_block_to_block (&block
, &argse
.pre
);
9486 gfc_add_block_to_block (&post_block
, &argse
.post
);
9488 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
9489 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
9491 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9494 stat
= null_pointer_node
;
9496 /* Early exit for GFC_FCOARRAY_SINGLE. */
9497 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9499 if (stat
!= NULL_TREE
)
9500 gfc_add_modify (&block
, stat
,
9501 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
9502 return gfc_finish_block (&block
);
9505 /* Handle the array. */
9506 gfc_init_se (&argse
, NULL
);
9507 if (code
->ext
.actual
->expr
->rank
== 0)
9509 symbol_attribute attr
;
9510 gfc_clear_attr (&attr
);
9511 gfc_init_se (&argse
, NULL
);
9512 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9513 gfc_add_block_to_block (&block
, &argse
.pre
);
9514 gfc_add_block_to_block (&post_block
, &argse
.post
);
9515 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
9516 array
= gfc_build_addr_expr (NULL_TREE
, array
);
9520 argse
.want_pointer
= 1;
9521 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
9524 gfc_add_block_to_block (&block
, &argse
.pre
);
9525 gfc_add_block_to_block (&post_block
, &argse
.post
);
9527 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
9528 strlen
= argse
.string_length
;
9530 strlen
= integer_zero_node
;
9535 gfc_init_se (&argse
, NULL
);
9536 gfc_conv_expr (&argse
, image_idx_expr
);
9537 gfc_add_block_to_block (&block
, &argse
.pre
);
9538 gfc_add_block_to_block (&post_block
, &argse
.post
);
9539 image_index
= fold_convert (integer_type_node
, argse
.expr
);
9542 image_index
= integer_zero_node
;
9547 gfc_init_se (&argse
, NULL
);
9548 gfc_conv_expr (&argse
, errmsg_expr
);
9549 gfc_add_block_to_block (&block
, &argse
.pre
);
9550 gfc_add_block_to_block (&post_block
, &argse
.post
);
9551 errmsg
= argse
.expr
;
9552 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
9556 errmsg
= null_pointer_node
;
9557 errmsg_len
= integer_zero_node
;
9560 /* Generate the function call. */
9561 switch (code
->resolved_isym
->id
)
9563 case GFC_ISYM_CO_BROADCAST
:
9564 fndecl
= gfor_fndecl_co_broadcast
;
9566 case GFC_ISYM_CO_MAX
:
9567 fndecl
= gfor_fndecl_co_max
;
9569 case GFC_ISYM_CO_MIN
:
9570 fndecl
= gfor_fndecl_co_min
;
9572 case GFC_ISYM_CO_REDUCE
:
9573 fndecl
= gfor_fndecl_co_reduce
;
9575 case GFC_ISYM_CO_SUM
:
9576 fndecl
= gfor_fndecl_co_sum
;
9582 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
9583 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
9584 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
9585 image_index
, stat
, errmsg
, errmsg_len
);
9586 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
9587 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
9588 stat
, errmsg
, strlen
, errmsg_len
);
9591 tree opr
, opr_flags
;
9593 // FIXME: Handle TS29113's bind(C) strings with descriptor.
9595 if (gfc_is_proc_ptr_comp (opr_expr
))
9597 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
9598 opr_flag_int
= sym
->attr
.dimension
9599 || (sym
->ts
.type
== BT_CHARACTER
9600 && !sym
->attr
.is_bind_c
)
9601 ? GFC_CAF_BYREF
: 0;
9602 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9603 && !sym
->attr
.is_bind_c
9604 ? GFC_CAF_HIDDENLEN
: 0;
9605 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
9609 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
9610 ? GFC_CAF_BYREF
: 0;
9611 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9612 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
9613 ? GFC_CAF_HIDDENLEN
: 0;
9614 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
9615 ? GFC_CAF_ARG_VALUE
: 0;
9617 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
9618 gfc_conv_expr (&argse
, opr_expr
);
9620 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
9621 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
9624 gfc_add_expr_to_block (&block
, fndecl
);
9625 gfc_add_block_to_block (&block
, &post_block
);
9627 return gfc_finish_block (&block
);
9632 conv_intrinsic_atomic_op (gfc_code
*code
)
9635 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
9636 stmtblock_t block
, post_block
;
9637 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9638 gfc_expr
*stat_expr
;
9639 built_in_function fn
;
9641 if (atom_expr
->expr_type
== EXPR_FUNCTION
9642 && atom_expr
->value
.function
.isym
9643 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9644 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9646 gfc_start_block (&block
);
9647 gfc_init_block (&post_block
);
9649 gfc_init_se (&argse
, NULL
);
9650 argse
.want_pointer
= 1;
9651 gfc_conv_expr (&argse
, atom_expr
);
9652 gfc_add_block_to_block (&block
, &argse
.pre
);
9653 gfc_add_block_to_block (&post_block
, &argse
.post
);
9656 gfc_init_se (&argse
, NULL
);
9657 if (flag_coarray
== GFC_FCOARRAY_LIB
9658 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9659 argse
.want_pointer
= 1;
9660 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9661 gfc_add_block_to_block (&block
, &argse
.pre
);
9662 gfc_add_block_to_block (&post_block
, &argse
.post
);
9665 switch (code
->resolved_isym
->id
)
9667 case GFC_ISYM_ATOMIC_ADD
:
9668 case GFC_ISYM_ATOMIC_AND
:
9669 case GFC_ISYM_ATOMIC_DEF
:
9670 case GFC_ISYM_ATOMIC_OR
:
9671 case GFC_ISYM_ATOMIC_XOR
:
9672 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9673 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9674 old
= null_pointer_node
;
9677 gfc_init_se (&argse
, NULL
);
9678 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9679 argse
.want_pointer
= 1;
9680 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9681 gfc_add_block_to_block (&block
, &argse
.pre
);
9682 gfc_add_block_to_block (&post_block
, &argse
.post
);
9684 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9688 if (stat_expr
!= NULL
)
9690 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
9691 gfc_init_se (&argse
, NULL
);
9692 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9693 argse
.want_pointer
= 1;
9694 gfc_conv_expr_val (&argse
, stat_expr
);
9695 gfc_add_block_to_block (&block
, &argse
.pre
);
9696 gfc_add_block_to_block (&post_block
, &argse
.post
);
9699 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9700 stat
= null_pointer_node
;
9702 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9704 tree image_index
, caf_decl
, offset
, token
;
9707 switch (code
->resolved_isym
->id
)
9709 case GFC_ISYM_ATOMIC_ADD
:
9710 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9711 op
= (int) GFC_CAF_ATOMIC_ADD
;
9713 case GFC_ISYM_ATOMIC_AND
:
9714 case GFC_ISYM_ATOMIC_FETCH_AND
:
9715 op
= (int) GFC_CAF_ATOMIC_AND
;
9717 case GFC_ISYM_ATOMIC_OR
:
9718 case GFC_ISYM_ATOMIC_FETCH_OR
:
9719 op
= (int) GFC_CAF_ATOMIC_OR
;
9721 case GFC_ISYM_ATOMIC_XOR
:
9722 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9723 op
= (int) GFC_CAF_ATOMIC_XOR
;
9725 case GFC_ISYM_ATOMIC_DEF
:
9726 op
= 0; /* Unused. */
9732 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9733 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9734 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9736 if (gfc_is_coindexed (atom_expr
))
9737 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9739 image_index
= integer_zero_node
;
9741 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9743 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9744 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
9745 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9748 gfc_init_se (&argse
, NULL
);
9749 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
9752 gfc_add_block_to_block (&block
, &argse
.pre
);
9753 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
9754 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
9755 token
, offset
, image_index
, value
, stat
,
9756 build_int_cst (integer_type_node
,
9757 (int) atom_expr
->ts
.type
),
9758 build_int_cst (integer_type_node
,
9759 (int) atom_expr
->ts
.kind
));
9761 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
9762 build_int_cst (integer_type_node
, op
),
9763 token
, offset
, image_index
, value
, old
, stat
,
9764 build_int_cst (integer_type_node
,
9765 (int) atom_expr
->ts
.type
),
9766 build_int_cst (integer_type_node
,
9767 (int) atom_expr
->ts
.kind
));
9769 gfc_add_expr_to_block (&block
, tmp
);
9770 gfc_add_block_to_block (&block
, &argse
.post
);
9771 gfc_add_block_to_block (&block
, &post_block
);
9772 return gfc_finish_block (&block
);
9776 switch (code
->resolved_isym
->id
)
9778 case GFC_ISYM_ATOMIC_ADD
:
9779 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9780 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
9782 case GFC_ISYM_ATOMIC_AND
:
9783 case GFC_ISYM_ATOMIC_FETCH_AND
:
9784 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
9786 case GFC_ISYM_ATOMIC_DEF
:
9787 fn
= BUILT_IN_ATOMIC_STORE_N
;
9789 case GFC_ISYM_ATOMIC_OR
:
9790 case GFC_ISYM_ATOMIC_FETCH_OR
:
9791 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
9793 case GFC_ISYM_ATOMIC_XOR
:
9794 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9795 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
9801 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9802 fn
= (built_in_function
) ((int) fn
9803 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9805 tmp
= builtin_decl_explicit (fn
);
9806 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
9807 tmp
= builtin_decl_explicit (fn
);
9809 switch (code
->resolved_isym
->id
)
9811 case GFC_ISYM_ATOMIC_ADD
:
9812 case GFC_ISYM_ATOMIC_AND
:
9813 case GFC_ISYM_ATOMIC_DEF
:
9814 case GFC_ISYM_ATOMIC_OR
:
9815 case GFC_ISYM_ATOMIC_XOR
:
9816 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9817 fold_convert (itype
, value
),
9818 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9819 gfc_add_expr_to_block (&block
, tmp
);
9822 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9823 fold_convert (itype
, value
),
9824 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9825 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
9829 if (stat
!= NULL_TREE
)
9830 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9831 gfc_add_block_to_block (&block
, &post_block
);
9832 return gfc_finish_block (&block
);
9837 conv_intrinsic_atomic_ref (gfc_code
*code
)
9840 tree tmp
, atom
, value
, stat
= NULL_TREE
;
9841 stmtblock_t block
, post_block
;
9842 built_in_function fn
;
9843 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
9845 if (atom_expr
->expr_type
== EXPR_FUNCTION
9846 && atom_expr
->value
.function
.isym
9847 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9848 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9850 gfc_start_block (&block
);
9851 gfc_init_block (&post_block
);
9852 gfc_init_se (&argse
, NULL
);
9853 argse
.want_pointer
= 1;
9854 gfc_conv_expr (&argse
, atom_expr
);
9855 gfc_add_block_to_block (&block
, &argse
.pre
);
9856 gfc_add_block_to_block (&post_block
, &argse
.post
);
9859 gfc_init_se (&argse
, NULL
);
9860 if (flag_coarray
== GFC_FCOARRAY_LIB
9861 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9862 argse
.want_pointer
= 1;
9863 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9864 gfc_add_block_to_block (&block
, &argse
.pre
);
9865 gfc_add_block_to_block (&post_block
, &argse
.post
);
9869 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
9871 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9873 gfc_init_se (&argse
, NULL
);
9874 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9875 argse
.want_pointer
= 1;
9876 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9877 gfc_add_block_to_block (&block
, &argse
.pre
);
9878 gfc_add_block_to_block (&post_block
, &argse
.post
);
9881 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9882 stat
= null_pointer_node
;
9884 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9886 tree image_index
, caf_decl
, offset
, token
;
9887 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
9889 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9890 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9891 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9893 if (gfc_is_coindexed (atom_expr
))
9894 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9896 image_index
= integer_zero_node
;
9898 gfc_init_se (&argse
, NULL
);
9899 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
9901 gfc_add_block_to_block (&block
, &argse
.pre
);
9903 /* Different type, need type conversion. */
9904 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9906 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9908 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
9911 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
9912 token
, offset
, image_index
, value
, stat
,
9913 build_int_cst (integer_type_node
,
9914 (int) atom_expr
->ts
.type
),
9915 build_int_cst (integer_type_node
,
9916 (int) atom_expr
->ts
.kind
));
9917 gfc_add_expr_to_block (&block
, tmp
);
9918 if (vardecl
!= NULL_TREE
)
9919 gfc_add_modify (&block
, orig_value
,
9920 fold_convert (TREE_TYPE (orig_value
), vardecl
));
9921 gfc_add_block_to_block (&block
, &argse
.post
);
9922 gfc_add_block_to_block (&block
, &post_block
);
9923 return gfc_finish_block (&block
);
9926 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9927 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
9928 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9930 tmp
= builtin_decl_explicit (fn
);
9931 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
9932 build_int_cst (integer_type_node
,
9934 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
9936 if (stat
!= NULL_TREE
)
9937 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9938 gfc_add_block_to_block (&block
, &post_block
);
9939 return gfc_finish_block (&block
);
9944 conv_intrinsic_atomic_cas (gfc_code
*code
)
9947 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
9948 stmtblock_t block
, post_block
;
9949 built_in_function fn
;
9950 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9952 if (atom_expr
->expr_type
== EXPR_FUNCTION
9953 && atom_expr
->value
.function
.isym
9954 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9955 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9957 gfc_init_block (&block
);
9958 gfc_init_block (&post_block
);
9959 gfc_init_se (&argse
, NULL
);
9960 argse
.want_pointer
= 1;
9961 gfc_conv_expr (&argse
, atom_expr
);
9964 gfc_init_se (&argse
, NULL
);
9965 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9966 argse
.want_pointer
= 1;
9967 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9968 gfc_add_block_to_block (&block
, &argse
.pre
);
9969 gfc_add_block_to_block (&post_block
, &argse
.post
);
9972 gfc_init_se (&argse
, NULL
);
9973 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9974 argse
.want_pointer
= 1;
9975 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9976 gfc_add_block_to_block (&block
, &argse
.pre
);
9977 gfc_add_block_to_block (&post_block
, &argse
.post
);
9980 gfc_init_se (&argse
, NULL
);
9981 if (flag_coarray
== GFC_FCOARRAY_LIB
9982 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
9983 == atom_expr
->ts
.kind
)
9984 argse
.want_pointer
= 1;
9985 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
9986 gfc_add_block_to_block (&block
, &argse
.pre
);
9987 gfc_add_block_to_block (&post_block
, &argse
.post
);
9988 new_val
= argse
.expr
;
9991 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
9993 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
9995 gfc_init_se (&argse
, NULL
);
9996 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9997 argse
.want_pointer
= 1;
9998 gfc_conv_expr_val (&argse
,
9999 code
->ext
.actual
->next
->next
->next
->next
->expr
);
10000 gfc_add_block_to_block (&block
, &argse
.pre
);
10001 gfc_add_block_to_block (&post_block
, &argse
.post
);
10004 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10005 stat
= null_pointer_node
;
10007 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10009 tree image_index
, caf_decl
, offset
, token
;
10011 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10012 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10013 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10015 if (gfc_is_coindexed (atom_expr
))
10016 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10018 image_index
= integer_zero_node
;
10020 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
10022 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
10023 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
10024 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10027 /* Convert a constant to a pointer. */
10028 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
10030 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
10031 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
10032 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10035 gfc_init_se (&argse
, NULL
);
10036 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10038 gfc_add_block_to_block (&block
, &argse
.pre
);
10040 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
10041 token
, offset
, image_index
, old
, comp
, new_val
,
10042 stat
, build_int_cst (integer_type_node
,
10043 (int) atom_expr
->ts
.type
),
10044 build_int_cst (integer_type_node
,
10045 (int) atom_expr
->ts
.kind
));
10046 gfc_add_expr_to_block (&block
, tmp
);
10047 gfc_add_block_to_block (&block
, &argse
.post
);
10048 gfc_add_block_to_block (&block
, &post_block
);
10049 return gfc_finish_block (&block
);
10052 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10053 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10054 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10056 tmp
= builtin_decl_explicit (fn
);
10058 gfc_add_modify (&block
, old
, comp
);
10059 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
10060 gfc_build_addr_expr (NULL
, old
),
10061 fold_convert (TREE_TYPE (old
), new_val
),
10062 boolean_false_node
,
10063 build_int_cst (NULL
, MEMMODEL_RELAXED
),
10064 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10065 gfc_add_expr_to_block (&block
, tmp
);
10067 if (stat
!= NULL_TREE
)
10068 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10069 gfc_add_block_to_block (&block
, &post_block
);
10070 return gfc_finish_block (&block
);
10074 conv_intrinsic_event_query (gfc_code
*code
)
10077 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
10078 tree count
= NULL_TREE
, count2
= NULL_TREE
;
10080 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
10082 if (code
->ext
.actual
->next
->next
->expr
)
10084 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10086 gfc_init_se (&argse
, NULL
);
10087 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10090 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10091 stat
= null_pointer_node
;
10093 if (code
->ext
.actual
->next
->expr
)
10095 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
10096 gfc_init_se (&argse
, NULL
);
10097 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
10098 count
= argse
.expr
;
10101 gfc_start_block (&se
.pre
);
10102 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10104 tree tmp
, token
, image_index
;
10105 tree index
= size_zero_node
;
10107 if (event_expr
->expr_type
== EXPR_FUNCTION
10108 && event_expr
->value
.function
.isym
10109 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10110 event_expr
= event_expr
->value
.function
.actual
->expr
;
10112 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
10114 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10115 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
10116 != INTMOD_ISO_FORTRAN_ENV
10117 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
10118 != ISOFORTRAN_EVENT_TYPE
)
10120 gfc_error ("Sorry, the event component of derived type at %L is not "
10121 "yet supported", &event_expr
->where
);
10125 if (gfc_is_coindexed (event_expr
))
10127 gfc_error ("The event variable at %L shall not be coindexed ",
10128 &event_expr
->where
);
10132 image_index
= integer_zero_node
;
10134 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10137 /* For arrays, obtain the array index. */
10138 if (gfc_expr_attr (event_expr
).dimension
)
10140 tree desc
, tmp
, extent
, lbound
, ubound
;
10141 gfc_array_ref
*ar
, ar2
;
10144 /* TODO: Extend this, once DT components are supported. */
10145 ar
= &event_expr
->ref
->u
.ar
;
10147 memset (ar
, '\0', sizeof (*ar
));
10149 ar
->type
= AR_FULL
;
10151 gfc_init_se (&argse
, NULL
);
10152 argse
.descriptor_only
= 1;
10153 gfc_conv_expr_descriptor (&argse
, event_expr
);
10154 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
10158 extent
= integer_one_node
;
10159 for (i
= 0; i
< ar
->dimen
; i
++)
10161 gfc_init_se (&argse
, NULL
);
10162 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
10163 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
10164 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
10165 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10166 integer_type_node
, argse
.expr
,
10167 fold_convert(integer_type_node
, lbound
));
10168 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10169 integer_type_node
, extent
, tmp
);
10170 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
10171 integer_type_node
, index
, tmp
);
10172 if (i
< ar
->dimen
- 1)
10174 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
10175 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10176 tmp
= fold_convert (integer_type_node
, tmp
);
10177 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
10178 integer_type_node
, extent
, tmp
);
10183 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
10186 count
= gfc_create_var (integer_type_node
, "count");
10189 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
10192 stat
= gfc_create_var (integer_type_node
, "stat");
10195 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
10196 token
, index
, image_index
, count
10197 ? gfc_build_addr_expr (NULL
, count
) : count
,
10198 stat
!= null_pointer_node
10199 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
10200 gfc_add_expr_to_block (&se
.pre
, tmp
);
10202 if (count2
!= NULL_TREE
)
10203 gfc_add_modify (&se
.pre
, count2
,
10204 fold_convert (TREE_TYPE (count2
), count
));
10206 if (stat2
!= NULL_TREE
)
10207 gfc_add_modify (&se
.pre
, stat2
,
10208 fold_convert (TREE_TYPE (stat2
), stat
));
10210 return gfc_finish_block (&se
.pre
);
10213 gfc_init_se (&argse
, NULL
);
10214 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
10215 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
10217 if (stat
!= NULL_TREE
)
10218 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10220 return gfc_finish_block (&se
.pre
);
10224 conv_intrinsic_move_alloc (gfc_code
*code
)
10227 gfc_expr
*from_expr
, *to_expr
;
10228 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
10229 gfc_se from_se
, to_se
;
10233 gfc_start_block (&block
);
10235 from_expr
= code
->ext
.actual
->expr
;
10236 to_expr
= code
->ext
.actual
->next
->expr
;
10238 gfc_init_se (&from_se
, NULL
);
10239 gfc_init_se (&to_se
, NULL
);
10241 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
10242 || to_expr
->ts
.type
== BT_CLASS
);
10243 coarray
= gfc_get_corank (from_expr
) != 0;
10245 if (from_expr
->rank
== 0 && !coarray
)
10247 if (from_expr
->ts
.type
!= BT_CLASS
)
10248 from_expr2
= from_expr
;
10251 from_expr2
= gfc_copy_expr (from_expr
);
10252 gfc_add_data_component (from_expr2
);
10255 if (to_expr
->ts
.type
!= BT_CLASS
)
10256 to_expr2
= to_expr
;
10259 to_expr2
= gfc_copy_expr (to_expr
);
10260 gfc_add_data_component (to_expr2
);
10263 from_se
.want_pointer
= 1;
10264 to_se
.want_pointer
= 1;
10265 gfc_conv_expr (&from_se
, from_expr2
);
10266 gfc_conv_expr (&to_se
, to_expr2
);
10267 gfc_add_block_to_block (&block
, &from_se
.pre
);
10268 gfc_add_block_to_block (&block
, &to_se
.pre
);
10270 /* Deallocate "to". */
10271 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
10272 to_expr
, to_expr
->ts
);
10273 gfc_add_expr_to_block (&block
, tmp
);
10275 /* Assign (_data) pointers. */
10276 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10277 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
10279 /* Set "from" to NULL. */
10280 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10281 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
10283 gfc_add_block_to_block (&block
, &from_se
.post
);
10284 gfc_add_block_to_block (&block
, &to_se
.post
);
10287 if (to_expr
->ts
.type
== BT_CLASS
)
10291 gfc_free_expr (to_expr2
);
10292 gfc_init_se (&to_se
, NULL
);
10293 to_se
.want_pointer
= 1;
10294 gfc_add_vptr_component (to_expr
);
10295 gfc_conv_expr (&to_se
, to_expr
);
10297 if (from_expr
->ts
.type
== BT_CLASS
)
10299 if (UNLIMITED_POLY (from_expr
))
10303 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10307 gfc_free_expr (from_expr2
);
10308 gfc_init_se (&from_se
, NULL
);
10309 from_se
.want_pointer
= 1;
10310 gfc_add_vptr_component (from_expr
);
10311 gfc_conv_expr (&from_se
, from_expr
);
10312 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10313 fold_convert (TREE_TYPE (to_se
.expr
),
10316 /* Reset _vptr component to declared type. */
10318 /* Unlimited polymorphic. */
10319 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10320 fold_convert (TREE_TYPE (from_se
.expr
),
10321 null_pointer_node
));
10324 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10325 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10326 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10331 vtab
= gfc_find_vtab (&from_expr
->ts
);
10333 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10334 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10335 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10339 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10341 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10342 fold_convert (TREE_TYPE (to_se
.string_length
),
10343 from_se
.string_length
));
10344 if (from_expr
->ts
.deferred
)
10345 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10346 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10349 return gfc_finish_block (&block
);
10352 /* Update _vptr component. */
10353 if (to_expr
->ts
.type
== BT_CLASS
)
10357 to_se
.want_pointer
= 1;
10358 to_expr2
= gfc_copy_expr (to_expr
);
10359 gfc_add_vptr_component (to_expr2
);
10360 gfc_conv_expr (&to_se
, to_expr2
);
10362 if (from_expr
->ts
.type
== BT_CLASS
)
10364 if (UNLIMITED_POLY (from_expr
))
10368 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10372 from_se
.want_pointer
= 1;
10373 from_expr2
= gfc_copy_expr (from_expr
);
10374 gfc_add_vptr_component (from_expr2
);
10375 gfc_conv_expr (&from_se
, from_expr2
);
10376 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10377 fold_convert (TREE_TYPE (to_se
.expr
),
10380 /* Reset _vptr component to declared type. */
10382 /* Unlimited polymorphic. */
10383 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10384 fold_convert (TREE_TYPE (from_se
.expr
),
10385 null_pointer_node
));
10388 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10389 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10390 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10395 vtab
= gfc_find_vtab (&from_expr
->ts
);
10397 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10398 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10399 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10402 gfc_free_expr (to_expr2
);
10403 gfc_init_se (&to_se
, NULL
);
10405 if (from_expr
->ts
.type
== BT_CLASS
)
10407 gfc_free_expr (from_expr2
);
10408 gfc_init_se (&from_se
, NULL
);
10413 /* Deallocate "to". */
10414 if (from_expr
->rank
== 0)
10416 to_se
.want_coarray
= 1;
10417 from_se
.want_coarray
= 1;
10419 gfc_conv_expr_descriptor (&to_se
, to_expr
);
10420 gfc_conv_expr_descriptor (&from_se
, from_expr
);
10422 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10423 is an image control "statement", cf. IR F08/0040 in 12-006A. */
10424 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10428 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10429 NULL_TREE
, NULL_TREE
, true, to_expr
,
10431 gfc_add_expr_to_block (&block
, tmp
);
10433 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10434 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10435 boolean_type_node
, tmp
,
10436 fold_convert (TREE_TYPE (tmp
),
10437 null_pointer_node
));
10438 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
10439 3, null_pointer_node
, null_pointer_node
,
10440 build_int_cst (integer_type_node
, 0));
10442 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
10443 tmp
, build_empty_stmt (input_location
));
10444 gfc_add_expr_to_block (&block
, tmp
);
10448 if (to_expr
->ts
.type
== BT_DERIVED
10449 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
10451 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
10452 to_se
.expr
, to_expr
->rank
);
10453 gfc_add_expr_to_block (&block
, tmp
);
10456 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10457 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10458 NULL_TREE
, true, to_expr
, false);
10459 gfc_add_expr_to_block (&block
, tmp
);
10462 /* Move the pointer and update the array descriptor data. */
10463 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
10465 /* Set "from" to NULL. */
10466 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
10467 gfc_add_modify_loc (input_location
, &block
, tmp
,
10468 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
10471 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10473 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10474 fold_convert (TREE_TYPE (to_se
.string_length
),
10475 from_se
.string_length
));
10476 if (from_expr
->ts
.deferred
)
10477 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10478 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10481 return gfc_finish_block (&block
);
10486 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
10490 gcc_assert (code
->resolved_isym
);
10492 switch (code
->resolved_isym
->id
)
10494 case GFC_ISYM_MOVE_ALLOC
:
10495 res
= conv_intrinsic_move_alloc (code
);
10498 case GFC_ISYM_ATOMIC_CAS
:
10499 res
= conv_intrinsic_atomic_cas (code
);
10502 case GFC_ISYM_ATOMIC_ADD
:
10503 case GFC_ISYM_ATOMIC_AND
:
10504 case GFC_ISYM_ATOMIC_DEF
:
10505 case GFC_ISYM_ATOMIC_OR
:
10506 case GFC_ISYM_ATOMIC_XOR
:
10507 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10508 case GFC_ISYM_ATOMIC_FETCH_AND
:
10509 case GFC_ISYM_ATOMIC_FETCH_OR
:
10510 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10511 res
= conv_intrinsic_atomic_op (code
);
10514 case GFC_ISYM_ATOMIC_REF
:
10515 res
= conv_intrinsic_atomic_ref (code
);
10518 case GFC_ISYM_EVENT_QUERY
:
10519 res
= conv_intrinsic_event_query (code
);
10522 case GFC_ISYM_C_F_POINTER
:
10523 case GFC_ISYM_C_F_PROCPOINTER
:
10524 res
= conv_isocbinding_subroutine (code
);
10527 case GFC_ISYM_CAF_SEND
:
10528 res
= conv_caf_send (code
);
10531 case GFC_ISYM_CO_BROADCAST
:
10532 case GFC_ISYM_CO_MIN
:
10533 case GFC_ISYM_CO_MAX
:
10534 case GFC_ISYM_CO_REDUCE
:
10535 case GFC_ISYM_CO_SUM
:
10536 res
= conv_co_collective (code
);
10539 case GFC_ISYM_FREE
:
10540 res
= conv_intrinsic_free (code
);
10543 case GFC_ISYM_SYSTEM_CLOCK
:
10544 res
= conv_intrinsic_system_clock (code
);
10555 #include "gt-fortran-trans-intrinsic.h"