1 /* Intrinsic translation
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "tree-nested.h"
35 #include "stor-layout.h"
36 #include "toplev.h" /* For rest_of_decl_compilation. */
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 #include "dependency.h" /* For CAF array alias analysis. */
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 /* This maps Fortran intrinsic math functions to external library or GCC
46 typedef struct GTY(()) gfc_intrinsic_map_t
{
47 /* The explicit enum is required to work around inadequacies in the
48 garbage collection/gengtype parsing mechanism. */
51 /* Enum value from the "language-independent", aka C-centric, part
52 of gcc, or END_BUILTINS of no such value set. */
53 enum built_in_function float_built_in
;
54 enum built_in_function double_built_in
;
55 enum built_in_function long_double_built_in
;
56 enum built_in_function complex_float_built_in
;
57 enum built_in_function complex_double_built_in
;
58 enum built_in_function complex_long_double_built_in
;
60 /* True if the naming pattern is to prepend "c" for complex and
61 append "f" for kind=4. False if the naming pattern is to
62 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
65 /* True if a complex version of the function exists. */
66 bool complex_available
;
68 /* True if the function should be marked const. */
71 /* The base library name of this function. */
74 /* Cache decls created for the various operand types. */
86 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
87 defines complex variants of all of the entries in mathbuiltins.def
89 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
90 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
91 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
92 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
93 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
95 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
96 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
97 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
98 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
99 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
101 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
102 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
107 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
108 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
109 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
115 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
116 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
117 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
118 #include "mathbuiltins.def"
120 /* Functions in libgfortran. */
121 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
124 LIB_FUNCTION (NONE
, NULL
, false)
129 #undef DEFINE_MATH_BUILTIN
130 #undef DEFINE_MATH_BUILTIN_C
133 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
136 /* Find the correct variant of a given builtin from its argument. */
138 builtin_decl_for_precision (enum built_in_function base_built_in
,
141 enum built_in_function i
= END_BUILTINS
;
143 gfc_intrinsic_map_t
*m
;
144 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
147 if (precision
== TYPE_PRECISION (float_type_node
))
148 i
= m
->float_built_in
;
149 else if (precision
== TYPE_PRECISION (double_type_node
))
150 i
= m
->double_built_in
;
151 else if (precision
== TYPE_PRECISION (long_double_type_node
))
152 i
= m
->long_double_built_in
;
153 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
155 /* Special treatment, because it is not exactly a built-in, but
156 a library function. */
157 return m
->real16_decl
;
160 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
165 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
168 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
170 if (gfc_real_kinds
[i
].c_float128
)
172 /* For __float128, the story is a bit different, because we return
173 a decl to a library function rather than a built-in. */
174 gfc_intrinsic_map_t
*m
;
175 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
178 return m
->real16_decl
;
181 return builtin_decl_for_precision (double_built_in
,
182 gfc_real_kinds
[i
].mode_precision
);
186 /* Evaluate the arguments to an intrinsic function. The value
187 of NARGS may be less than the actual number of arguments in EXPR
188 to allow optional "KIND" arguments that are not included in the
189 generated code to be ignored. */
192 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
193 tree
*argarray
, int nargs
)
195 gfc_actual_arglist
*actual
;
197 gfc_intrinsic_arg
*formal
;
201 formal
= expr
->value
.function
.isym
->formal
;
202 actual
= expr
->value
.function
.actual
;
204 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
205 actual
= actual
->next
,
206 formal
= formal
? formal
->next
: NULL
)
210 /* Skip omitted optional arguments. */
217 /* Evaluate the parameter. This will substitute scalarized
218 references automatically. */
219 gfc_init_se (&argse
, se
);
221 if (e
->ts
.type
== BT_CHARACTER
)
223 gfc_conv_expr (&argse
, e
);
224 gfc_conv_string_parameter (&argse
);
225 argarray
[curr_arg
++] = argse
.string_length
;
226 gcc_assert (curr_arg
< nargs
);
229 gfc_conv_expr_val (&argse
, e
);
231 /* If an optional argument is itself an optional dummy argument,
232 check its presence and substitute a null if absent. */
233 if (e
->expr_type
== EXPR_VARIABLE
234 && e
->symtree
->n
.sym
->attr
.optional
237 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
239 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
240 gfc_add_block_to_block (&se
->post
, &argse
.post
);
241 argarray
[curr_arg
] = argse
.expr
;
245 /* Count the number of actual arguments to the intrinsic function EXPR
246 including any "hidden" string length arguments. */
249 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
252 gfc_actual_arglist
*actual
;
254 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
259 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
269 /* Conversions between different types are output by the frontend as
270 intrinsic functions. We implement these directly with inline code. */
273 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
279 nargs
= gfc_intrinsic_argument_list_length (expr
);
280 args
= XALLOCAVEC (tree
, nargs
);
282 /* Evaluate all the arguments passed. Whilst we're only interested in the
283 first one here, there are other parts of the front-end that assume this
284 and will trigger an ICE if it's not the case. */
285 type
= gfc_typenode_for_spec (&expr
->ts
);
286 gcc_assert (expr
->value
.function
.actual
->expr
);
287 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
289 /* Conversion between character kinds involves a call to a library
291 if (expr
->ts
.type
== BT_CHARACTER
)
293 tree fndecl
, var
, addr
, tmp
;
295 if (expr
->ts
.kind
== 1
296 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
297 fndecl
= gfor_fndecl_convert_char4_to_char1
;
298 else if (expr
->ts
.kind
== 4
299 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
300 fndecl
= gfor_fndecl_convert_char1_to_char4
;
304 /* Create the variable storing the converted value. */
305 type
= gfc_get_pchar_type (expr
->ts
.kind
);
306 var
= gfc_create_var (type
, "str");
307 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
309 /* Call the library function that will perform the conversion. */
310 gcc_assert (nargs
>= 2);
311 tmp
= build_call_expr_loc (input_location
,
312 fndecl
, 3, addr
, args
[0], args
[1]);
313 gfc_add_expr_to_block (&se
->pre
, tmp
);
315 /* Free the temporary afterwards. */
316 tmp
= gfc_call_free (var
);
317 gfc_add_expr_to_block (&se
->post
, tmp
);
320 se
->string_length
= args
[0];
325 /* Conversion from complex to non-complex involves taking the real
326 component of the value. */
327 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
328 && expr
->ts
.type
!= BT_COMPLEX
)
332 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
333 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
337 se
->expr
= convert (type
, args
[0]);
340 /* This is needed because the gcc backend only implements
341 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
342 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
343 Similarly for CEILING. */
346 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
353 argtype
= TREE_TYPE (arg
);
354 arg
= gfc_evaluate_now (arg
, pblock
);
356 intval
= convert (type
, arg
);
357 intval
= gfc_evaluate_now (intval
, pblock
);
359 tmp
= convert (argtype
, intval
);
360 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
361 boolean_type_node
, tmp
, arg
);
363 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
364 intval
, build_int_cst (type
, 1));
365 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
370 /* Round to nearest integer, away from zero. */
373 build_round_expr (tree arg
, tree restype
)
377 int argprec
, resprec
;
379 argtype
= TREE_TYPE (arg
);
380 argprec
= TYPE_PRECISION (argtype
);
381 resprec
= TYPE_PRECISION (restype
);
383 /* Depending on the type of the result, choose the int intrinsic
384 (iround, available only as a builtin, therefore cannot use it for
385 __float128), long int intrinsic (lround family) or long long
386 intrinsic (llround). We might also need to convert the result
388 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
389 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
390 else if (resprec
<= LONG_TYPE_SIZE
)
391 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
392 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
393 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
397 return fold_convert (restype
, build_call_expr_loc (input_location
,
402 /* Convert a real to an integer using a specific rounding mode.
403 Ideally we would just build the corresponding GENERIC node,
404 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
407 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
408 enum rounding_mode op
)
413 return build_fixbound_expr (pblock
, arg
, type
, 0);
416 return build_fixbound_expr (pblock
, arg
, type
, 1);
419 return build_round_expr (arg
, type
);
422 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
430 /* Round a real value using the specified rounding mode.
431 We use a temporary integer of that same kind size as the result.
432 Values larger than those that can be represented by this kind are
433 unchanged, as they will not be accurate enough to represent the
435 huge = HUGE (KIND (a))
436 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
440 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
452 kind
= expr
->ts
.kind
;
453 nargs
= gfc_intrinsic_argument_list_length (expr
);
456 /* We have builtin functions for some cases. */
460 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
464 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
471 /* Evaluate the argument. */
472 gcc_assert (expr
->value
.function
.actual
->expr
);
473 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
475 /* Use a builtin function if one exists. */
476 if (decl
!= NULL_TREE
)
478 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
482 /* This code is probably redundant, but we'll keep it lying around just
484 type
= gfc_typenode_for_spec (&expr
->ts
);
485 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
487 /* Test if the value is too large to handle sensibly. */
488 gfc_set_model_kind (kind
);
490 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
491 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
492 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
493 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
496 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
497 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
498 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
500 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
502 itype
= gfc_get_int_type (kind
);
504 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
505 tmp
= convert (type
, tmp
);
506 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
512 /* Convert to an integer using the specified rounding mode. */
515 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
521 nargs
= gfc_intrinsic_argument_list_length (expr
);
522 args
= XALLOCAVEC (tree
, nargs
);
524 /* Evaluate the argument, we process all arguments even though we only
525 use the first one for code generation purposes. */
526 type
= gfc_typenode_for_spec (&expr
->ts
);
527 gcc_assert (expr
->value
.function
.actual
->expr
);
528 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
530 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
532 /* Conversion to a different integer kind. */
533 se
->expr
= convert (type
, args
[0]);
537 /* Conversion from complex to non-complex involves taking the real
538 component of the value. */
539 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
540 && expr
->ts
.type
!= BT_COMPLEX
)
544 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
545 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
549 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
554 /* Get the imaginary component of a value. */
557 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
561 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
562 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
563 TREE_TYPE (TREE_TYPE (arg
)), arg
);
567 /* Get the complex conjugate of a value. */
570 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
574 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
575 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
581 define_quad_builtin (const char *name
, tree type
, bool is_const
)
584 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
587 /* Mark the decl as external. */
588 DECL_EXTERNAL (fndecl
) = 1;
589 TREE_PUBLIC (fndecl
) = 1;
591 /* Mark it __attribute__((const)). */
592 TREE_READONLY (fndecl
) = is_const
;
594 rest_of_decl_compilation (fndecl
, 1, 0);
601 /* Initialize function decls for library functions. The external functions
602 are created as required. Builtin functions are added here. */
605 gfc_build_intrinsic_lib_fndecls (void)
607 gfc_intrinsic_map_t
*m
;
608 tree quad_decls
[END_BUILTINS
+ 1];
610 if (gfc_real16_is_float128
)
612 /* If we have soft-float types, we create the decls for their
613 C99-like library functions. For now, we only handle __float128
614 q-suffixed functions. */
616 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
617 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
619 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
621 type
= gfc_float128_type_node
;
622 complex_type
= gfc_complex_float128_type_node
;
623 /* type (*) (type) */
624 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
626 func_iround
= build_function_type_list (integer_type_node
,
628 /* long (*) (type) */
629 func_lround
= build_function_type_list (long_integer_type_node
,
631 /* long long (*) (type) */
632 func_llround
= build_function_type_list (long_long_integer_type_node
,
634 /* type (*) (type, type) */
635 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
636 /* type (*) (type, &int) */
638 = build_function_type_list (type
,
640 build_pointer_type (integer_type_node
),
642 /* type (*) (type, int) */
643 func_scalbn
= build_function_type_list (type
,
644 type
, integer_type_node
, NULL_TREE
);
645 /* type (*) (complex type) */
646 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
647 /* complex type (*) (complex type, complex type) */
649 = build_function_type_list (complex_type
,
650 complex_type
, complex_type
, NULL_TREE
);
652 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
653 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
654 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
656 /* Only these built-ins are actually needed here. These are used directly
657 from the code, when calling builtin_decl_for_precision() or
658 builtin_decl_for_float_type(). The others are all constructed by
659 gfc_get_intrinsic_lib_fndecl(). */
660 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
661 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
663 #include "mathbuiltins.def"
667 #undef DEFINE_MATH_BUILTIN
668 #undef DEFINE_MATH_BUILTIN_C
670 /* There is one built-in we defined manually, because it gets called
671 with builtin_decl_for_precision() or builtin_decl_for_float_type()
672 even though it is not an OTHER_BUILTIN: it is SQRT. */
673 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
677 /* Add GCC builtin functions. */
678 for (m
= gfc_intrinsic_map
;
679 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
681 if (m
->float_built_in
!= END_BUILTINS
)
682 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
683 if (m
->complex_float_built_in
!= END_BUILTINS
)
684 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
685 if (m
->double_built_in
!= END_BUILTINS
)
686 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
687 if (m
->complex_double_built_in
!= END_BUILTINS
)
688 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
690 /* If real(kind=10) exists, it is always long double. */
691 if (m
->long_double_built_in
!= END_BUILTINS
)
692 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
693 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
695 = builtin_decl_explicit (m
->complex_long_double_built_in
);
697 if (!gfc_real16_is_float128
)
699 if (m
->long_double_built_in
!= END_BUILTINS
)
700 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
701 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
703 = builtin_decl_explicit (m
->complex_long_double_built_in
);
705 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m
->real16_decl
= quad_decls
[m
->double_built_in
];
712 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
714 /* Same thing for the complex ones. */
715 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
721 /* Create a fndecl for a simple intrinsic library function. */
724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
727 vec
<tree
, va_gc
> *argtypes
;
729 gfc_actual_arglist
*actual
;
732 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
735 if (ts
->type
== BT_REAL
)
740 pdecl
= &m
->real4_decl
;
743 pdecl
= &m
->real8_decl
;
746 pdecl
= &m
->real10_decl
;
749 pdecl
= &m
->real16_decl
;
755 else if (ts
->type
== BT_COMPLEX
)
757 gcc_assert (m
->complex_available
);
762 pdecl
= &m
->complex4_decl
;
765 pdecl
= &m
->complex8_decl
;
768 pdecl
= &m
->complex10_decl
;
771 pdecl
= &m
->complex16_decl
;
785 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
786 if (gfc_real_kinds
[n
].c_float
)
787 snprintf (name
, sizeof (name
), "%s%s%s",
788 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
789 else if (gfc_real_kinds
[n
].c_double
)
790 snprintf (name
, sizeof (name
), "%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
792 else if (gfc_real_kinds
[n
].c_long_double
)
793 snprintf (name
, sizeof (name
), "%s%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
795 else if (gfc_real_kinds
[n
].c_float128
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
803 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
804 ts
->type
== BT_COMPLEX
? 'c' : 'r',
809 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
811 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
812 vec_safe_push (argtypes
, type
);
814 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
815 fndecl
= build_decl (input_location
,
816 FUNCTION_DECL
, get_identifier (name
), type
);
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl
) = 1;
820 TREE_PUBLIC (fndecl
) = 1;
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl
) = m
->is_constant
;
825 rest_of_decl_compilation (fndecl
, 1, 0);
832 /* Convert an intrinsic function into an external or builtin call. */
835 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
837 gfc_intrinsic_map_t
*m
;
841 unsigned int num_args
;
844 id
= expr
->value
.function
.isym
->id
;
845 /* Find the entry for this function. */
846 for (m
= gfc_intrinsic_map
;
847 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
853 if (m
->id
== GFC_ISYM_NONE
)
855 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
856 expr
->value
.function
.name
, id
);
859 /* Get the decl and generate the call. */
860 num_args
= gfc_intrinsic_argument_list_length (expr
);
861 args
= XALLOCAVEC (tree
, num_args
);
863 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
864 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
865 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
867 fndecl
= build_addr (fndecl
);
868 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
877 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
878 tree a
, tree b
, stmtblock_t
* target
)
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
887 /* Compare the two string lengths. */
888 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
890 /* Output the runtime-check. */
891 name
= gfc_build_cstring_const (intr_name
);
892 name
= gfc_build_addr_expr (pchar_type_node
, name
);
893 gfc_trans_runtime_check (true, false, cond
, target
, where
,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node
, a
),
896 fold_convert (long_integer_type_node
, b
), name
);
900 /* The EXPONENT(X) intrinsic function is translated into
902 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
903 so that if X is a NaN or infinity, the result is HUGE(0).
907 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
909 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
912 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
913 expr
->value
.function
.actual
->expr
->ts
.kind
);
915 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
916 arg
= gfc_evaluate_now (arg
, &se
->pre
);
918 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
919 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
920 cond
= build_call_expr_loc (input_location
,
921 builtin_decl_explicit (BUILT_IN_ISFINITE
),
924 res
= gfc_create_var (integer_type_node
, NULL
);
925 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
926 gfc_build_addr_expr (NULL_TREE
, res
));
927 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
929 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
932 type
= gfc_typenode_for_spec (&expr
->ts
);
933 se
->expr
= fold_convert (type
, se
->expr
);
937 /* Fill in the following structure
938 struct caf_vector_t {
939 size_t nvec; // size of the vector
946 ptrdiff_t lower_bound;
947 ptrdiff_t upper_bound;
954 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
955 tree lower
, tree upper
, tree stride
,
956 tree vector
, int kind
, tree nvec
)
958 tree field
, type
, tmp
;
960 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
961 type
= TREE_TYPE (desc
);
963 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
964 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
965 desc
, field
, NULL_TREE
);
966 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
969 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
970 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
971 desc
, field
, NULL_TREE
);
972 type
= TREE_TYPE (desc
);
974 /* Access the inner struct. */
975 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
976 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
977 desc
, field
, NULL_TREE
);
978 type
= TREE_TYPE (desc
);
980 if (vector
!= NULL_TREE
)
982 /* Set vector and kind. */
983 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
984 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
985 desc
, field
, NULL_TREE
);
986 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
987 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
988 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
989 desc
, field
, NULL_TREE
);
990 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
994 /* Set dim.lower/upper/stride. */
995 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
996 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
997 desc
, field
, NULL_TREE
);
998 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1000 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1001 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1002 desc
, field
, NULL_TREE
);
1003 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1005 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1006 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1007 desc
, field
, NULL_TREE
);
1008 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1014 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1017 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1018 tree lbound
, ubound
, tmp
;
1021 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1023 for (i
= 0; i
< ar
->dimen
; i
++)
1024 switch (ar
->dimen_type
[i
])
1029 gfc_init_se (&argse
, NULL
);
1030 gfc_conv_expr (&argse
, ar
->end
[i
]);
1031 gfc_add_block_to_block (block
, &argse
.pre
);
1032 upper
= gfc_evaluate_now (argse
.expr
, block
);
1035 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1038 gfc_init_se (&argse
, NULL
);
1039 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1040 gfc_add_block_to_block (block
, &argse
.pre
);
1041 stride
= gfc_evaluate_now (argse
.expr
, block
);
1044 stride
= gfc_index_one_node
;
1050 gfc_init_se (&argse
, NULL
);
1051 gfc_conv_expr (&argse
, ar
->start
[i
]);
1052 gfc_add_block_to_block (block
, &argse
.pre
);
1053 lower
= gfc_evaluate_now (argse
.expr
, block
);
1056 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1057 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1060 stride
= gfc_index_one_node
;
1063 nvec
= size_zero_node
;
1064 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1069 gfc_init_se (&argse
, NULL
);
1070 argse
.descriptor_only
= 1;
1071 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1072 gfc_add_block_to_block (block
, &argse
.pre
);
1073 vector
= argse
.expr
;
1074 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1075 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1076 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1077 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1078 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1079 TREE_TYPE (nvec
), nvec
, tmp
);
1080 lower
= gfc_index_zero_node
;
1081 upper
= gfc_index_zero_node
;
1082 stride
= gfc_index_zero_node
;
1083 vector
= gfc_conv_descriptor_data_get (vector
);
1084 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1085 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1090 return gfc_build_addr_expr (NULL_TREE
, var
);
1095 compute_component_offset (tree field
, tree type
)
1098 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1099 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1101 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1102 DECL_FIELD_BIT_OFFSET (field
),
1104 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1107 return DECL_FIELD_OFFSET (field
);
1112 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1114 gfc_ref
*ref
= expr
->ref
, *last_comp_ref
;
1115 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1116 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1117 start
, end
, stride
, vector
, nvec
;
1119 bool ref_static_array
= false;
1120 tree last_component_ref_tree
= NULL_TREE
;
1125 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1126 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
;
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_CAF_COARRAY_NOCOARRAY
);
1679 gfc_add_expr_to_block (&se
->post
, tmp
);
1684 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1685 if (lhs_kind
== NULL_TREE
)
1688 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1689 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1690 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1691 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1693 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1696 /* No overlap possible as we have generated a temporary. */
1697 if (lhs
== NULL_TREE
)
1698 may_require_tmp
= boolean_false_node
;
1700 /* It guarantees memory consistency within the same segment. */
1701 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1702 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1703 gfc_build_string_const (1, ""), NULL_TREE
,
1704 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1706 ASM_VOLATILE_P (tmp
) = 1;
1707 gfc_add_expr_to_block (&se
->pre
, tmp
);
1709 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1710 9, token
, image_index
, dst_var
,
1711 caf_reference
, lhs_kind
, kind
,
1713 may_realloc
? boolean_true_node
:
1717 gfc_add_expr_to_block (&se
->pre
, tmp
);
1720 gfc_advance_se_ss_chain (se
);
1723 if (array_expr
->ts
.type
== BT_CHARACTER
)
1724 se
->string_length
= argse
.string_length
;
1730 gfc_init_se (&argse
, NULL
);
1731 if (array_expr
->rank
== 0)
1733 symbol_attribute attr
;
1735 gfc_clear_attr (&attr
);
1736 gfc_conv_expr (&argse
, array_expr
);
1738 if (lhs
== NULL_TREE
)
1740 gfc_clear_attr (&attr
);
1741 if (array_expr
->ts
.type
== BT_CHARACTER
)
1742 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1743 argse
.string_length
);
1745 res_var
= gfc_create_var (type
, "caf_res");
1746 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1747 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1749 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1750 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1754 /* If has_vector, pass descriptor for whole array and the
1755 vector bounds separately. */
1756 gfc_array_ref
*ar
, ar2
;
1757 bool has_vector
= false;
1759 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1762 ar
= gfc_find_array_ref (expr
);
1764 memset (ar
, '\0', sizeof (*ar
));
1768 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1769 gfc_conv_expr_descriptor (&argse
, array_expr
);
1770 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1771 has the wrong type if component references are done. */
1772 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1773 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1778 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1782 if (lhs
== NULL_TREE
)
1784 /* Create temporary. */
1785 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1786 if (se
->loop
->to
[n
] == NULL_TREE
)
1788 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1790 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1793 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1794 NULL_TREE
, false, true, false,
1795 &array_expr
->where
);
1796 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1797 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1799 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1802 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1803 if (lhs_kind
== NULL_TREE
)
1806 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1807 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1809 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1810 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1811 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1812 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1813 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1816 /* No overlap possible as we have generated a temporary. */
1817 if (lhs
== NULL_TREE
)
1818 may_require_tmp
= boolean_false_node
;
1820 /* It guarantees memory consistency within the same segment. */
1821 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1822 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1823 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1824 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1825 ASM_VOLATILE_P (tmp
) = 1;
1826 gfc_add_expr_to_block (&se
->pre
, tmp
);
1828 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1829 token
, offset
, image_index
, argse
.expr
, vec
,
1830 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1832 gfc_add_expr_to_block (&se
->pre
, tmp
);
1835 gfc_advance_se_ss_chain (se
);
1838 if (array_expr
->ts
.type
== BT_CHARACTER
)
1839 se
->string_length
= argse
.string_length
;
1843 /* Send data to a remote coarray. */
1846 conv_caf_send (gfc_code
*code
) {
1847 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
;
1848 gfc_se lhs_se
, rhs_se
;
1850 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1851 tree may_require_tmp
, src_stat
, dst_stat
;
1852 tree lhs_type
= NULL_TREE
;
1853 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1854 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1856 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1858 lhs_expr
= code
->ext
.actual
->expr
;
1859 rhs_expr
= code
->ext
.actual
->next
->expr
;
1860 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1861 ? boolean_false_node
: boolean_true_node
;
1862 gfc_init_block (&block
);
1864 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1865 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1866 src_stat
= dst_stat
= null_pointer_node
;
1869 gfc_init_se (&lhs_se
, NULL
);
1870 if (lhs_expr
->rank
== 0)
1872 symbol_attribute attr
;
1873 gfc_clear_attr (&attr
);
1874 gfc_conv_expr (&lhs_se
, lhs_expr
);
1875 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1876 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1877 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1879 else if (lhs_caf_attr
.alloc_comp
&& lhs_caf_attr
.codimension
)
1881 lhs_se
.want_pointer
= 1;
1882 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1883 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1884 has the wrong type if component references are done. */
1885 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1886 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1887 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1888 gfc_get_dtype_rank_type (
1889 gfc_has_vector_subscript (lhs_expr
)
1890 ? gfc_find_array_ref (lhs_expr
)->dimen
1896 /* If has_vector, pass descriptor for whole array and the
1897 vector bounds separately. */
1898 gfc_array_ref
*ar
, ar2
;
1899 bool has_vector
= false;
1901 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1904 ar
= gfc_find_array_ref (lhs_expr
);
1906 memset (ar
, '\0', sizeof (*ar
));
1910 lhs_se
.want_pointer
= 1;
1911 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1912 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1913 has the wrong type if component references are done. */
1914 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1915 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1916 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1917 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1922 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1927 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1929 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1930 temporary and a loop. */
1931 if (!gfc_is_coindexed (lhs_expr
)
1932 && (!lhs_caf_attr
.codimension
1933 || !(lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
)))
1935 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
1936 gcc_assert (gfc_is_coindexed (rhs_expr
));
1937 gfc_init_se (&rhs_se
, NULL
);
1938 if (lhs_expr
->rank
== 0 && gfc_expr_attr (lhs_expr
).allocatable
)
1941 gfc_init_se (&scal_se
, NULL
);
1942 scal_se
.want_pointer
= 1;
1943 gfc_conv_expr (&scal_se
, lhs_expr
);
1944 /* Ensure scalar on lhs is allocated. */
1945 gfc_add_block_to_block (&block
, &scal_se
.pre
);
1947 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
1949 gfc_typenode_for_spec (&lhs_expr
->ts
)),
1951 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, scal_se
.expr
,
1953 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1954 tmp
, gfc_finish_block (&scal_se
.pre
),
1955 build_empty_stmt (input_location
));
1956 gfc_add_expr_to_block (&block
, tmp
);
1959 lhs_may_realloc
= lhs_may_realloc
1960 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
1961 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1962 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1963 may_require_tmp
, lhs_may_realloc
,
1965 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1966 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1967 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1968 return gfc_finish_block (&block
);
1971 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1973 /* Obtain token, offset and image index for the LHS. */
1974 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1975 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1976 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1977 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1979 if (lhs_caf_attr
.alloc_comp
)
1980 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
1983 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
1988 gfc_init_se (&rhs_se
, NULL
);
1989 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1990 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1991 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1992 if (rhs_expr
->rank
== 0)
1994 symbol_attribute attr
;
1995 gfc_clear_attr (&attr
);
1996 gfc_conv_expr (&rhs_se
, rhs_expr
);
1997 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
1998 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2000 else if (rhs_caf_attr
.alloc_comp
&& rhs_caf_attr
.codimension
)
2003 rhs_se
.want_pointer
= 1;
2004 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2005 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2006 has the wrong type if component references are done. */
2007 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2008 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2009 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2010 gfc_get_dtype_rank_type (
2011 gfc_has_vector_subscript (rhs_expr
)
2012 ? gfc_find_array_ref (rhs_expr
)->dimen
2018 /* If has_vector, pass descriptor for whole array and the
2019 vector bounds separately. */
2020 gfc_array_ref
*ar
, ar2
;
2021 bool has_vector
= false;
2024 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2027 ar
= gfc_find_array_ref (rhs_expr
);
2029 memset (ar
, '\0', sizeof (*ar
));
2033 rhs_se
.want_pointer
= 1;
2034 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2035 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2036 has the wrong type if component references are done. */
2037 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2038 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2039 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2040 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2045 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2050 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2052 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2054 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2059 gfc_init_se (&stat_se
, NULL
);
2060 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2061 dst_stat
= stat_se
.expr
;
2062 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2063 gfc_add_block_to_block (&block
, &stat_se
.post
);
2066 if (!gfc_is_coindexed (rhs_expr
))
2068 if (lhs_caf_attr
.alloc_comp
)
2070 tree reference
, dst_realloc
;
2071 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2072 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2073 : boolean_false_node
;
2074 tmp
= build_call_expr_loc (input_location
,
2075 gfor_fndecl_caf_send_by_ref
,
2076 9, token
, image_index
, rhs_se
.expr
,
2077 reference
, lhs_kind
, rhs_kind
,
2078 may_require_tmp
, dst_realloc
, src_stat
);
2081 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 10,
2082 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2083 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2084 may_require_tmp
, src_stat
);
2088 tree rhs_token
, rhs_offset
, rhs_image_index
;
2090 /* It guarantees memory consistency within the same segment. */
2091 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2092 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2093 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2094 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2095 ASM_VOLATILE_P (tmp
) = 1;
2096 gfc_add_expr_to_block (&block
, tmp
);
2098 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2099 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2100 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2101 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2103 if (rhs_caf_attr
.alloc_comp
)
2105 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2110 gfc_init_se (&stat_se
, NULL
);
2111 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2112 src_stat
= stat_se
.expr
;
2113 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2114 gfc_add_block_to_block (&block
, &stat_se
.post
);
2117 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2119 tree lhs_reference
, rhs_reference
;
2120 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2121 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2122 tmp
= build_call_expr_loc (input_location
,
2123 gfor_fndecl_caf_sendget_by_ref
, 11,
2124 token
, image_index
, lhs_reference
,
2125 rhs_token
, rhs_image_index
, rhs_reference
,
2126 lhs_kind
, rhs_kind
, may_require_tmp
,
2127 dst_stat
, src_stat
);
2131 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2133 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2134 14, token
, offset
, image_index
,
2135 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2136 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2137 rhs_kind
, may_require_tmp
, src_stat
);
2140 gfc_add_expr_to_block (&block
, tmp
);
2141 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2142 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2144 /* It guarantees memory consistency within the same segment. */
2145 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2146 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2147 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2148 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2149 ASM_VOLATILE_P (tmp
) = 1;
2150 gfc_add_expr_to_block (&block
, tmp
);
2152 return gfc_finish_block (&block
);
2157 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2160 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2161 lbound
, ubound
, extent
, ml
;
2164 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2166 if (expr
->value
.function
.actual
->expr
2167 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2168 distance
= expr
->value
.function
.actual
->expr
;
2170 /* The case -fcoarray=single is handled elsewhere. */
2171 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2173 /* Argument-free version: THIS_IMAGE(). */
2174 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2178 gfc_init_se (&argse
, NULL
);
2179 gfc_conv_expr_val (&argse
, distance
);
2180 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2181 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2182 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2185 tmp
= integer_zero_node
;
2186 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2188 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2193 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2195 type
= gfc_get_int_type (gfc_default_integer_kind
);
2196 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2197 rank
= expr
->value
.function
.actual
->expr
->rank
;
2199 /* Obtain the descriptor of the COARRAY. */
2200 gfc_init_se (&argse
, NULL
);
2201 argse
.want_coarray
= 1;
2202 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2203 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2204 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2209 /* Create an implicit second parameter from the loop variable. */
2210 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2211 gcc_assert (corank
> 0);
2212 gcc_assert (se
->loop
->dimen
== 1);
2213 gcc_assert (se
->ss
->info
->expr
== expr
);
2215 dim_arg
= se
->loop
->loopvar
[0];
2216 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2217 gfc_array_index_type
, dim_arg
,
2218 build_int_cst (TREE_TYPE (dim_arg
), 1));
2219 gfc_advance_se_ss_chain (se
);
2223 /* Use the passed DIM= argument. */
2224 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2225 gfc_init_se (&argse
, NULL
);
2226 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2227 gfc_array_index_type
);
2228 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2229 dim_arg
= argse
.expr
;
2231 if (INTEGER_CST_P (dim_arg
))
2233 if (wi::ltu_p (dim_arg
, 1)
2234 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2235 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2236 "dimension index", expr
->value
.function
.isym
->name
,
2239 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2241 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2242 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2244 build_int_cst (TREE_TYPE (dim_arg
), 1));
2245 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2246 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2248 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2249 boolean_type_node
, cond
, tmp
);
2250 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2255 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2256 one always has a dim_arg argument.
2258 m = this_image() - 1
2261 sub(1) = m + lcobound(corank)
2265 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2268 extent = gfc_extent(i)
2276 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2277 : m + lcobound(corank)
2280 /* this_image () - 1. */
2281 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2283 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2284 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2287 /* sub(1) = m + lcobound(corank). */
2288 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2289 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2291 lbound
= fold_convert (type
, lbound
);
2292 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2298 m
= gfc_create_var (type
, NULL
);
2299 ml
= gfc_create_var (type
, NULL
);
2300 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2301 min_var
= gfc_create_var (integer_type_node
, NULL
);
2303 /* m = this_image () - 1. */
2304 gfc_add_modify (&se
->pre
, m
, tmp
);
2306 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2307 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2308 fold_convert (integer_type_node
, dim_arg
),
2309 build_int_cst (integer_type_node
, rank
- 1));
2310 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2311 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2313 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2316 tmp
= build_int_cst (integer_type_node
, rank
);
2317 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2319 exit_label
= gfc_build_label_decl (NULL_TREE
);
2320 TREE_USED (exit_label
) = 1;
2323 gfc_init_block (&loop
);
2326 gfc_add_modify (&loop
, ml
, m
);
2329 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2330 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2331 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2332 extent
= fold_convert (type
, extent
);
2335 gfc_add_modify (&loop
, m
,
2336 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2339 /* Exit condition: if (i >= min_var) goto exit_label. */
2340 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
2342 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2343 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2344 build_empty_stmt (input_location
));
2345 gfc_add_expr_to_block (&loop
, tmp
);
2347 /* Increment loop variable: i++. */
2348 gfc_add_modify (&loop
, loop_var
,
2349 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2351 build_int_cst (integer_type_node
, 1)));
2353 /* Making the loop... actually loop! */
2354 tmp
= gfc_finish_block (&loop
);
2355 tmp
= build1_v (LOOP_EXPR
, tmp
);
2356 gfc_add_expr_to_block (&se
->pre
, tmp
);
2358 /* The exit label. */
2359 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2360 gfc_add_expr_to_block (&se
->pre
, tmp
);
2362 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2363 : m + lcobound(corank) */
2365 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
2366 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2368 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2369 fold_build2_loc (input_location
, PLUS_EXPR
,
2370 gfc_array_index_type
, dim_arg
,
2371 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2372 lbound
= fold_convert (type
, lbound
);
2374 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2375 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2377 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2379 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2380 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2386 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2388 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2390 gfc_se argse
, subse
;
2391 int rank
, corank
, codim
;
2393 type
= gfc_get_int_type (gfc_default_integer_kind
);
2394 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2395 rank
= expr
->value
.function
.actual
->expr
->rank
;
2397 /* Obtain the descriptor of the COARRAY. */
2398 gfc_init_se (&argse
, NULL
);
2399 argse
.want_coarray
= 1;
2400 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2401 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2402 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2405 /* Obtain a handle to the SUB argument. */
2406 gfc_init_se (&subse
, NULL
);
2407 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2408 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2409 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2410 subdesc
= build_fold_indirect_ref_loc (input_location
,
2411 gfc_conv_descriptor_data_get (subse
.expr
));
2413 /* Fortran 2008 does not require that the values remain in the cobounds,
2414 thus we need explicitly check this - and return 0 if they are exceeded. */
2416 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2417 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2418 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2419 fold_convert (gfc_array_index_type
, tmp
),
2422 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2424 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2425 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2426 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2427 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2428 fold_convert (gfc_array_index_type
, tmp
),
2430 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2431 boolean_type_node
, invalid_bound
, cond
);
2432 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2433 fold_convert (gfc_array_index_type
, tmp
),
2435 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2436 boolean_type_node
, invalid_bound
, cond
);
2439 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2441 /* See Fortran 2008, C.10 for the following algorithm. */
2443 /* coindex = sub(corank) - lcobound(n). */
2444 coindex
= fold_convert (gfc_array_index_type
,
2445 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2447 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2448 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2449 fold_convert (gfc_array_index_type
, coindex
),
2452 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2454 tree extent
, ubound
;
2456 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2457 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2458 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2459 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2461 /* coindex *= extent. */
2462 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2463 gfc_array_index_type
, coindex
, extent
);
2465 /* coindex += sub(codim). */
2466 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2467 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2468 gfc_array_index_type
, coindex
,
2469 fold_convert (gfc_array_index_type
, tmp
));
2471 /* coindex -= lbound(codim). */
2472 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2473 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2474 gfc_array_index_type
, coindex
, lbound
);
2477 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2478 fold_convert(type
, coindex
),
2479 build_int_cst (type
, 1));
2481 /* Return 0 if "coindex" exceeds num_images(). */
2483 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2484 num_images
= build_int_cst (type
, 1);
2487 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2489 build_int_cst (integer_type_node
, -1));
2490 num_images
= fold_convert (type
, tmp
);
2493 tmp
= gfc_create_var (type
, NULL
);
2494 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2496 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
2498 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
2500 fold_convert (boolean_type_node
, invalid_bound
));
2501 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2502 build_int_cst (type
, 0), tmp
);
2507 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2509 tree tmp
, distance
, failed
;
2512 if (expr
->value
.function
.actual
->expr
)
2514 gfc_init_se (&argse
, NULL
);
2515 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2516 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2517 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2518 distance
= fold_convert (integer_type_node
, argse
.expr
);
2521 distance
= integer_zero_node
;
2523 if (expr
->value
.function
.actual
->next
->expr
)
2525 gfc_init_se (&argse
, NULL
);
2526 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2527 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2528 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2529 failed
= fold_convert (integer_type_node
, argse
.expr
);
2532 failed
= build_int_cst (integer_type_node
, -1);
2534 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2536 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2541 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2545 gfc_init_se (&argse
, NULL
);
2546 argse
.data_not_needed
= 1;
2547 argse
.descriptor_only
= 1;
2549 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2550 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2551 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2553 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2557 /* Evaluate a single upper or lower bound. */
2558 /* TODO: bound intrinsic generates way too much unnecessary code. */
2561 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2563 gfc_actual_arglist
*arg
;
2564 gfc_actual_arglist
*arg2
;
2569 tree cond
, cond1
, cond3
, cond4
, size
;
2573 gfc_array_spec
* as
;
2574 bool assumed_rank_lb_one
;
2576 arg
= expr
->value
.function
.actual
;
2581 /* Create an implicit second parameter from the loop variable. */
2582 gcc_assert (!arg2
->expr
);
2583 gcc_assert (se
->loop
->dimen
== 1);
2584 gcc_assert (se
->ss
->info
->expr
== expr
);
2585 gfc_advance_se_ss_chain (se
);
2586 bound
= se
->loop
->loopvar
[0];
2587 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2588 gfc_array_index_type
, bound
,
2593 /* use the passed argument. */
2594 gcc_assert (arg2
->expr
);
2595 gfc_init_se (&argse
, NULL
);
2596 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2597 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2599 /* Convert from one based to zero based. */
2600 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2601 gfc_array_index_type
, bound
,
2602 gfc_index_one_node
);
2605 /* TODO: don't re-evaluate the descriptor on each iteration. */
2606 /* Get a descriptor for the first parameter. */
2607 gfc_init_se (&argse
, NULL
);
2608 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2609 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2610 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2614 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2616 if (INTEGER_CST_P (bound
))
2618 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2619 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2620 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
2621 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2622 "dimension index", upper
? "UBOUND" : "LBOUND",
2626 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
2628 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2630 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2631 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2632 bound
, build_int_cst (TREE_TYPE (bound
), 0));
2633 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2634 tmp
= gfc_conv_descriptor_rank (desc
);
2636 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
2637 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2638 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
2639 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2640 boolean_type_node
, cond
, tmp
);
2641 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2646 /* Take care of the lbound shift for assumed-rank arrays, which are
2647 nonallocatable and nonpointers. Those has a lbound of 1. */
2648 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
2649 && ((arg
->expr
->ts
.type
!= BT_CLASS
2650 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
2651 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
2652 || (arg
->expr
->ts
.type
== BT_CLASS
2653 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
2654 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
2656 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2657 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2659 /* 13.14.53: Result value for LBOUND
2661 Case (i): For an array section or for an array expression other than a
2662 whole array or array structure component, LBOUND(ARRAY, DIM)
2663 has the value 1. For a whole array or array structure
2664 component, LBOUND(ARRAY, DIM) has the value:
2665 (a) equal to the lower bound for subscript DIM of ARRAY if
2666 dimension DIM of ARRAY does not have extent zero
2667 or if ARRAY is an assumed-size array of rank DIM,
2670 13.14.113: Result value for UBOUND
2672 Case (i): For an array section or for an array expression other than a
2673 whole array or array structure component, UBOUND(ARRAY, DIM)
2674 has the value equal to the number of elements in the given
2675 dimension; otherwise, it has a value equal to the upper bound
2676 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2677 not have size zero and has value zero if dimension DIM has
2680 if (!upper
&& assumed_rank_lb_one
)
2681 se
->expr
= gfc_index_one_node
;
2684 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
2686 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2688 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2689 stride
, gfc_index_zero_node
);
2690 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2691 boolean_type_node
, cond3
, cond1
);
2692 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2693 stride
, gfc_index_zero_node
);
2698 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2699 boolean_type_node
, cond3
, cond4
);
2700 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2701 gfc_index_one_node
, lbound
);
2702 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2703 boolean_type_node
, cond4
, cond5
);
2705 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2706 boolean_type_node
, cond
, cond5
);
2708 if (assumed_rank_lb_one
)
2710 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2711 gfc_array_index_type
, ubound
, lbound
);
2712 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2713 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2718 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2719 gfc_array_index_type
, cond
,
2720 tmp
, gfc_index_zero_node
);
2724 if (as
->type
== AS_ASSUMED_SIZE
)
2725 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2726 bound
, build_int_cst (TREE_TYPE (bound
),
2727 arg
->expr
->rank
- 1));
2729 cond
= boolean_false_node
;
2731 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2732 boolean_type_node
, cond3
, cond4
);
2733 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2734 boolean_type_node
, cond
, cond1
);
2736 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2737 gfc_array_index_type
, cond
,
2738 lbound
, gfc_index_one_node
);
2745 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2746 gfc_array_index_type
, ubound
, lbound
);
2747 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2748 gfc_array_index_type
, size
,
2749 gfc_index_one_node
);
2750 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2751 gfc_array_index_type
, se
->expr
,
2752 gfc_index_zero_node
);
2755 se
->expr
= gfc_index_one_node
;
2758 type
= gfc_typenode_for_spec (&expr
->ts
);
2759 se
->expr
= convert (type
, se
->expr
);
2764 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2766 gfc_actual_arglist
*arg
;
2767 gfc_actual_arglist
*arg2
;
2769 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2773 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2774 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2775 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2777 arg
= expr
->value
.function
.actual
;
2780 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2781 corank
= gfc_get_corank (arg
->expr
);
2783 gfc_init_se (&argse
, NULL
);
2784 argse
.want_coarray
= 1;
2786 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2787 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2788 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2793 /* Create an implicit second parameter from the loop variable. */
2794 gcc_assert (!arg2
->expr
);
2795 gcc_assert (corank
> 0);
2796 gcc_assert (se
->loop
->dimen
== 1);
2797 gcc_assert (se
->ss
->info
->expr
== expr
);
2799 bound
= se
->loop
->loopvar
[0];
2800 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2801 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2802 gfc_advance_se_ss_chain (se
);
2806 /* use the passed argument. */
2807 gcc_assert (arg2
->expr
);
2808 gfc_init_se (&argse
, NULL
);
2809 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2810 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2813 if (INTEGER_CST_P (bound
))
2815 if (wi::ltu_p (bound
, 1)
2816 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2817 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2818 "dimension index", expr
->value
.function
.isym
->name
,
2821 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2823 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2824 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2825 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2826 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2827 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2829 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2830 boolean_type_node
, cond
, tmp
);
2831 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2836 /* Subtract 1 to get to zero based and add dimensions. */
2837 switch (arg
->expr
->rank
)
2840 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2841 gfc_array_index_type
, bound
,
2842 gfc_index_one_node
);
2846 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2847 gfc_array_index_type
, bound
,
2848 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2852 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2854 /* Handle UCOBOUND with special handling of the last codimension. */
2855 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2857 /* Last codimension: For -fcoarray=single just return
2858 the lcobound - otherwise add
2859 ceiling (real (num_images ()) / real (size)) - 1
2860 = (num_images () + size - 1) / size - 1
2861 = (num_images - 1) / size(),
2862 where size is the product of the extent of all but the last
2865 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2869 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2870 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2871 2, integer_zero_node
,
2872 build_int_cst (integer_type_node
, -1));
2873 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2874 gfc_array_index_type
,
2875 fold_convert (gfc_array_index_type
, tmp
),
2876 build_int_cst (gfc_array_index_type
, 1));
2877 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2878 gfc_array_index_type
, tmp
,
2879 fold_convert (gfc_array_index_type
, cosize
));
2880 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2881 gfc_array_index_type
, resbound
, tmp
);
2883 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2885 /* ubound = lbound + num_images() - 1. */
2886 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2887 2, integer_zero_node
,
2888 build_int_cst (integer_type_node
, -1));
2889 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2890 gfc_array_index_type
,
2891 fold_convert (gfc_array_index_type
, tmp
),
2892 build_int_cst (gfc_array_index_type
, 1));
2893 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2894 gfc_array_index_type
, resbound
, tmp
);
2899 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2901 build_int_cst (TREE_TYPE (bound
),
2902 arg
->expr
->rank
+ corank
- 1));
2904 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2905 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2906 gfc_array_index_type
, cond
,
2907 resbound
, resbound2
);
2910 se
->expr
= resbound
;
2913 se
->expr
= resbound
;
2915 type
= gfc_typenode_for_spec (&expr
->ts
);
2916 se
->expr
= convert (type
, se
->expr
);
2921 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2923 gfc_actual_arglist
*array_arg
;
2924 gfc_actual_arglist
*dim_arg
;
2928 array_arg
= expr
->value
.function
.actual
;
2929 dim_arg
= array_arg
->next
;
2931 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2933 gfc_init_se (&argse
, NULL
);
2934 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2935 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2936 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2939 gcc_assert (dim_arg
->expr
);
2940 gfc_init_se (&argse
, NULL
);
2941 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2942 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2943 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2944 argse
.expr
, gfc_index_one_node
);
2945 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2950 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2954 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2956 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
2960 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
2965 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
2966 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
2975 /* Create a complex value from one or two real components. */
2978 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
2984 unsigned int num_args
;
2986 num_args
= gfc_intrinsic_argument_list_length (expr
);
2987 args
= XALLOCAVEC (tree
, num_args
);
2989 type
= gfc_typenode_for_spec (&expr
->ts
);
2990 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2991 real
= convert (TREE_TYPE (type
), args
[0]);
2993 imag
= convert (TREE_TYPE (type
), args
[1]);
2994 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
2996 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2997 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
2998 imag
= convert (TREE_TYPE (type
), imag
);
3001 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3003 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3007 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3008 MODULO(A, P) = A - FLOOR (A / P) * P
3010 The obvious algorithms above are numerically instable for large
3011 arguments, hence these intrinsics are instead implemented via calls
3012 to the fmod family of functions. It is the responsibility of the
3013 user to ensure that the second argument is non-zero. */
3016 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3026 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3028 switch (expr
->ts
.type
)
3031 /* Integer case is easy, we've got a builtin op. */
3032 type
= TREE_TYPE (args
[0]);
3035 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3038 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3044 /* Check if we have a builtin fmod. */
3045 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3047 /* The builtin should always be available. */
3048 gcc_assert (fmod
!= NULL_TREE
);
3050 tmp
= build_addr (fmod
);
3051 se
->expr
= build_call_array_loc (input_location
,
3052 TREE_TYPE (TREE_TYPE (fmod
)),
3057 type
= TREE_TYPE (args
[0]);
3059 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3060 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3063 modulo = arg - floor (arg/arg2) * arg2
3065 In order to calculate the result accurately, we use the fmod
3066 function as follows.
3068 res = fmod (arg, arg2);
3071 if ((arg < 0) xor (arg2 < 0))
3075 res = copysign (0., arg2);
3077 => As two nested ternary exprs:
3079 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3080 : copysign (0., arg2);
3084 zero
= gfc_build_const (type
, integer_zero_node
);
3085 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3086 if (!flag_signed_zeros
)
3088 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3090 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3092 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3093 boolean_type_node
, test
, test2
);
3094 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3096 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3097 boolean_type_node
, test
, test2
);
3098 test
= gfc_evaluate_now (test
, &se
->pre
);
3099 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3100 fold_build2_loc (input_location
,
3102 type
, tmp
, args
[1]),
3107 tree expr1
, copysign
, cscall
;
3108 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3110 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3112 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
3114 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3115 boolean_type_node
, test
, test2
);
3116 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3117 fold_build2_loc (input_location
,
3119 type
, tmp
, args
[1]),
3121 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3123 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3125 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3135 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3136 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3137 where the right shifts are logical (i.e. 0's are shifted in).
3138 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3139 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3141 DSHIFTL(I,J,BITSIZE) = J
3143 DSHIFTR(I,J,BITSIZE) = I. */
3146 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3148 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3149 tree args
[3], cond
, tmp
;
3152 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3154 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3155 type
= TREE_TYPE (args
[0]);
3156 bitsize
= TYPE_PRECISION (type
);
3157 utype
= unsigned_type_for (type
);
3158 stype
= TREE_TYPE (args
[2]);
3160 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3161 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3162 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3164 /* The generic case. */
3165 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3166 build_int_cst (stype
, bitsize
), shift
);
3167 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3168 arg1
, dshiftl
? shift
: tmp
);
3170 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3171 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3172 right
= fold_convert (type
, right
);
3174 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3176 /* Special cases. */
3177 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
3178 build_int_cst (stype
, 0));
3179 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3180 dshiftl
? arg1
: arg2
, res
);
3182 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
3183 build_int_cst (stype
, bitsize
));
3184 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3185 dshiftl
? arg2
: arg1
, res
);
3191 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3194 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3202 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3203 type
= TREE_TYPE (args
[0]);
3205 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3206 val
= gfc_evaluate_now (val
, &se
->pre
);
3208 zero
= gfc_build_const (type
, integer_zero_node
);
3209 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
3210 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3214 /* SIGN(A, B) is absolute value of A times sign of B.
3215 The real value versions use library functions to ensure the correct
3216 handling of negative zero. Integer case implemented as:
3217 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3221 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3227 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3228 if (expr
->ts
.type
== BT_REAL
)
3232 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3233 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3235 /* We explicitly have to ignore the minus sign. We do so by using
3236 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3238 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3241 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3242 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3244 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3245 TREE_TYPE (args
[0]), cond
,
3246 build_call_expr_loc (input_location
, abs
, 1,
3248 build_call_expr_loc (input_location
, tmp
, 2,
3252 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3257 /* Having excluded floating point types, we know we are now dealing
3258 with signed integer types. */
3259 type
= TREE_TYPE (args
[0]);
3261 /* Args[0] is used multiple times below. */
3262 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3264 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3265 the signs of A and B are the same, and of all ones if they differ. */
3266 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3267 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3268 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3269 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3271 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3272 is all ones (i.e. -1). */
3273 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3274 fold_build2_loc (input_location
, PLUS_EXPR
,
3275 type
, args
[0], tmp
), tmp
);
3279 /* Test for the presence of an optional argument. */
3282 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3286 arg
= expr
->value
.function
.actual
->expr
;
3287 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3288 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3289 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3293 /* Calculate the double precision product of two single precision values. */
3296 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3301 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3303 /* Convert the args to double precision before multiplying. */
3304 type
= gfc_typenode_for_spec (&expr
->ts
);
3305 args
[0] = convert (type
, args
[0]);
3306 args
[1] = convert (type
, args
[1]);
3307 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3312 /* Return a length one character string containing an ascii character. */
3315 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3320 unsigned int num_args
;
3322 num_args
= gfc_intrinsic_argument_list_length (expr
);
3323 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3325 type
= gfc_get_char_type (expr
->ts
.kind
);
3326 var
= gfc_create_var (type
, "char");
3328 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3329 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3330 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3331 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3336 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3344 unsigned int num_args
;
3346 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3347 args
= XALLOCAVEC (tree
, num_args
);
3349 var
= gfc_create_var (pchar_type_node
, "pstr");
3350 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3352 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3353 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3354 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3356 fndecl
= build_addr (gfor_fndecl_ctime
);
3357 tmp
= build_call_array_loc (input_location
,
3358 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3359 fndecl
, num_args
, args
);
3360 gfc_add_expr_to_block (&se
->pre
, tmp
);
3362 /* Free the temporary afterwards, if necessary. */
3363 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3364 len
, build_int_cst (TREE_TYPE (len
), 0));
3365 tmp
= gfc_call_free (var
);
3366 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3367 gfc_add_expr_to_block (&se
->post
, tmp
);
3370 se
->string_length
= len
;
3375 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3383 unsigned int num_args
;
3385 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3386 args
= XALLOCAVEC (tree
, num_args
);
3388 var
= gfc_create_var (pchar_type_node
, "pstr");
3389 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3391 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3392 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3393 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3395 fndecl
= build_addr (gfor_fndecl_fdate
);
3396 tmp
= build_call_array_loc (input_location
,
3397 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3398 fndecl
, num_args
, args
);
3399 gfc_add_expr_to_block (&se
->pre
, tmp
);
3401 /* Free the temporary afterwards, if necessary. */
3402 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3403 len
, build_int_cst (TREE_TYPE (len
), 0));
3404 tmp
= gfc_call_free (var
);
3405 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3406 gfc_add_expr_to_block (&se
->post
, tmp
);
3409 se
->string_length
= len
;
3413 /* Generate a direct call to free() for the FREE subroutine. */
3416 conv_intrinsic_free (gfc_code
*code
)
3422 gfc_init_se (&argse
, NULL
);
3423 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3424 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3426 gfc_init_block (&block
);
3427 call
= build_call_expr_loc (input_location
,
3428 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3429 gfc_add_expr_to_block (&block
, call
);
3430 return gfc_finish_block (&block
);
3434 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3438 conv_intrinsic_system_clock (gfc_code
*code
)
3441 gfc_se count_se
, count_rate_se
, count_max_se
;
3442 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3446 gfc_expr
*count
= code
->ext
.actual
->expr
;
3447 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3448 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3450 /* Evaluate our arguments. */
3453 gfc_init_se (&count_se
, NULL
);
3454 gfc_conv_expr (&count_se
, count
);
3459 gfc_init_se (&count_rate_se
, NULL
);
3460 gfc_conv_expr (&count_rate_se
, count_rate
);
3465 gfc_init_se (&count_max_se
, NULL
);
3466 gfc_conv_expr (&count_max_se
, count_max
);
3469 /* Find the smallest kind found of the arguments. */
3471 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3472 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3474 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3477 /* Prepare temporary variables. */
3482 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3483 else if (least
== 4)
3484 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3485 else if (count
->ts
.kind
== 1)
3486 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3489 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3496 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3497 else if (least
== 4)
3498 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3500 arg2
= integer_zero_node
;
3506 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3507 else if (least
== 4)
3508 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3510 arg3
= integer_zero_node
;
3513 /* Make the function call. */
3514 gfc_init_block (&block
);
3520 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3521 : null_pointer_node
;
3522 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3523 : null_pointer_node
;
3524 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3525 : null_pointer_node
;
3530 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3531 : null_pointer_node
;
3532 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3533 : null_pointer_node
;
3534 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3535 : null_pointer_node
;
3542 tmp
= build_call_expr_loc (input_location
,
3543 gfor_fndecl_system_clock4
, 3,
3544 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3545 : null_pointer_node
,
3546 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3547 : null_pointer_node
,
3548 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3549 : null_pointer_node
);
3550 gfc_add_expr_to_block (&block
, tmp
);
3552 /* Handle kind>=8, 10, or 16 arguments */
3555 tmp
= build_call_expr_loc (input_location
,
3556 gfor_fndecl_system_clock8
, 3,
3557 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3558 : null_pointer_node
,
3559 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3560 : null_pointer_node
,
3561 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3562 : null_pointer_node
);
3563 gfc_add_expr_to_block (&block
, tmp
);
3567 /* And store values back if needed. */
3568 if (arg1
&& arg1
!= count_se
.expr
)
3569 gfc_add_modify (&block
, count_se
.expr
,
3570 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
3571 if (arg2
&& arg2
!= count_rate_se
.expr
)
3572 gfc_add_modify (&block
, count_rate_se
.expr
,
3573 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
3574 if (arg3
&& arg3
!= count_max_se
.expr
)
3575 gfc_add_modify (&block
, count_max_se
.expr
,
3576 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
3578 return gfc_finish_block (&block
);
3582 /* Return a character string containing the tty name. */
3585 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
3593 unsigned int num_args
;
3595 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3596 args
= XALLOCAVEC (tree
, num_args
);
3598 var
= gfc_create_var (pchar_type_node
, "pstr");
3599 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3601 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3602 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3603 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3605 fndecl
= build_addr (gfor_fndecl_ttynam
);
3606 tmp
= build_call_array_loc (input_location
,
3607 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
3608 fndecl
, num_args
, args
);
3609 gfc_add_expr_to_block (&se
->pre
, tmp
);
3611 /* Free the temporary afterwards, if necessary. */
3612 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3613 len
, build_int_cst (TREE_TYPE (len
), 0));
3614 tmp
= gfc_call_free (var
);
3615 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3616 gfc_add_expr_to_block (&se
->post
, tmp
);
3619 se
->string_length
= len
;
3623 /* Get the minimum/maximum value of all the parameters.
3624 minmax (a1, a2, a3, ...)
3627 if (a2 .op. mvar || isnan (mvar))
3629 if (a3 .op. mvar || isnan (mvar))
3636 /* TODO: Mismatching types can occur when specific names are used.
3637 These should be handled during resolution. */
3639 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3647 gfc_actual_arglist
*argexpr
;
3648 unsigned int i
, nargs
;
3650 nargs
= gfc_intrinsic_argument_list_length (expr
);
3651 args
= XALLOCAVEC (tree
, nargs
);
3653 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
3654 type
= gfc_typenode_for_spec (&expr
->ts
);
3656 argexpr
= expr
->value
.function
.actual
;
3657 if (TREE_TYPE (args
[0]) != type
)
3658 args
[0] = convert (type
, args
[0]);
3659 /* Only evaluate the argument once. */
3660 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
3661 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3663 mvar
= gfc_create_var (type
, "M");
3664 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
3665 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
3671 /* Handle absent optional arguments by ignoring the comparison. */
3672 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
3673 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
3674 && TREE_CODE (val
) == INDIRECT_REF
)
3675 cond
= fold_build2_loc (input_location
,
3676 NE_EXPR
, boolean_type_node
,
3677 TREE_OPERAND (val
, 0),
3678 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
3683 /* Only evaluate the argument once. */
3684 if (!VAR_P (val
) && !TREE_CONSTANT (val
))
3685 val
= gfc_evaluate_now (val
, &se
->pre
);
3688 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
3690 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3691 convert (type
, val
), mvar
);
3693 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3694 __builtin_isnan might be made dependent on that module being loaded,
3695 to help performance of programs that don't rely on IEEE semantics. */
3696 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
3698 isnan
= build_call_expr_loc (input_location
,
3699 builtin_decl_explicit (BUILT_IN_ISNAN
),
3701 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3702 boolean_type_node
, tmp
,
3703 fold_convert (boolean_type_node
, isnan
));
3705 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
3706 build_empty_stmt (input_location
));
3708 if (cond
!= NULL_TREE
)
3709 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
3710 build_empty_stmt (input_location
));
3712 gfc_add_expr_to_block (&se
->pre
, tmp
);
3713 argexpr
= argexpr
->next
;
3719 /* Generate library calls for MIN and MAX intrinsics for character
3722 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
3725 tree var
, len
, fndecl
, tmp
, cond
, function
;
3728 nargs
= gfc_intrinsic_argument_list_length (expr
);
3729 args
= XALLOCAVEC (tree
, nargs
+ 4);
3730 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
3732 /* Create the result variables. */
3733 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3734 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3735 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3736 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3737 args
[2] = build_int_cst (integer_type_node
, op
);
3738 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3740 if (expr
->ts
.kind
== 1)
3741 function
= gfor_fndecl_string_minmax
;
3742 else if (expr
->ts
.kind
== 4)
3743 function
= gfor_fndecl_string_minmax_char4
;
3747 /* Make the function call. */
3748 fndecl
= build_addr (function
);
3749 tmp
= build_call_array_loc (input_location
,
3750 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3752 gfc_add_expr_to_block (&se
->pre
, tmp
);
3754 /* Free the temporary afterwards, if necessary. */
3755 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3756 len
, build_int_cst (TREE_TYPE (len
), 0));
3757 tmp
= gfc_call_free (var
);
3758 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3759 gfc_add_expr_to_block (&se
->post
, tmp
);
3762 se
->string_length
= len
;
3766 /* Create a symbol node for this intrinsic. The symbol from the frontend
3767 has the generic name. */
3770 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3774 /* TODO: Add symbols for intrinsic function to the global namespace. */
3775 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3776 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3779 sym
->attr
.external
= 1;
3780 sym
->attr
.function
= 1;
3781 sym
->attr
.always_explicit
= 1;
3782 sym
->attr
.proc
= PROC_INTRINSIC
;
3783 sym
->attr
.flavor
= FL_PROCEDURE
;
3787 sym
->attr
.dimension
= 1;
3788 sym
->as
= gfc_get_array_spec ();
3789 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3790 sym
->as
->rank
= expr
->rank
;
3793 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3794 ignore_optional
? expr
->value
.function
.actual
3800 /* Generate a call to an external intrinsic function. */
3802 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3805 vec
<tree
, va_gc
> *append_args
;
3807 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3810 gcc_assert (expr
->rank
> 0);
3812 gcc_assert (expr
->rank
== 0);
3814 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3816 /* Calls to libgfortran_matmul need to be appended special arguments,
3817 to be able to call the BLAS ?gemm functions if required and possible. */
3819 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3820 && sym
->ts
.type
!= BT_LOGICAL
)
3822 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3824 if (flag_external_blas
3825 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3826 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3830 if (sym
->ts
.type
== BT_REAL
)
3832 if (sym
->ts
.kind
== 4)
3833 gemm_fndecl
= gfor_fndecl_sgemm
;
3835 gemm_fndecl
= gfor_fndecl_dgemm
;
3839 if (sym
->ts
.kind
== 4)
3840 gemm_fndecl
= gfor_fndecl_cgemm
;
3842 gemm_fndecl
= gfor_fndecl_zgemm
;
3845 vec_alloc (append_args
, 3);
3846 append_args
->quick_push (build_int_cst (cint
, 1));
3847 append_args
->quick_push (build_int_cst (cint
,
3848 flag_blas_matmul_limit
));
3849 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3854 vec_alloc (append_args
, 3);
3855 append_args
->quick_push (build_int_cst (cint
, 0));
3856 append_args
->quick_push (build_int_cst (cint
, 0));
3857 append_args
->quick_push (null_pointer_node
);
3861 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3863 gfc_free_symbol (sym
);
3866 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3886 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3895 gfc_actual_arglist
*actual
;
3902 gfc_conv_intrinsic_funcall (se
, expr
);
3906 actual
= expr
->value
.function
.actual
;
3907 type
= gfc_typenode_for_spec (&expr
->ts
);
3908 /* Initialize the result. */
3909 resvar
= gfc_create_var (type
, "test");
3911 tmp
= convert (type
, boolean_true_node
);
3913 tmp
= convert (type
, boolean_false_node
);
3914 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3916 /* Walk the arguments. */
3917 arrayss
= gfc_walk_expr (actual
->expr
);
3918 gcc_assert (arrayss
!= gfc_ss_terminator
);
3920 /* Initialize the scalarizer. */
3921 gfc_init_loopinfo (&loop
);
3922 exit_label
= gfc_build_label_decl (NULL_TREE
);
3923 TREE_USED (exit_label
) = 1;
3924 gfc_add_ss_to_loop (&loop
, arrayss
);
3926 /* Initialize the loop. */
3927 gfc_conv_ss_startstride (&loop
);
3928 gfc_conv_loop_setup (&loop
, &expr
->where
);
3930 gfc_mark_ss_chain_used (arrayss
, 1);
3931 /* Generate the loop body. */
3932 gfc_start_scalarized_body (&loop
, &body
);
3934 /* If the condition matches then set the return value. */
3935 gfc_start_block (&block
);
3937 tmp
= convert (type
, boolean_false_node
);
3939 tmp
= convert (type
, boolean_true_node
);
3940 gfc_add_modify (&block
, resvar
, tmp
);
3942 /* And break out of the loop. */
3943 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3944 gfc_add_expr_to_block (&block
, tmp
);
3946 found
= gfc_finish_block (&block
);
3948 /* Check this element. */
3949 gfc_init_se (&arrayse
, NULL
);
3950 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3951 arrayse
.ss
= arrayss
;
3952 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3954 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3955 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3956 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3957 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3958 gfc_add_expr_to_block (&body
, tmp
);
3959 gfc_add_block_to_block (&body
, &arrayse
.post
);
3961 gfc_trans_scalarizing_loops (&loop
, &body
);
3963 /* Add the exit label. */
3964 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3965 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3967 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3968 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3969 gfc_cleanup_loop (&loop
);
3974 /* COUNT(A) = Number of true elements in A. */
3976 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
3983 gfc_actual_arglist
*actual
;
3989 gfc_conv_intrinsic_funcall (se
, expr
);
3993 actual
= expr
->value
.function
.actual
;
3995 type
= gfc_typenode_for_spec (&expr
->ts
);
3996 /* Initialize the result. */
3997 resvar
= gfc_create_var (type
, "count");
3998 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4000 /* Walk the arguments. */
4001 arrayss
= gfc_walk_expr (actual
->expr
);
4002 gcc_assert (arrayss
!= gfc_ss_terminator
);
4004 /* Initialize the scalarizer. */
4005 gfc_init_loopinfo (&loop
);
4006 gfc_add_ss_to_loop (&loop
, arrayss
);
4008 /* Initialize the loop. */
4009 gfc_conv_ss_startstride (&loop
);
4010 gfc_conv_loop_setup (&loop
, &expr
->where
);
4012 gfc_mark_ss_chain_used (arrayss
, 1);
4013 /* Generate the loop body. */
4014 gfc_start_scalarized_body (&loop
, &body
);
4016 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4017 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4018 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4020 gfc_init_se (&arrayse
, NULL
);
4021 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4022 arrayse
.ss
= arrayss
;
4023 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4024 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4025 build_empty_stmt (input_location
));
4027 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4028 gfc_add_expr_to_block (&body
, tmp
);
4029 gfc_add_block_to_block (&body
, &arrayse
.post
);
4031 gfc_trans_scalarizing_loops (&loop
, &body
);
4033 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4034 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4035 gfc_cleanup_loop (&loop
);
4041 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4042 struct and return the corresponding loopinfo. */
4044 static gfc_loopinfo
*
4045 enter_nested_loop (gfc_se
*se
)
4047 se
->ss
= se
->ss
->nested_ss
;
4048 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4050 return se
->ss
->loop
;
4054 /* Inline implementation of the sum and product intrinsics. */
4056 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4060 tree scale
= NULL_TREE
;
4065 gfc_loopinfo loop
, *ploop
;
4066 gfc_actual_arglist
*arg_array
, *arg_mask
;
4067 gfc_ss
*arrayss
= NULL
;
4068 gfc_ss
*maskss
= NULL
;
4072 gfc_expr
*arrayexpr
;
4077 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4083 type
= gfc_typenode_for_spec (&expr
->ts
);
4084 /* Initialize the result. */
4085 resvar
= gfc_create_var (type
, "val");
4090 scale
= gfc_create_var (type
, "scale");
4091 gfc_add_modify (&se
->pre
, scale
,
4092 gfc_build_const (type
, integer_one_node
));
4093 tmp
= gfc_build_const (type
, integer_zero_node
);
4095 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4096 tmp
= gfc_build_const (type
, integer_zero_node
);
4097 else if (op
== NE_EXPR
)
4099 tmp
= convert (type
, boolean_false_node
);
4100 else if (op
== BIT_AND_EXPR
)
4101 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4102 type
, integer_one_node
));
4104 tmp
= gfc_build_const (type
, integer_one_node
);
4106 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4108 arg_array
= expr
->value
.function
.actual
;
4110 arrayexpr
= arg_array
->expr
;
4112 if (op
== NE_EXPR
|| norm2
)
4113 /* PARITY and NORM2. */
4117 arg_mask
= arg_array
->next
->next
;
4118 gcc_assert (arg_mask
!= NULL
);
4119 maskexpr
= arg_mask
->expr
;
4122 if (expr
->rank
== 0)
4124 /* Walk the arguments. */
4125 arrayss
= gfc_walk_expr (arrayexpr
);
4126 gcc_assert (arrayss
!= gfc_ss_terminator
);
4128 if (maskexpr
&& maskexpr
->rank
> 0)
4130 maskss
= gfc_walk_expr (maskexpr
);
4131 gcc_assert (maskss
!= gfc_ss_terminator
);
4136 /* Initialize the scalarizer. */
4137 gfc_init_loopinfo (&loop
);
4138 gfc_add_ss_to_loop (&loop
, arrayss
);
4139 if (maskexpr
&& maskexpr
->rank
> 0)
4140 gfc_add_ss_to_loop (&loop
, maskss
);
4142 /* Initialize the loop. */
4143 gfc_conv_ss_startstride (&loop
);
4144 gfc_conv_loop_setup (&loop
, &expr
->where
);
4146 gfc_mark_ss_chain_used (arrayss
, 1);
4147 if (maskexpr
&& maskexpr
->rank
> 0)
4148 gfc_mark_ss_chain_used (maskss
, 1);
4153 /* All the work has been done in the parent loops. */
4154 ploop
= enter_nested_loop (se
);
4158 /* Generate the loop body. */
4159 gfc_start_scalarized_body (ploop
, &body
);
4161 /* If we have a mask, only add this element if the mask is set. */
4162 if (maskexpr
&& maskexpr
->rank
> 0)
4164 gfc_init_se (&maskse
, parent_se
);
4165 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4166 if (expr
->rank
== 0)
4168 gfc_conv_expr_val (&maskse
, maskexpr
);
4169 gfc_add_block_to_block (&body
, &maskse
.pre
);
4171 gfc_start_block (&block
);
4174 gfc_init_block (&block
);
4176 /* Do the actual summation/product. */
4177 gfc_init_se (&arrayse
, parent_se
);
4178 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4179 if (expr
->rank
== 0)
4180 arrayse
.ss
= arrayss
;
4181 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4182 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4186 /* if (x (i) != 0.0)
4192 result = 1.0 + result * val * val;
4198 result += val * val;
4201 tree res1
, res2
, cond
, absX
, val
;
4202 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4204 gfc_init_block (&ifblock1
);
4206 absX
= gfc_create_var (type
, "absX");
4207 gfc_add_modify (&ifblock1
, absX
,
4208 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4210 val
= gfc_create_var (type
, "val");
4211 gfc_add_expr_to_block (&ifblock1
, val
);
4213 gfc_init_block (&ifblock2
);
4214 gfc_add_modify (&ifblock2
, val
,
4215 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4217 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4218 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4219 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4220 gfc_build_const (type
, integer_one_node
));
4221 gfc_add_modify (&ifblock2
, resvar
, res1
);
4222 gfc_add_modify (&ifblock2
, scale
, absX
);
4223 res1
= gfc_finish_block (&ifblock2
);
4225 gfc_init_block (&ifblock3
);
4226 gfc_add_modify (&ifblock3
, val
,
4227 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4229 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4230 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4231 gfc_add_modify (&ifblock3
, resvar
, res2
);
4232 res2
= gfc_finish_block (&ifblock3
);
4234 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
4236 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4237 gfc_add_expr_to_block (&ifblock1
, tmp
);
4238 tmp
= gfc_finish_block (&ifblock1
);
4240 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4242 gfc_build_const (type
, integer_zero_node
));
4244 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4245 gfc_add_expr_to_block (&block
, tmp
);
4249 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4250 gfc_add_modify (&block
, resvar
, tmp
);
4253 gfc_add_block_to_block (&block
, &arrayse
.post
);
4255 if (maskexpr
&& maskexpr
->rank
> 0)
4257 /* We enclose the above in if (mask) {...} . */
4259 tmp
= gfc_finish_block (&block
);
4260 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4261 build_empty_stmt (input_location
));
4264 tmp
= gfc_finish_block (&block
);
4265 gfc_add_expr_to_block (&body
, tmp
);
4267 gfc_trans_scalarizing_loops (ploop
, &body
);
4269 /* For a scalar mask, enclose the loop in an if statement. */
4270 if (maskexpr
&& maskexpr
->rank
== 0)
4272 gfc_init_block (&block
);
4273 gfc_add_block_to_block (&block
, &ploop
->pre
);
4274 gfc_add_block_to_block (&block
, &ploop
->post
);
4275 tmp
= gfc_finish_block (&block
);
4279 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4280 build_empty_stmt (input_location
));
4281 gfc_advance_se_ss_chain (se
);
4285 gcc_assert (expr
->rank
== 0);
4286 gfc_init_se (&maskse
, NULL
);
4287 gfc_conv_expr_val (&maskse
, maskexpr
);
4288 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4289 build_empty_stmt (input_location
));
4292 gfc_add_expr_to_block (&block
, tmp
);
4293 gfc_add_block_to_block (&se
->pre
, &block
);
4294 gcc_assert (se
->post
.head
== NULL
);
4298 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4299 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4302 if (expr
->rank
== 0)
4303 gfc_cleanup_loop (ploop
);
4307 /* result = scale * sqrt(result). */
4309 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4310 resvar
= build_call_expr_loc (input_location
,
4312 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4319 /* Inline implementation of the dot_product intrinsic. This function
4320 is based on gfc_conv_intrinsic_arith (the previous function). */
4322 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4330 gfc_actual_arglist
*actual
;
4331 gfc_ss
*arrayss1
, *arrayss2
;
4332 gfc_se arrayse1
, arrayse2
;
4333 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4335 type
= gfc_typenode_for_spec (&expr
->ts
);
4337 /* Initialize the result. */
4338 resvar
= gfc_create_var (type
, "val");
4339 if (expr
->ts
.type
== BT_LOGICAL
)
4340 tmp
= build_int_cst (type
, 0);
4342 tmp
= gfc_build_const (type
, integer_zero_node
);
4344 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4346 /* Walk argument #1. */
4347 actual
= expr
->value
.function
.actual
;
4348 arrayexpr1
= actual
->expr
;
4349 arrayss1
= gfc_walk_expr (arrayexpr1
);
4350 gcc_assert (arrayss1
!= gfc_ss_terminator
);
4352 /* Walk argument #2. */
4353 actual
= actual
->next
;
4354 arrayexpr2
= actual
->expr
;
4355 arrayss2
= gfc_walk_expr (arrayexpr2
);
4356 gcc_assert (arrayss2
!= gfc_ss_terminator
);
4358 /* Initialize the scalarizer. */
4359 gfc_init_loopinfo (&loop
);
4360 gfc_add_ss_to_loop (&loop
, arrayss1
);
4361 gfc_add_ss_to_loop (&loop
, arrayss2
);
4363 /* Initialize the loop. */
4364 gfc_conv_ss_startstride (&loop
);
4365 gfc_conv_loop_setup (&loop
, &expr
->where
);
4367 gfc_mark_ss_chain_used (arrayss1
, 1);
4368 gfc_mark_ss_chain_used (arrayss2
, 1);
4370 /* Generate the loop body. */
4371 gfc_start_scalarized_body (&loop
, &body
);
4372 gfc_init_block (&block
);
4374 /* Make the tree expression for [conjg(]array1[)]. */
4375 gfc_init_se (&arrayse1
, NULL
);
4376 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
4377 arrayse1
.ss
= arrayss1
;
4378 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
4379 if (expr
->ts
.type
== BT_COMPLEX
)
4380 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
4382 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
4384 /* Make the tree expression for array2. */
4385 gfc_init_se (&arrayse2
, NULL
);
4386 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
4387 arrayse2
.ss
= arrayss2
;
4388 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
4389 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
4391 /* Do the actual product and sum. */
4392 if (expr
->ts
.type
== BT_LOGICAL
)
4394 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
4395 arrayse1
.expr
, arrayse2
.expr
);
4396 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
4400 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
4402 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
4404 gfc_add_modify (&block
, resvar
, tmp
);
4406 /* Finish up the loop block and the loop. */
4407 tmp
= gfc_finish_block (&block
);
4408 gfc_add_expr_to_block (&body
, tmp
);
4410 gfc_trans_scalarizing_loops (&loop
, &body
);
4411 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4412 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4413 gfc_cleanup_loop (&loop
);
4419 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4420 we need to handle. For performance reasons we sometimes create two
4421 loops instead of one, where the second one is much simpler.
4422 Examples for minloc intrinsic:
4423 1) Result is an array, a call is generated
4424 2) Array mask is used and NaNs need to be supported:
4430 if (pos == 0) pos = S + (1 - from);
4431 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4438 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4442 3) NaNs need to be supported, but it is known at compile time or cheaply
4443 at runtime whether array is nonempty or not:
4448 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4451 if (from <= to) pos = 1;
4455 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4459 4) NaNs aren't supported, array mask is used:
4460 limit = infinities_supported ? Infinity : huge (limit);
4464 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4470 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4474 5) Same without array mask:
4475 limit = infinities_supported ? Infinity : huge (limit);
4476 pos = (from <= to) ? 1 : 0;
4479 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4482 For 3) and 5), if mask is scalar, this all goes into a conditional,
4483 setting pos = 0; in the else branch. */
4486 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4490 stmtblock_t ifblock
;
4491 stmtblock_t elseblock
;
4502 gfc_actual_arglist
*actual
;
4507 gfc_expr
*arrayexpr
;
4514 gfc_conv_intrinsic_funcall (se
, expr
);
4518 /* Initialize the result. */
4519 pos
= gfc_create_var (gfc_array_index_type
, "pos");
4520 offset
= gfc_create_var (gfc_array_index_type
, "offset");
4521 type
= gfc_typenode_for_spec (&expr
->ts
);
4523 /* Walk the arguments. */
4524 actual
= expr
->value
.function
.actual
;
4525 arrayexpr
= actual
->expr
;
4526 arrayss
= gfc_walk_expr (arrayexpr
);
4527 gcc_assert (arrayss
!= gfc_ss_terminator
);
4529 actual
= actual
->next
->next
;
4530 gcc_assert (actual
);
4531 maskexpr
= actual
->expr
;
4533 if (maskexpr
&& maskexpr
->rank
!= 0)
4535 maskss
= gfc_walk_expr (maskexpr
);
4536 gcc_assert (maskss
!= gfc_ss_terminator
);
4541 if (gfc_array_size (arrayexpr
, &asize
))
4543 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4545 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4546 boolean_type_node
, nonempty
,
4547 gfc_index_zero_node
);
4552 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
4553 switch (arrayexpr
->ts
.type
)
4556 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
4560 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
4561 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
4562 arrayexpr
->ts
.kind
);
4569 /* We start with the most negative possible value for MAXLOC, and the most
4570 positive possible value for MINLOC. The most negative possible value is
4571 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4572 possible value is HUGE in both cases. */
4574 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4575 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
4576 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
4577 build_int_cst (TREE_TYPE (tmp
), 1));
4579 gfc_add_modify (&se
->pre
, limit
, tmp
);
4581 /* Initialize the scalarizer. */
4582 gfc_init_loopinfo (&loop
);
4583 gfc_add_ss_to_loop (&loop
, arrayss
);
4585 gfc_add_ss_to_loop (&loop
, maskss
);
4587 /* Initialize the loop. */
4588 gfc_conv_ss_startstride (&loop
);
4590 /* The code generated can have more than one loop in sequence (see the
4591 comment at the function header). This doesn't work well with the
4592 scalarizer, which changes arrays' offset when the scalarization loops
4593 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4594 are currently inlined in the scalar case only (for which loop is of rank
4595 one). As there is no dependency to care about in that case, there is no
4596 temporary, so that we can use the scalarizer temporary code to handle
4597 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4598 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4600 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4601 should eventually go away. We could either create two loops properly,
4602 or find another way to save/restore the array offsets between the two
4603 loops (without conflicting with temporary management), or use a single
4604 loop minmaxloc implementation. See PR 31067. */
4605 loop
.temp_dim
= loop
.dimen
;
4606 gfc_conv_loop_setup (&loop
, &expr
->where
);
4608 gcc_assert (loop
.dimen
== 1);
4609 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
4610 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4611 loop
.from
[0], loop
.to
[0]);
4615 /* Initialize the position to zero, following Fortran 2003. We are free
4616 to do this because Fortran 95 allows the result of an entirely false
4617 mask to be processor dependent. If we know at compile time the array
4618 is non-empty and no MASK is used, we can initialize to 1 to simplify
4620 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
4621 gfc_add_modify (&loop
.pre
, pos
,
4622 fold_build3_loc (input_location
, COND_EXPR
,
4623 gfc_array_index_type
,
4624 nonempty
, gfc_index_one_node
,
4625 gfc_index_zero_node
));
4628 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
4629 lab1
= gfc_build_label_decl (NULL_TREE
);
4630 TREE_USED (lab1
) = 1;
4631 lab2
= gfc_build_label_decl (NULL_TREE
);
4632 TREE_USED (lab2
) = 1;
4635 /* An offset must be added to the loop
4636 counter to obtain the required position. */
4637 gcc_assert (loop
.from
[0]);
4639 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4640 gfc_index_one_node
, loop
.from
[0]);
4641 gfc_add_modify (&loop
.pre
, offset
, tmp
);
4643 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
4645 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
4646 /* Generate the loop body. */
4647 gfc_start_scalarized_body (&loop
, &body
);
4649 /* If we have a mask, only check this element if the mask is set. */
4652 gfc_init_se (&maskse
, NULL
);
4653 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4655 gfc_conv_expr_val (&maskse
, maskexpr
);
4656 gfc_add_block_to_block (&body
, &maskse
.pre
);
4658 gfc_start_block (&block
);
4661 gfc_init_block (&block
);
4663 /* Compare with the current limit. */
4664 gfc_init_se (&arrayse
, NULL
);
4665 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4666 arrayse
.ss
= arrayss
;
4667 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4668 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4670 /* We do the following if this is a more extreme value. */
4671 gfc_start_block (&ifblock
);
4673 /* Assign the value to the limit... */
4674 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4676 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
4678 stmtblock_t ifblock2
;
4681 gfc_start_block (&ifblock2
);
4682 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4683 loop
.loopvar
[0], offset
);
4684 gfc_add_modify (&ifblock2
, pos
, tmp
);
4685 ifbody2
= gfc_finish_block (&ifblock2
);
4686 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
4687 gfc_index_zero_node
);
4688 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
4689 build_empty_stmt (input_location
));
4690 gfc_add_expr_to_block (&block
, tmp
);
4693 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4694 loop
.loopvar
[0], offset
);
4695 gfc_add_modify (&ifblock
, pos
, tmp
);
4698 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
4700 ifbody
= gfc_finish_block (&ifblock
);
4702 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
4705 cond
= fold_build2_loc (input_location
,
4706 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4707 boolean_type_node
, arrayse
.expr
, limit
);
4709 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4710 arrayse
.expr
, limit
);
4712 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
4713 build_empty_stmt (input_location
));
4715 gfc_add_expr_to_block (&block
, ifbody
);
4719 /* We enclose the above in if (mask) {...}. */
4720 tmp
= gfc_finish_block (&block
);
4722 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4723 build_empty_stmt (input_location
));
4726 tmp
= gfc_finish_block (&block
);
4727 gfc_add_expr_to_block (&body
, tmp
);
4731 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4733 if (HONOR_NANS (DECL_MODE (limit
)))
4735 if (nonempty
!= NULL
)
4737 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
4738 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
4739 build_empty_stmt (input_location
));
4740 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
4744 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
4745 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
4747 /* If we have a mask, only check this element if the mask is set. */
4750 gfc_init_se (&maskse
, NULL
);
4751 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4753 gfc_conv_expr_val (&maskse
, maskexpr
);
4754 gfc_add_block_to_block (&body
, &maskse
.pre
);
4756 gfc_start_block (&block
);
4759 gfc_init_block (&block
);
4761 /* Compare with the current limit. */
4762 gfc_init_se (&arrayse
, NULL
);
4763 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4764 arrayse
.ss
= arrayss
;
4765 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4766 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4768 /* We do the following if this is a more extreme value. */
4769 gfc_start_block (&ifblock
);
4771 /* Assign the value to the limit... */
4772 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4774 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4775 loop
.loopvar
[0], offset
);
4776 gfc_add_modify (&ifblock
, pos
, tmp
);
4778 ifbody
= gfc_finish_block (&ifblock
);
4780 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4781 arrayse
.expr
, limit
);
4783 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4784 build_empty_stmt (input_location
));
4785 gfc_add_expr_to_block (&block
, tmp
);
4789 /* We enclose the above in if (mask) {...}. */
4790 tmp
= gfc_finish_block (&block
);
4792 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4793 build_empty_stmt (input_location
));
4796 tmp
= gfc_finish_block (&block
);
4797 gfc_add_expr_to_block (&body
, tmp
);
4798 /* Avoid initializing loopvar[0] again, it should be left where
4799 it finished by the first loop. */
4800 loop
.from
[0] = loop
.loopvar
[0];
4803 gfc_trans_scalarizing_loops (&loop
, &body
);
4806 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4808 /* For a scalar mask, enclose the loop in an if statement. */
4809 if (maskexpr
&& maskss
== NULL
)
4811 gfc_init_se (&maskse
, NULL
);
4812 gfc_conv_expr_val (&maskse
, maskexpr
);
4813 gfc_init_block (&block
);
4814 gfc_add_block_to_block (&block
, &loop
.pre
);
4815 gfc_add_block_to_block (&block
, &loop
.post
);
4816 tmp
= gfc_finish_block (&block
);
4818 /* For the else part of the scalar mask, just initialize
4819 the pos variable the same way as above. */
4821 gfc_init_block (&elseblock
);
4822 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4823 elsetmp
= gfc_finish_block (&elseblock
);
4825 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4826 gfc_add_expr_to_block (&block
, tmp
);
4827 gfc_add_block_to_block (&se
->pre
, &block
);
4831 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4832 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4834 gfc_cleanup_loop (&loop
);
4836 se
->expr
= convert (type
, pos
);
4839 /* Emit code for minval or maxval intrinsic. There are many different cases
4840 we need to handle. For performance reasons we sometimes create two
4841 loops instead of one, where the second one is much simpler.
4842 Examples for minval intrinsic:
4843 1) Result is an array, a call is generated
4844 2) Array mask is used and NaNs need to be supported, rank 1:
4849 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4852 limit = nonempty ? NaN : huge (limit);
4854 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4855 3) NaNs need to be supported, but it is known at compile time or cheaply
4856 at runtime whether array is nonempty or not, rank 1:
4859 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4860 limit = (from <= to) ? NaN : huge (limit);
4862 while (S <= to) { limit = min (a[S], limit); S++; }
4863 4) Array mask is used and NaNs need to be supported, rank > 1:
4872 if (fast) limit = min (a[S1][S2], limit);
4875 if (a[S1][S2] <= limit) {
4886 limit = nonempty ? NaN : huge (limit);
4887 5) NaNs need to be supported, but it is known at compile time or cheaply
4888 at runtime whether array is nonempty or not, rank > 1:
4895 if (fast) limit = min (a[S1][S2], limit);
4897 if (a[S1][S2] <= limit) {
4907 limit = (nonempty_array) ? NaN : huge (limit);
4908 6) NaNs aren't supported, but infinities are. Array mask is used:
4913 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4916 limit = nonempty ? limit : huge (limit);
4917 7) Same without array mask:
4920 while (S <= to) { limit = min (a[S], limit); S++; }
4921 limit = (from <= to) ? limit : huge (limit);
4922 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4923 limit = huge (limit);
4925 while (S <= to) { limit = min (a[S], limit); S++); }
4927 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4928 with array mask instead).
4929 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4930 setting limit = huge (limit); in the else branch. */
4933 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4943 tree huge_cst
= NULL
, nan_cst
= NULL
;
4945 stmtblock_t block
, block2
;
4947 gfc_actual_arglist
*actual
;
4952 gfc_expr
*arrayexpr
;
4958 gfc_conv_intrinsic_funcall (se
, expr
);
4962 type
= gfc_typenode_for_spec (&expr
->ts
);
4963 /* Initialize the result. */
4964 limit
= gfc_create_var (type
, "limit");
4965 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
4966 switch (expr
->ts
.type
)
4969 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
4971 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4973 REAL_VALUE_TYPE real
;
4975 tmp
= build_real (type
, real
);
4979 if (HONOR_NANS (DECL_MODE (limit
)))
4980 nan_cst
= gfc_build_nan (type
, "");
4984 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
4991 /* We start with the most negative possible value for MAXVAL, and the most
4992 positive possible value for MINVAL. The most negative possible value is
4993 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4994 possible value is HUGE in both cases. */
4997 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4999 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
5000 TREE_TYPE (huge_cst
), huge_cst
);
5003 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
5004 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5005 tmp
, build_int_cst (type
, 1));
5007 gfc_add_modify (&se
->pre
, limit
, tmp
);
5009 /* Walk the arguments. */
5010 actual
= expr
->value
.function
.actual
;
5011 arrayexpr
= actual
->expr
;
5012 arrayss
= gfc_walk_expr (arrayexpr
);
5013 gcc_assert (arrayss
!= gfc_ss_terminator
);
5015 actual
= actual
->next
->next
;
5016 gcc_assert (actual
);
5017 maskexpr
= actual
->expr
;
5019 if (maskexpr
&& maskexpr
->rank
!= 0)
5021 maskss
= gfc_walk_expr (maskexpr
);
5022 gcc_assert (maskss
!= gfc_ss_terminator
);
5027 if (gfc_array_size (arrayexpr
, &asize
))
5029 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5031 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5032 boolean_type_node
, nonempty
,
5033 gfc_index_zero_node
);
5038 /* Initialize the scalarizer. */
5039 gfc_init_loopinfo (&loop
);
5040 gfc_add_ss_to_loop (&loop
, arrayss
);
5042 gfc_add_ss_to_loop (&loop
, maskss
);
5044 /* Initialize the loop. */
5045 gfc_conv_ss_startstride (&loop
);
5047 /* The code generated can have more than one loop in sequence (see the
5048 comment at the function header). This doesn't work well with the
5049 scalarizer, which changes arrays' offset when the scalarization loops
5050 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5051 are currently inlined in the scalar case only. As there is no dependency
5052 to care about in that case, there is no temporary, so that we can use the
5053 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5054 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5055 gfc_trans_scalarized_loop_boundary even later to restore offset.
5056 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5057 should eventually go away. We could either create two loops properly,
5058 or find another way to save/restore the array offsets between the two
5059 loops (without conflicting with temporary management), or use a single
5060 loop minmaxval implementation. See PR 31067. */
5061 loop
.temp_dim
= loop
.dimen
;
5062 gfc_conv_loop_setup (&loop
, &expr
->where
);
5064 if (nonempty
== NULL
&& maskss
== NULL
5065 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5066 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5067 loop
.from
[0], loop
.to
[0]);
5068 nonempty_var
= NULL
;
5069 if (nonempty
== NULL
5070 && (HONOR_INFINITIES (DECL_MODE (limit
))
5071 || HONOR_NANS (DECL_MODE (limit
))))
5073 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
5074 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
5075 nonempty
= nonempty_var
;
5079 if (HONOR_NANS (DECL_MODE (limit
)))
5081 if (loop
.dimen
== 1)
5083 lab
= gfc_build_label_decl (NULL_TREE
);
5084 TREE_USED (lab
) = 1;
5088 fast
= gfc_create_var (boolean_type_node
, "fast");
5089 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
5093 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5095 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5096 /* Generate the loop body. */
5097 gfc_start_scalarized_body (&loop
, &body
);
5099 /* If we have a mask, only add this element if the mask is set. */
5102 gfc_init_se (&maskse
, NULL
);
5103 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5105 gfc_conv_expr_val (&maskse
, maskexpr
);
5106 gfc_add_block_to_block (&body
, &maskse
.pre
);
5108 gfc_start_block (&block
);
5111 gfc_init_block (&block
);
5113 /* Compare with the current limit. */
5114 gfc_init_se (&arrayse
, NULL
);
5115 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5116 arrayse
.ss
= arrayss
;
5117 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5118 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5120 gfc_init_block (&block2
);
5123 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
5125 if (HONOR_NANS (DECL_MODE (limit
)))
5127 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5128 boolean_type_node
, arrayse
.expr
, limit
);
5130 ifbody
= build1_v (GOTO_EXPR
, lab
);
5133 stmtblock_t ifblock
;
5135 gfc_init_block (&ifblock
);
5136 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5137 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
5138 ifbody
= gfc_finish_block (&ifblock
);
5140 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5141 build_empty_stmt (input_location
));
5142 gfc_add_expr_to_block (&block2
, tmp
);
5146 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5148 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5150 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5151 arrayse
.expr
, limit
);
5152 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5153 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5154 build_empty_stmt (input_location
));
5155 gfc_add_expr_to_block (&block2
, tmp
);
5159 tmp
= fold_build2_loc (input_location
,
5160 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5161 type
, arrayse
.expr
, limit
);
5162 gfc_add_modify (&block2
, limit
, tmp
);
5168 tree elsebody
= gfc_finish_block (&block2
);
5170 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5172 if (HONOR_NANS (DECL_MODE (limit
))
5173 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5175 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5176 arrayse
.expr
, limit
);
5177 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5178 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5179 build_empty_stmt (input_location
));
5183 tmp
= fold_build2_loc (input_location
,
5184 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5185 type
, arrayse
.expr
, limit
);
5186 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5188 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5189 gfc_add_expr_to_block (&block
, tmp
);
5192 gfc_add_block_to_block (&block
, &block2
);
5194 gfc_add_block_to_block (&block
, &arrayse
.post
);
5196 tmp
= gfc_finish_block (&block
);
5198 /* We enclose the above in if (mask) {...}. */
5199 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5200 build_empty_stmt (input_location
));
5201 gfc_add_expr_to_block (&body
, tmp
);
5205 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5207 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5209 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
5210 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
5212 /* If we have a mask, only add this element if the mask is set. */
5215 gfc_init_se (&maskse
, NULL
);
5216 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5218 gfc_conv_expr_val (&maskse
, maskexpr
);
5219 gfc_add_block_to_block (&body
, &maskse
.pre
);
5221 gfc_start_block (&block
);
5224 gfc_init_block (&block
);
5226 /* Compare with the current limit. */
5227 gfc_init_se (&arrayse
, NULL
);
5228 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5229 arrayse
.ss
= arrayss
;
5230 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5231 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5233 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5235 if (HONOR_NANS (DECL_MODE (limit
))
5236 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5238 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5239 arrayse
.expr
, limit
);
5240 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5241 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5242 build_empty_stmt (input_location
));
5243 gfc_add_expr_to_block (&block
, tmp
);
5247 tmp
= fold_build2_loc (input_location
,
5248 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5249 type
, arrayse
.expr
, limit
);
5250 gfc_add_modify (&block
, limit
, tmp
);
5253 gfc_add_block_to_block (&block
, &arrayse
.post
);
5255 tmp
= gfc_finish_block (&block
);
5257 /* We enclose the above in if (mask) {...}. */
5258 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5259 build_empty_stmt (input_location
));
5260 gfc_add_expr_to_block (&body
, tmp
);
5261 /* Avoid initializing loopvar[0] again, it should be left where
5262 it finished by the first loop. */
5263 loop
.from
[0] = loop
.loopvar
[0];
5265 gfc_trans_scalarizing_loops (&loop
, &body
);
5269 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5271 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5272 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
5274 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5276 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
5278 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
5280 gfc_add_modify (&loop
.pre
, limit
, tmp
);
5283 /* For a scalar mask, enclose the loop in an if statement. */
5284 if (maskexpr
&& maskss
== NULL
)
5288 gfc_init_se (&maskse
, NULL
);
5289 gfc_conv_expr_val (&maskse
, maskexpr
);
5290 gfc_init_block (&block
);
5291 gfc_add_block_to_block (&block
, &loop
.pre
);
5292 gfc_add_block_to_block (&block
, &loop
.post
);
5293 tmp
= gfc_finish_block (&block
);
5295 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5296 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
5298 else_stmt
= build_empty_stmt (input_location
);
5299 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
5300 gfc_add_expr_to_block (&block
, tmp
);
5301 gfc_add_block_to_block (&se
->pre
, &block
);
5305 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5306 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5309 gfc_cleanup_loop (&loop
);
5314 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5316 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
5322 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5323 type
= TREE_TYPE (args
[0]);
5325 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5326 build_int_cst (type
, 1), args
[1]);
5327 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
5328 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5329 build_int_cst (type
, 0));
5330 type
= gfc_typenode_for_spec (&expr
->ts
);
5331 se
->expr
= convert (type
, tmp
);
5335 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5337 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5341 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5343 /* Convert both arguments to the unsigned type of the same size. */
5344 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
5345 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
5347 /* If they have unequal type size, convert to the larger one. */
5348 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
5349 > TYPE_PRECISION (TREE_TYPE (args
[1])))
5350 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
5351 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
5352 > TYPE_PRECISION (TREE_TYPE (args
[0])))
5353 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
5355 /* Now, we compare them. */
5356 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
5361 /* Generate code to perform the specified operation. */
5363 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5367 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5368 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
5374 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
5378 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5379 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5380 TREE_TYPE (arg
), arg
);
5383 /* Set or clear a single bit. */
5385 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
5392 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5393 type
= TREE_TYPE (args
[0]);
5395 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5396 build_int_cst (type
, 1), args
[1]);
5402 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
5404 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
5407 /* Extract a sequence of bits.
5408 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5410 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
5417 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5418 type
= TREE_TYPE (args
[0]);
5420 mask
= build_int_cst (type
, -1);
5421 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
5422 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
5424 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
5426 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
5430 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
5433 tree args
[2], type
, num_bits
, cond
;
5435 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5437 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5438 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5439 type
= TREE_TYPE (args
[0]);
5442 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
5444 gcc_assert (right_shift
);
5446 se
->expr
= fold_build2_loc (input_location
,
5447 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
5448 TREE_TYPE (args
[0]), args
[0], args
[1]);
5451 se
->expr
= fold_convert (type
, se
->expr
);
5453 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5454 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5456 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5457 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5460 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5461 build_int_cst (type
, 0), se
->expr
);
5464 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5466 : ((shift >= 0) ? i << shift : i >> -shift)
5467 where all shifts are logical shifts. */
5469 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
5481 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5483 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5484 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5486 type
= TREE_TYPE (args
[0]);
5487 utype
= unsigned_type_for (type
);
5489 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
5492 /* Left shift if positive. */
5493 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
5495 /* Right shift if negative.
5496 We convert to an unsigned type because we want a logical shift.
5497 The standard doesn't define the case of shifting negative
5498 numbers, and we try to be compatible with other compilers, most
5499 notably g77, here. */
5500 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
5501 utype
, convert (utype
, args
[0]), width
));
5503 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
5504 build_int_cst (TREE_TYPE (args
[1]), 0));
5505 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
5507 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5508 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5510 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5511 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
5513 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5514 build_int_cst (type
, 0), tmp
);
5518 /* Circular shift. AKA rotate or barrel shift. */
5521 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
5529 unsigned int num_args
;
5531 num_args
= gfc_intrinsic_argument_list_length (expr
);
5532 args
= XALLOCAVEC (tree
, num_args
);
5534 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5538 /* Use a library function for the 3 parameter version. */
5539 tree int4type
= gfc_get_int_type (4);
5541 type
= TREE_TYPE (args
[0]);
5542 /* We convert the first argument to at least 4 bytes, and
5543 convert back afterwards. This removes the need for library
5544 functions for all argument sizes, and function will be
5545 aligned to at least 32 bits, so there's no loss. */
5546 if (expr
->ts
.kind
< 4)
5547 args
[0] = convert (int4type
, args
[0]);
5549 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5550 need loads of library functions. They cannot have values >
5551 BIT_SIZE (I) so the conversion is safe. */
5552 args
[1] = convert (int4type
, args
[1]);
5553 args
[2] = convert (int4type
, args
[2]);
5555 switch (expr
->ts
.kind
)
5560 tmp
= gfor_fndecl_math_ishftc4
;
5563 tmp
= gfor_fndecl_math_ishftc8
;
5566 tmp
= gfor_fndecl_math_ishftc16
;
5571 se
->expr
= build_call_expr_loc (input_location
,
5572 tmp
, 3, args
[0], args
[1], args
[2]);
5573 /* Convert the result back to the original type, if we extended
5574 the first argument's width above. */
5575 if (expr
->ts
.kind
< 4)
5576 se
->expr
= convert (type
, se
->expr
);
5580 type
= TREE_TYPE (args
[0]);
5582 /* Evaluate arguments only once. */
5583 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5584 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5586 /* Rotate left if positive. */
5587 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
5589 /* Rotate right if negative. */
5590 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
5592 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
5594 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
5595 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
5597 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
5599 /* Do nothing if shift == 0. */
5600 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
5602 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
5607 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5608 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5610 The conditional expression is necessary because the result of LEADZ(0)
5611 is defined, but the result of __builtin_clz(0) is undefined for most
5614 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5615 difference in bit size between the argument of LEADZ and the C int. */
5618 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
5630 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5631 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5633 /* Which variant of __builtin_clz* should we call? */
5634 if (argsize
<= INT_TYPE_SIZE
)
5636 arg_type
= unsigned_type_node
;
5637 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
5639 else if (argsize
<= LONG_TYPE_SIZE
)
5641 arg_type
= long_unsigned_type_node
;
5642 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
5644 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5646 arg_type
= long_long_unsigned_type_node
;
5647 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5651 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5652 arg_type
= gfc_build_uint_type (argsize
);
5656 /* Convert the actual argument twice: first, to the unsigned type of the
5657 same size; then, to the proper argument type for the built-in
5658 function. But the return type is of the default INTEGER kind. */
5659 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5660 arg
= fold_convert (arg_type
, arg
);
5661 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5662 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5664 /* Compute LEADZ for the case i .ne. 0. */
5667 s
= TYPE_PRECISION (arg_type
) - argsize
;
5668 tmp
= fold_convert (result_type
,
5669 build_call_expr_loc (input_location
, func
,
5671 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
5672 tmp
, build_int_cst (result_type
, s
));
5676 /* We end up here if the argument type is larger than 'long long'.
5677 We generate this code:
5679 if (x & (ULL_MAX << ULL_SIZE) != 0)
5680 return clzll ((unsigned long long) (x >> ULLSIZE));
5682 return ULL_SIZE + clzll ((unsigned long long) x);
5683 where ULL_MAX is the largest value that a ULL_MAX can hold
5684 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5685 is the bit-size of the long long type (64 in this example). */
5686 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5688 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5689 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5690 long_long_unsigned_type_node
,
5691 build_int_cst (long_long_unsigned_type_node
,
5694 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
5695 fold_convert (arg_type
, ullmax
), ullsize
);
5696 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
5698 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5699 cond
, build_int_cst (arg_type
, 0));
5701 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5703 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5704 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5705 tmp1
= fold_convert (result_type
,
5706 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5708 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5709 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5710 tmp2
= fold_convert (result_type
,
5711 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5712 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5715 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5719 /* Build BIT_SIZE. */
5720 bit_size
= build_int_cst (result_type
, argsize
);
5722 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5723 arg
, build_int_cst (arg_type
, 0));
5724 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5729 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5731 The conditional expression is necessary because the result of TRAILZ(0)
5732 is defined, but the result of __builtin_ctz(0) is undefined for most
5736 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
5747 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5748 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5750 /* Which variant of __builtin_ctz* should we call? */
5751 if (argsize
<= INT_TYPE_SIZE
)
5753 arg_type
= unsigned_type_node
;
5754 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5756 else if (argsize
<= LONG_TYPE_SIZE
)
5758 arg_type
= long_unsigned_type_node
;
5759 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5761 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5763 arg_type
= long_long_unsigned_type_node
;
5764 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5768 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5769 arg_type
= gfc_build_uint_type (argsize
);
5773 /* Convert the actual argument twice: first, to the unsigned type of the
5774 same size; then, to the proper argument type for the built-in
5775 function. But the return type is of the default INTEGER kind. */
5776 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5777 arg
= fold_convert (arg_type
, arg
);
5778 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5779 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5781 /* Compute TRAILZ for the case i .ne. 0. */
5783 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5787 /* We end up here if the argument type is larger than 'long long'.
5788 We generate this code:
5790 if ((x & ULL_MAX) == 0)
5791 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5793 return ctzll ((unsigned long long) x);
5795 where ULL_MAX is the largest value that a ULL_MAX can hold
5796 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5797 is the bit-size of the long long type (64 in this example). */
5798 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5800 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5801 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5802 long_long_unsigned_type_node
,
5803 build_int_cst (long_long_unsigned_type_node
, 0));
5805 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5806 fold_convert (arg_type
, ullmax
));
5807 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
5808 build_int_cst (arg_type
, 0));
5810 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5812 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5813 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5814 tmp1
= fold_convert (result_type
,
5815 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5816 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5819 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5820 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5821 tmp2
= fold_convert (result_type
,
5822 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5824 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5828 /* Build BIT_SIZE. */
5829 bit_size
= build_int_cst (result_type
, argsize
);
5831 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5832 arg
, build_int_cst (arg_type
, 0));
5833 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5837 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5838 for types larger than "long long", we call the long long built-in for
5839 the lower and higher bits and combine the result. */
5842 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5850 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5851 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5852 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5854 /* Which variant of the builtin should we call? */
5855 if (argsize
<= INT_TYPE_SIZE
)
5857 arg_type
= unsigned_type_node
;
5858 func
= builtin_decl_explicit (parity
5860 : BUILT_IN_POPCOUNT
);
5862 else if (argsize
<= LONG_TYPE_SIZE
)
5864 arg_type
= long_unsigned_type_node
;
5865 func
= builtin_decl_explicit (parity
5867 : BUILT_IN_POPCOUNTL
);
5869 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5871 arg_type
= long_long_unsigned_type_node
;
5872 func
= builtin_decl_explicit (parity
5874 : BUILT_IN_POPCOUNTLL
);
5878 /* Our argument type is larger than 'long long', which mean none
5879 of the POPCOUNT builtins covers it. We thus call the 'long long'
5880 variant multiple times, and add the results. */
5881 tree utype
, arg2
, call1
, call2
;
5883 /* For now, we only cover the case where argsize is twice as large
5885 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5887 func
= builtin_decl_explicit (parity
5889 : BUILT_IN_POPCOUNTLL
);
5891 /* Convert it to an integer, and store into a variable. */
5892 utype
= gfc_build_uint_type (argsize
);
5893 arg
= fold_convert (utype
, arg
);
5894 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5896 /* Call the builtin twice. */
5897 call1
= build_call_expr_loc (input_location
, func
, 1,
5898 fold_convert (long_long_unsigned_type_node
,
5901 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5902 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5903 call2
= build_call_expr_loc (input_location
, func
, 1,
5904 fold_convert (long_long_unsigned_type_node
,
5907 /* Combine the results. */
5909 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5912 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5918 /* Convert the actual argument twice: first, to the unsigned type of the
5919 same size; then, to the proper argument type for the built-in
5921 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5922 arg
= fold_convert (arg_type
, arg
);
5924 se
->expr
= fold_convert (result_type
,
5925 build_call_expr_loc (input_location
, func
, 1, arg
));
5929 /* Process an intrinsic with unspecified argument-types that has an optional
5930 argument (which could be of type character), e.g. EOSHIFT. For those, we
5931 need to append the string length of the optional argument if it is not
5932 present and the type is really character.
5933 primary specifies the position (starting at 1) of the non-optional argument
5934 specifying the type and optional gives the position of the optional
5935 argument in the arglist. */
5938 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5939 unsigned primary
, unsigned optional
)
5941 gfc_actual_arglist
* prim_arg
;
5942 gfc_actual_arglist
* opt_arg
;
5944 gfc_actual_arglist
* arg
;
5946 vec
<tree
, va_gc
> *append_args
;
5948 /* Find the two arguments given as position. */
5952 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5956 if (cur_pos
== primary
)
5958 if (cur_pos
== optional
)
5961 if (cur_pos
>= primary
&& cur_pos
>= optional
)
5964 gcc_assert (prim_arg
);
5965 gcc_assert (prim_arg
->expr
);
5966 gcc_assert (opt_arg
);
5968 /* If we do have type CHARACTER and the optional argument is really absent,
5969 append a dummy 0 as string length. */
5971 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
5975 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
5976 vec_alloc (append_args
, 1);
5977 append_args
->quick_push (dummy
);
5980 /* Build the call itself. */
5981 gcc_assert (!se
->ignore_optional
);
5982 sym
= gfc_get_symbol_for_expr (expr
, false);
5983 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5985 gfc_free_symbol (sym
);
5989 /* The length of a character string. */
5991 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
6000 gcc_assert (!se
->ss
);
6002 arg
= expr
->value
.function
.actual
->expr
;
6004 type
= gfc_typenode_for_spec (&expr
->ts
);
6005 switch (arg
->expr_type
)
6008 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
6012 /* Obtain the string length from the function used by
6013 trans-array.c(gfc_trans_array_constructor). */
6015 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
6019 if (arg
->ref
== NULL
6020 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6022 /* This doesn't catch all cases.
6023 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6024 and the surrounding thread. */
6025 sym
= arg
->symtree
->n
.sym
;
6026 decl
= gfc_get_symbol_decl (sym
);
6027 if (decl
== current_function_decl
&& sym
->attr
.function
6028 && (sym
->result
== sym
))
6029 decl
= gfc_get_fake_result_decl (sym
, 0);
6031 len
= sym
->ts
.u
.cl
->backend_decl
;
6039 /* Anybody stupid enough to do this deserves inefficient code. */
6040 gfc_init_se (&argse
, se
);
6042 gfc_conv_expr (&argse
, arg
);
6044 gfc_conv_expr_descriptor (&argse
, arg
);
6045 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6046 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6047 len
= argse
.string_length
;
6050 se
->expr
= convert (type
, len
);
6053 /* The length of a character string not including trailing blanks. */
6055 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6057 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6058 tree args
[2], type
, fndecl
;
6060 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6061 type
= gfc_typenode_for_spec (&expr
->ts
);
6064 fndecl
= gfor_fndecl_string_len_trim
;
6066 fndecl
= gfor_fndecl_string_len_trim_char4
;
6070 se
->expr
= build_call_expr_loc (input_location
,
6071 fndecl
, 2, args
[0], args
[1]);
6072 se
->expr
= convert (type
, se
->expr
);
6076 /* Returns the starting position of a substring within a string. */
6079 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6082 tree logical4_type_node
= gfc_get_logical_type (4);
6086 unsigned int num_args
;
6088 args
= XALLOCAVEC (tree
, 5);
6090 /* Get number of arguments; characters count double due to the
6091 string length argument. Kind= is not passed to the library
6092 and thus ignored. */
6093 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6098 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6099 type
= gfc_typenode_for_spec (&expr
->ts
);
6102 args
[4] = build_int_cst (logical4_type_node
, 0);
6104 args
[4] = convert (logical4_type_node
, args
[4]);
6106 fndecl
= build_addr (function
);
6107 se
->expr
= build_call_array_loc (input_location
,
6108 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6110 se
->expr
= convert (type
, se
->expr
);
6114 /* The ascii value for a single character. */
6116 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6118 tree args
[3], type
, pchartype
;
6121 nargs
= gfc_intrinsic_argument_list_length (expr
);
6122 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6123 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6124 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6125 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6126 type
= gfc_typenode_for_spec (&expr
->ts
);
6128 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6130 se
->expr
= convert (type
, se
->expr
);
6134 /* Intrinsic ISNAN calls __builtin_isnan. */
6137 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6141 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6142 se
->expr
= build_call_expr_loc (input_location
,
6143 builtin_decl_explicit (BUILT_IN_ISNAN
),
6145 STRIP_TYPE_NOPS (se
->expr
);
6146 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6150 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6151 their argument against a constant integer value. */
6154 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6158 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6159 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6160 gfc_typenode_for_spec (&expr
->ts
),
6161 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6166 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6169 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
6177 unsigned int num_args
;
6179 num_args
= gfc_intrinsic_argument_list_length (expr
);
6180 args
= XALLOCAVEC (tree
, num_args
);
6182 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6183 if (expr
->ts
.type
!= BT_CHARACTER
)
6191 /* We do the same as in the non-character case, but the argument
6192 list is different because of the string length arguments. We
6193 also have to set the string length for the result. */
6200 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
6202 se
->string_length
= len
;
6204 type
= TREE_TYPE (tsource
);
6205 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
6206 fold_convert (type
, fsource
));
6210 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6213 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
6215 tree args
[3], mask
, type
;
6217 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6218 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
6220 type
= TREE_TYPE (args
[0]);
6221 gcc_assert (TREE_TYPE (args
[1]) == type
);
6222 gcc_assert (TREE_TYPE (mask
) == type
);
6224 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
6225 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
6226 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6228 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
6233 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6234 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6237 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
6239 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
6242 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6243 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6245 type
= gfc_get_int_type (expr
->ts
.kind
);
6246 utype
= unsigned_type_for (type
);
6248 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
6249 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
6251 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
6252 build_int_cst (utype
, 0));
6256 /* Left-justified mask. */
6257 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
6259 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6260 fold_convert (utype
, res
));
6262 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6263 smaller than type width. */
6264 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
6265 build_int_cst (TREE_TYPE (arg
), 0));
6266 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
6267 build_int_cst (utype
, 0), res
);
6271 /* Right-justified mask. */
6272 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6273 fold_convert (utype
, arg
));
6274 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
6276 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6277 strictly smaller than type width. */
6278 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6280 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
6281 cond
, allones
, res
);
6284 se
->expr
= fold_convert (type
, res
);
6288 /* FRACTION (s) is translated into:
6289 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6291 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
6293 tree arg
, type
, tmp
, res
, frexp
, cond
;
6295 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6297 type
= gfc_typenode_for_spec (&expr
->ts
);
6298 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6299 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6301 cond
= build_call_expr_loc (input_location
,
6302 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6305 tmp
= gfc_create_var (integer_type_node
, NULL
);
6306 res
= build_call_expr_loc (input_location
, frexp
, 2,
6307 fold_convert (type
, arg
),
6308 gfc_build_addr_expr (NULL_TREE
, tmp
));
6309 res
= fold_convert (type
, res
);
6311 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
6312 cond
, res
, gfc_build_nan (type
, ""));
6316 /* NEAREST (s, dir) is translated into
6317 tmp = copysign (HUGE_VAL, dir);
6318 return nextafter (s, tmp);
6321 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
6323 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
6325 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
6326 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
6328 type
= gfc_typenode_for_spec (&expr
->ts
);
6329 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6331 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
6332 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
6333 fold_convert (type
, args
[1]));
6334 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
6335 fold_convert (type
, args
[0]), tmp
);
6336 se
->expr
= fold_convert (type
, se
->expr
);
6340 /* SPACING (s) is translated into
6350 e = MAX_EXPR (e, emin);
6351 res = scalbn (1., e);
6355 where prec is the precision of s, gfc_real_kinds[k].digits,
6356 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6357 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6360 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
6362 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
6363 tree cond
, nan
, tmp
, frexp
, scalbn
;
6367 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6368 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
6369 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
6370 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
6372 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6373 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6375 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6376 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6378 type
= gfc_typenode_for_spec (&expr
->ts
);
6379 e
= gfc_create_var (integer_type_node
, NULL
);
6380 res
= gfc_create_var (type
, NULL
);
6383 /* Build the block for s /= 0. */
6384 gfc_start_block (&block
);
6385 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6386 gfc_build_addr_expr (NULL_TREE
, e
));
6387 gfc_add_expr_to_block (&block
, tmp
);
6389 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
6391 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
6392 integer_type_node
, tmp
, emin
));
6394 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
6395 build_real_from_int_cst (type
, integer_one_node
), e
);
6396 gfc_add_modify (&block
, res
, tmp
);
6398 /* Finish by building the IF statement for value zero. */
6399 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
6400 build_real_from_int_cst (type
, integer_zero_node
));
6401 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
6402 gfc_finish_block (&block
));
6404 /* And deal with infinities and NaNs. */
6405 cond
= build_call_expr_loc (input_location
,
6406 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6408 nan
= gfc_build_nan (type
, "");
6409 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
6411 gfc_add_expr_to_block (&se
->pre
, tmp
);
6416 /* RRSPACING (s) is translated into
6425 x = scalbn (x, precision - e);
6432 where precision is gfc_real_kinds[k].digits. */
6435 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
6437 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
6441 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6442 prec
= gfc_real_kinds
[k
].digits
;
6444 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6445 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6446 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
6448 type
= gfc_typenode_for_spec (&expr
->ts
);
6449 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6450 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6452 e
= gfc_create_var (integer_type_node
, NULL
);
6453 x
= gfc_create_var (type
, NULL
);
6454 gfc_add_modify (&se
->pre
, x
,
6455 build_call_expr_loc (input_location
, fabs
, 1, arg
));
6458 gfc_start_block (&block
);
6459 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6460 gfc_build_addr_expr (NULL_TREE
, e
));
6461 gfc_add_expr_to_block (&block
, tmp
);
6463 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
6464 build_int_cst (integer_type_node
, prec
), e
);
6465 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
6466 gfc_add_modify (&block
, x
, tmp
);
6467 stmt
= gfc_finish_block (&block
);
6470 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
6471 build_real_from_int_cst (type
, integer_zero_node
));
6472 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
6474 /* And deal with infinities and NaNs. */
6475 cond
= build_call_expr_loc (input_location
,
6476 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6478 nan
= gfc_build_nan (type
, "");
6479 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
6481 gfc_add_expr_to_block (&se
->pre
, tmp
);
6482 se
->expr
= fold_convert (type
, x
);
6486 /* SCALE (s, i) is translated into scalbn (s, i). */
6488 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
6490 tree args
[2], type
, scalbn
;
6492 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6494 type
= gfc_typenode_for_spec (&expr
->ts
);
6495 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6496 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
6497 fold_convert (type
, args
[0]),
6498 fold_convert (integer_type_node
, args
[1]));
6499 se
->expr
= fold_convert (type
, se
->expr
);
6503 /* SET_EXPONENT (s, i) is translated into
6504 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6506 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
6508 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
6510 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6511 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6513 type
= gfc_typenode_for_spec (&expr
->ts
);
6514 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6515 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6517 tmp
= gfc_create_var (integer_type_node
, NULL
);
6518 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
6519 fold_convert (type
, args
[0]),
6520 gfc_build_addr_expr (NULL_TREE
, tmp
));
6521 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
6522 fold_convert (integer_type_node
, args
[1]));
6523 res
= fold_convert (type
, res
);
6525 /* Call to isfinite */
6526 cond
= build_call_expr_loc (input_location
,
6527 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6529 nan
= gfc_build_nan (type
, "");
6531 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6537 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
6539 gfc_actual_arglist
*actual
;
6546 gfc_init_se (&argse
, NULL
);
6547 actual
= expr
->value
.function
.actual
;
6549 if (actual
->expr
->ts
.type
== BT_CLASS
)
6550 gfc_add_class_array_ref (actual
->expr
);
6552 argse
.data_not_needed
= 1;
6553 if (gfc_is_alloc_class_array_function (actual
->expr
))
6555 /* For functions that return a class array conv_expr_descriptor is not
6556 able to get the descriptor right. Therefore this special case. */
6557 gfc_conv_expr_reference (&argse
, actual
->expr
);
6558 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6559 gfc_class_data_get (argse
.expr
));
6563 argse
.want_pointer
= 1;
6564 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
6566 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6567 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6568 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
6570 /* Build the call to size0. */
6571 fncall0
= build_call_expr_loc (input_location
,
6572 gfor_fndecl_size0
, 1, arg1
);
6574 actual
= actual
->next
;
6578 gfc_init_se (&argse
, NULL
);
6579 gfc_conv_expr_type (&argse
, actual
->expr
,
6580 gfc_array_index_type
);
6581 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6583 /* Unusually, for an intrinsic, size does not exclude
6584 an optional arg2, so we must test for it. */
6585 if (actual
->expr
->expr_type
== EXPR_VARIABLE
6586 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
6587 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
6590 /* Build the call to size1. */
6591 fncall1
= build_call_expr_loc (input_location
,
6592 gfor_fndecl_size1
, 2,
6595 gfc_init_se (&argse
, NULL
);
6596 argse
.want_pointer
= 1;
6597 argse
.data_not_needed
= 1;
6598 gfc_conv_expr (&argse
, actual
->expr
);
6599 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6600 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6601 argse
.expr
, null_pointer_node
);
6602 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6603 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
6604 pvoid_type_node
, tmp
, fncall1
, fncall0
);
6608 se
->expr
= NULL_TREE
;
6609 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6610 gfc_array_index_type
,
6611 argse
.expr
, gfc_index_one_node
);
6614 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
6616 argse
.expr
= gfc_index_zero_node
;
6617 se
->expr
= NULL_TREE
;
6622 if (se
->expr
== NULL_TREE
)
6624 tree ubound
, lbound
;
6626 arg1
= build_fold_indirect_ref_loc (input_location
,
6628 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
6629 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
6630 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6631 gfc_array_index_type
, ubound
, lbound
);
6632 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
6633 gfc_array_index_type
,
6634 se
->expr
, gfc_index_one_node
);
6635 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6636 gfc_array_index_type
, se
->expr
,
6637 gfc_index_zero_node
);
6640 type
= gfc_typenode_for_spec (&expr
->ts
);
6641 se
->expr
= convert (type
, se
->expr
);
6645 /* Helper function to compute the size of a character variable,
6646 excluding the terminating null characters. The result has
6647 gfc_array_index_type type. */
6650 size_of_string_in_bytes (int kind
, tree string_length
)
6653 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
6655 bytesize
= build_int_cst (gfc_array_index_type
,
6656 gfc_character_kinds
[i
].bit_size
/ 8);
6658 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6660 fold_convert (gfc_array_index_type
, string_length
));
6665 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
6676 gfc_init_se (&argse
, NULL
);
6677 arg
= expr
->value
.function
.actual
->expr
;
6679 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
6680 gfc_conv_expr_descriptor (&argse
, arg
);
6682 gfc_conv_expr_reference (&argse
, arg
);
6684 if (arg
->ts
.type
== BT_ASSUMED
)
6686 /* This only works if an array descriptor has been passed; thus, extract
6687 the size from the descriptor. */
6688 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
6689 == TYPE_PRECISION (size_type_node
));
6690 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
6691 tmp
= DECL_LANG_SPECIFIC (tmp
)
6692 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
6693 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
6694 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
6695 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6696 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
6697 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
6698 build_int_cst (TREE_TYPE (tmp
),
6699 GFC_DTYPE_SIZE_SHIFT
));
6700 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
6702 else if (arg
->ts
.type
== BT_CLASS
)
6704 /* Conv_expr_descriptor returns a component_ref to _data component of the
6705 class object. The class object may be a non-pointer object, e.g.
6706 located on the stack, or a memory location pointed to, e.g. a
6707 parameter, i.e., an indirect_ref. */
6709 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
6710 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
6711 && GFC_DECL_CLASS (TREE_OPERAND (
6712 TREE_OPERAND (argse
.expr
, 0), 0)))
6713 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
6714 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6715 else if (arg
->rank
> 0
6717 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
6718 /* The scalarizer added an additional temp. To get the class' vptr
6719 one has to look at the original backend_decl. */
6720 byte_size
= gfc_class_vtab_size_get (
6721 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6723 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
6727 if (arg
->ts
.type
== BT_CHARACTER
)
6728 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6732 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6735 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6736 byte_size
= fold_convert (gfc_array_index_type
,
6737 size_in_bytes (byte_size
));
6742 se
->expr
= byte_size
;
6745 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
6746 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
6748 if (arg
->rank
== -1)
6750 tree cond
, loop_var
, exit_label
;
6753 tmp
= fold_convert (gfc_array_index_type
,
6754 gfc_conv_descriptor_rank (argse
.expr
));
6755 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
6756 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
6757 exit_label
= gfc_build_label_decl (NULL_TREE
);
6764 source_bytes = source_bytes * array.dim[i].extent;
6768 gfc_start_block (&body
);
6769 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6771 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6772 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6773 cond
, tmp
, build_empty_stmt (input_location
));
6774 gfc_add_expr_to_block (&body
, tmp
);
6776 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6777 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6778 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6779 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6780 gfc_array_index_type
, tmp
, source_bytes
);
6781 gfc_add_modify (&body
, source_bytes
, tmp
);
6783 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6784 gfc_array_index_type
, loop_var
,
6785 gfc_index_one_node
);
6786 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6788 tmp
= gfc_finish_block (&body
);
6790 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6792 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6794 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6795 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6799 /* Obtain the size of the array in bytes. */
6800 for (n
= 0; n
< arg
->rank
; n
++)
6803 idx
= gfc_rank_cst
[n
];
6804 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6805 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6806 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6807 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6808 gfc_array_index_type
, tmp
, source_bytes
);
6809 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6812 se
->expr
= source_bytes
;
6815 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6820 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6824 tree type
, result_type
, tmp
;
6826 arg
= expr
->value
.function
.actual
->expr
;
6828 gfc_init_se (&argse
, NULL
);
6829 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6833 if (arg
->ts
.type
== BT_CLASS
)
6835 gfc_add_vptr_component (arg
);
6836 gfc_add_size_component (arg
);
6837 gfc_conv_expr (&argse
, arg
);
6838 tmp
= fold_convert (result_type
, argse
.expr
);
6842 gfc_conv_expr_reference (&argse
, arg
);
6843 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6848 argse
.want_pointer
= 0;
6849 gfc_conv_expr_descriptor (&argse
, arg
);
6850 if (arg
->ts
.type
== BT_CLASS
)
6853 tmp
= gfc_class_vtab_size_get (
6854 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6856 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6857 tmp
= fold_convert (result_type
, tmp
);
6860 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6863 /* Obtain the argument's word length. */
6864 if (arg
->ts
.type
== BT_CHARACTER
)
6865 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6867 tmp
= size_in_bytes (type
);
6868 tmp
= fold_convert (result_type
, tmp
);
6871 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6872 build_int_cst (result_type
, BITS_PER_UNIT
));
6873 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6877 /* Intrinsic string comparison functions. */
6880 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6884 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6887 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6888 expr
->value
.function
.actual
->expr
->ts
.kind
,
6890 se
->expr
= fold_build2_loc (input_location
, op
,
6891 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6892 build_int_cst (TREE_TYPE (se
->expr
), 0));
6895 /* Generate a call to the adjustl/adjustr library function. */
6897 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6905 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6908 type
= TREE_TYPE (args
[2]);
6909 var
= gfc_conv_string_tmp (se
, type
, len
);
6912 tmp
= build_call_expr_loc (input_location
,
6913 fndecl
, 3, args
[0], args
[1], args
[2]);
6914 gfc_add_expr_to_block (&se
->pre
, tmp
);
6916 se
->string_length
= len
;
6920 /* Generate code for the TRANSFER intrinsic:
6922 DEST = TRANSFER (SOURCE, MOLD)
6924 typeof<DEST> = typeof<MOLD>
6929 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6931 typeof<DEST> = typeof<MOLD>
6933 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6934 sizeof (DEST(0) * SIZE). */
6936 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6952 gfc_actual_arglist
*arg
;
6954 gfc_array_info
*info
;
6958 gfc_expr
*source_expr
, *mold_expr
;
6962 info
= &se
->ss
->info
->data
.array
;
6964 /* Convert SOURCE. The output from this stage is:-
6965 source_bytes = length of the source in bytes
6966 source = pointer to the source data. */
6967 arg
= expr
->value
.function
.actual
;
6968 source_expr
= arg
->expr
;
6970 /* Ensure double transfer through LOGICAL preserves all
6972 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6973 && arg
->expr
->value
.function
.esym
== NULL
6974 && arg
->expr
->value
.function
.isym
!= NULL
6975 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6976 && arg
->expr
->ts
.type
== BT_LOGICAL
6977 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6978 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6980 gfc_init_se (&argse
, NULL
);
6982 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6984 /* Obtain the pointer to source and the length of source in bytes. */
6985 if (arg
->expr
->rank
== 0)
6987 gfc_conv_expr_reference (&argse
, arg
->expr
);
6988 if (arg
->expr
->ts
.type
== BT_CLASS
)
6989 source
= gfc_class_data_get (argse
.expr
);
6991 source
= argse
.expr
;
6993 /* Obtain the source word length. */
6994 switch (arg
->expr
->ts
.type
)
6997 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6998 argse
.string_length
);
7001 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7004 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7006 tmp
= fold_convert (gfc_array_index_type
,
7007 size_in_bytes (source_type
));
7013 argse
.want_pointer
= 0;
7014 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7015 source
= gfc_conv_descriptor_data_get (argse
.expr
);
7016 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7018 /* Repack the source if not simply contiguous. */
7019 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
7021 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
7023 if (warn_array_temporaries
)
7024 gfc_warning (OPT_Warray_temporaries
,
7025 "Creating array temporary at %L", &expr
->where
);
7027 source
= build_call_expr_loc (input_location
,
7028 gfor_fndecl_in_pack
, 1, tmp
);
7029 source
= gfc_evaluate_now (source
, &argse
.pre
);
7031 /* Free the temporary. */
7032 gfc_start_block (&block
);
7033 tmp
= gfc_call_free (source
);
7034 gfc_add_expr_to_block (&block
, tmp
);
7035 stmt
= gfc_finish_block (&block
);
7037 /* Clean up if it was repacked. */
7038 gfc_init_block (&block
);
7039 tmp
= gfc_conv_array_data (argse
.expr
);
7040 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7042 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7043 build_empty_stmt (input_location
));
7044 gfc_add_expr_to_block (&block
, tmp
);
7045 gfc_add_block_to_block (&block
, &se
->post
);
7046 gfc_init_block (&se
->post
);
7047 gfc_add_block_to_block (&se
->post
, &block
);
7050 /* Obtain the source word length. */
7051 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7052 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7053 argse
.string_length
);
7055 tmp
= fold_convert (gfc_array_index_type
,
7056 size_in_bytes (source_type
));
7058 /* Obtain the size of the array in bytes. */
7059 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7060 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7063 idx
= gfc_rank_cst
[n
];
7064 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7065 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7066 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7067 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7068 gfc_array_index_type
, upper
, lower
);
7069 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7070 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7071 gfc_array_index_type
, extent
,
7072 gfc_index_one_node
);
7073 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7074 gfc_array_index_type
, tmp
, source_bytes
);
7078 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7079 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7080 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7082 /* Now convert MOLD. The outputs are:
7083 mold_type = the TREE type of MOLD
7084 dest_word_len = destination word length in bytes. */
7086 mold_expr
= arg
->expr
;
7088 gfc_init_se (&argse
, NULL
);
7090 scalar_mold
= arg
->expr
->rank
== 0;
7092 if (arg
->expr
->rank
== 0)
7094 gfc_conv_expr_reference (&argse
, arg
->expr
);
7095 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7100 gfc_init_se (&argse
, NULL
);
7101 argse
.want_pointer
= 0;
7102 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7103 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7106 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7107 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7109 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7111 /* If this TRANSFER is nested in another TRANSFER, use a type
7112 that preserves all bits. */
7113 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7114 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7117 /* Obtain the destination word length. */
7118 switch (arg
->expr
->ts
.type
)
7121 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7122 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7125 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7128 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7131 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7132 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7134 /* Finally convert SIZE, if it is present. */
7136 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7140 gfc_init_se (&argse
, NULL
);
7141 gfc_conv_expr_reference (&argse
, arg
->expr
);
7142 tmp
= convert (gfc_array_index_type
,
7143 build_fold_indirect_ref_loc (input_location
,
7145 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7146 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7151 /* Separate array and scalar results. */
7152 if (scalar_mold
&& tmp
== NULL_TREE
)
7153 goto scalar_transfer
;
7155 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7156 if (tmp
!= NULL_TREE
)
7157 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7158 tmp
, dest_word_len
);
7162 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
7163 gfc_add_modify (&se
->pre
, size_words
,
7164 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
7165 gfc_array_index_type
,
7166 size_bytes
, dest_word_len
));
7168 /* Evaluate the bounds of the result. If the loop range exists, we have
7169 to check if it is too large. If so, we modify loop->to be consistent
7170 with min(size, size(source)). Otherwise, size is made consistent with
7171 the loop range, so that the right number of bytes is transferred.*/
7172 n
= se
->loop
->order
[0];
7173 if (se
->loop
->to
[n
] != NULL_TREE
)
7175 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7176 se
->loop
->to
[n
], se
->loop
->from
[n
]);
7177 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7178 tmp
, gfc_index_one_node
);
7179 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7181 gfc_add_modify (&se
->pre
, size_words
, tmp
);
7182 gfc_add_modify (&se
->pre
, size_bytes
,
7183 fold_build2_loc (input_location
, MULT_EXPR
,
7184 gfc_array_index_type
,
7185 size_words
, dest_word_len
));
7186 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7187 size_words
, se
->loop
->from
[n
]);
7188 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7189 upper
, gfc_index_one_node
);
7193 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7194 size_words
, gfc_index_one_node
);
7195 se
->loop
->from
[n
] = gfc_index_zero_node
;
7198 se
->loop
->to
[n
] = upper
;
7200 /* Build a destination descriptor, using the pointer, source, as the
7202 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
7203 NULL_TREE
, false, true, false, &expr
->where
);
7205 /* Cast the pointer to the result. */
7206 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7207 tmp
= fold_convert (pvoid_type_node
, tmp
);
7209 /* Use memcpy to do the transfer. */
7211 = build_call_expr_loc (input_location
,
7212 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
7213 fold_convert (pvoid_type_node
, source
),
7214 fold_convert (size_type_node
,
7215 fold_build2_loc (input_location
,
7217 gfc_array_index_type
,
7220 gfc_add_expr_to_block (&se
->pre
, tmp
);
7222 se
->expr
= info
->descriptor
;
7223 if (expr
->ts
.type
== BT_CHARACTER
)
7224 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7228 /* Deal with scalar results. */
7230 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7231 dest_word_len
, source_bytes
);
7232 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7233 extent
, gfc_index_zero_node
);
7235 if (expr
->ts
.type
== BT_CHARACTER
)
7237 tree direct
, indirect
, free
;
7239 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
7240 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
7243 /* If source is longer than the destination, use a pointer to
7244 the source directly. */
7245 gfc_init_block (&block
);
7246 gfc_add_modify (&block
, tmpdecl
, ptr
);
7247 direct
= gfc_finish_block (&block
);
7249 /* Otherwise, allocate a string with the length of the destination
7250 and copy the source into it. */
7251 gfc_init_block (&block
);
7252 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
7253 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
7254 gfc_add_modify (&block
, tmpdecl
,
7255 fold_convert (TREE_TYPE (ptr
), tmp
));
7256 tmp
= build_call_expr_loc (input_location
,
7257 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7258 fold_convert (pvoid_type_node
, tmpdecl
),
7259 fold_convert (pvoid_type_node
, ptr
),
7260 fold_convert (size_type_node
, extent
));
7261 gfc_add_expr_to_block (&block
, tmp
);
7262 indirect
= gfc_finish_block (&block
);
7264 /* Wrap it up with the condition. */
7265 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
7266 dest_word_len
, source_bytes
);
7267 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
7268 gfc_add_expr_to_block (&se
->pre
, tmp
);
7270 /* Free the temporary string, if necessary. */
7271 free
= gfc_call_free (tmpdecl
);
7272 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7273 dest_word_len
, source_bytes
);
7274 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
7275 gfc_add_expr_to_block (&se
->post
, tmp
);
7278 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7282 tmpdecl
= gfc_create_var (mold_type
, "transfer");
7284 ptr
= convert (build_pointer_type (mold_type
), source
);
7286 /* For CLASS results, allocate the needed memory first. */
7287 if (mold_expr
->ts
.type
== BT_CLASS
)
7290 cdata
= gfc_class_data_get (tmpdecl
);
7291 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
7292 gfc_add_modify (&se
->pre
, cdata
, tmp
);
7295 /* Use memcpy to do the transfer. */
7296 if (mold_expr
->ts
.type
== BT_CLASS
)
7297 tmp
= gfc_class_data_get (tmpdecl
);
7299 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
7301 tmp
= build_call_expr_loc (input_location
,
7302 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7303 fold_convert (pvoid_type_node
, tmp
),
7304 fold_convert (pvoid_type_node
, ptr
),
7305 fold_convert (size_type_node
, extent
));
7306 gfc_add_expr_to_block (&se
->pre
, tmp
);
7308 /* For CLASS results, set the _vptr. */
7309 if (mold_expr
->ts
.type
== BT_CLASS
)
7313 vptr
= gfc_class_vptr_get (tmpdecl
);
7314 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
7316 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7317 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
7325 /* Generate a call to caf_is_present. */
7328 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
7330 tree caf_reference
, caf_decl
, token
, image_index
;
7332 /* Compile the reference chain. */
7333 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
7334 gcc_assert (caf_reference
!= NULL_TREE
);
7336 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
7337 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
7338 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
7339 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
7340 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
7343 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
7344 3, token
, image_index
, caf_reference
);
7348 /* Test whether this ref-chain refs this image only. */
7351 caf_this_image_ref (gfc_ref
*ref
)
7353 for ( ; ref
; ref
= ref
->next
)
7354 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
7355 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
7361 /* Generate code for the ALLOCATED intrinsic.
7362 Generate inline code that directly check the address of the argument. */
7365 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
7367 gfc_actual_arglist
*arg1
;
7370 symbol_attribute caf_attr
;
7372 gfc_init_se (&arg1se
, NULL
);
7373 arg1
= expr
->value
.function
.actual
;
7375 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7377 /* Make sure that class array expressions have both a _data
7378 component reference and an array reference.... */
7379 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
7380 gfc_add_class_array_ref (arg1
->expr
);
7381 /* .... whilst scalars only need the _data component. */
7383 gfc_add_data_component (arg1
->expr
);
7386 /* When arg1 references an allocatable component in a coarray, then call
7387 the caf-library function caf_is_present (). */
7388 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
7389 && arg1
->expr
->value
.function
.isym
7390 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
7391 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
7393 gfc_clear_attr (&caf_attr
);
7394 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
7395 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
7396 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
7399 if (arg1
->expr
->rank
== 0)
7401 /* Allocatable scalar. */
7402 arg1se
.want_pointer
= 1;
7403 gfc_conv_expr (&arg1se
, arg1
->expr
);
7408 /* Allocatable array. */
7409 arg1se
.descriptor_only
= 1;
7410 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7411 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7414 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
7415 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7417 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7421 /* Generate code for the ASSOCIATED intrinsic.
7422 If both POINTER and TARGET are arrays, generate a call to library function
7423 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7424 In other cases, generate inline code that directly compare the address of
7425 POINTER with the address of TARGET. */
7428 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
7430 gfc_actual_arglist
*arg1
;
7431 gfc_actual_arglist
*arg2
;
7436 tree nonzero_charlen
;
7437 tree nonzero_arraylen
;
7441 gfc_init_se (&arg1se
, NULL
);
7442 gfc_init_se (&arg2se
, NULL
);
7443 arg1
= expr
->value
.function
.actual
;
7446 /* Check whether the expression is a scalar or not; we cannot use
7447 arg1->expr->rank as it can be nonzero for proc pointers. */
7448 ss
= gfc_walk_expr (arg1
->expr
);
7449 scalar
= ss
== gfc_ss_terminator
;
7451 gfc_free_ss_chain (ss
);
7455 /* No optional target. */
7458 /* A pointer to a scalar. */
7459 arg1se
.want_pointer
= 1;
7460 gfc_conv_expr (&arg1se
, arg1
->expr
);
7461 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7462 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7463 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7465 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7467 tmp2
= gfc_class_data_get (arg1se
.expr
);
7468 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7469 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7476 /* A pointer to an array. */
7477 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7478 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7480 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7481 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7482 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
7483 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
7488 /* An optional target. */
7489 if (arg2
->expr
->ts
.type
== BT_CLASS
)
7490 gfc_add_data_component (arg2
->expr
);
7492 nonzero_charlen
= NULL_TREE
;
7493 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
7494 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
7496 arg1
->expr
->ts
.u
.cl
->backend_decl
,
7500 /* A pointer to a scalar. */
7501 arg1se
.want_pointer
= 1;
7502 gfc_conv_expr (&arg1se
, arg1
->expr
);
7503 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7504 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7505 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7507 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7508 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
7510 arg2se
.want_pointer
= 1;
7511 gfc_conv_expr (&arg2se
, arg2
->expr
);
7512 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7513 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
7514 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
7516 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7517 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7518 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7519 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7520 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7521 arg1se
.expr
, arg2se
.expr
);
7522 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7523 arg1se
.expr
, null_pointer_node
);
7524 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7525 boolean_type_node
, tmp
, tmp2
);
7529 /* An array pointer of zero length is not associated if target is
7531 arg1se
.descriptor_only
= 1;
7532 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
7533 if (arg1
->expr
->rank
== -1)
7535 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
7536 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7537 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
7540 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
7541 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
7542 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
7543 boolean_type_node
, tmp
,
7544 build_int_cst (TREE_TYPE (tmp
), 0));
7546 /* A pointer to an array, call library function _gfor_associated. */
7547 arg1se
.want_pointer
= 1;
7548 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7550 arg2se
.want_pointer
= 1;
7551 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
7552 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7553 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7554 se
->expr
= build_call_expr_loc (input_location
,
7555 gfor_fndecl_associated
, 2,
7556 arg1se
.expr
, arg2se
.expr
);
7557 se
->expr
= convert (boolean_type_node
, se
->expr
);
7558 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7559 boolean_type_node
, se
->expr
,
7563 /* If target is present zero character length pointers cannot
7565 if (nonzero_charlen
!= NULL_TREE
)
7566 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7568 se
->expr
, nonzero_charlen
);
7571 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7575 /* Generate code for the SAME_TYPE_AS intrinsic.
7576 Generate inline code that directly checks the vindices. */
7579 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
7584 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
7586 gfc_init_se (&se1
, NULL
);
7587 gfc_init_se (&se2
, NULL
);
7589 a
= expr
->value
.function
.actual
->expr
;
7590 b
= expr
->value
.function
.actual
->next
->expr
;
7592 if (UNLIMITED_POLY (a
))
7594 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
7595 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7596 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7599 if (UNLIMITED_POLY (b
))
7601 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
7602 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7603 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7606 if (a
->ts
.type
== BT_CLASS
)
7608 gfc_add_vptr_component (a
);
7609 gfc_add_hash_component (a
);
7611 else if (a
->ts
.type
== BT_DERIVED
)
7612 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7613 a
->ts
.u
.derived
->hash_value
);
7615 if (b
->ts
.type
== BT_CLASS
)
7617 gfc_add_vptr_component (b
);
7618 gfc_add_hash_component (b
);
7620 else if (b
->ts
.type
== BT_DERIVED
)
7621 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7622 b
->ts
.u
.derived
->hash_value
);
7624 gfc_conv_expr (&se1
, a
);
7625 gfc_conv_expr (&se2
, b
);
7627 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
7628 boolean_type_node
, se1
.expr
,
7629 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
7632 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7633 boolean_type_node
, conda
, tmp
);
7636 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7637 boolean_type_node
, condb
, tmp
);
7639 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7643 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
7646 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
7650 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7651 se
->expr
= build_call_expr_loc (input_location
,
7652 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
7653 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7657 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
7660 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
7664 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7666 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
7667 type
= gfc_get_int_type (4);
7668 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
7670 /* Convert it to the required type. */
7671 type
= gfc_typenode_for_spec (&expr
->ts
);
7672 se
->expr
= build_call_expr_loc (input_location
,
7673 gfor_fndecl_si_kind
, 1, arg
);
7674 se
->expr
= fold_convert (type
, se
->expr
);
7678 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
7681 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
7683 gfc_actual_arglist
*actual
;
7686 vec
<tree
, va_gc
> *args
= NULL
;
7688 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
7690 gfc_init_se (&argse
, se
);
7692 /* Pass a NULL pointer for an absent arg. */
7693 if (actual
->expr
== NULL
)
7694 argse
.expr
= null_pointer_node
;
7700 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
7702 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
7703 ts
.type
= BT_INTEGER
;
7704 ts
.kind
= gfc_c_int_kind
;
7705 gfc_convert_type (actual
->expr
, &ts
, 2);
7707 gfc_conv_expr_reference (&argse
, actual
->expr
);
7710 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7711 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7712 vec_safe_push (args
, argse
.expr
);
7715 /* Convert it to the required type. */
7716 type
= gfc_typenode_for_spec (&expr
->ts
);
7717 se
->expr
= build_call_expr_loc_vec (input_location
,
7718 gfor_fndecl_sr_kind
, args
);
7719 se
->expr
= fold_convert (type
, se
->expr
);
7723 /* Generate code for TRIM (A) intrinsic function. */
7726 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
7736 unsigned int num_args
;
7738 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
7739 args
= XALLOCAVEC (tree
, num_args
);
7741 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
7742 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
7743 len
= gfc_create_var (gfc_charlen_type_node
, "len");
7745 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
7746 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
7749 if (expr
->ts
.kind
== 1)
7750 function
= gfor_fndecl_string_trim
;
7751 else if (expr
->ts
.kind
== 4)
7752 function
= gfor_fndecl_string_trim_char4
;
7756 fndecl
= build_addr (function
);
7757 tmp
= build_call_array_loc (input_location
,
7758 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7760 gfc_add_expr_to_block (&se
->pre
, tmp
);
7762 /* Free the temporary afterwards, if necessary. */
7763 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7764 len
, build_int_cst (TREE_TYPE (len
), 0));
7765 tmp
= gfc_call_free (var
);
7766 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
7767 gfc_add_expr_to_block (&se
->post
, tmp
);
7770 se
->string_length
= len
;
7774 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
7777 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
7779 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
7780 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
7782 stmtblock_t block
, body
;
7785 /* We store in charsize the size of a character. */
7786 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
7787 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
7789 /* Get the arguments. */
7790 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7791 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
7793 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
7794 ncopies_type
= TREE_TYPE (ncopies
);
7796 /* Check that NCOPIES is not negative. */
7797 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
7798 build_int_cst (ncopies_type
, 0));
7799 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7800 "Argument NCOPIES of REPEAT intrinsic is negative "
7801 "(its value is %ld)",
7802 fold_convert (long_integer_type_node
, ncopies
));
7804 /* If the source length is zero, any non negative value of NCOPIES
7805 is valid, and nothing happens. */
7806 n
= gfc_create_var (ncopies_type
, "ncopies");
7807 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7808 build_int_cst (size_type_node
, 0));
7809 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
7810 build_int_cst (ncopies_type
, 0), ncopies
);
7811 gfc_add_modify (&se
->pre
, n
, tmp
);
7814 /* Check that ncopies is not too large: ncopies should be less than
7815 (or equal to) MAX / slen, where MAX is the maximal integer of
7816 the gfc_charlen_type_node type. If slen == 0, we need a special
7817 case to avoid the division by zero. */
7818 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
7819 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
7820 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
7821 fold_convert (size_type_node
, max
), slen
);
7822 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
7823 ? size_type_node
: ncopies_type
;
7824 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7825 fold_convert (largest
, ncopies
),
7826 fold_convert (largest
, max
));
7827 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7828 build_int_cst (size_type_node
, 0));
7829 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
7830 boolean_false_node
, cond
);
7831 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7832 "Argument NCOPIES of REPEAT intrinsic is too large");
7834 /* Compute the destination length. */
7835 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7836 fold_convert (gfc_charlen_type_node
, slen
),
7837 fold_convert (gfc_charlen_type_node
, ncopies
));
7838 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
7839 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
7841 /* Generate the code to do the repeat operation:
7842 for (i = 0; i < ncopies; i++)
7843 memmove (dest + (i * slen * size), src, slen*size); */
7844 gfc_start_block (&block
);
7845 count
= gfc_create_var (ncopies_type
, "count");
7846 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
7847 exit_label
= gfc_build_label_decl (NULL_TREE
);
7849 /* Start the loop body. */
7850 gfc_start_block (&body
);
7852 /* Exit the loop if count >= ncopies. */
7853 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
7855 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7856 TREE_USED (exit_label
) = 1;
7857 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7858 build_empty_stmt (input_location
));
7859 gfc_add_expr_to_block (&body
, tmp
);
7861 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7862 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7863 fold_convert (gfc_charlen_type_node
, slen
),
7864 fold_convert (gfc_charlen_type_node
, count
));
7865 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7866 tmp
, fold_convert (gfc_charlen_type_node
, size
));
7867 tmp
= fold_build_pointer_plus_loc (input_location
,
7868 fold_convert (pvoid_type_node
, dest
), tmp
);
7869 tmp
= build_call_expr_loc (input_location
,
7870 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7872 fold_build2_loc (input_location
, MULT_EXPR
,
7873 size_type_node
, slen
,
7874 fold_convert (size_type_node
,
7876 gfc_add_expr_to_block (&body
, tmp
);
7878 /* Increment count. */
7879 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
7880 count
, build_int_cst (TREE_TYPE (count
), 1));
7881 gfc_add_modify (&body
, count
, tmp
);
7883 /* Build the loop. */
7884 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7885 gfc_add_expr_to_block (&block
, tmp
);
7887 /* Add the exit label. */
7888 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7889 gfc_add_expr_to_block (&block
, tmp
);
7891 /* Finish the block. */
7892 tmp
= gfc_finish_block (&block
);
7893 gfc_add_expr_to_block (&se
->pre
, tmp
);
7895 /* Set the result value. */
7897 se
->string_length
= dlen
;
7901 /* Generate code for the IARGC intrinsic. */
7904 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
7910 /* Call the library function. This always returns an INTEGER(4). */
7911 fndecl
= gfor_fndecl_iargc
;
7912 tmp
= build_call_expr_loc (input_location
,
7915 /* Convert it to the required type. */
7916 type
= gfc_typenode_for_spec (&expr
->ts
);
7917 tmp
= fold_convert (type
, tmp
);
7923 /* The loc intrinsic returns the address of its argument as
7924 gfc_index_integer_kind integer. */
7927 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7932 gcc_assert (!se
->ss
);
7934 arg_expr
= expr
->value
.function
.actual
->expr
;
7935 if (arg_expr
->rank
== 0)
7937 if (arg_expr
->ts
.type
== BT_CLASS
)
7938 gfc_add_data_component (arg_expr
);
7939 gfc_conv_expr_reference (se
, arg_expr
);
7942 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7943 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7945 /* Create a temporary variable for loc return value. Without this,
7946 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7947 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7948 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7949 se
->expr
= temp_var
;
7953 /* The following routine generates code for the intrinsic
7954 functions from the ISO_C_BINDING module:
7960 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7962 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7964 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7966 if (arg
->expr
->rank
== 0)
7967 gfc_conv_expr_reference (se
, arg
->expr
);
7968 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
7969 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7972 gfc_conv_expr_descriptor (se
, arg
->expr
);
7973 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7976 /* TODO -- the following two lines shouldn't be necessary, but if
7977 they're removed, a bug is exposed later in the code path.
7978 This workaround was thus introduced, but will have to be
7979 removed; please see PR 35150 for details about the issue. */
7980 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7981 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7983 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7984 gfc_conv_expr_reference (se
, arg
->expr
);
7985 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7990 /* Build the addr_expr for the first argument. The argument is
7991 already an *address* so we don't need to set want_pointer in
7993 gfc_init_se (&arg1se
, NULL
);
7994 gfc_conv_expr (&arg1se
, arg
->expr
);
7995 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7996 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7998 /* See if we were given two arguments. */
7999 if (arg
->next
->expr
== NULL
)
8000 /* Only given one arg so generate a null and do a
8001 not-equal comparison against the first arg. */
8002 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8004 fold_convert (TREE_TYPE (arg1se
.expr
),
8005 null_pointer_node
));
8011 /* Given two arguments so build the arg2se from second arg. */
8012 gfc_init_se (&arg2se
, NULL
);
8013 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
8014 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8015 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8017 /* Generate test to compare that the two args are equal. */
8018 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8019 arg1se
.expr
, arg2se
.expr
);
8020 /* Generate test to ensure that the first arg is not null. */
8021 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
8023 arg1se
.expr
, null_pointer_node
);
8025 /* Finally, the generated test must check that both arg1 is not
8026 NULL and that it is equal to the second arg. */
8027 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8029 not_null_expr
, eq_expr
);
8037 /* The following routine generates code for the intrinsic
8038 subroutines from the ISO_C_BINDING module:
8040 * C_F_PROCPOINTER. */
8043 conv_isocbinding_subroutine (gfc_code
*code
)
8050 tree desc
, dim
, tmp
, stride
, offset
;
8051 stmtblock_t body
, block
;
8053 gfc_actual_arglist
*arg
= code
->ext
.actual
;
8055 gfc_init_se (&se
, NULL
);
8056 gfc_init_se (&cptrse
, NULL
);
8057 gfc_conv_expr (&cptrse
, arg
->expr
);
8058 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
8059 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
8061 gfc_init_se (&fptrse
, NULL
);
8062 if (arg
->next
->expr
->rank
== 0)
8064 fptrse
.want_pointer
= 1;
8065 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
8066 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
8067 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
8068 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8069 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
8070 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
8072 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8073 TREE_TYPE (fptrse
.expr
),
8075 fold_convert (TREE_TYPE (fptrse
.expr
),
8077 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
8078 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8079 return gfc_finish_block (&se
.pre
);
8082 gfc_start_block (&block
);
8084 /* Get the descriptor of the Fortran pointer. */
8085 fptrse
.descriptor_only
= 1;
8086 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
8087 gfc_add_block_to_block (&block
, &fptrse
.pre
);
8090 /* Set data value, dtype, and offset. */
8091 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
8092 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
8093 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
8094 gfc_get_dtype (TREE_TYPE (desc
)));
8096 /* Start scalarization of the bounds, using the shape argument. */
8098 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
8099 gcc_assert (shape_ss
!= gfc_ss_terminator
);
8100 gfc_init_se (&shapese
, NULL
);
8102 gfc_init_loopinfo (&loop
);
8103 gfc_add_ss_to_loop (&loop
, shape_ss
);
8104 gfc_conv_ss_startstride (&loop
);
8105 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
8106 gfc_mark_ss_chain_used (shape_ss
, 1);
8108 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
8109 shapese
.ss
= shape_ss
;
8111 stride
= gfc_create_var (gfc_array_index_type
, "stride");
8112 offset
= gfc_create_var (gfc_array_index_type
, "offset");
8113 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
8114 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8117 gfc_start_scalarized_body (&loop
, &body
);
8119 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8120 loop
.loopvar
[0], loop
.from
[0]);
8122 /* Set bounds and stride. */
8123 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
8124 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
8126 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
8127 gfc_add_block_to_block (&body
, &shapese
.pre
);
8128 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
8129 gfc_add_block_to_block (&body
, &shapese
.post
);
8131 /* Calculate offset. */
8132 gfc_add_modify (&body
, offset
,
8133 fold_build2_loc (input_location
, PLUS_EXPR
,
8134 gfc_array_index_type
, offset
, stride
));
8135 /* Update stride. */
8136 gfc_add_modify (&body
, stride
,
8137 fold_build2_loc (input_location
, MULT_EXPR
,
8138 gfc_array_index_type
, stride
,
8139 fold_convert (gfc_array_index_type
,
8141 /* Finish scalarization loop. */
8142 gfc_trans_scalarizing_loops (&loop
, &body
);
8143 gfc_add_block_to_block (&block
, &loop
.pre
);
8144 gfc_add_block_to_block (&block
, &loop
.post
);
8145 gfc_add_block_to_block (&block
, &fptrse
.post
);
8146 gfc_cleanup_loop (&loop
);
8148 gfc_add_modify (&block
, offset
,
8149 fold_build1_loc (input_location
, NEGATE_EXPR
,
8150 gfc_array_index_type
, offset
));
8151 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
8153 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
8154 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8155 return gfc_finish_block (&se
.pre
);
8159 /* Save and restore floating-point state. */
8162 gfc_save_fp_state (stmtblock_t
*block
)
8164 tree type
, fpstate
, tmp
;
8166 type
= build_array_type (char_type_node
,
8167 build_range_type (size_type_node
, size_zero_node
,
8168 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
8169 fpstate
= gfc_create_var (type
, "fpstate");
8170 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
8172 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
8174 gfc_add_expr_to_block (block
, tmp
);
8181 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
8185 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
8187 gfc_add_expr_to_block (block
, tmp
);
8191 /* Generate code for arguments of IEEE functions. */
8194 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
8197 gfc_actual_arglist
*actual
;
8202 actual
= expr
->value
.function
.actual
;
8203 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
8205 gcc_assert (actual
);
8208 gfc_init_se (&argse
, se
);
8209 gfc_conv_expr_val (&argse
, e
);
8211 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8212 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8213 argarray
[arg
] = argse
.expr
;
8218 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8219 and IEEE_UNORDERED, which translate directly to GCC type-generic
8223 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
8224 enum built_in_function code
, int nargs
)
8227 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
8229 conv_ieee_function_args (se
, expr
, args
, nargs
);
8230 se
->expr
= build_call_expr_loc_array (input_location
,
8231 builtin_decl_explicit (code
),
8233 STRIP_TYPE_NOPS (se
->expr
);
8234 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8238 /* Generate code for IEEE_IS_NORMAL intrinsic:
8239 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8242 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
8244 tree arg
, isnormal
, iszero
;
8246 /* Convert arg, evaluate it only once. */
8247 conv_ieee_function_args (se
, expr
, &arg
, 1);
8248 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8250 isnormal
= build_call_expr_loc (input_location
,
8251 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
8253 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
8254 build_real_from_int_cst (TREE_TYPE (arg
),
8255 integer_zero_node
));
8256 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8257 boolean_type_node
, isnormal
, iszero
);
8258 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8262 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8263 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8266 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
8268 tree arg
, signbit
, isnan
;
8270 /* Convert arg, evaluate it only once. */
8271 conv_ieee_function_args (se
, expr
, &arg
, 1);
8272 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8274 isnan
= build_call_expr_loc (input_location
,
8275 builtin_decl_explicit (BUILT_IN_ISNAN
),
8277 STRIP_TYPE_NOPS (isnan
);
8279 signbit
= build_call_expr_loc (input_location
,
8280 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8282 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8283 signbit
, integer_zero_node
);
8285 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8286 boolean_type_node
, signbit
,
8287 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
8288 TREE_TYPE(isnan
), isnan
));
8290 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8294 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8297 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
8298 enum built_in_function code
)
8300 tree arg
, decl
, call
, fpstate
;
8303 conv_ieee_function_args (se
, expr
, &arg
, 1);
8304 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
8305 decl
= builtin_decl_for_precision (code
, argprec
);
8307 /* Save floating-point state. */
8308 fpstate
= gfc_save_fp_state (&se
->pre
);
8310 /* Make the function call. */
8311 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
8312 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
8314 /* Restore floating-point state. */
8315 gfc_restore_fp_state (&se
->post
, fpstate
);
8319 /* Generate code for IEEE_REM. */
8322 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
8324 tree args
[2], decl
, call
, fpstate
;
8327 conv_ieee_function_args (se
, expr
, args
, 2);
8329 /* If arguments have unequal size, convert them to the larger. */
8330 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
8331 > TYPE_PRECISION (TREE_TYPE (args
[1])))
8332 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8333 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
8334 > TYPE_PRECISION (TREE_TYPE (args
[0])))
8335 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
8337 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8338 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
8340 /* Save floating-point state. */
8341 fpstate
= gfc_save_fp_state (&se
->pre
);
8343 /* Make the function call. */
8344 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8345 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8347 /* Restore floating-point state. */
8348 gfc_restore_fp_state (&se
->post
, fpstate
);
8352 /* Generate code for IEEE_NEXT_AFTER. */
8355 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
8357 tree args
[2], decl
, call
, fpstate
;
8360 conv_ieee_function_args (se
, expr
, args
, 2);
8362 /* Result has the characteristics of first argument. */
8363 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8364 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8365 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
8367 /* Save floating-point state. */
8368 fpstate
= gfc_save_fp_state (&se
->pre
);
8370 /* Make the function call. */
8371 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8372 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8374 /* Restore floating-point state. */
8375 gfc_restore_fp_state (&se
->post
, fpstate
);
8379 /* Generate code for IEEE_SCALB. */
8382 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
8384 tree args
[2], decl
, call
, huge
, type
;
8387 conv_ieee_function_args (se
, expr
, args
, 2);
8389 /* Result has the characteristics of first argument. */
8390 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8391 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
8393 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
8395 /* We need to fold the integer into the range of a C int. */
8396 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
8397 type
= TREE_TYPE (args
[1]);
8399 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
8400 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
8402 huge
= fold_convert (type
, huge
);
8403 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
8405 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
8406 fold_build1_loc (input_location
, NEGATE_EXPR
,
8410 args
[1] = fold_convert (integer_type_node
, args
[1]);
8412 /* Make the function call. */
8413 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8414 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8418 /* Generate code for IEEE_COPY_SIGN. */
8421 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
8423 tree args
[2], decl
, sign
;
8426 conv_ieee_function_args (se
, expr
, args
, 2);
8428 /* Get the sign of the second argument. */
8429 sign
= build_call_expr_loc (input_location
,
8430 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8432 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8433 sign
, integer_zero_node
);
8435 /* Create a value of one, with the right sign. */
8436 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
8438 fold_build1_loc (input_location
, NEGATE_EXPR
,
8442 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
8444 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8445 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
8447 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8451 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8455 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
8457 const char *name
= expr
->value
.function
.name
;
8459 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8461 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
8462 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
8463 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
8464 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
8465 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
8466 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
8467 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
8468 conv_intrinsic_ieee_is_normal (se
, expr
);
8469 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
8470 conv_intrinsic_ieee_is_negative (se
, expr
);
8471 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
8472 conv_intrinsic_ieee_copy_sign (se
, expr
);
8473 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
8474 conv_intrinsic_ieee_scalb (se
, expr
);
8475 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
8476 conv_intrinsic_ieee_next_after (se
, expr
);
8477 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
8478 conv_intrinsic_ieee_rem (se
, expr
);
8479 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
8480 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
8481 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
8482 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
8484 /* It is not among the functions we translate directly. We return
8485 false, so a library function call is emitted. */
8494 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8497 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
8499 tree arg
, res
, restype
;
8501 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8502 arg
= fold_convert (size_type_node
, arg
);
8503 res
= build_call_expr_loc (input_location
,
8504 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
8505 restype
= gfc_typenode_for_spec (&expr
->ts
);
8506 se
->expr
= fold_convert (restype
, res
);
8510 /* Generate code for an intrinsic function. Some map directly to library
8511 calls, others get special handling. In some cases the name of the function
8512 used depends on the type specifiers. */
8515 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
8521 name
= &expr
->value
.function
.name
[2];
8525 lib
= gfc_is_intrinsic_libcall (expr
);
8529 se
->ignore_optional
= 1;
8531 switch (expr
->value
.function
.isym
->id
)
8533 case GFC_ISYM_EOSHIFT
:
8535 case GFC_ISYM_RESHAPE
:
8536 /* For all of those the first argument specifies the type and the
8537 third is optional. */
8538 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
8542 gfc_conv_intrinsic_funcall (se
, expr
);
8550 switch (expr
->value
.function
.isym
->id
)
8555 case GFC_ISYM_REPEAT
:
8556 gfc_conv_intrinsic_repeat (se
, expr
);
8560 gfc_conv_intrinsic_trim (se
, expr
);
8563 case GFC_ISYM_SC_KIND
:
8564 gfc_conv_intrinsic_sc_kind (se
, expr
);
8567 case GFC_ISYM_SI_KIND
:
8568 gfc_conv_intrinsic_si_kind (se
, expr
);
8571 case GFC_ISYM_SR_KIND
:
8572 gfc_conv_intrinsic_sr_kind (se
, expr
);
8575 case GFC_ISYM_EXPONENT
:
8576 gfc_conv_intrinsic_exponent (se
, expr
);
8580 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8582 fndecl
= gfor_fndecl_string_scan
;
8584 fndecl
= gfor_fndecl_string_scan_char4
;
8588 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8591 case GFC_ISYM_VERIFY
:
8592 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8594 fndecl
= gfor_fndecl_string_verify
;
8596 fndecl
= gfor_fndecl_string_verify_char4
;
8600 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8603 case GFC_ISYM_ALLOCATED
:
8604 gfc_conv_allocated (se
, expr
);
8607 case GFC_ISYM_ASSOCIATED
:
8608 gfc_conv_associated(se
, expr
);
8611 case GFC_ISYM_SAME_TYPE_AS
:
8612 gfc_conv_same_type_as (se
, expr
);
8616 gfc_conv_intrinsic_abs (se
, expr
);
8619 case GFC_ISYM_ADJUSTL
:
8620 if (expr
->ts
.kind
== 1)
8621 fndecl
= gfor_fndecl_adjustl
;
8622 else if (expr
->ts
.kind
== 4)
8623 fndecl
= gfor_fndecl_adjustl_char4
;
8627 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8630 case GFC_ISYM_ADJUSTR
:
8631 if (expr
->ts
.kind
== 1)
8632 fndecl
= gfor_fndecl_adjustr
;
8633 else if (expr
->ts
.kind
== 4)
8634 fndecl
= gfor_fndecl_adjustr_char4
;
8638 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8641 case GFC_ISYM_AIMAG
:
8642 gfc_conv_intrinsic_imagpart (se
, expr
);
8646 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
8650 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
8653 case GFC_ISYM_ANINT
:
8654 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
8658 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8662 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
8665 case GFC_ISYM_BTEST
:
8666 gfc_conv_intrinsic_btest (se
, expr
);
8670 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
8674 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
8678 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
8682 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
8685 case GFC_ISYM_C_ASSOCIATED
:
8686 case GFC_ISYM_C_FUNLOC
:
8687 case GFC_ISYM_C_LOC
:
8688 conv_isocbinding_function (se
, expr
);
8691 case GFC_ISYM_ACHAR
:
8693 gfc_conv_intrinsic_char (se
, expr
);
8696 case GFC_ISYM_CONVERSION
:
8698 case GFC_ISYM_LOGICAL
:
8700 gfc_conv_intrinsic_conversion (se
, expr
);
8703 /* Integer conversions are handled separately to make sure we get the
8704 correct rounding mode. */
8709 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
8713 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
8716 case GFC_ISYM_CEILING
:
8717 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
8720 case GFC_ISYM_FLOOR
:
8721 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
8725 gfc_conv_intrinsic_mod (se
, expr
, 0);
8728 case GFC_ISYM_MODULO
:
8729 gfc_conv_intrinsic_mod (se
, expr
, 1);
8732 case GFC_ISYM_CAF_GET
:
8733 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
8737 case GFC_ISYM_CMPLX
:
8738 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
8741 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
8742 gfc_conv_intrinsic_iargc (se
, expr
);
8745 case GFC_ISYM_COMPLEX
:
8746 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
8749 case GFC_ISYM_CONJG
:
8750 gfc_conv_intrinsic_conjg (se
, expr
);
8753 case GFC_ISYM_COUNT
:
8754 gfc_conv_intrinsic_count (se
, expr
);
8757 case GFC_ISYM_CTIME
:
8758 gfc_conv_intrinsic_ctime (se
, expr
);
8762 gfc_conv_intrinsic_dim (se
, expr
);
8765 case GFC_ISYM_DOT_PRODUCT
:
8766 gfc_conv_intrinsic_dot_product (se
, expr
);
8769 case GFC_ISYM_DPROD
:
8770 gfc_conv_intrinsic_dprod (se
, expr
);
8773 case GFC_ISYM_DSHIFTL
:
8774 gfc_conv_intrinsic_dshift (se
, expr
, true);
8777 case GFC_ISYM_DSHIFTR
:
8778 gfc_conv_intrinsic_dshift (se
, expr
, false);
8781 case GFC_ISYM_FDATE
:
8782 gfc_conv_intrinsic_fdate (se
, expr
);
8785 case GFC_ISYM_FRACTION
:
8786 gfc_conv_intrinsic_fraction (se
, expr
);
8790 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
8794 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8798 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
8801 case GFC_ISYM_IBCLR
:
8802 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
8805 case GFC_ISYM_IBITS
:
8806 gfc_conv_intrinsic_ibits (se
, expr
);
8809 case GFC_ISYM_IBSET
:
8810 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
8813 case GFC_ISYM_IACHAR
:
8814 case GFC_ISYM_ICHAR
:
8815 /* We assume ASCII character sequence. */
8816 gfc_conv_intrinsic_ichar (se
, expr
);
8819 case GFC_ISYM_IARGC
:
8820 gfc_conv_intrinsic_iargc (se
, expr
);
8824 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8827 case GFC_ISYM_INDEX
:
8828 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8830 fndecl
= gfor_fndecl_string_index
;
8832 fndecl
= gfor_fndecl_string_index_char4
;
8836 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8840 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8843 case GFC_ISYM_IPARITY
:
8844 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
8847 case GFC_ISYM_IS_IOSTAT_END
:
8848 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
8851 case GFC_ISYM_IS_IOSTAT_EOR
:
8852 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
8855 case GFC_ISYM_ISNAN
:
8856 gfc_conv_intrinsic_isnan (se
, expr
);
8859 case GFC_ISYM_LSHIFT
:
8860 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8863 case GFC_ISYM_RSHIFT
:
8864 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8867 case GFC_ISYM_SHIFTA
:
8868 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8871 case GFC_ISYM_SHIFTL
:
8872 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8875 case GFC_ISYM_SHIFTR
:
8876 gfc_conv_intrinsic_shift (se
, expr
, true, false);
8879 case GFC_ISYM_ISHFT
:
8880 gfc_conv_intrinsic_ishft (se
, expr
);
8883 case GFC_ISYM_ISHFTC
:
8884 gfc_conv_intrinsic_ishftc (se
, expr
);
8887 case GFC_ISYM_LEADZ
:
8888 gfc_conv_intrinsic_leadz (se
, expr
);
8891 case GFC_ISYM_TRAILZ
:
8892 gfc_conv_intrinsic_trailz (se
, expr
);
8895 case GFC_ISYM_POPCNT
:
8896 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
8899 case GFC_ISYM_POPPAR
:
8900 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
8903 case GFC_ISYM_LBOUND
:
8904 gfc_conv_intrinsic_bound (se
, expr
, 0);
8907 case GFC_ISYM_LCOBOUND
:
8908 conv_intrinsic_cobound (se
, expr
);
8911 case GFC_ISYM_TRANSPOSE
:
8912 /* The scalarizer has already been set up for reversed dimension access
8913 order ; now we just get the argument value normally. */
8914 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
8918 gfc_conv_intrinsic_len (se
, expr
);
8921 case GFC_ISYM_LEN_TRIM
:
8922 gfc_conv_intrinsic_len_trim (se
, expr
);
8926 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
8930 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
8934 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
8938 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
8941 case GFC_ISYM_MALLOC
:
8942 gfc_conv_intrinsic_malloc (se
, expr
);
8945 case GFC_ISYM_MASKL
:
8946 gfc_conv_intrinsic_mask (se
, expr
, 1);
8949 case GFC_ISYM_MASKR
:
8950 gfc_conv_intrinsic_mask (se
, expr
, 0);
8954 if (expr
->ts
.type
== BT_CHARACTER
)
8955 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
8957 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
8960 case GFC_ISYM_MAXLOC
:
8961 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8964 case GFC_ISYM_MAXVAL
:
8965 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
8968 case GFC_ISYM_MERGE
:
8969 gfc_conv_intrinsic_merge (se
, expr
);
8972 case GFC_ISYM_MERGE_BITS
:
8973 gfc_conv_intrinsic_merge_bits (se
, expr
);
8977 if (expr
->ts
.type
== BT_CHARACTER
)
8978 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
8980 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
8983 case GFC_ISYM_MINLOC
:
8984 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8987 case GFC_ISYM_MINVAL
:
8988 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
8991 case GFC_ISYM_NEAREST
:
8992 gfc_conv_intrinsic_nearest (se
, expr
);
8995 case GFC_ISYM_NORM2
:
8996 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
9000 gfc_conv_intrinsic_not (se
, expr
);
9004 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9007 case GFC_ISYM_PARITY
:
9008 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
9011 case GFC_ISYM_PRESENT
:
9012 gfc_conv_intrinsic_present (se
, expr
);
9015 case GFC_ISYM_PRODUCT
:
9016 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
9020 gfc_conv_intrinsic_rank (se
, expr
);
9023 case GFC_ISYM_RRSPACING
:
9024 gfc_conv_intrinsic_rrspacing (se
, expr
);
9027 case GFC_ISYM_SET_EXPONENT
:
9028 gfc_conv_intrinsic_set_exponent (se
, expr
);
9031 case GFC_ISYM_SCALE
:
9032 gfc_conv_intrinsic_scale (se
, expr
);
9036 gfc_conv_intrinsic_sign (se
, expr
);
9040 gfc_conv_intrinsic_size (se
, expr
);
9043 case GFC_ISYM_SIZEOF
:
9044 case GFC_ISYM_C_SIZEOF
:
9045 gfc_conv_intrinsic_sizeof (se
, expr
);
9048 case GFC_ISYM_STORAGE_SIZE
:
9049 gfc_conv_intrinsic_storage_size (se
, expr
);
9052 case GFC_ISYM_SPACING
:
9053 gfc_conv_intrinsic_spacing (se
, expr
);
9056 case GFC_ISYM_STRIDE
:
9057 conv_intrinsic_stride (se
, expr
);
9061 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
9064 case GFC_ISYM_TRANSFER
:
9065 if (se
->ss
&& se
->ss
->info
->useflags
)
9066 /* Access the previously obtained result. */
9067 gfc_conv_tmp_array_ref (se
);
9069 gfc_conv_intrinsic_transfer (se
, expr
);
9072 case GFC_ISYM_TTYNAM
:
9073 gfc_conv_intrinsic_ttynam (se
, expr
);
9076 case GFC_ISYM_UBOUND
:
9077 gfc_conv_intrinsic_bound (se
, expr
, 1);
9080 case GFC_ISYM_UCOBOUND
:
9081 conv_intrinsic_cobound (se
, expr
);
9085 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9089 gfc_conv_intrinsic_loc (se
, expr
);
9092 case GFC_ISYM_THIS_IMAGE
:
9093 /* For num_images() == 1, handle as LCOBOUND. */
9094 if (expr
->value
.function
.actual
->expr
9095 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
9096 conv_intrinsic_cobound (se
, expr
);
9098 trans_this_image (se
, expr
);
9101 case GFC_ISYM_IMAGE_INDEX
:
9102 trans_image_index (se
, expr
);
9105 case GFC_ISYM_NUM_IMAGES
:
9106 trans_num_images (se
, expr
);
9109 case GFC_ISYM_ACCESS
:
9110 case GFC_ISYM_CHDIR
:
9111 case GFC_ISYM_CHMOD
:
9112 case GFC_ISYM_DTIME
:
9113 case GFC_ISYM_ETIME
:
9114 case GFC_ISYM_EXTENDS_TYPE_OF
:
9116 case GFC_ISYM_FGETC
:
9119 case GFC_ISYM_FPUTC
:
9120 case GFC_ISYM_FSTAT
:
9121 case GFC_ISYM_FTELL
:
9122 case GFC_ISYM_GETCWD
:
9123 case GFC_ISYM_GETGID
:
9124 case GFC_ISYM_GETPID
:
9125 case GFC_ISYM_GETUID
:
9126 case GFC_ISYM_HOSTNM
:
9128 case GFC_ISYM_IERRNO
:
9129 case GFC_ISYM_IRAND
:
9130 case GFC_ISYM_ISATTY
:
9133 case GFC_ISYM_LSTAT
:
9134 case GFC_ISYM_MATMUL
:
9135 case GFC_ISYM_MCLOCK
:
9136 case GFC_ISYM_MCLOCK8
:
9138 case GFC_ISYM_RENAME
:
9139 case GFC_ISYM_SECOND
:
9140 case GFC_ISYM_SECNDS
:
9141 case GFC_ISYM_SIGNAL
:
9143 case GFC_ISYM_SYMLNK
:
9144 case GFC_ISYM_SYSTEM
:
9146 case GFC_ISYM_TIME8
:
9147 case GFC_ISYM_UMASK
:
9148 case GFC_ISYM_UNLINK
:
9150 gfc_conv_intrinsic_funcall (se
, expr
);
9153 case GFC_ISYM_EOSHIFT
:
9155 case GFC_ISYM_RESHAPE
:
9156 /* For those, expr->rank should always be >0 and thus the if above the
9157 switch should have matched. */
9162 gfc_conv_intrinsic_lib_function (se
, expr
);
9169 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
9171 gfc_ss
*arg_ss
, *tmp_ss
;
9172 gfc_actual_arglist
*arg
;
9174 arg
= expr
->value
.function
.actual
;
9176 gcc_assert (arg
->expr
);
9178 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
9179 gcc_assert (arg_ss
!= gfc_ss_terminator
);
9181 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
9183 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
9184 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
9186 gcc_assert (tmp_ss
->dimen
== 2);
9188 /* We just invert dimensions. */
9189 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
9192 /* Stop when tmp_ss points to the last valid element of the chain... */
9193 if (tmp_ss
->next
== gfc_ss_terminator
)
9197 /* ... so that we can attach the rest of the chain to it. */
9204 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9205 This has the side effect of reversing the nested list, so there is no
9206 need to call gfc_reverse_ss on it (the given list is assumed not to be
9210 nest_loop_dimension (gfc_ss
*ss
, int dim
)
9213 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
9214 gfc_loopinfo
*new_loop
;
9216 gcc_assert (ss
!= gfc_ss_terminator
);
9218 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
9220 new_ss
= gfc_get_ss ();
9221 new_ss
->next
= prev_ss
;
9222 new_ss
->parent
= ss
;
9223 new_ss
->info
= ss
->info
;
9224 new_ss
->info
->refcount
++;
9227 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
9228 && ss
->info
->type
!= GFC_SS_REFERENCE
);
9231 new_ss
->dim
[0] = ss
->dim
[dim
];
9233 gcc_assert (dim
< ss
->dimen
);
9235 ss_dim
= --ss
->dimen
;
9236 for (i
= dim
; i
< ss_dim
; i
++)
9237 ss
->dim
[i
] = ss
->dim
[i
+ 1];
9239 ss
->dim
[ss_dim
] = 0;
9245 ss
->nested_ss
->parent
= new_ss
;
9246 new_ss
->nested_ss
= ss
->nested_ss
;
9248 ss
->nested_ss
= new_ss
;
9251 new_loop
= gfc_get_loopinfo ();
9252 gfc_init_loopinfo (new_loop
);
9254 gcc_assert (prev_ss
!= NULL
);
9255 gcc_assert (prev_ss
!= gfc_ss_terminator
);
9256 gfc_add_ss_to_loop (new_loop
, prev_ss
);
9257 return new_ss
->parent
;
9261 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9262 is to be inlined. */
9265 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
9267 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
9268 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
9270 bool scalar_mask
= false;
9272 /* The rank of the result will be determined later. */
9273 arg1
= expr
->value
.function
.actual
;
9276 gcc_assert (arg3
!= NULL
);
9278 if (expr
->rank
== 0)
9281 tmp_ss
= gfc_ss_terminator
;
9287 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
9288 if (mask_ss
== tmp_ss
)
9294 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
9295 gcc_assert (array_ss
!= tmp_ss
);
9297 /* Odd thing: If the mask is scalar, it is used by the frontend after
9298 the array (to make an if around the nested loop). Thus it shall
9299 be after array_ss once the gfc_ss list is reversed. */
9301 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
9305 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9307 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
9308 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
9316 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
9319 switch (expr
->value
.function
.isym
->id
)
9321 case GFC_ISYM_PRODUCT
:
9323 return walk_inline_intrinsic_arith (ss
, expr
);
9325 case GFC_ISYM_TRANSPOSE
:
9326 return walk_inline_intrinsic_transpose (ss
, expr
);
9335 /* This generates code to execute before entering the scalarization loop.
9336 Currently does nothing. */
9339 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
9341 switch (ss
->info
->expr
->value
.function
.isym
->id
)
9343 case GFC_ISYM_UBOUND
:
9344 case GFC_ISYM_LBOUND
:
9345 case GFC_ISYM_UCOBOUND
:
9346 case GFC_ISYM_LCOBOUND
:
9347 case GFC_ISYM_THIS_IMAGE
:
9356 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9357 are expanded into code inside the scalarization loop. */
9360 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
9362 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
9363 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
9365 /* The two argument version returns a scalar. */
9366 if (expr
->value
.function
.actual
->next
->expr
)
9369 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
9373 /* Walk an intrinsic array libcall. */
9376 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
9378 gcc_assert (expr
->rank
> 0);
9379 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9383 /* Return whether the function call expression EXPR will be expanded
9384 inline by gfc_conv_intrinsic_function. */
9387 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
9389 gfc_actual_arglist
*args
;
9391 if (!expr
->value
.function
.isym
)
9394 switch (expr
->value
.function
.isym
->id
)
9396 case GFC_ISYM_PRODUCT
:
9398 /* Disable inline expansion if code size matters. */
9402 args
= expr
->value
.function
.actual
;
9403 /* We need to be able to subset the SUM argument at compile-time. */
9404 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
9409 case GFC_ISYM_TRANSPOSE
:
9418 /* Returns nonzero if the specified intrinsic function call maps directly to
9419 an external library call. Should only be used for functions that return
9423 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
9425 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
9426 gcc_assert (expr
->rank
> 0);
9428 if (gfc_inline_intrinsic_function_p (expr
))
9431 switch (expr
->value
.function
.isym
->id
)
9435 case GFC_ISYM_COUNT
:
9439 case GFC_ISYM_IPARITY
:
9440 case GFC_ISYM_MATMUL
:
9441 case GFC_ISYM_MAXLOC
:
9442 case GFC_ISYM_MAXVAL
:
9443 case GFC_ISYM_MINLOC
:
9444 case GFC_ISYM_MINVAL
:
9445 case GFC_ISYM_NORM2
:
9446 case GFC_ISYM_PARITY
:
9447 case GFC_ISYM_PRODUCT
:
9449 case GFC_ISYM_SHAPE
:
9450 case GFC_ISYM_SPREAD
:
9452 /* Ignore absent optional parameters. */
9455 case GFC_ISYM_RESHAPE
:
9456 case GFC_ISYM_CSHIFT
:
9457 case GFC_ISYM_EOSHIFT
:
9459 case GFC_ISYM_UNPACK
:
9460 /* Pass absent optional parameters. */
9468 /* Walk an intrinsic function. */
9470 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
9471 gfc_intrinsic_sym
* isym
)
9475 if (isym
->elemental
)
9476 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9477 NULL
, GFC_SS_SCALAR
);
9479 if (expr
->rank
== 0)
9482 if (gfc_inline_intrinsic_function_p (expr
))
9483 return walk_inline_intrinsic_function (ss
, expr
);
9485 if (gfc_is_intrinsic_libcall (expr
))
9486 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9488 /* Special cases. */
9491 case GFC_ISYM_LBOUND
:
9492 case GFC_ISYM_LCOBOUND
:
9493 case GFC_ISYM_UBOUND
:
9494 case GFC_ISYM_UCOBOUND
:
9495 case GFC_ISYM_THIS_IMAGE
:
9496 return gfc_walk_intrinsic_bound (ss
, expr
);
9498 case GFC_ISYM_TRANSFER
:
9499 case GFC_ISYM_CAF_GET
:
9500 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9503 /* This probably meant someone forgot to add an intrinsic to the above
9504 list(s) when they implemented it, or something's gone horribly
9512 conv_co_collective (gfc_code
*code
)
9515 stmtblock_t block
, post_block
;
9516 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
9517 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
9519 gfc_start_block (&block
);
9520 gfc_init_block (&post_block
);
9522 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
9524 opr_expr
= code
->ext
.actual
->next
->expr
;
9525 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
9526 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9527 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
9532 image_idx_expr
= code
->ext
.actual
->next
->expr
;
9533 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9534 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9540 gfc_init_se (&argse
, NULL
);
9541 gfc_conv_expr (&argse
, stat_expr
);
9542 gfc_add_block_to_block (&block
, &argse
.pre
);
9543 gfc_add_block_to_block (&post_block
, &argse
.post
);
9545 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
9546 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
9548 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9551 stat
= null_pointer_node
;
9553 /* Early exit for GFC_FCOARRAY_SINGLE. */
9554 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9556 if (stat
!= NULL_TREE
)
9557 gfc_add_modify (&block
, stat
,
9558 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
9559 return gfc_finish_block (&block
);
9562 /* Handle the array. */
9563 gfc_init_se (&argse
, NULL
);
9564 if (code
->ext
.actual
->expr
->rank
== 0)
9566 symbol_attribute attr
;
9567 gfc_clear_attr (&attr
);
9568 gfc_init_se (&argse
, NULL
);
9569 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9570 gfc_add_block_to_block (&block
, &argse
.pre
);
9571 gfc_add_block_to_block (&post_block
, &argse
.post
);
9572 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
9573 array
= gfc_build_addr_expr (NULL_TREE
, array
);
9577 argse
.want_pointer
= 1;
9578 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
9581 gfc_add_block_to_block (&block
, &argse
.pre
);
9582 gfc_add_block_to_block (&post_block
, &argse
.post
);
9584 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
9585 strlen
= argse
.string_length
;
9587 strlen
= integer_zero_node
;
9592 gfc_init_se (&argse
, NULL
);
9593 gfc_conv_expr (&argse
, image_idx_expr
);
9594 gfc_add_block_to_block (&block
, &argse
.pre
);
9595 gfc_add_block_to_block (&post_block
, &argse
.post
);
9596 image_index
= fold_convert (integer_type_node
, argse
.expr
);
9599 image_index
= integer_zero_node
;
9604 gfc_init_se (&argse
, NULL
);
9605 gfc_conv_expr (&argse
, errmsg_expr
);
9606 gfc_add_block_to_block (&block
, &argse
.pre
);
9607 gfc_add_block_to_block (&post_block
, &argse
.post
);
9608 errmsg
= argse
.expr
;
9609 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
9613 errmsg
= null_pointer_node
;
9614 errmsg_len
= integer_zero_node
;
9617 /* Generate the function call. */
9618 switch (code
->resolved_isym
->id
)
9620 case GFC_ISYM_CO_BROADCAST
:
9621 fndecl
= gfor_fndecl_co_broadcast
;
9623 case GFC_ISYM_CO_MAX
:
9624 fndecl
= gfor_fndecl_co_max
;
9626 case GFC_ISYM_CO_MIN
:
9627 fndecl
= gfor_fndecl_co_min
;
9629 case GFC_ISYM_CO_REDUCE
:
9630 fndecl
= gfor_fndecl_co_reduce
;
9632 case GFC_ISYM_CO_SUM
:
9633 fndecl
= gfor_fndecl_co_sum
;
9639 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
9640 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
9641 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
9642 image_index
, stat
, errmsg
, errmsg_len
);
9643 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
9644 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
9645 stat
, errmsg
, strlen
, errmsg_len
);
9648 tree opr
, opr_flags
;
9650 // FIXME: Handle TS29113's bind(C) strings with descriptor.
9652 if (gfc_is_proc_ptr_comp (opr_expr
))
9654 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
9655 opr_flag_int
= sym
->attr
.dimension
9656 || (sym
->ts
.type
== BT_CHARACTER
9657 && !sym
->attr
.is_bind_c
)
9658 ? GFC_CAF_BYREF
: 0;
9659 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9660 && !sym
->attr
.is_bind_c
9661 ? GFC_CAF_HIDDENLEN
: 0;
9662 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
9666 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
9667 ? GFC_CAF_BYREF
: 0;
9668 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9669 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
9670 ? GFC_CAF_HIDDENLEN
: 0;
9671 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
9672 ? GFC_CAF_ARG_VALUE
: 0;
9674 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
9675 gfc_conv_expr (&argse
, opr_expr
);
9677 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
9678 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
9681 gfc_add_expr_to_block (&block
, fndecl
);
9682 gfc_add_block_to_block (&block
, &post_block
);
9684 return gfc_finish_block (&block
);
9689 conv_intrinsic_atomic_op (gfc_code
*code
)
9692 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
9693 stmtblock_t block
, post_block
;
9694 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9695 gfc_expr
*stat_expr
;
9696 built_in_function fn
;
9698 if (atom_expr
->expr_type
== EXPR_FUNCTION
9699 && atom_expr
->value
.function
.isym
9700 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9701 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9703 gfc_start_block (&block
);
9704 gfc_init_block (&post_block
);
9706 gfc_init_se (&argse
, NULL
);
9707 argse
.want_pointer
= 1;
9708 gfc_conv_expr (&argse
, atom_expr
);
9709 gfc_add_block_to_block (&block
, &argse
.pre
);
9710 gfc_add_block_to_block (&post_block
, &argse
.post
);
9713 gfc_init_se (&argse
, NULL
);
9714 if (flag_coarray
== GFC_FCOARRAY_LIB
9715 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9716 argse
.want_pointer
= 1;
9717 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9718 gfc_add_block_to_block (&block
, &argse
.pre
);
9719 gfc_add_block_to_block (&post_block
, &argse
.post
);
9722 switch (code
->resolved_isym
->id
)
9724 case GFC_ISYM_ATOMIC_ADD
:
9725 case GFC_ISYM_ATOMIC_AND
:
9726 case GFC_ISYM_ATOMIC_DEF
:
9727 case GFC_ISYM_ATOMIC_OR
:
9728 case GFC_ISYM_ATOMIC_XOR
:
9729 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9730 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9731 old
= null_pointer_node
;
9734 gfc_init_se (&argse
, NULL
);
9735 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9736 argse
.want_pointer
= 1;
9737 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9738 gfc_add_block_to_block (&block
, &argse
.pre
);
9739 gfc_add_block_to_block (&post_block
, &argse
.post
);
9741 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9745 if (stat_expr
!= NULL
)
9747 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
9748 gfc_init_se (&argse
, NULL
);
9749 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9750 argse
.want_pointer
= 1;
9751 gfc_conv_expr_val (&argse
, stat_expr
);
9752 gfc_add_block_to_block (&block
, &argse
.pre
);
9753 gfc_add_block_to_block (&post_block
, &argse
.post
);
9756 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9757 stat
= null_pointer_node
;
9759 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9761 tree image_index
, caf_decl
, offset
, token
;
9764 switch (code
->resolved_isym
->id
)
9766 case GFC_ISYM_ATOMIC_ADD
:
9767 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9768 op
= (int) GFC_CAF_ATOMIC_ADD
;
9770 case GFC_ISYM_ATOMIC_AND
:
9771 case GFC_ISYM_ATOMIC_FETCH_AND
:
9772 op
= (int) GFC_CAF_ATOMIC_AND
;
9774 case GFC_ISYM_ATOMIC_OR
:
9775 case GFC_ISYM_ATOMIC_FETCH_OR
:
9776 op
= (int) GFC_CAF_ATOMIC_OR
;
9778 case GFC_ISYM_ATOMIC_XOR
:
9779 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9780 op
= (int) GFC_CAF_ATOMIC_XOR
;
9782 case GFC_ISYM_ATOMIC_DEF
:
9783 op
= 0; /* Unused. */
9789 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9790 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9791 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9793 if (gfc_is_coindexed (atom_expr
))
9794 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9796 image_index
= integer_zero_node
;
9798 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9800 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9801 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
9802 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9805 gfc_init_se (&argse
, NULL
);
9806 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
9809 gfc_add_block_to_block (&block
, &argse
.pre
);
9810 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
9811 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
9812 token
, offset
, image_index
, value
, stat
,
9813 build_int_cst (integer_type_node
,
9814 (int) atom_expr
->ts
.type
),
9815 build_int_cst (integer_type_node
,
9816 (int) atom_expr
->ts
.kind
));
9818 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
9819 build_int_cst (integer_type_node
, op
),
9820 token
, offset
, image_index
, value
, old
, stat
,
9821 build_int_cst (integer_type_node
,
9822 (int) atom_expr
->ts
.type
),
9823 build_int_cst (integer_type_node
,
9824 (int) atom_expr
->ts
.kind
));
9826 gfc_add_expr_to_block (&block
, tmp
);
9827 gfc_add_block_to_block (&block
, &argse
.post
);
9828 gfc_add_block_to_block (&block
, &post_block
);
9829 return gfc_finish_block (&block
);
9833 switch (code
->resolved_isym
->id
)
9835 case GFC_ISYM_ATOMIC_ADD
:
9836 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9837 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
9839 case GFC_ISYM_ATOMIC_AND
:
9840 case GFC_ISYM_ATOMIC_FETCH_AND
:
9841 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
9843 case GFC_ISYM_ATOMIC_DEF
:
9844 fn
= BUILT_IN_ATOMIC_STORE_N
;
9846 case GFC_ISYM_ATOMIC_OR
:
9847 case GFC_ISYM_ATOMIC_FETCH_OR
:
9848 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
9850 case GFC_ISYM_ATOMIC_XOR
:
9851 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9852 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
9858 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9859 fn
= (built_in_function
) ((int) fn
9860 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9862 tmp
= builtin_decl_explicit (fn
);
9863 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
9864 tmp
= builtin_decl_explicit (fn
);
9866 switch (code
->resolved_isym
->id
)
9868 case GFC_ISYM_ATOMIC_ADD
:
9869 case GFC_ISYM_ATOMIC_AND
:
9870 case GFC_ISYM_ATOMIC_DEF
:
9871 case GFC_ISYM_ATOMIC_OR
:
9872 case GFC_ISYM_ATOMIC_XOR
:
9873 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9874 fold_convert (itype
, value
),
9875 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9876 gfc_add_expr_to_block (&block
, tmp
);
9879 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9880 fold_convert (itype
, value
),
9881 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9882 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
9886 if (stat
!= NULL_TREE
)
9887 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9888 gfc_add_block_to_block (&block
, &post_block
);
9889 return gfc_finish_block (&block
);
9894 conv_intrinsic_atomic_ref (gfc_code
*code
)
9897 tree tmp
, atom
, value
, stat
= NULL_TREE
;
9898 stmtblock_t block
, post_block
;
9899 built_in_function fn
;
9900 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
9902 if (atom_expr
->expr_type
== EXPR_FUNCTION
9903 && atom_expr
->value
.function
.isym
9904 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9905 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9907 gfc_start_block (&block
);
9908 gfc_init_block (&post_block
);
9909 gfc_init_se (&argse
, NULL
);
9910 argse
.want_pointer
= 1;
9911 gfc_conv_expr (&argse
, atom_expr
);
9912 gfc_add_block_to_block (&block
, &argse
.pre
);
9913 gfc_add_block_to_block (&post_block
, &argse
.post
);
9916 gfc_init_se (&argse
, NULL
);
9917 if (flag_coarray
== GFC_FCOARRAY_LIB
9918 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9919 argse
.want_pointer
= 1;
9920 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9921 gfc_add_block_to_block (&block
, &argse
.pre
);
9922 gfc_add_block_to_block (&post_block
, &argse
.post
);
9926 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
9928 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9930 gfc_init_se (&argse
, NULL
);
9931 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9932 argse
.want_pointer
= 1;
9933 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9934 gfc_add_block_to_block (&block
, &argse
.pre
);
9935 gfc_add_block_to_block (&post_block
, &argse
.post
);
9938 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9939 stat
= null_pointer_node
;
9941 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9943 tree image_index
, caf_decl
, offset
, token
;
9944 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
9946 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9947 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9948 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9950 if (gfc_is_coindexed (atom_expr
))
9951 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9953 image_index
= integer_zero_node
;
9955 gfc_init_se (&argse
, NULL
);
9956 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
9958 gfc_add_block_to_block (&block
, &argse
.pre
);
9960 /* Different type, need type conversion. */
9961 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9963 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9965 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
9968 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
9969 token
, offset
, image_index
, value
, stat
,
9970 build_int_cst (integer_type_node
,
9971 (int) atom_expr
->ts
.type
),
9972 build_int_cst (integer_type_node
,
9973 (int) atom_expr
->ts
.kind
));
9974 gfc_add_expr_to_block (&block
, tmp
);
9975 if (vardecl
!= NULL_TREE
)
9976 gfc_add_modify (&block
, orig_value
,
9977 fold_convert (TREE_TYPE (orig_value
), vardecl
));
9978 gfc_add_block_to_block (&block
, &argse
.post
);
9979 gfc_add_block_to_block (&block
, &post_block
);
9980 return gfc_finish_block (&block
);
9983 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9984 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
9985 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9987 tmp
= builtin_decl_explicit (fn
);
9988 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
9989 build_int_cst (integer_type_node
,
9991 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
9993 if (stat
!= NULL_TREE
)
9994 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9995 gfc_add_block_to_block (&block
, &post_block
);
9996 return gfc_finish_block (&block
);
10001 conv_intrinsic_atomic_cas (gfc_code
*code
)
10004 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
10005 stmtblock_t block
, post_block
;
10006 built_in_function fn
;
10007 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10009 if (atom_expr
->expr_type
== EXPR_FUNCTION
10010 && atom_expr
->value
.function
.isym
10011 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10012 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10014 gfc_init_block (&block
);
10015 gfc_init_block (&post_block
);
10016 gfc_init_se (&argse
, NULL
);
10017 argse
.want_pointer
= 1;
10018 gfc_conv_expr (&argse
, atom_expr
);
10021 gfc_init_se (&argse
, NULL
);
10022 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10023 argse
.want_pointer
= 1;
10024 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10025 gfc_add_block_to_block (&block
, &argse
.pre
);
10026 gfc_add_block_to_block (&post_block
, &argse
.post
);
10029 gfc_init_se (&argse
, NULL
);
10030 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10031 argse
.want_pointer
= 1;
10032 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10033 gfc_add_block_to_block (&block
, &argse
.pre
);
10034 gfc_add_block_to_block (&post_block
, &argse
.post
);
10037 gfc_init_se (&argse
, NULL
);
10038 if (flag_coarray
== GFC_FCOARRAY_LIB
10039 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
10040 == atom_expr
->ts
.kind
)
10041 argse
.want_pointer
= 1;
10042 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
10043 gfc_add_block_to_block (&block
, &argse
.pre
);
10044 gfc_add_block_to_block (&post_block
, &argse
.post
);
10045 new_val
= argse
.expr
;
10048 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
10050 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
10052 gfc_init_se (&argse
, NULL
);
10053 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10054 argse
.want_pointer
= 1;
10055 gfc_conv_expr_val (&argse
,
10056 code
->ext
.actual
->next
->next
->next
->next
->expr
);
10057 gfc_add_block_to_block (&block
, &argse
.pre
);
10058 gfc_add_block_to_block (&post_block
, &argse
.post
);
10061 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10062 stat
= null_pointer_node
;
10064 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10066 tree image_index
, caf_decl
, offset
, token
;
10068 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10069 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10070 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10072 if (gfc_is_coindexed (atom_expr
))
10073 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10075 image_index
= integer_zero_node
;
10077 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
10079 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
10080 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
10081 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10084 /* Convert a constant to a pointer. */
10085 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
10087 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
10088 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
10089 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10092 gfc_init_se (&argse
, NULL
);
10093 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10095 gfc_add_block_to_block (&block
, &argse
.pre
);
10097 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
10098 token
, offset
, image_index
, old
, comp
, new_val
,
10099 stat
, build_int_cst (integer_type_node
,
10100 (int) atom_expr
->ts
.type
),
10101 build_int_cst (integer_type_node
,
10102 (int) atom_expr
->ts
.kind
));
10103 gfc_add_expr_to_block (&block
, tmp
);
10104 gfc_add_block_to_block (&block
, &argse
.post
);
10105 gfc_add_block_to_block (&block
, &post_block
);
10106 return gfc_finish_block (&block
);
10109 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10110 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10111 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10113 tmp
= builtin_decl_explicit (fn
);
10115 gfc_add_modify (&block
, old
, comp
);
10116 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
10117 gfc_build_addr_expr (NULL
, old
),
10118 fold_convert (TREE_TYPE (old
), new_val
),
10119 boolean_false_node
,
10120 build_int_cst (NULL
, MEMMODEL_RELAXED
),
10121 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10122 gfc_add_expr_to_block (&block
, tmp
);
10124 if (stat
!= NULL_TREE
)
10125 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10126 gfc_add_block_to_block (&block
, &post_block
);
10127 return gfc_finish_block (&block
);
10131 conv_intrinsic_event_query (gfc_code
*code
)
10134 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
10135 tree count
= NULL_TREE
, count2
= NULL_TREE
;
10137 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
10139 if (code
->ext
.actual
->next
->next
->expr
)
10141 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10143 gfc_init_se (&argse
, NULL
);
10144 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10147 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10148 stat
= null_pointer_node
;
10150 if (code
->ext
.actual
->next
->expr
)
10152 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
10153 gfc_init_se (&argse
, NULL
);
10154 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
10155 count
= argse
.expr
;
10158 gfc_start_block (&se
.pre
);
10159 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10161 tree tmp
, token
, image_index
;
10162 tree index
= size_zero_node
;
10164 if (event_expr
->expr_type
== EXPR_FUNCTION
10165 && event_expr
->value
.function
.isym
10166 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10167 event_expr
= event_expr
->value
.function
.actual
->expr
;
10169 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
10171 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10172 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
10173 != INTMOD_ISO_FORTRAN_ENV
10174 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
10175 != ISOFORTRAN_EVENT_TYPE
)
10177 gfc_error ("Sorry, the event component of derived type at %L is not "
10178 "yet supported", &event_expr
->where
);
10182 if (gfc_is_coindexed (event_expr
))
10184 gfc_error ("The event variable at %L shall not be coindexed ",
10185 &event_expr
->where
);
10189 image_index
= integer_zero_node
;
10191 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10194 /* For arrays, obtain the array index. */
10195 if (gfc_expr_attr (event_expr
).dimension
)
10197 tree desc
, tmp
, extent
, lbound
, ubound
;
10198 gfc_array_ref
*ar
, ar2
;
10201 /* TODO: Extend this, once DT components are supported. */
10202 ar
= &event_expr
->ref
->u
.ar
;
10204 memset (ar
, '\0', sizeof (*ar
));
10206 ar
->type
= AR_FULL
;
10208 gfc_init_se (&argse
, NULL
);
10209 argse
.descriptor_only
= 1;
10210 gfc_conv_expr_descriptor (&argse
, event_expr
);
10211 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
10215 extent
= integer_one_node
;
10216 for (i
= 0; i
< ar
->dimen
; i
++)
10218 gfc_init_se (&argse
, NULL
);
10219 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
10220 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
10221 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
10222 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10223 integer_type_node
, argse
.expr
,
10224 fold_convert(integer_type_node
, lbound
));
10225 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10226 integer_type_node
, extent
, tmp
);
10227 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
10228 integer_type_node
, index
, tmp
);
10229 if (i
< ar
->dimen
- 1)
10231 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
10232 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10233 tmp
= fold_convert (integer_type_node
, tmp
);
10234 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
10235 integer_type_node
, extent
, tmp
);
10240 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
10243 count
= gfc_create_var (integer_type_node
, "count");
10246 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
10249 stat
= gfc_create_var (integer_type_node
, "stat");
10252 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
10253 token
, index
, image_index
, count
10254 ? gfc_build_addr_expr (NULL
, count
) : count
,
10255 stat
!= null_pointer_node
10256 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
10257 gfc_add_expr_to_block (&se
.pre
, tmp
);
10259 if (count2
!= NULL_TREE
)
10260 gfc_add_modify (&se
.pre
, count2
,
10261 fold_convert (TREE_TYPE (count2
), count
));
10263 if (stat2
!= NULL_TREE
)
10264 gfc_add_modify (&se
.pre
, stat2
,
10265 fold_convert (TREE_TYPE (stat2
), stat
));
10267 return gfc_finish_block (&se
.pre
);
10270 gfc_init_se (&argse
, NULL
);
10271 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
10272 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
10274 if (stat
!= NULL_TREE
)
10275 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10277 return gfc_finish_block (&se
.pre
);
10281 conv_intrinsic_move_alloc (gfc_code
*code
)
10284 gfc_expr
*from_expr
, *to_expr
;
10285 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
10286 gfc_se from_se
, to_se
;
10290 gfc_start_block (&block
);
10292 from_expr
= code
->ext
.actual
->expr
;
10293 to_expr
= code
->ext
.actual
->next
->expr
;
10295 gfc_init_se (&from_se
, NULL
);
10296 gfc_init_se (&to_se
, NULL
);
10298 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
10299 || to_expr
->ts
.type
== BT_CLASS
);
10300 coarray
= gfc_get_corank (from_expr
) != 0;
10302 if (from_expr
->rank
== 0 && !coarray
)
10304 if (from_expr
->ts
.type
!= BT_CLASS
)
10305 from_expr2
= from_expr
;
10308 from_expr2
= gfc_copy_expr (from_expr
);
10309 gfc_add_data_component (from_expr2
);
10312 if (to_expr
->ts
.type
!= BT_CLASS
)
10313 to_expr2
= to_expr
;
10316 to_expr2
= gfc_copy_expr (to_expr
);
10317 gfc_add_data_component (to_expr2
);
10320 from_se
.want_pointer
= 1;
10321 to_se
.want_pointer
= 1;
10322 gfc_conv_expr (&from_se
, from_expr2
);
10323 gfc_conv_expr (&to_se
, to_expr2
);
10324 gfc_add_block_to_block (&block
, &from_se
.pre
);
10325 gfc_add_block_to_block (&block
, &to_se
.pre
);
10327 /* Deallocate "to". */
10328 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10329 true, to_expr
, to_expr
->ts
);
10330 gfc_add_expr_to_block (&block
, tmp
);
10332 /* Assign (_data) pointers. */
10333 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10334 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
10336 /* Set "from" to NULL. */
10337 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10338 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
10340 gfc_add_block_to_block (&block
, &from_se
.post
);
10341 gfc_add_block_to_block (&block
, &to_se
.post
);
10344 if (to_expr
->ts
.type
== BT_CLASS
)
10348 gfc_free_expr (to_expr2
);
10349 gfc_init_se (&to_se
, NULL
);
10350 to_se
.want_pointer
= 1;
10351 gfc_add_vptr_component (to_expr
);
10352 gfc_conv_expr (&to_se
, to_expr
);
10354 if (from_expr
->ts
.type
== BT_CLASS
)
10356 if (UNLIMITED_POLY (from_expr
))
10360 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10364 gfc_free_expr (from_expr2
);
10365 gfc_init_se (&from_se
, NULL
);
10366 from_se
.want_pointer
= 1;
10367 gfc_add_vptr_component (from_expr
);
10368 gfc_conv_expr (&from_se
, from_expr
);
10369 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10370 fold_convert (TREE_TYPE (to_se
.expr
),
10373 /* Reset _vptr component to declared type. */
10375 /* Unlimited polymorphic. */
10376 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10377 fold_convert (TREE_TYPE (from_se
.expr
),
10378 null_pointer_node
));
10381 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10382 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10383 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10388 vtab
= gfc_find_vtab (&from_expr
->ts
);
10390 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10391 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10392 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10396 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10398 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10399 fold_convert (TREE_TYPE (to_se
.string_length
),
10400 from_se
.string_length
));
10401 if (from_expr
->ts
.deferred
)
10402 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10403 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10406 return gfc_finish_block (&block
);
10409 /* Update _vptr component. */
10410 if (to_expr
->ts
.type
== BT_CLASS
)
10414 to_se
.want_pointer
= 1;
10415 to_expr2
= gfc_copy_expr (to_expr
);
10416 gfc_add_vptr_component (to_expr2
);
10417 gfc_conv_expr (&to_se
, to_expr2
);
10419 if (from_expr
->ts
.type
== BT_CLASS
)
10421 if (UNLIMITED_POLY (from_expr
))
10425 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10429 from_se
.want_pointer
= 1;
10430 from_expr2
= gfc_copy_expr (from_expr
);
10431 gfc_add_vptr_component (from_expr2
);
10432 gfc_conv_expr (&from_se
, from_expr2
);
10433 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10434 fold_convert (TREE_TYPE (to_se
.expr
),
10437 /* Reset _vptr component to declared type. */
10439 /* Unlimited polymorphic. */
10440 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10441 fold_convert (TREE_TYPE (from_se
.expr
),
10442 null_pointer_node
));
10445 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10446 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10447 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10452 vtab
= gfc_find_vtab (&from_expr
->ts
);
10454 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10455 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10456 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10459 gfc_free_expr (to_expr2
);
10460 gfc_init_se (&to_se
, NULL
);
10462 if (from_expr
->ts
.type
== BT_CLASS
)
10464 gfc_free_expr (from_expr2
);
10465 gfc_init_se (&from_se
, NULL
);
10470 /* Deallocate "to". */
10471 if (from_expr
->rank
== 0)
10473 to_se
.want_coarray
= 1;
10474 from_se
.want_coarray
= 1;
10476 gfc_conv_expr_descriptor (&to_se
, to_expr
);
10477 gfc_conv_expr_descriptor (&from_se
, from_expr
);
10479 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10480 is an image control "statement", cf. IR F08/0040 in 12-006A. */
10481 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10485 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10486 NULL_TREE
, NULL_TREE
, true, to_expr
,
10487 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
10488 gfc_add_expr_to_block (&block
, tmp
);
10490 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10491 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10492 boolean_type_node
, tmp
,
10493 fold_convert (TREE_TYPE (tmp
),
10494 null_pointer_node
));
10495 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
10496 3, null_pointer_node
, null_pointer_node
,
10497 build_int_cst (integer_type_node
, 0));
10499 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
10500 tmp
, build_empty_stmt (input_location
));
10501 gfc_add_expr_to_block (&block
, tmp
);
10505 if (to_expr
->ts
.type
== BT_DERIVED
10506 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
10508 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
10509 to_se
.expr
, to_expr
->rank
);
10510 gfc_add_expr_to_block (&block
, tmp
);
10513 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10514 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10515 NULL_TREE
, true, to_expr
,
10516 GFC_CAF_COARRAY_NOCOARRAY
);
10517 gfc_add_expr_to_block (&block
, tmp
);
10520 /* Move the pointer and update the array descriptor data. */
10521 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
10523 /* Set "from" to NULL. */
10524 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
10525 gfc_add_modify_loc (input_location
, &block
, tmp
,
10526 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
10529 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10531 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10532 fold_convert (TREE_TYPE (to_se
.string_length
),
10533 from_se
.string_length
));
10534 if (from_expr
->ts
.deferred
)
10535 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10536 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10539 return gfc_finish_block (&block
);
10544 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
10548 gcc_assert (code
->resolved_isym
);
10550 switch (code
->resolved_isym
->id
)
10552 case GFC_ISYM_MOVE_ALLOC
:
10553 res
= conv_intrinsic_move_alloc (code
);
10556 case GFC_ISYM_ATOMIC_CAS
:
10557 res
= conv_intrinsic_atomic_cas (code
);
10560 case GFC_ISYM_ATOMIC_ADD
:
10561 case GFC_ISYM_ATOMIC_AND
:
10562 case GFC_ISYM_ATOMIC_DEF
:
10563 case GFC_ISYM_ATOMIC_OR
:
10564 case GFC_ISYM_ATOMIC_XOR
:
10565 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10566 case GFC_ISYM_ATOMIC_FETCH_AND
:
10567 case GFC_ISYM_ATOMIC_FETCH_OR
:
10568 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10569 res
= conv_intrinsic_atomic_op (code
);
10572 case GFC_ISYM_ATOMIC_REF
:
10573 res
= conv_intrinsic_atomic_ref (code
);
10576 case GFC_ISYM_EVENT_QUERY
:
10577 res
= conv_intrinsic_event_query (code
);
10580 case GFC_ISYM_C_F_POINTER
:
10581 case GFC_ISYM_C_F_PROCPOINTER
:
10582 res
= conv_isocbinding_subroutine (code
);
10585 case GFC_ISYM_CAF_SEND
:
10586 res
= conv_caf_send (code
);
10589 case GFC_ISYM_CO_BROADCAST
:
10590 case GFC_ISYM_CO_MIN
:
10591 case GFC_ISYM_CO_MAX
:
10592 case GFC_ISYM_CO_REDUCE
:
10593 case GFC_ISYM_CO_SUM
:
10594 res
= conv_co_collective (code
);
10597 case GFC_ISYM_FREE
:
10598 res
= conv_intrinsic_free (code
);
10601 case GFC_ISYM_SYSTEM_CLOCK
:
10602 res
= conv_intrinsic_system_clock (code
);
10613 #include "gt-fortran-trans-intrinsic.h"