1 /* Intrinsic translation
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "tree-nested.h"
35 #include "stor-layout.h"
36 #include "toplev.h" /* For rest_of_decl_compilation. */
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 #include "dependency.h" /* For CAF array alias analysis. */
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 /* This maps Fortran intrinsic math functions to external library or GCC
46 typedef struct GTY(()) gfc_intrinsic_map_t
{
47 /* The explicit enum is required to work around inadequacies in the
48 garbage collection/gengtype parsing mechanism. */
51 /* Enum value from the "language-independent", aka C-centric, part
52 of gcc, or END_BUILTINS of no such value set. */
53 enum built_in_function float_built_in
;
54 enum built_in_function double_built_in
;
55 enum built_in_function long_double_built_in
;
56 enum built_in_function complex_float_built_in
;
57 enum built_in_function complex_double_built_in
;
58 enum built_in_function complex_long_double_built_in
;
60 /* True if the naming pattern is to prepend "c" for complex and
61 append "f" for kind=4. False if the naming pattern is to
62 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
65 /* True if a complex version of the function exists. */
66 bool complex_available
;
68 /* True if the function should be marked const. */
71 /* The base library name of this function. */
74 /* Cache decls created for the various operand types. */
86 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
87 defines complex variants of all of the entries in mathbuiltins.def
89 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
90 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
91 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
92 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
93 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
95 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
96 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
97 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
98 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
99 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
101 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
102 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
107 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
108 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
109 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
115 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
116 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
117 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
118 #include "mathbuiltins.def"
120 /* Functions in libgfortran. */
121 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
124 LIB_FUNCTION (NONE
, NULL
, false)
129 #undef DEFINE_MATH_BUILTIN
130 #undef DEFINE_MATH_BUILTIN_C
133 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
136 /* Find the correct variant of a given builtin from its argument. */
138 builtin_decl_for_precision (enum built_in_function base_built_in
,
141 enum built_in_function i
= END_BUILTINS
;
143 gfc_intrinsic_map_t
*m
;
144 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
147 if (precision
== TYPE_PRECISION (float_type_node
))
148 i
= m
->float_built_in
;
149 else if (precision
== TYPE_PRECISION (double_type_node
))
150 i
= m
->double_built_in
;
151 else if (precision
== TYPE_PRECISION (long_double_type_node
))
152 i
= m
->long_double_built_in
;
153 else if (precision
== TYPE_PRECISION (gfc_float128_type_node
))
155 /* Special treatment, because it is not exactly a built-in, but
156 a library function. */
157 return m
->real16_decl
;
160 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
165 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
168 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
170 if (gfc_real_kinds
[i
].c_float128
)
172 /* For __float128, the story is a bit different, because we return
173 a decl to a library function rather than a built-in. */
174 gfc_intrinsic_map_t
*m
;
175 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
178 return m
->real16_decl
;
181 return builtin_decl_for_precision (double_built_in
,
182 gfc_real_kinds
[i
].mode_precision
);
186 /* Evaluate the arguments to an intrinsic function. The value
187 of NARGS may be less than the actual number of arguments in EXPR
188 to allow optional "KIND" arguments that are not included in the
189 generated code to be ignored. */
192 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
193 tree
*argarray
, int nargs
)
195 gfc_actual_arglist
*actual
;
197 gfc_intrinsic_arg
*formal
;
201 formal
= expr
->value
.function
.isym
->formal
;
202 actual
= expr
->value
.function
.actual
;
204 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
205 actual
= actual
->next
,
206 formal
= formal
? formal
->next
: NULL
)
210 /* Skip omitted optional arguments. */
217 /* Evaluate the parameter. This will substitute scalarized
218 references automatically. */
219 gfc_init_se (&argse
, se
);
221 if (e
->ts
.type
== BT_CHARACTER
)
223 gfc_conv_expr (&argse
, e
);
224 gfc_conv_string_parameter (&argse
);
225 argarray
[curr_arg
++] = argse
.string_length
;
226 gcc_assert (curr_arg
< nargs
);
229 gfc_conv_expr_val (&argse
, e
);
231 /* If an optional argument is itself an optional dummy argument,
232 check its presence and substitute a null if absent. */
233 if (e
->expr_type
== EXPR_VARIABLE
234 && e
->symtree
->n
.sym
->attr
.optional
237 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
239 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
240 gfc_add_block_to_block (&se
->post
, &argse
.post
);
241 argarray
[curr_arg
] = argse
.expr
;
245 /* Count the number of actual arguments to the intrinsic function EXPR
246 including any "hidden" string length arguments. */
249 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
252 gfc_actual_arglist
*actual
;
254 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
259 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
269 /* Conversions between different types are output by the frontend as
270 intrinsic functions. We implement these directly with inline code. */
273 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
279 nargs
= gfc_intrinsic_argument_list_length (expr
);
280 args
= XALLOCAVEC (tree
, nargs
);
282 /* Evaluate all the arguments passed. Whilst we're only interested in the
283 first one here, there are other parts of the front-end that assume this
284 and will trigger an ICE if it's not the case. */
285 type
= gfc_typenode_for_spec (&expr
->ts
);
286 gcc_assert (expr
->value
.function
.actual
->expr
);
287 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
289 /* Conversion between character kinds involves a call to a library
291 if (expr
->ts
.type
== BT_CHARACTER
)
293 tree fndecl
, var
, addr
, tmp
;
295 if (expr
->ts
.kind
== 1
296 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
297 fndecl
= gfor_fndecl_convert_char4_to_char1
;
298 else if (expr
->ts
.kind
== 4
299 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
300 fndecl
= gfor_fndecl_convert_char1_to_char4
;
304 /* Create the variable storing the converted value. */
305 type
= gfc_get_pchar_type (expr
->ts
.kind
);
306 var
= gfc_create_var (type
, "str");
307 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
309 /* Call the library function that will perform the conversion. */
310 gcc_assert (nargs
>= 2);
311 tmp
= build_call_expr_loc (input_location
,
312 fndecl
, 3, addr
, args
[0], args
[1]);
313 gfc_add_expr_to_block (&se
->pre
, tmp
);
315 /* Free the temporary afterwards. */
316 tmp
= gfc_call_free (var
);
317 gfc_add_expr_to_block (&se
->post
, tmp
);
320 se
->string_length
= args
[0];
325 /* Conversion from complex to non-complex involves taking the real
326 component of the value. */
327 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
328 && expr
->ts
.type
!= BT_COMPLEX
)
332 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
333 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
337 se
->expr
= convert (type
, args
[0]);
340 /* This is needed because the gcc backend only implements
341 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
342 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
343 Similarly for CEILING. */
346 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
353 argtype
= TREE_TYPE (arg
);
354 arg
= gfc_evaluate_now (arg
, pblock
);
356 intval
= convert (type
, arg
);
357 intval
= gfc_evaluate_now (intval
, pblock
);
359 tmp
= convert (argtype
, intval
);
360 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
361 logical_type_node
, tmp
, arg
);
363 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
364 intval
, build_int_cst (type
, 1));
365 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
370 /* Round to nearest integer, away from zero. */
373 build_round_expr (tree arg
, tree restype
)
377 int argprec
, resprec
;
379 argtype
= TREE_TYPE (arg
);
380 argprec
= TYPE_PRECISION (argtype
);
381 resprec
= TYPE_PRECISION (restype
);
383 /* Depending on the type of the result, choose the int intrinsic
384 (iround, available only as a builtin, therefore cannot use it for
385 __float128), long int intrinsic (lround family) or long long
386 intrinsic (llround). We might also need to convert the result
388 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
389 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
390 else if (resprec
<= LONG_TYPE_SIZE
)
391 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
392 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
393 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
397 return fold_convert (restype
, build_call_expr_loc (input_location
,
402 /* Convert a real to an integer using a specific rounding mode.
403 Ideally we would just build the corresponding GENERIC node,
404 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
407 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
408 enum rounding_mode op
)
413 return build_fixbound_expr (pblock
, arg
, type
, 0);
416 return build_fixbound_expr (pblock
, arg
, type
, 1);
419 return build_round_expr (arg
, type
);
422 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
430 /* Round a real value using the specified rounding mode.
431 We use a temporary integer of that same kind size as the result.
432 Values larger than those that can be represented by this kind are
433 unchanged, as they will not be accurate enough to represent the
435 huge = HUGE (KIND (a))
436 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
440 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
452 kind
= expr
->ts
.kind
;
453 nargs
= gfc_intrinsic_argument_list_length (expr
);
456 /* We have builtin functions for some cases. */
460 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
464 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
471 /* Evaluate the argument. */
472 gcc_assert (expr
->value
.function
.actual
->expr
);
473 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
475 /* Use a builtin function if one exists. */
476 if (decl
!= NULL_TREE
)
478 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
482 /* This code is probably redundant, but we'll keep it lying around just
484 type
= gfc_typenode_for_spec (&expr
->ts
);
485 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
487 /* Test if the value is too large to handle sensibly. */
488 gfc_set_model_kind (kind
);
490 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
491 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
492 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
493 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, arg
[0],
496 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
497 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
498 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, arg
[0],
500 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, logical_type_node
,
502 itype
= gfc_get_int_type (kind
);
504 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
505 tmp
= convert (type
, tmp
);
506 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
512 /* Convert to an integer using the specified rounding mode. */
515 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
521 nargs
= gfc_intrinsic_argument_list_length (expr
);
522 args
= XALLOCAVEC (tree
, nargs
);
524 /* Evaluate the argument, we process all arguments even though we only
525 use the first one for code generation purposes. */
526 type
= gfc_typenode_for_spec (&expr
->ts
);
527 gcc_assert (expr
->value
.function
.actual
->expr
);
528 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
530 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
532 /* Conversion to a different integer kind. */
533 se
->expr
= convert (type
, args
[0]);
537 /* Conversion from complex to non-complex involves taking the real
538 component of the value. */
539 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
540 && expr
->ts
.type
!= BT_COMPLEX
)
544 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
545 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
549 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
554 /* Get the imaginary component of a value. */
557 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
561 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
562 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
563 TREE_TYPE (TREE_TYPE (arg
)), arg
);
567 /* Get the complex conjugate of a value. */
570 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
574 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
575 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
581 define_quad_builtin (const char *name
, tree type
, bool is_const
)
584 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
587 /* Mark the decl as external. */
588 DECL_EXTERNAL (fndecl
) = 1;
589 TREE_PUBLIC (fndecl
) = 1;
591 /* Mark it __attribute__((const)). */
592 TREE_READONLY (fndecl
) = is_const
;
594 rest_of_decl_compilation (fndecl
, 1, 0);
601 /* Initialize function decls for library functions. The external functions
602 are created as required. Builtin functions are added here. */
605 gfc_build_intrinsic_lib_fndecls (void)
607 gfc_intrinsic_map_t
*m
;
608 tree quad_decls
[END_BUILTINS
+ 1];
610 if (gfc_real16_is_float128
)
612 /* If we have soft-float types, we create the decls for their
613 C99-like library functions. For now, we only handle __float128
614 q-suffixed functions. */
616 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
617 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
619 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
621 type
= gfc_float128_type_node
;
622 complex_type
= gfc_complex_float128_type_node
;
623 /* type (*) (type) */
624 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
626 func_iround
= build_function_type_list (integer_type_node
,
628 /* long (*) (type) */
629 func_lround
= build_function_type_list (long_integer_type_node
,
631 /* long long (*) (type) */
632 func_llround
= build_function_type_list (long_long_integer_type_node
,
634 /* type (*) (type, type) */
635 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
636 /* type (*) (type, &int) */
638 = build_function_type_list (type
,
640 build_pointer_type (integer_type_node
),
642 /* type (*) (type, int) */
643 func_scalbn
= build_function_type_list (type
,
644 type
, integer_type_node
, NULL_TREE
);
645 /* type (*) (complex type) */
646 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
647 /* complex type (*) (complex type, complex type) */
649 = build_function_type_list (complex_type
,
650 complex_type
, complex_type
, NULL_TREE
);
652 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
653 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
654 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
656 /* Only these built-ins are actually needed here. These are used directly
657 from the code, when calling builtin_decl_for_precision() or
658 builtin_decl_for_float_type(). The others are all constructed by
659 gfc_get_intrinsic_lib_fndecl(). */
660 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
661 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
663 #include "mathbuiltins.def"
667 #undef DEFINE_MATH_BUILTIN
668 #undef DEFINE_MATH_BUILTIN_C
670 /* There is one built-in we defined manually, because it gets called
671 with builtin_decl_for_precision() or builtin_decl_for_float_type()
672 even though it is not an OTHER_BUILTIN: it is SQRT. */
673 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
677 /* Add GCC builtin functions. */
678 for (m
= gfc_intrinsic_map
;
679 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
681 if (m
->float_built_in
!= END_BUILTINS
)
682 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
683 if (m
->complex_float_built_in
!= END_BUILTINS
)
684 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
685 if (m
->double_built_in
!= END_BUILTINS
)
686 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
687 if (m
->complex_double_built_in
!= END_BUILTINS
)
688 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
690 /* If real(kind=10) exists, it is always long double. */
691 if (m
->long_double_built_in
!= END_BUILTINS
)
692 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
693 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
695 = builtin_decl_explicit (m
->complex_long_double_built_in
);
697 if (!gfc_real16_is_float128
)
699 if (m
->long_double_built_in
!= END_BUILTINS
)
700 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
701 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
703 = builtin_decl_explicit (m
->complex_long_double_built_in
);
705 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m
->real16_decl
= quad_decls
[m
->double_built_in
];
712 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
714 /* Same thing for the complex ones. */
715 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
721 /* Create a fndecl for a simple intrinsic library function. */
724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
727 vec
<tree
, va_gc
> *argtypes
;
729 gfc_actual_arglist
*actual
;
732 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
735 if (ts
->type
== BT_REAL
)
740 pdecl
= &m
->real4_decl
;
743 pdecl
= &m
->real8_decl
;
746 pdecl
= &m
->real10_decl
;
749 pdecl
= &m
->real16_decl
;
755 else if (ts
->type
== BT_COMPLEX
)
757 gcc_assert (m
->complex_available
);
762 pdecl
= &m
->complex4_decl
;
765 pdecl
= &m
->complex8_decl
;
768 pdecl
= &m
->complex10_decl
;
771 pdecl
= &m
->complex16_decl
;
785 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
786 if (gfc_real_kinds
[n
].c_float
)
787 snprintf (name
, sizeof (name
), "%s%s%s",
788 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
789 else if (gfc_real_kinds
[n
].c_double
)
790 snprintf (name
, sizeof (name
), "%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
792 else if (gfc_real_kinds
[n
].c_long_double
)
793 snprintf (name
, sizeof (name
), "%s%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
795 else if (gfc_real_kinds
[n
].c_float128
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
803 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
804 ts
->type
== BT_COMPLEX
? 'c' : 'r',
809 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
811 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
812 vec_safe_push (argtypes
, type
);
814 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
815 fndecl
= build_decl (input_location
,
816 FUNCTION_DECL
, get_identifier (name
), type
);
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl
) = 1;
820 TREE_PUBLIC (fndecl
) = 1;
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl
) = m
->is_constant
;
825 rest_of_decl_compilation (fndecl
, 1, 0);
832 /* Convert an intrinsic function into an external or builtin call. */
835 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
837 gfc_intrinsic_map_t
*m
;
841 unsigned int num_args
;
844 id
= expr
->value
.function
.isym
->id
;
845 /* Find the entry for this function. */
846 for (m
= gfc_intrinsic_map
;
847 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
853 if (m
->id
== GFC_ISYM_NONE
)
855 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
856 expr
->value
.function
.name
, id
);
859 /* Get the decl and generate the call. */
860 num_args
= gfc_intrinsic_argument_list_length (expr
);
861 args
= XALLOCAVEC (tree
, num_args
);
863 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
864 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
865 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
867 fndecl
= build_addr (fndecl
);
868 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
877 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
878 tree a
, tree b
, stmtblock_t
* target
)
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
887 /* Compare the two string lengths. */
888 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, a
, b
);
890 /* Output the runtime-check. */
891 name
= gfc_build_cstring_const (intr_name
);
892 name
= gfc_build_addr_expr (pchar_type_node
, name
);
893 gfc_trans_runtime_check (true, false, cond
, target
, where
,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node
, a
),
896 fold_convert (long_integer_type_node
, b
), name
);
900 /* The EXPONENT(X) intrinsic function is translated into
902 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
903 so that if X is a NaN or infinity, the result is HUGE(0).
907 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
909 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
912 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
913 expr
->value
.function
.actual
->expr
->ts
.kind
);
915 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
916 arg
= gfc_evaluate_now (arg
, &se
->pre
);
918 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
919 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
920 cond
= build_call_expr_loc (input_location
,
921 builtin_decl_explicit (BUILT_IN_ISFINITE
),
924 res
= gfc_create_var (integer_type_node
, NULL
);
925 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
926 gfc_build_addr_expr (NULL_TREE
, res
));
927 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
929 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
932 type
= gfc_typenode_for_spec (&expr
->ts
);
933 se
->expr
= fold_convert (type
, se
->expr
);
937 /* Fill in the following structure
938 struct caf_vector_t {
939 size_t nvec; // size of the vector
946 ptrdiff_t lower_bound;
947 ptrdiff_t upper_bound;
954 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
955 tree lower
, tree upper
, tree stride
,
956 tree vector
, int kind
, tree nvec
)
958 tree field
, type
, tmp
;
960 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
961 type
= TREE_TYPE (desc
);
963 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
964 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
965 desc
, field
, NULL_TREE
);
966 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
969 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
970 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
971 desc
, field
, NULL_TREE
);
972 type
= TREE_TYPE (desc
);
974 /* Access the inner struct. */
975 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
976 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
977 desc
, field
, NULL_TREE
);
978 type
= TREE_TYPE (desc
);
980 if (vector
!= NULL_TREE
)
982 /* Set vector and kind. */
983 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
984 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
985 desc
, field
, NULL_TREE
);
986 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
987 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
988 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
989 desc
, field
, NULL_TREE
);
990 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
994 /* Set dim.lower/upper/stride. */
995 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
996 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
997 desc
, field
, NULL_TREE
);
998 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1000 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1001 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1002 desc
, field
, NULL_TREE
);
1003 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1005 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1006 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1007 desc
, field
, NULL_TREE
);
1008 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1014 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1017 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1018 tree lbound
, ubound
, tmp
;
1021 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1023 for (i
= 0; i
< ar
->dimen
; i
++)
1024 switch (ar
->dimen_type
[i
])
1029 gfc_init_se (&argse
, NULL
);
1030 gfc_conv_expr (&argse
, ar
->end
[i
]);
1031 gfc_add_block_to_block (block
, &argse
.pre
);
1032 upper
= gfc_evaluate_now (argse
.expr
, block
);
1035 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1038 gfc_init_se (&argse
, NULL
);
1039 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1040 gfc_add_block_to_block (block
, &argse
.pre
);
1041 stride
= gfc_evaluate_now (argse
.expr
, block
);
1044 stride
= gfc_index_one_node
;
1050 gfc_init_se (&argse
, NULL
);
1051 gfc_conv_expr (&argse
, ar
->start
[i
]);
1052 gfc_add_block_to_block (block
, &argse
.pre
);
1053 lower
= gfc_evaluate_now (argse
.expr
, block
);
1056 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1057 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1060 stride
= gfc_index_one_node
;
1063 nvec
= size_zero_node
;
1064 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1069 gfc_init_se (&argse
, NULL
);
1070 argse
.descriptor_only
= 1;
1071 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1072 gfc_add_block_to_block (block
, &argse
.pre
);
1073 vector
= argse
.expr
;
1074 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1075 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1076 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1077 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1078 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1079 TREE_TYPE (nvec
), nvec
, tmp
);
1080 lower
= gfc_index_zero_node
;
1081 upper
= gfc_index_zero_node
;
1082 stride
= gfc_index_zero_node
;
1083 vector
= gfc_conv_descriptor_data_get (vector
);
1084 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1085 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1090 return gfc_build_addr_expr (NULL_TREE
, var
);
1095 compute_component_offset (tree field
, tree type
)
1098 if (DECL_FIELD_BIT_OFFSET (field
) != NULL_TREE
1099 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field
)))
1101 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
,
1102 DECL_FIELD_BIT_OFFSET (field
),
1104 return fold_build2 (PLUS_EXPR
, type
, DECL_FIELD_OFFSET (field
), tmp
);
1107 return DECL_FIELD_OFFSET (field
);
1112 conv_expr_ref_to_caf_ref (stmtblock_t
*block
, gfc_expr
*expr
)
1114 gfc_ref
*ref
= expr
->ref
, *last_comp_ref
;
1115 tree caf_ref
= NULL_TREE
, prev_caf_ref
= NULL_TREE
, reference_type
, tmp
, tmp2
,
1116 field
, last_type
, inner_struct
, mode
, mode_rhs
, dim_array
, dim
, dim_type
,
1117 start
, end
, stride
, vector
, nvec
;
1119 bool ref_static_array
= false;
1120 tree last_component_ref_tree
= NULL_TREE
;
1125 last_component_ref_tree
= expr
->symtree
->n
.sym
->backend_decl
;
1126 ref_static_array
= !expr
->symtree
->n
.sym
->attr
.allocatable
1127 && !expr
->symtree
->n
.sym
->attr
.pointer
;
1130 /* Prevent uninit-warning. */
1131 reference_type
= NULL_TREE
;
1133 /* Skip refs upto the first coarray-ref. */
1134 last_comp_ref
= NULL
;
1135 while (ref
&& (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
== 0))
1137 /* Remember the type of components skipped. */
1138 if (ref
->type
== REF_COMPONENT
)
1139 last_comp_ref
= ref
;
1142 /* When a component was skipped, get the type information of the last
1143 component ref, else get the type from the symbol. */
1146 last_type
= gfc_typenode_for_spec (&last_comp_ref
->u
.c
.component
->ts
);
1147 last_type_n
= last_comp_ref
->u
.c
.component
->ts
.type
;
1151 last_type
= gfc_typenode_for_spec (&expr
->symtree
->n
.sym
->ts
);
1152 last_type_n
= expr
->symtree
->n
.sym
->ts
.type
;
1157 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0
1158 && ref
->u
.ar
.dimen
== 0)
1160 /* Skip pure coindexes. */
1164 tmp
= gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1165 reference_type
= TREE_TYPE (tmp
);
1167 if (caf_ref
== NULL_TREE
)
1170 /* Construct the chain of refs. */
1171 if (prev_caf_ref
!= NULL_TREE
)
1173 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1174 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1175 TREE_TYPE (field
), prev_caf_ref
, field
,
1177 gfc_add_modify (block
, tmp2
, gfc_build_addr_expr (TREE_TYPE (field
),
1185 last_type
= gfc_typenode_for_spec (&ref
->u
.c
.component
->ts
);
1186 last_type_n
= ref
->u
.c
.component
->ts
.type
;
1187 /* Set the type of the ref. */
1188 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1189 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1190 TREE_TYPE (field
), prev_caf_ref
, field
,
1192 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1193 GFC_CAF_REF_COMPONENT
));
1195 /* Ref the c in union u. */
1196 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1197 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1198 TREE_TYPE (field
), prev_caf_ref
, field
,
1200 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 0);
1201 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1202 TREE_TYPE (field
), tmp
, field
,
1205 /* Set the offset. */
1206 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1207 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1208 TREE_TYPE (field
), inner_struct
, field
,
1210 /* Computing the offset is somewhat harder. The bit_offset has to be
1211 taken into account. When the bit_offset in the field_decl is non-
1212 null, divide it by the bitsize_unit and add it to the regular
1214 tmp2
= compute_component_offset (ref
->u
.c
.component
->backend_decl
,
1216 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1218 /* Set caf_token_offset. */
1219 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 1);
1220 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1221 TREE_TYPE (field
), inner_struct
, field
,
1223 if ((ref
->u
.c
.component
->attr
.allocatable
1224 || ref
->u
.c
.component
->attr
.pointer
)
1225 && ref
->u
.c
.component
->attr
.dimension
)
1227 tree arr_desc_token_offset
;
1228 /* Get the token field from the descriptor. */
1229 arr_desc_token_offset
= TREE_OPERAND (
1230 gfc_conv_descriptor_token (ref
->u
.c
.component
->backend_decl
), 1);
1231 arr_desc_token_offset
1232 = compute_component_offset (arr_desc_token_offset
,
1234 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
,
1235 TREE_TYPE (tmp2
), tmp2
,
1236 arr_desc_token_offset
);
1238 else if (ref
->u
.c
.component
->caf_token
)
1239 tmp2
= compute_component_offset (ref
->u
.c
.component
->caf_token
,
1242 tmp2
= integer_zero_node
;
1243 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
1245 /* Remember whether this ref was to a non-allocatable/non-pointer
1246 component so the next array ref can be tailored correctly. */
1247 ref_static_array
= !ref
->u
.c
.component
->attr
.allocatable
1248 && !ref
->u
.c
.component
->attr
.pointer
;
1249 last_component_ref_tree
= ref_static_array
1250 ? ref
->u
.c
.component
->backend_decl
: NULL_TREE
;
1253 if (ref_static_array
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
)
1254 ref_static_array
= false;
1255 /* Set the type of the ref. */
1256 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 1);
1257 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1258 TREE_TYPE (field
), prev_caf_ref
, field
,
1260 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
,
1262 ? GFC_CAF_REF_STATIC_ARRAY
1263 : GFC_CAF_REF_ARRAY
));
1265 /* Ref the a in union u. */
1266 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 3);
1267 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1268 TREE_TYPE (field
), prev_caf_ref
, field
,
1270 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field
)), 1);
1271 inner_struct
= fold_build3_loc (input_location
, COMPONENT_REF
,
1272 TREE_TYPE (field
), tmp
, field
,
1275 /* Set the static_array_type in a for static arrays. */
1276 if (ref_static_array
)
1278 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)),
1280 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1281 TREE_TYPE (field
), inner_struct
, field
,
1283 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (tmp
),
1286 /* Ref the mode in the inner_struct. */
1287 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 0);
1288 mode
= fold_build3_loc (input_location
, COMPONENT_REF
,
1289 TREE_TYPE (field
), inner_struct
, field
,
1291 /* Ref the dim in the inner_struct. */
1292 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct
)), 2);
1293 dim_array
= fold_build3_loc (input_location
, COMPONENT_REF
,
1294 TREE_TYPE (field
), inner_struct
, field
,
1296 for (i
= 0; i
< ref
->u
.ar
.dimen
; ++i
)
1299 dim
= gfc_build_array_ref (dim_array
, gfc_rank_cst
[i
], NULL_TREE
);
1300 dim_type
= TREE_TYPE (dim
);
1301 mode_rhs
= start
= end
= stride
= NULL_TREE
;
1302 switch (ref
->u
.ar
.dimen_type
[i
])
1305 if (ref
->u
.ar
.end
[i
])
1307 gfc_init_se (&se
, NULL
);
1308 gfc_conv_expr (&se
, ref
->u
.ar
.end
[i
]);
1309 gfc_add_block_to_block (block
, &se
.pre
);
1310 if (ref_static_array
)
1312 /* Make the index zero-based, when reffing a static
1315 gfc_init_se (&se
, NULL
);
1316 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1317 gfc_add_block_to_block (block
, &se
.pre
);
1318 se
.expr
= fold_build2 (MINUS_EXPR
,
1319 gfc_array_index_type
,
1321 gfc_array_index_type
,
1324 end
= gfc_evaluate_now (fold_convert (
1325 gfc_array_index_type
,
1329 else if (ref_static_array
)
1330 end
= fold_build2 (MINUS_EXPR
,
1331 gfc_array_index_type
,
1332 gfc_conv_array_ubound (
1333 last_component_ref_tree
, i
),
1334 gfc_conv_array_lbound (
1335 last_component_ref_tree
, i
));
1339 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1340 GFC_CAF_ARR_REF_OPEN_END
);
1342 if (ref
->u
.ar
.stride
[i
])
1344 gfc_init_se (&se
, NULL
);
1345 gfc_conv_expr (&se
, ref
->u
.ar
.stride
[i
]);
1346 gfc_add_block_to_block (block
, &se
.pre
);
1347 stride
= gfc_evaluate_now (fold_convert (
1348 gfc_array_index_type
,
1351 if (ref_static_array
)
1353 /* Make the index zero-based, when reffing a static
1355 stride
= fold_build2 (MULT_EXPR
,
1356 gfc_array_index_type
,
1357 gfc_conv_array_stride (
1358 last_component_ref_tree
,
1361 gcc_assert (end
!= NULL_TREE
);
1362 /* Multiply with the product of array's stride and
1363 the step of the ref to a virtual upper bound.
1364 We can not compute the actual upper bound here or
1365 the caflib would compute the extend
1367 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1368 end
, gfc_conv_array_stride (
1369 last_component_ref_tree
,
1371 end
= gfc_evaluate_now (end
, block
);
1372 stride
= gfc_evaluate_now (stride
, block
);
1375 else if (ref_static_array
)
1377 stride
= gfc_conv_array_stride (last_component_ref_tree
,
1379 end
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1381 end
= gfc_evaluate_now (end
, block
);
1384 /* Always set a ref stride of one to make caflib's
1386 stride
= gfc_index_one_node
;
1390 if (ref
->u
.ar
.start
[i
])
1392 gfc_init_se (&se
, NULL
);
1393 gfc_conv_expr (&se
, ref
->u
.ar
.start
[i
]);
1394 gfc_add_block_to_block (block
, &se
.pre
);
1395 if (ref_static_array
)
1397 /* Make the index zero-based, when reffing a static
1399 start
= fold_convert (gfc_array_index_type
, se
.expr
);
1400 gfc_init_se (&se
, NULL
);
1401 gfc_conv_expr (&se
, ref
->u
.ar
.as
->lower
[i
]);
1402 gfc_add_block_to_block (block
, &se
.pre
);
1403 se
.expr
= fold_build2 (MINUS_EXPR
,
1404 gfc_array_index_type
,
1405 start
, fold_convert (
1406 gfc_array_index_type
,
1408 /* Multiply with the stride. */
1409 se
.expr
= fold_build2 (MULT_EXPR
,
1410 gfc_array_index_type
,
1412 gfc_conv_array_stride (
1413 last_component_ref_tree
,
1416 start
= gfc_evaluate_now (fold_convert (
1417 gfc_array_index_type
,
1420 if (mode_rhs
== NULL_TREE
)
1421 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1422 ref
->u
.ar
.dimen_type
[i
]
1424 ? GFC_CAF_ARR_REF_SINGLE
1425 : GFC_CAF_ARR_REF_RANGE
);
1427 else if (ref_static_array
)
1429 start
= integer_zero_node
;
1430 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1431 ref
->u
.ar
.start
[i
] == NULL
1432 ? GFC_CAF_ARR_REF_FULL
1433 : GFC_CAF_ARR_REF_RANGE
);
1435 else if (end
== NULL_TREE
)
1436 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1437 GFC_CAF_ARR_REF_FULL
);
1439 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1440 GFC_CAF_ARR_REF_OPEN_START
);
1442 /* Ref the s in dim. */
1443 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 0);
1444 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1445 TREE_TYPE (field
), dim
, field
,
1448 /* Set start in s. */
1449 if (start
!= NULL_TREE
)
1451 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1453 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1454 TREE_TYPE (field
), tmp
, field
,
1456 gfc_add_modify (block
, tmp2
,
1457 fold_convert (TREE_TYPE (tmp2
), start
));
1461 if (end
!= NULL_TREE
)
1463 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1465 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1466 TREE_TYPE (field
), tmp
, field
,
1468 gfc_add_modify (block
, tmp2
,
1469 fold_convert (TREE_TYPE (tmp2
), end
));
1473 if (stride
!= NULL_TREE
)
1475 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)),
1477 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1478 TREE_TYPE (field
), tmp
, field
,
1480 gfc_add_modify (block
, tmp2
,
1481 fold_convert (TREE_TYPE (tmp2
), stride
));
1485 /* TODO: In case of static array. */
1486 gcc_assert (!ref_static_array
);
1487 mode_rhs
= build_int_cst (unsigned_char_type_node
,
1488 GFC_CAF_ARR_REF_VECTOR
);
1489 gfc_init_se (&se
, NULL
);
1490 se
.descriptor_only
= 1;
1491 gfc_conv_expr_descriptor (&se
, ref
->u
.ar
.start
[i
]);
1492 gfc_add_block_to_block (block
, &se
.pre
);
1494 tmp
= gfc_conv_descriptor_lbound_get (vector
,
1496 tmp2
= gfc_conv_descriptor_ubound_get (vector
,
1498 nvec
= gfc_conv_array_extent_dim (tmp
, tmp2
, NULL
);
1499 tmp
= gfc_conv_descriptor_stride_get (vector
,
1501 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1502 TREE_TYPE (nvec
), nvec
, tmp
);
1503 vector
= gfc_conv_descriptor_data_get (vector
);
1505 /* Ref the v in dim. */
1506 field
= gfc_advance_chain (TYPE_FIELDS (dim_type
), 1);
1507 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1508 TREE_TYPE (field
), dim
, field
,
1511 /* Set vector in v. */
1512 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 0);
1513 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1514 TREE_TYPE (field
), tmp
, field
,
1516 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1519 /* Set nvec in v. */
1520 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 1);
1521 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1522 TREE_TYPE (field
), tmp
, field
,
1524 gfc_add_modify (block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1527 /* Set kind in v. */
1528 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp
)), 2);
1529 tmp2
= fold_build3_loc (input_location
, COMPONENT_REF
,
1530 TREE_TYPE (field
), tmp
, field
,
1532 gfc_add_modify (block
, tmp2
, build_int_cst (integer_type_node
,
1533 ref
->u
.ar
.start
[i
]->ts
.kind
));
1538 /* Set the mode for dim i. */
1539 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1540 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (tmp
),
1544 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1545 if (i
< GFC_MAX_DIMENSIONS
)
1547 tmp
= gfc_build_array_ref (mode
, gfc_rank_cst
[i
], NULL_TREE
);
1548 gfc_add_modify (block
, tmp
,
1549 build_int_cst (unsigned_char_type_node
,
1550 GFC_CAF_ARR_REF_NONE
));
1557 /* Set the size of the current type. */
1558 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 2);
1559 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1560 prev_caf_ref
, field
, NULL_TREE
);
1561 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1562 TYPE_SIZE_UNIT (last_type
)));
1567 if (prev_caf_ref
!= NULL_TREE
)
1569 field
= gfc_advance_chain (TYPE_FIELDS (reference_type
), 0);
1570 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1571 prev_caf_ref
, field
, NULL_TREE
);
1572 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
),
1573 null_pointer_node
));
1575 return caf_ref
!= NULL_TREE
? gfc_build_addr_expr (NULL_TREE
, caf_ref
)
1579 /* Get data from a remote coarray. */
1582 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1583 tree may_require_tmp
, bool may_realloc
,
1584 symbol_attribute
*caf_attr
)
1586 gfc_expr
*array_expr
, *tmp_stat
;
1588 tree caf_decl
, token
, offset
, image_index
, tmp
;
1589 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
1591 symbol_attribute caf_attr_store
;
1593 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1595 if (se
->ss
&& se
->ss
->info
->useflags
)
1597 /* Access the previously obtained result. */
1598 gfc_conv_tmp_array_ref (se
);
1602 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1603 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1604 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1606 if (caf_attr
== NULL
)
1608 caf_attr_store
= gfc_caf_attr (array_expr
);
1609 caf_attr
= &caf_attr_store
;
1615 vec
= null_pointer_node
;
1616 tmp_stat
= gfc_find_stat_co (expr
);
1621 gfc_init_se (&stat_se
, NULL
);
1622 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1623 stat
= stat_se
.expr
;
1624 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1625 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1628 stat
= null_pointer_node
;
1630 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1631 is reallocatable or the right-hand side has allocatable components. */
1632 if (caf_attr
->alloc_comp
|| caf_attr
->pointer_comp
|| may_realloc
)
1634 /* Get using caf_get_by_ref. */
1635 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, array_expr
);
1637 if (caf_reference
!= NULL_TREE
)
1639 if (lhs
== NULL_TREE
)
1641 if (array_expr
->ts
.type
== BT_CHARACTER
)
1642 gfc_init_se (&argse
, NULL
);
1643 if (array_expr
->rank
== 0)
1645 symbol_attribute attr
;
1646 gfc_clear_attr (&attr
);
1647 if (array_expr
->ts
.type
== BT_CHARACTER
)
1649 res_var
= gfc_conv_string_tmp (se
,
1650 build_pointer_type (type
),
1651 array_expr
->ts
.u
.cl
->backend_decl
);
1652 argse
.string_length
= array_expr
->ts
.u
.cl
->backend_decl
;
1655 res_var
= gfc_create_var (type
, "caf_res");
1656 dst_var
= gfc_conv_scalar_to_descriptor (se
, res_var
, attr
);
1657 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1661 /* Create temporary. */
1662 if (array_expr
->ts
.type
== BT_CHARACTER
)
1663 gfc_conv_expr_descriptor (&argse
, array_expr
);
1664 may_realloc
= gfc_trans_create_temp_array (&se
->pre
,
1671 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1672 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1675 tmp
= gfc_conv_descriptor_data_get (res_var
);
1676 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
,
1677 NULL_TREE
, NULL_TREE
,
1680 GFC_CAF_COARRAY_NOCOARRAY
);
1681 gfc_add_expr_to_block (&se
->post
, tmp
);
1686 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1687 if (lhs_kind
== NULL_TREE
)
1690 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1691 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1692 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1693 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
,
1695 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
1698 /* No overlap possible as we have generated a temporary. */
1699 if (lhs
== NULL_TREE
)
1700 may_require_tmp
= boolean_false_node
;
1702 /* It guarantees memory consistency within the same segment. */
1703 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1704 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1705 gfc_build_string_const (1, ""), NULL_TREE
,
1706 NULL_TREE
, tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1708 ASM_VOLATILE_P (tmp
) = 1;
1709 gfc_add_expr_to_block (&se
->pre
, tmp
);
1711 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get_by_ref
,
1712 9, token
, image_index
, dst_var
,
1713 caf_reference
, lhs_kind
, kind
,
1715 may_realloc
? boolean_true_node
:
1719 gfc_add_expr_to_block (&se
->pre
, tmp
);
1722 gfc_advance_se_ss_chain (se
);
1725 if (array_expr
->ts
.type
== BT_CHARACTER
)
1726 se
->string_length
= argse
.string_length
;
1732 gfc_init_se (&argse
, NULL
);
1733 if (array_expr
->rank
== 0)
1735 symbol_attribute attr
;
1737 gfc_clear_attr (&attr
);
1738 gfc_conv_expr (&argse
, array_expr
);
1740 if (lhs
== NULL_TREE
)
1742 gfc_clear_attr (&attr
);
1743 if (array_expr
->ts
.type
== BT_CHARACTER
)
1744 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1745 argse
.string_length
);
1747 res_var
= gfc_create_var (type
, "caf_res");
1748 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1749 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1751 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1752 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1756 /* If has_vector, pass descriptor for whole array and the
1757 vector bounds separately. */
1758 gfc_array_ref
*ar
, ar2
;
1759 bool has_vector
= false;
1761 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1764 ar
= gfc_find_array_ref (expr
);
1766 memset (ar
, '\0', sizeof (*ar
));
1770 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1771 gfc_conv_expr_descriptor (&argse
, array_expr
);
1772 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1773 has the wrong type if component references are done. */
1774 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1775 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1780 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1784 if (lhs
== NULL_TREE
)
1786 /* Create temporary. */
1787 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1788 if (se
->loop
->to
[n
] == NULL_TREE
)
1790 se
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (argse
.expr
,
1792 se
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (argse
.expr
,
1795 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1796 NULL_TREE
, false, true, false,
1797 &array_expr
->where
);
1798 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1799 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1801 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1804 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1805 if (lhs_kind
== NULL_TREE
)
1808 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1809 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1811 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1812 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1813 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1814 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1815 gfc_get_caf_token_offset (se
, &token
, &offset
, caf_decl
, argse
.expr
,
1818 /* No overlap possible as we have generated a temporary. */
1819 if (lhs
== NULL_TREE
)
1820 may_require_tmp
= boolean_false_node
;
1822 /* It guarantees memory consistency within the same segment. */
1823 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
1824 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1825 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1826 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1827 ASM_VOLATILE_P (tmp
) = 1;
1828 gfc_add_expr_to_block (&se
->pre
, tmp
);
1830 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1831 token
, offset
, image_index
, argse
.expr
, vec
,
1832 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1834 gfc_add_expr_to_block (&se
->pre
, tmp
);
1837 gfc_advance_se_ss_chain (se
);
1840 if (array_expr
->ts
.type
== BT_CHARACTER
)
1841 se
->string_length
= argse
.string_length
;
1845 /* Send data to a remote coarray. */
1848 conv_caf_send (gfc_code
*code
) {
1849 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
;
1850 gfc_se lhs_se
, rhs_se
;
1852 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1853 tree may_require_tmp
, src_stat
, dst_stat
;
1854 tree lhs_type
= NULL_TREE
;
1855 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1856 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
1858 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1860 lhs_expr
= code
->ext
.actual
->expr
;
1861 rhs_expr
= code
->ext
.actual
->next
->expr
;
1862 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1863 ? boolean_false_node
: boolean_true_node
;
1864 gfc_init_block (&block
);
1866 lhs_caf_attr
= gfc_caf_attr (lhs_expr
);
1867 rhs_caf_attr
= gfc_caf_attr (rhs_expr
);
1868 src_stat
= dst_stat
= null_pointer_node
;
1871 gfc_init_se (&lhs_se
, NULL
);
1872 if (lhs_expr
->rank
== 0)
1874 if (lhs_expr
->ts
.type
== BT_CHARACTER
&& lhs_expr
->ts
.deferred
)
1876 lhs_se
.expr
= gfc_get_tree_for_caf_expr (lhs_expr
);
1877 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1881 symbol_attribute attr
;
1882 gfc_clear_attr (&attr
);
1883 gfc_conv_expr (&lhs_se
, lhs_expr
);
1884 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1885 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
,
1887 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1890 else if ((lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
1891 && lhs_caf_attr
.codimension
)
1893 lhs_se
.want_pointer
= 1;
1894 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1895 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1896 has the wrong type if component references are done. */
1897 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1898 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1899 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1900 gfc_get_dtype_rank_type (
1901 gfc_has_vector_subscript (lhs_expr
)
1902 ? gfc_find_array_ref (lhs_expr
)->dimen
1908 /* If has_vector, pass descriptor for whole array and the
1909 vector bounds separately. */
1910 gfc_array_ref
*ar
, ar2
;
1911 bool has_vector
= false;
1913 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1916 ar
= gfc_find_array_ref (lhs_expr
);
1918 memset (ar
, '\0', sizeof (*ar
));
1922 lhs_se
.want_pointer
= 1;
1923 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1924 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1925 has the wrong type if component references are done. */
1926 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1927 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1928 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1929 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1934 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1939 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1941 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1942 temporary and a loop. */
1943 if (!gfc_is_coindexed (lhs_expr
)
1944 && (!lhs_caf_attr
.codimension
1945 || !(lhs_expr
->rank
> 0
1946 && (lhs_caf_attr
.allocatable
|| lhs_caf_attr
.pointer
))))
1948 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
1949 gcc_assert (gfc_is_coindexed (rhs_expr
));
1950 gfc_init_se (&rhs_se
, NULL
);
1951 if (lhs_expr
->rank
== 0 && lhs_caf_attr
.allocatable
)
1954 gfc_init_se (&scal_se
, NULL
);
1955 scal_se
.want_pointer
= 1;
1956 gfc_conv_expr (&scal_se
, lhs_expr
);
1957 /* Ensure scalar on lhs is allocated. */
1958 gfc_add_block_to_block (&block
, &scal_se
.pre
);
1960 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
1962 gfc_typenode_for_spec (&lhs_expr
->ts
)),
1964 tmp
= fold_build2 (EQ_EXPR
, logical_type_node
, scal_se
.expr
,
1966 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1967 tmp
, gfc_finish_block (&scal_se
.pre
),
1968 build_empty_stmt (input_location
));
1969 gfc_add_expr_to_block (&block
, tmp
);
1972 lhs_may_realloc
= lhs_may_realloc
1973 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
1974 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1975 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1976 may_require_tmp
, lhs_may_realloc
,
1978 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1979 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1980 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1981 return gfc_finish_block (&block
);
1984 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1986 /* Obtain token, offset and image index for the LHS. */
1987 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1988 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1989 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1990 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1992 if (lhs_caf_attr
.alloc_comp
)
1993 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
1996 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
2001 gfc_init_se (&rhs_se
, NULL
);
2002 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
2003 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2004 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
2005 if (rhs_expr
->rank
== 0)
2007 symbol_attribute attr
;
2008 gfc_clear_attr (&attr
);
2009 gfc_conv_expr (&rhs_se
, rhs_expr
);
2010 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
2011 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2013 else if ((rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2014 && rhs_caf_attr
.codimension
)
2017 rhs_se
.want_pointer
= 1;
2018 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2019 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2020 has the wrong type if component references are done. */
2021 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2022 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2023 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2024 gfc_get_dtype_rank_type (
2025 gfc_has_vector_subscript (rhs_expr
)
2026 ? gfc_find_array_ref (rhs_expr
)->dimen
2032 /* If has_vector, pass descriptor for whole array and the
2033 vector bounds separately. */
2034 gfc_array_ref
*ar
, ar2
;
2035 bool has_vector
= false;
2038 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2041 ar
= gfc_find_array_ref (rhs_expr
);
2043 memset (ar
, '\0', sizeof (*ar
));
2047 rhs_se
.want_pointer
= 1;
2048 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2049 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2050 has the wrong type if component references are done. */
2051 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2052 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2053 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2054 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2059 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2064 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2066 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2068 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2073 gfc_init_se (&stat_se
, NULL
);
2074 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2075 dst_stat
= stat_se
.expr
;
2076 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2077 gfc_add_block_to_block (&block
, &stat_se
.post
);
2080 if (!gfc_is_coindexed (rhs_expr
))
2082 if (lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
2084 tree reference
, dst_realloc
;
2085 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2086 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2087 : boolean_false_node
;
2088 tmp
= build_call_expr_loc (input_location
,
2089 gfor_fndecl_caf_send_by_ref
,
2090 9, token
, image_index
, rhs_se
.expr
,
2091 reference
, lhs_kind
, rhs_kind
,
2092 may_require_tmp
, dst_realloc
, src_stat
);
2095 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 10,
2096 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2097 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2098 may_require_tmp
, src_stat
);
2102 tree rhs_token
, rhs_offset
, rhs_image_index
;
2104 /* It guarantees memory consistency within the same segment. */
2105 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2106 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2107 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2108 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2109 ASM_VOLATILE_P (tmp
) = 1;
2110 gfc_add_expr_to_block (&block
, tmp
);
2112 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2113 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2114 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2115 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2117 if (rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2119 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2124 gfc_init_se (&stat_se
, NULL
);
2125 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2126 src_stat
= stat_se
.expr
;
2127 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2128 gfc_add_block_to_block (&block
, &stat_se
.post
);
2131 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2133 tree lhs_reference
, rhs_reference
;
2134 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2135 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2136 tmp
= build_call_expr_loc (input_location
,
2137 gfor_fndecl_caf_sendget_by_ref
, 11,
2138 token
, image_index
, lhs_reference
,
2139 rhs_token
, rhs_image_index
, rhs_reference
,
2140 lhs_kind
, rhs_kind
, may_require_tmp
,
2141 dst_stat
, src_stat
);
2145 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2147 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2148 14, token
, offset
, image_index
,
2149 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2150 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2151 rhs_kind
, may_require_tmp
, src_stat
);
2154 gfc_add_expr_to_block (&block
, tmp
);
2155 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2156 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2158 /* It guarantees memory consistency within the same segment. */
2159 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2160 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2161 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2162 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2163 ASM_VOLATILE_P (tmp
) = 1;
2164 gfc_add_expr_to_block (&block
, tmp
);
2166 return gfc_finish_block (&block
);
2171 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2174 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2175 lbound
, ubound
, extent
, ml
;
2178 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2180 if (expr
->value
.function
.actual
->expr
2181 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2182 distance
= expr
->value
.function
.actual
->expr
;
2184 /* The case -fcoarray=single is handled elsewhere. */
2185 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2187 /* Argument-free version: THIS_IMAGE(). */
2188 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2192 gfc_init_se (&argse
, NULL
);
2193 gfc_conv_expr_val (&argse
, distance
);
2194 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2195 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2196 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2199 tmp
= integer_zero_node
;
2200 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2202 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2207 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2209 type
= gfc_get_int_type (gfc_default_integer_kind
);
2210 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2211 rank
= expr
->value
.function
.actual
->expr
->rank
;
2213 /* Obtain the descriptor of the COARRAY. */
2214 gfc_init_se (&argse
, NULL
);
2215 argse
.want_coarray
= 1;
2216 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2217 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2218 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2223 /* Create an implicit second parameter from the loop variable. */
2224 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2225 gcc_assert (corank
> 0);
2226 gcc_assert (se
->loop
->dimen
== 1);
2227 gcc_assert (se
->ss
->info
->expr
== expr
);
2229 dim_arg
= se
->loop
->loopvar
[0];
2230 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2231 gfc_array_index_type
, dim_arg
,
2232 build_int_cst (TREE_TYPE (dim_arg
), 1));
2233 gfc_advance_se_ss_chain (se
);
2237 /* Use the passed DIM= argument. */
2238 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2239 gfc_init_se (&argse
, NULL
);
2240 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2241 gfc_array_index_type
);
2242 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2243 dim_arg
= argse
.expr
;
2245 if (INTEGER_CST_P (dim_arg
))
2247 if (wi::ltu_p (wi::to_wide (dim_arg
), 1)
2248 || wi::gtu_p (wi::to_wide (dim_arg
),
2249 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2250 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2251 "dimension index", expr
->value
.function
.isym
->name
,
2254 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2256 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2257 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2259 build_int_cst (TREE_TYPE (dim_arg
), 1));
2260 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2261 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2263 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2264 logical_type_node
, cond
, tmp
);
2265 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2270 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2271 one always has a dim_arg argument.
2273 m = this_image() - 1
2276 sub(1) = m + lcobound(corank)
2280 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2283 extent = gfc_extent(i)
2291 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2292 : m + lcobound(corank)
2295 /* this_image () - 1. */
2296 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2298 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2299 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2302 /* sub(1) = m + lcobound(corank). */
2303 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2304 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2306 lbound
= fold_convert (type
, lbound
);
2307 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2313 m
= gfc_create_var (type
, NULL
);
2314 ml
= gfc_create_var (type
, NULL
);
2315 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2316 min_var
= gfc_create_var (integer_type_node
, NULL
);
2318 /* m = this_image () - 1. */
2319 gfc_add_modify (&se
->pre
, m
, tmp
);
2321 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2322 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2323 fold_convert (integer_type_node
, dim_arg
),
2324 build_int_cst (integer_type_node
, rank
- 1));
2325 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2326 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2328 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2331 tmp
= build_int_cst (integer_type_node
, rank
);
2332 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2334 exit_label
= gfc_build_label_decl (NULL_TREE
);
2335 TREE_USED (exit_label
) = 1;
2338 gfc_init_block (&loop
);
2341 gfc_add_modify (&loop
, ml
, m
);
2344 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2345 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2346 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2347 extent
= fold_convert (type
, extent
);
2350 gfc_add_modify (&loop
, m
,
2351 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2354 /* Exit condition: if (i >= min_var) goto exit_label. */
2355 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, loop_var
,
2357 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2358 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2359 build_empty_stmt (input_location
));
2360 gfc_add_expr_to_block (&loop
, tmp
);
2362 /* Increment loop variable: i++. */
2363 gfc_add_modify (&loop
, loop_var
,
2364 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2366 build_int_cst (integer_type_node
, 1)));
2368 /* Making the loop... actually loop! */
2369 tmp
= gfc_finish_block (&loop
);
2370 tmp
= build1_v (LOOP_EXPR
, tmp
);
2371 gfc_add_expr_to_block (&se
->pre
, tmp
);
2373 /* The exit label. */
2374 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2375 gfc_add_expr_to_block (&se
->pre
, tmp
);
2377 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2378 : m + lcobound(corank) */
2380 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, dim_arg
,
2381 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2383 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2384 fold_build2_loc (input_location
, PLUS_EXPR
,
2385 gfc_array_index_type
, dim_arg
,
2386 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2387 lbound
= fold_convert (type
, lbound
);
2389 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2390 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2392 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2394 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2395 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2400 /* Convert a call to image_status. */
2403 conv_intrinsic_image_status (gfc_se
*se
, gfc_expr
*expr
)
2405 unsigned int num_args
;
2408 num_args
= gfc_intrinsic_argument_list_length (expr
);
2409 args
= XALLOCAVEC (tree
, num_args
);
2410 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2411 /* In args[0] the number of the image the status is desired for has to be
2414 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2417 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2418 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2419 fold_convert (integer_type_node
, arg
),
2421 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2422 tmp
, integer_zero_node
,
2423 build_int_cst (integer_type_node
,
2424 GFC_STAT_STOPPED_IMAGE
));
2426 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2427 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_image_status
, 2,
2428 args
[0], build_int_cst (integer_type_node
, -1));
2437 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2439 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2441 gfc_se argse
, subse
;
2442 int rank
, corank
, codim
;
2444 type
= gfc_get_int_type (gfc_default_integer_kind
);
2445 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2446 rank
= expr
->value
.function
.actual
->expr
->rank
;
2448 /* Obtain the descriptor of the COARRAY. */
2449 gfc_init_se (&argse
, NULL
);
2450 argse
.want_coarray
= 1;
2451 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2452 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2453 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2456 /* Obtain a handle to the SUB argument. */
2457 gfc_init_se (&subse
, NULL
);
2458 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2459 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2460 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2461 subdesc
= build_fold_indirect_ref_loc (input_location
,
2462 gfc_conv_descriptor_data_get (subse
.expr
));
2464 /* Fortran 2008 does not require that the values remain in the cobounds,
2465 thus we need explicitly check this - and return 0 if they are exceeded. */
2467 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2468 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2469 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2470 fold_convert (gfc_array_index_type
, tmp
),
2473 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2475 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2476 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2477 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2478 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2479 fold_convert (gfc_array_index_type
, tmp
),
2481 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2482 logical_type_node
, invalid_bound
, cond
);
2483 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2484 fold_convert (gfc_array_index_type
, tmp
),
2486 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2487 logical_type_node
, invalid_bound
, cond
);
2490 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2492 /* See Fortran 2008, C.10 for the following algorithm. */
2494 /* coindex = sub(corank) - lcobound(n). */
2495 coindex
= fold_convert (gfc_array_index_type
,
2496 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2498 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2499 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2500 fold_convert (gfc_array_index_type
, coindex
),
2503 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2505 tree extent
, ubound
;
2507 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2508 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2509 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2510 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2512 /* coindex *= extent. */
2513 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2514 gfc_array_index_type
, coindex
, extent
);
2516 /* coindex += sub(codim). */
2517 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2518 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2519 gfc_array_index_type
, coindex
,
2520 fold_convert (gfc_array_index_type
, tmp
));
2522 /* coindex -= lbound(codim). */
2523 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2524 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2525 gfc_array_index_type
, coindex
, lbound
);
2528 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2529 fold_convert(type
, coindex
),
2530 build_int_cst (type
, 1));
2532 /* Return 0 if "coindex" exceeds num_images(). */
2534 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2535 num_images
= build_int_cst (type
, 1);
2538 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2540 build_int_cst (integer_type_node
, -1));
2541 num_images
= fold_convert (type
, tmp
);
2544 tmp
= gfc_create_var (type
, NULL
);
2545 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2547 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, tmp
,
2549 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
2551 fold_convert (logical_type_node
, invalid_bound
));
2552 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2553 build_int_cst (type
, 0), tmp
);
2558 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2560 tree tmp
, distance
, failed
;
2563 if (expr
->value
.function
.actual
->expr
)
2565 gfc_init_se (&argse
, NULL
);
2566 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2567 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2568 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2569 distance
= fold_convert (integer_type_node
, argse
.expr
);
2572 distance
= integer_zero_node
;
2574 if (expr
->value
.function
.actual
->next
->expr
)
2576 gfc_init_se (&argse
, NULL
);
2577 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2578 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2579 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2580 failed
= fold_convert (integer_type_node
, argse
.expr
);
2583 failed
= build_int_cst (integer_type_node
, -1);
2585 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2587 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2592 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2596 gfc_init_se (&argse
, NULL
);
2597 argse
.data_not_needed
= 1;
2598 argse
.descriptor_only
= 1;
2600 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2601 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2602 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2604 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2608 /* Evaluate a single upper or lower bound. */
2609 /* TODO: bound intrinsic generates way too much unnecessary code. */
2612 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2614 gfc_actual_arglist
*arg
;
2615 gfc_actual_arglist
*arg2
;
2620 tree cond
, cond1
, cond3
, cond4
, size
;
2624 gfc_array_spec
* as
;
2625 bool assumed_rank_lb_one
;
2627 arg
= expr
->value
.function
.actual
;
2632 /* Create an implicit second parameter from the loop variable. */
2633 gcc_assert (!arg2
->expr
);
2634 gcc_assert (se
->loop
->dimen
== 1);
2635 gcc_assert (se
->ss
->info
->expr
== expr
);
2636 gfc_advance_se_ss_chain (se
);
2637 bound
= se
->loop
->loopvar
[0];
2638 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2639 gfc_array_index_type
, bound
,
2644 /* use the passed argument. */
2645 gcc_assert (arg2
->expr
);
2646 gfc_init_se (&argse
, NULL
);
2647 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2648 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2650 /* Convert from one based to zero based. */
2651 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2652 gfc_array_index_type
, bound
,
2653 gfc_index_one_node
);
2656 /* TODO: don't re-evaluate the descriptor on each iteration. */
2657 /* Get a descriptor for the first parameter. */
2658 gfc_init_se (&argse
, NULL
);
2659 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2660 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2661 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2665 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2667 if (INTEGER_CST_P (bound
))
2669 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2670 && wi::geu_p (wi::to_wide (bound
),
2671 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2672 || wi::gtu_p (wi::to_wide (bound
), GFC_MAX_DIMENSIONS
))
2673 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2674 "dimension index", upper
? "UBOUND" : "LBOUND",
2678 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
2680 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2682 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2683 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2684 bound
, build_int_cst (TREE_TYPE (bound
), 0));
2685 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2686 tmp
= gfc_conv_descriptor_rank (desc
);
2688 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
2689 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2690 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
2691 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2692 logical_type_node
, cond
, tmp
);
2693 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2698 /* Take care of the lbound shift for assumed-rank arrays, which are
2699 nonallocatable and nonpointers. Those has a lbound of 1. */
2700 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
2701 && ((arg
->expr
->ts
.type
!= BT_CLASS
2702 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
2703 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
2704 || (arg
->expr
->ts
.type
== BT_CLASS
2705 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
2706 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
2708 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2709 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2711 /* 13.14.53: Result value for LBOUND
2713 Case (i): For an array section or for an array expression other than a
2714 whole array or array structure component, LBOUND(ARRAY, DIM)
2715 has the value 1. For a whole array or array structure
2716 component, LBOUND(ARRAY, DIM) has the value:
2717 (a) equal to the lower bound for subscript DIM of ARRAY if
2718 dimension DIM of ARRAY does not have extent zero
2719 or if ARRAY is an assumed-size array of rank DIM,
2722 13.14.113: Result value for UBOUND
2724 Case (i): For an array section or for an array expression other than a
2725 whole array or array structure component, UBOUND(ARRAY, DIM)
2726 has the value equal to the number of elements in the given
2727 dimension; otherwise, it has a value equal to the upper bound
2728 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2729 not have size zero and has value zero if dimension DIM has
2732 if (!upper
&& assumed_rank_lb_one
)
2733 se
->expr
= gfc_index_one_node
;
2736 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
2738 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2740 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2741 stride
, gfc_index_zero_node
);
2742 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2743 logical_type_node
, cond3
, cond1
);
2744 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2745 stride
, gfc_index_zero_node
);
2750 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2751 logical_type_node
, cond3
, cond4
);
2752 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2753 gfc_index_one_node
, lbound
);
2754 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2755 logical_type_node
, cond4
, cond5
);
2757 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2758 logical_type_node
, cond
, cond5
);
2760 if (assumed_rank_lb_one
)
2762 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2763 gfc_array_index_type
, ubound
, lbound
);
2764 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2765 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2770 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2771 gfc_array_index_type
, cond
,
2772 tmp
, gfc_index_zero_node
);
2776 if (as
->type
== AS_ASSUMED_SIZE
)
2777 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2778 bound
, build_int_cst (TREE_TYPE (bound
),
2779 arg
->expr
->rank
- 1));
2781 cond
= logical_false_node
;
2783 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2784 logical_type_node
, cond3
, cond4
);
2785 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2786 logical_type_node
, cond
, cond1
);
2788 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2789 gfc_array_index_type
, cond
,
2790 lbound
, gfc_index_one_node
);
2797 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2798 gfc_array_index_type
, ubound
, lbound
);
2799 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2800 gfc_array_index_type
, size
,
2801 gfc_index_one_node
);
2802 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2803 gfc_array_index_type
, se
->expr
,
2804 gfc_index_zero_node
);
2807 se
->expr
= gfc_index_one_node
;
2810 type
= gfc_typenode_for_spec (&expr
->ts
);
2811 se
->expr
= convert (type
, se
->expr
);
2816 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2818 gfc_actual_arglist
*arg
;
2819 gfc_actual_arglist
*arg2
;
2821 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2825 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2826 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2827 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2829 arg
= expr
->value
.function
.actual
;
2832 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2833 corank
= gfc_get_corank (arg
->expr
);
2835 gfc_init_se (&argse
, NULL
);
2836 argse
.want_coarray
= 1;
2838 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2839 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2840 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2845 /* Create an implicit second parameter from the loop variable. */
2846 gcc_assert (!arg2
->expr
);
2847 gcc_assert (corank
> 0);
2848 gcc_assert (se
->loop
->dimen
== 1);
2849 gcc_assert (se
->ss
->info
->expr
== expr
);
2851 bound
= se
->loop
->loopvar
[0];
2852 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2853 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2854 gfc_advance_se_ss_chain (se
);
2858 /* use the passed argument. */
2859 gcc_assert (arg2
->expr
);
2860 gfc_init_se (&argse
, NULL
);
2861 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2862 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2865 if (INTEGER_CST_P (bound
))
2867 if (wi::ltu_p (wi::to_wide (bound
), 1)
2868 || wi::gtu_p (wi::to_wide (bound
),
2869 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2870 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2871 "dimension index", expr
->value
.function
.isym
->name
,
2874 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2876 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2877 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2878 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2879 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2880 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2882 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2883 logical_type_node
, cond
, tmp
);
2884 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2889 /* Subtract 1 to get to zero based and add dimensions. */
2890 switch (arg
->expr
->rank
)
2893 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2894 gfc_array_index_type
, bound
,
2895 gfc_index_one_node
);
2899 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2900 gfc_array_index_type
, bound
,
2901 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2905 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2907 /* Handle UCOBOUND with special handling of the last codimension. */
2908 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2910 /* Last codimension: For -fcoarray=single just return
2911 the lcobound - otherwise add
2912 ceiling (real (num_images ()) / real (size)) - 1
2913 = (num_images () + size - 1) / size - 1
2914 = (num_images - 1) / size(),
2915 where size is the product of the extent of all but the last
2918 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2922 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2923 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2924 2, integer_zero_node
,
2925 build_int_cst (integer_type_node
, -1));
2926 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2927 gfc_array_index_type
,
2928 fold_convert (gfc_array_index_type
, tmp
),
2929 build_int_cst (gfc_array_index_type
, 1));
2930 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2931 gfc_array_index_type
, tmp
,
2932 fold_convert (gfc_array_index_type
, cosize
));
2933 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2934 gfc_array_index_type
, resbound
, tmp
);
2936 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2938 /* ubound = lbound + num_images() - 1. */
2939 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2940 2, integer_zero_node
,
2941 build_int_cst (integer_type_node
, -1));
2942 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2943 gfc_array_index_type
,
2944 fold_convert (gfc_array_index_type
, tmp
),
2945 build_int_cst (gfc_array_index_type
, 1));
2946 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2947 gfc_array_index_type
, resbound
, tmp
);
2952 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2954 build_int_cst (TREE_TYPE (bound
),
2955 arg
->expr
->rank
+ corank
- 1));
2957 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2958 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2959 gfc_array_index_type
, cond
,
2960 resbound
, resbound2
);
2963 se
->expr
= resbound
;
2966 se
->expr
= resbound
;
2968 type
= gfc_typenode_for_spec (&expr
->ts
);
2969 se
->expr
= convert (type
, se
->expr
);
2974 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2976 gfc_actual_arglist
*array_arg
;
2977 gfc_actual_arglist
*dim_arg
;
2981 array_arg
= expr
->value
.function
.actual
;
2982 dim_arg
= array_arg
->next
;
2984 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2986 gfc_init_se (&argse
, NULL
);
2987 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2988 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2989 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2992 gcc_assert (dim_arg
->expr
);
2993 gfc_init_se (&argse
, NULL
);
2994 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2995 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2996 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2997 argse
.expr
, gfc_index_one_node
);
2998 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
3003 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
3007 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3009 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
3013 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
3018 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
3019 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
3028 /* Create a complex value from one or two real components. */
3031 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
3037 unsigned int num_args
;
3039 num_args
= gfc_intrinsic_argument_list_length (expr
);
3040 args
= XALLOCAVEC (tree
, num_args
);
3042 type
= gfc_typenode_for_spec (&expr
->ts
);
3043 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3044 real
= convert (TREE_TYPE (type
), args
[0]);
3046 imag
= convert (TREE_TYPE (type
), args
[1]);
3047 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
3049 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
3050 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
3051 imag
= convert (TREE_TYPE (type
), imag
);
3054 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3056 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3060 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3061 MODULO(A, P) = A - FLOOR (A / P) * P
3063 The obvious algorithms above are numerically instable for large
3064 arguments, hence these intrinsics are instead implemented via calls
3065 to the fmod family of functions. It is the responsibility of the
3066 user to ensure that the second argument is non-zero. */
3069 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3079 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3081 switch (expr
->ts
.type
)
3084 /* Integer case is easy, we've got a builtin op. */
3085 type
= TREE_TYPE (args
[0]);
3088 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3091 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3097 /* Check if we have a builtin fmod. */
3098 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3100 /* The builtin should always be available. */
3101 gcc_assert (fmod
!= NULL_TREE
);
3103 tmp
= build_addr (fmod
);
3104 se
->expr
= build_call_array_loc (input_location
,
3105 TREE_TYPE (TREE_TYPE (fmod
)),
3110 type
= TREE_TYPE (args
[0]);
3112 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3113 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3116 modulo = arg - floor (arg/arg2) * arg2
3118 In order to calculate the result accurately, we use the fmod
3119 function as follows.
3121 res = fmod (arg, arg2);
3124 if ((arg < 0) xor (arg2 < 0))
3128 res = copysign (0., arg2);
3130 => As two nested ternary exprs:
3132 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3133 : copysign (0., arg2);
3137 zero
= gfc_build_const (type
, integer_zero_node
);
3138 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3139 if (!flag_signed_zeros
)
3141 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3143 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3145 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3146 logical_type_node
, test
, test2
);
3147 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3149 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3150 logical_type_node
, test
, test2
);
3151 test
= gfc_evaluate_now (test
, &se
->pre
);
3152 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3153 fold_build2_loc (input_location
,
3155 type
, tmp
, args
[1]),
3160 tree expr1
, copysign
, cscall
;
3161 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3163 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3165 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3167 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3168 logical_type_node
, test
, test2
);
3169 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3170 fold_build2_loc (input_location
,
3172 type
, tmp
, args
[1]),
3174 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3176 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3178 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3188 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3189 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3190 where the right shifts are logical (i.e. 0's are shifted in).
3191 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3192 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3194 DSHIFTL(I,J,BITSIZE) = J
3196 DSHIFTR(I,J,BITSIZE) = I. */
3199 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3201 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3202 tree args
[3], cond
, tmp
;
3205 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3207 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3208 type
= TREE_TYPE (args
[0]);
3209 bitsize
= TYPE_PRECISION (type
);
3210 utype
= unsigned_type_for (type
);
3211 stype
= TREE_TYPE (args
[2]);
3213 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3214 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3215 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3217 /* The generic case. */
3218 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3219 build_int_cst (stype
, bitsize
), shift
);
3220 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3221 arg1
, dshiftl
? shift
: tmp
);
3223 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3224 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3225 right
= fold_convert (type
, right
);
3227 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3229 /* Special cases. */
3230 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3231 build_int_cst (stype
, 0));
3232 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3233 dshiftl
? arg1
: arg2
, res
);
3235 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3236 build_int_cst (stype
, bitsize
));
3237 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3238 dshiftl
? arg2
: arg1
, res
);
3244 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3247 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3255 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3256 type
= TREE_TYPE (args
[0]);
3258 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3259 val
= gfc_evaluate_now (val
, &se
->pre
);
3261 zero
= gfc_build_const (type
, integer_zero_node
);
3262 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, val
, zero
);
3263 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3267 /* SIGN(A, B) is absolute value of A times sign of B.
3268 The real value versions use library functions to ensure the correct
3269 handling of negative zero. Integer case implemented as:
3270 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3274 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3280 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3281 if (expr
->ts
.type
== BT_REAL
)
3285 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3286 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3288 /* We explicitly have to ignore the minus sign. We do so by using
3289 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3291 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3294 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3295 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3297 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3298 TREE_TYPE (args
[0]), cond
,
3299 build_call_expr_loc (input_location
, abs
, 1,
3301 build_call_expr_loc (input_location
, tmp
, 2,
3305 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3310 /* Having excluded floating point types, we know we are now dealing
3311 with signed integer types. */
3312 type
= TREE_TYPE (args
[0]);
3314 /* Args[0] is used multiple times below. */
3315 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3317 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3318 the signs of A and B are the same, and of all ones if they differ. */
3319 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3320 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3321 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3322 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3324 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3325 is all ones (i.e. -1). */
3326 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3327 fold_build2_loc (input_location
, PLUS_EXPR
,
3328 type
, args
[0], tmp
), tmp
);
3332 /* Test for the presence of an optional argument. */
3335 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3339 arg
= expr
->value
.function
.actual
->expr
;
3340 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3341 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3342 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3346 /* Calculate the double precision product of two single precision values. */
3349 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3354 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3356 /* Convert the args to double precision before multiplying. */
3357 type
= gfc_typenode_for_spec (&expr
->ts
);
3358 args
[0] = convert (type
, args
[0]);
3359 args
[1] = convert (type
, args
[1]);
3360 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3365 /* Return a length one character string containing an ascii character. */
3368 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3373 unsigned int num_args
;
3375 num_args
= gfc_intrinsic_argument_list_length (expr
);
3376 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3378 type
= gfc_get_char_type (expr
->ts
.kind
);
3379 var
= gfc_create_var (type
, "char");
3381 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3382 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3383 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3384 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3389 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3397 unsigned int num_args
;
3399 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3400 args
= XALLOCAVEC (tree
, num_args
);
3402 var
= gfc_create_var (pchar_type_node
, "pstr");
3403 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3405 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3406 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3407 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3409 fndecl
= build_addr (gfor_fndecl_ctime
);
3410 tmp
= build_call_array_loc (input_location
,
3411 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3412 fndecl
, num_args
, args
);
3413 gfc_add_expr_to_block (&se
->pre
, tmp
);
3415 /* Free the temporary afterwards, if necessary. */
3416 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3417 len
, build_int_cst (TREE_TYPE (len
), 0));
3418 tmp
= gfc_call_free (var
);
3419 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3420 gfc_add_expr_to_block (&se
->post
, tmp
);
3423 se
->string_length
= len
;
3428 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3436 unsigned int num_args
;
3438 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3439 args
= XALLOCAVEC (tree
, num_args
);
3441 var
= gfc_create_var (pchar_type_node
, "pstr");
3442 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3444 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3445 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3446 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3448 fndecl
= build_addr (gfor_fndecl_fdate
);
3449 tmp
= build_call_array_loc (input_location
,
3450 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3451 fndecl
, num_args
, args
);
3452 gfc_add_expr_to_block (&se
->pre
, tmp
);
3454 /* Free the temporary afterwards, if necessary. */
3455 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3456 len
, build_int_cst (TREE_TYPE (len
), 0));
3457 tmp
= gfc_call_free (var
);
3458 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3459 gfc_add_expr_to_block (&se
->post
, tmp
);
3462 se
->string_length
= len
;
3466 /* Generate a direct call to free() for the FREE subroutine. */
3469 conv_intrinsic_free (gfc_code
*code
)
3475 gfc_init_se (&argse
, NULL
);
3476 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3477 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3479 gfc_init_block (&block
);
3480 call
= build_call_expr_loc (input_location
,
3481 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3482 gfc_add_expr_to_block (&block
, call
);
3483 return gfc_finish_block (&block
);
3487 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3491 conv_intrinsic_system_clock (gfc_code
*code
)
3494 gfc_se count_se
, count_rate_se
, count_max_se
;
3495 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3499 gfc_expr
*count
= code
->ext
.actual
->expr
;
3500 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3501 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3503 /* Evaluate our arguments. */
3506 gfc_init_se (&count_se
, NULL
);
3507 gfc_conv_expr (&count_se
, count
);
3512 gfc_init_se (&count_rate_se
, NULL
);
3513 gfc_conv_expr (&count_rate_se
, count_rate
);
3518 gfc_init_se (&count_max_se
, NULL
);
3519 gfc_conv_expr (&count_max_se
, count_max
);
3522 /* Find the smallest kind found of the arguments. */
3524 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3525 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3527 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3530 /* Prepare temporary variables. */
3535 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3536 else if (least
== 4)
3537 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3538 else if (count
->ts
.kind
== 1)
3539 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3542 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3549 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3550 else if (least
== 4)
3551 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3553 arg2
= integer_zero_node
;
3559 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3560 else if (least
== 4)
3561 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3563 arg3
= integer_zero_node
;
3566 /* Make the function call. */
3567 gfc_init_block (&block
);
3573 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3574 : null_pointer_node
;
3575 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3576 : null_pointer_node
;
3577 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3578 : null_pointer_node
;
3583 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3584 : null_pointer_node
;
3585 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3586 : null_pointer_node
;
3587 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3588 : null_pointer_node
;
3595 tmp
= build_call_expr_loc (input_location
,
3596 gfor_fndecl_system_clock4
, 3,
3597 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3598 : null_pointer_node
,
3599 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3600 : null_pointer_node
,
3601 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3602 : null_pointer_node
);
3603 gfc_add_expr_to_block (&block
, tmp
);
3605 /* Handle kind>=8, 10, or 16 arguments */
3608 tmp
= build_call_expr_loc (input_location
,
3609 gfor_fndecl_system_clock8
, 3,
3610 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3611 : null_pointer_node
,
3612 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3613 : null_pointer_node
,
3614 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3615 : null_pointer_node
);
3616 gfc_add_expr_to_block (&block
, tmp
);
3620 /* And store values back if needed. */
3621 if (arg1
&& arg1
!= count_se
.expr
)
3622 gfc_add_modify (&block
, count_se
.expr
,
3623 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
3624 if (arg2
&& arg2
!= count_rate_se
.expr
)
3625 gfc_add_modify (&block
, count_rate_se
.expr
,
3626 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
3627 if (arg3
&& arg3
!= count_max_se
.expr
)
3628 gfc_add_modify (&block
, count_max_se
.expr
,
3629 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
3631 return gfc_finish_block (&block
);
3635 /* Return a character string containing the tty name. */
3638 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
3646 unsigned int num_args
;
3648 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3649 args
= XALLOCAVEC (tree
, num_args
);
3651 var
= gfc_create_var (pchar_type_node
, "pstr");
3652 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3654 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3655 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3656 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3658 fndecl
= build_addr (gfor_fndecl_ttynam
);
3659 tmp
= build_call_array_loc (input_location
,
3660 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
3661 fndecl
, num_args
, args
);
3662 gfc_add_expr_to_block (&se
->pre
, tmp
);
3664 /* Free the temporary afterwards, if necessary. */
3665 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3666 len
, build_int_cst (TREE_TYPE (len
), 0));
3667 tmp
= gfc_call_free (var
);
3668 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3669 gfc_add_expr_to_block (&se
->post
, tmp
);
3672 se
->string_length
= len
;
3676 /* Get the minimum/maximum value of all the parameters.
3677 minmax (a1, a2, a3, ...)
3680 if (a2 .op. mvar || isnan (mvar))
3682 if (a3 .op. mvar || isnan (mvar))
3689 /* TODO: Mismatching types can occur when specific names are used.
3690 These should be handled during resolution. */
3692 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3700 gfc_actual_arglist
*argexpr
;
3701 unsigned int i
, nargs
;
3703 nargs
= gfc_intrinsic_argument_list_length (expr
);
3704 args
= XALLOCAVEC (tree
, nargs
);
3706 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
3707 type
= gfc_typenode_for_spec (&expr
->ts
);
3709 argexpr
= expr
->value
.function
.actual
;
3710 if (TREE_TYPE (args
[0]) != type
)
3711 args
[0] = convert (type
, args
[0]);
3712 /* Only evaluate the argument once. */
3713 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
3714 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3716 mvar
= gfc_create_var (type
, "M");
3717 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
3718 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
3724 /* Handle absent optional arguments by ignoring the comparison. */
3725 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
3726 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
3727 && TREE_CODE (val
) == INDIRECT_REF
)
3728 cond
= fold_build2_loc (input_location
,
3729 NE_EXPR
, logical_type_node
,
3730 TREE_OPERAND (val
, 0),
3731 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
3736 /* Only evaluate the argument once. */
3737 if (!VAR_P (val
) && !TREE_CONSTANT (val
))
3738 val
= gfc_evaluate_now (val
, &se
->pre
);
3741 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
3743 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
3744 convert (type
, val
), mvar
);
3746 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3747 __builtin_isnan might be made dependent on that module being loaded,
3748 to help performance of programs that don't rely on IEEE semantics. */
3749 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
3751 isnan
= build_call_expr_loc (input_location
,
3752 builtin_decl_explicit (BUILT_IN_ISNAN
),
3754 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3755 logical_type_node
, tmp
,
3756 fold_convert (logical_type_node
, isnan
));
3758 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
3759 build_empty_stmt (input_location
));
3761 if (cond
!= NULL_TREE
)
3762 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
3763 build_empty_stmt (input_location
));
3765 gfc_add_expr_to_block (&se
->pre
, tmp
);
3766 argexpr
= argexpr
->next
;
3772 /* Generate library calls for MIN and MAX intrinsics for character
3775 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
3778 tree var
, len
, fndecl
, tmp
, cond
, function
;
3781 nargs
= gfc_intrinsic_argument_list_length (expr
);
3782 args
= XALLOCAVEC (tree
, nargs
+ 4);
3783 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
3785 /* Create the result variables. */
3786 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3787 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3788 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3789 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3790 args
[2] = build_int_cst (integer_type_node
, op
);
3791 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3793 if (expr
->ts
.kind
== 1)
3794 function
= gfor_fndecl_string_minmax
;
3795 else if (expr
->ts
.kind
== 4)
3796 function
= gfor_fndecl_string_minmax_char4
;
3800 /* Make the function call. */
3801 fndecl
= build_addr (function
);
3802 tmp
= build_call_array_loc (input_location
,
3803 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3805 gfc_add_expr_to_block (&se
->pre
, tmp
);
3807 /* Free the temporary afterwards, if necessary. */
3808 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3809 len
, build_int_cst (TREE_TYPE (len
), 0));
3810 tmp
= gfc_call_free (var
);
3811 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3812 gfc_add_expr_to_block (&se
->post
, tmp
);
3815 se
->string_length
= len
;
3819 /* Create a symbol node for this intrinsic. The symbol from the frontend
3820 has the generic name. */
3823 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3827 /* TODO: Add symbols for intrinsic function to the global namespace. */
3828 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3829 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3832 sym
->attr
.external
= 1;
3833 sym
->attr
.function
= 1;
3834 sym
->attr
.always_explicit
= 1;
3835 sym
->attr
.proc
= PROC_INTRINSIC
;
3836 sym
->attr
.flavor
= FL_PROCEDURE
;
3840 sym
->attr
.dimension
= 1;
3841 sym
->as
= gfc_get_array_spec ();
3842 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3843 sym
->as
->rank
= expr
->rank
;
3846 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3847 ignore_optional
? expr
->value
.function
.actual
3853 /* Generate a call to an external intrinsic function. */
3855 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3858 vec
<tree
, va_gc
> *append_args
;
3860 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3863 gcc_assert (expr
->rank
> 0);
3865 gcc_assert (expr
->rank
== 0);
3867 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3869 /* Calls to libgfortran_matmul need to be appended special arguments,
3870 to be able to call the BLAS ?gemm functions if required and possible. */
3872 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3873 && sym
->ts
.type
!= BT_LOGICAL
)
3875 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3877 if (flag_external_blas
3878 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3879 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3883 if (sym
->ts
.type
== BT_REAL
)
3885 if (sym
->ts
.kind
== 4)
3886 gemm_fndecl
= gfor_fndecl_sgemm
;
3888 gemm_fndecl
= gfor_fndecl_dgemm
;
3892 if (sym
->ts
.kind
== 4)
3893 gemm_fndecl
= gfor_fndecl_cgemm
;
3895 gemm_fndecl
= gfor_fndecl_zgemm
;
3898 vec_alloc (append_args
, 3);
3899 append_args
->quick_push (build_int_cst (cint
, 1));
3900 append_args
->quick_push (build_int_cst (cint
,
3901 flag_blas_matmul_limit
));
3902 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3907 vec_alloc (append_args
, 3);
3908 append_args
->quick_push (build_int_cst (cint
, 0));
3909 append_args
->quick_push (build_int_cst (cint
, 0));
3910 append_args
->quick_push (null_pointer_node
);
3914 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3916 gfc_free_symbol (sym
);
3919 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3939 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3948 gfc_actual_arglist
*actual
;
3955 gfc_conv_intrinsic_funcall (se
, expr
);
3959 actual
= expr
->value
.function
.actual
;
3960 type
= gfc_typenode_for_spec (&expr
->ts
);
3961 /* Initialize the result. */
3962 resvar
= gfc_create_var (type
, "test");
3964 tmp
= convert (type
, boolean_true_node
);
3966 tmp
= convert (type
, boolean_false_node
);
3967 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3969 /* Walk the arguments. */
3970 arrayss
= gfc_walk_expr (actual
->expr
);
3971 gcc_assert (arrayss
!= gfc_ss_terminator
);
3973 /* Initialize the scalarizer. */
3974 gfc_init_loopinfo (&loop
);
3975 exit_label
= gfc_build_label_decl (NULL_TREE
);
3976 TREE_USED (exit_label
) = 1;
3977 gfc_add_ss_to_loop (&loop
, arrayss
);
3979 /* Initialize the loop. */
3980 gfc_conv_ss_startstride (&loop
);
3981 gfc_conv_loop_setup (&loop
, &expr
->where
);
3983 gfc_mark_ss_chain_used (arrayss
, 1);
3984 /* Generate the loop body. */
3985 gfc_start_scalarized_body (&loop
, &body
);
3987 /* If the condition matches then set the return value. */
3988 gfc_start_block (&block
);
3990 tmp
= convert (type
, boolean_false_node
);
3992 tmp
= convert (type
, boolean_true_node
);
3993 gfc_add_modify (&block
, resvar
, tmp
);
3995 /* And break out of the loop. */
3996 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3997 gfc_add_expr_to_block (&block
, tmp
);
3999 found
= gfc_finish_block (&block
);
4001 /* Check this element. */
4002 gfc_init_se (&arrayse
, NULL
);
4003 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4004 arrayse
.ss
= arrayss
;
4005 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4007 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4008 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
, arrayse
.expr
,
4009 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
4010 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
4011 gfc_add_expr_to_block (&body
, tmp
);
4012 gfc_add_block_to_block (&body
, &arrayse
.post
);
4014 gfc_trans_scalarizing_loops (&loop
, &body
);
4016 /* Add the exit label. */
4017 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4018 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4020 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4021 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4022 gfc_cleanup_loop (&loop
);
4027 /* COUNT(A) = Number of true elements in A. */
4029 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4036 gfc_actual_arglist
*actual
;
4042 gfc_conv_intrinsic_funcall (se
, expr
);
4046 actual
= expr
->value
.function
.actual
;
4048 type
= gfc_typenode_for_spec (&expr
->ts
);
4049 /* Initialize the result. */
4050 resvar
= gfc_create_var (type
, "count");
4051 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4053 /* Walk the arguments. */
4054 arrayss
= gfc_walk_expr (actual
->expr
);
4055 gcc_assert (arrayss
!= gfc_ss_terminator
);
4057 /* Initialize the scalarizer. */
4058 gfc_init_loopinfo (&loop
);
4059 gfc_add_ss_to_loop (&loop
, arrayss
);
4061 /* Initialize the loop. */
4062 gfc_conv_ss_startstride (&loop
);
4063 gfc_conv_loop_setup (&loop
, &expr
->where
);
4065 gfc_mark_ss_chain_used (arrayss
, 1);
4066 /* Generate the loop body. */
4067 gfc_start_scalarized_body (&loop
, &body
);
4069 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4070 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4071 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4073 gfc_init_se (&arrayse
, NULL
);
4074 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4075 arrayse
.ss
= arrayss
;
4076 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4077 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4078 build_empty_stmt (input_location
));
4080 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4081 gfc_add_expr_to_block (&body
, tmp
);
4082 gfc_add_block_to_block (&body
, &arrayse
.post
);
4084 gfc_trans_scalarizing_loops (&loop
, &body
);
4086 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4087 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4088 gfc_cleanup_loop (&loop
);
4094 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4095 struct and return the corresponding loopinfo. */
4097 static gfc_loopinfo
*
4098 enter_nested_loop (gfc_se
*se
)
4100 se
->ss
= se
->ss
->nested_ss
;
4101 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4103 return se
->ss
->loop
;
4107 /* Inline implementation of the sum and product intrinsics. */
4109 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4113 tree scale
= NULL_TREE
;
4118 gfc_loopinfo loop
, *ploop
;
4119 gfc_actual_arglist
*arg_array
, *arg_mask
;
4120 gfc_ss
*arrayss
= NULL
;
4121 gfc_ss
*maskss
= NULL
;
4125 gfc_expr
*arrayexpr
;
4130 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4136 type
= gfc_typenode_for_spec (&expr
->ts
);
4137 /* Initialize the result. */
4138 resvar
= gfc_create_var (type
, "val");
4143 scale
= gfc_create_var (type
, "scale");
4144 gfc_add_modify (&se
->pre
, scale
,
4145 gfc_build_const (type
, integer_one_node
));
4146 tmp
= gfc_build_const (type
, integer_zero_node
);
4148 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4149 tmp
= gfc_build_const (type
, integer_zero_node
);
4150 else if (op
== NE_EXPR
)
4152 tmp
= convert (type
, boolean_false_node
);
4153 else if (op
== BIT_AND_EXPR
)
4154 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4155 type
, integer_one_node
));
4157 tmp
= gfc_build_const (type
, integer_one_node
);
4159 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4161 arg_array
= expr
->value
.function
.actual
;
4163 arrayexpr
= arg_array
->expr
;
4165 if (op
== NE_EXPR
|| norm2
)
4166 /* PARITY and NORM2. */
4170 arg_mask
= arg_array
->next
->next
;
4171 gcc_assert (arg_mask
!= NULL
);
4172 maskexpr
= arg_mask
->expr
;
4175 if (expr
->rank
== 0)
4177 /* Walk the arguments. */
4178 arrayss
= gfc_walk_expr (arrayexpr
);
4179 gcc_assert (arrayss
!= gfc_ss_terminator
);
4181 if (maskexpr
&& maskexpr
->rank
> 0)
4183 maskss
= gfc_walk_expr (maskexpr
);
4184 gcc_assert (maskss
!= gfc_ss_terminator
);
4189 /* Initialize the scalarizer. */
4190 gfc_init_loopinfo (&loop
);
4191 gfc_add_ss_to_loop (&loop
, arrayss
);
4192 if (maskexpr
&& maskexpr
->rank
> 0)
4193 gfc_add_ss_to_loop (&loop
, maskss
);
4195 /* Initialize the loop. */
4196 gfc_conv_ss_startstride (&loop
);
4197 gfc_conv_loop_setup (&loop
, &expr
->where
);
4199 gfc_mark_ss_chain_used (arrayss
, 1);
4200 if (maskexpr
&& maskexpr
->rank
> 0)
4201 gfc_mark_ss_chain_used (maskss
, 1);
4206 /* All the work has been done in the parent loops. */
4207 ploop
= enter_nested_loop (se
);
4211 /* Generate the loop body. */
4212 gfc_start_scalarized_body (ploop
, &body
);
4214 /* If we have a mask, only add this element if the mask is set. */
4215 if (maskexpr
&& maskexpr
->rank
> 0)
4217 gfc_init_se (&maskse
, parent_se
);
4218 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4219 if (expr
->rank
== 0)
4221 gfc_conv_expr_val (&maskse
, maskexpr
);
4222 gfc_add_block_to_block (&body
, &maskse
.pre
);
4224 gfc_start_block (&block
);
4227 gfc_init_block (&block
);
4229 /* Do the actual summation/product. */
4230 gfc_init_se (&arrayse
, parent_se
);
4231 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4232 if (expr
->rank
== 0)
4233 arrayse
.ss
= arrayss
;
4234 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4235 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4239 /* if (x (i) != 0.0)
4245 result = 1.0 + result * val * val;
4251 result += val * val;
4254 tree res1
, res2
, cond
, absX
, val
;
4255 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4257 gfc_init_block (&ifblock1
);
4259 absX
= gfc_create_var (type
, "absX");
4260 gfc_add_modify (&ifblock1
, absX
,
4261 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4263 val
= gfc_create_var (type
, "val");
4264 gfc_add_expr_to_block (&ifblock1
, val
);
4266 gfc_init_block (&ifblock2
);
4267 gfc_add_modify (&ifblock2
, val
,
4268 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4270 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4271 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4272 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4273 gfc_build_const (type
, integer_one_node
));
4274 gfc_add_modify (&ifblock2
, resvar
, res1
);
4275 gfc_add_modify (&ifblock2
, scale
, absX
);
4276 res1
= gfc_finish_block (&ifblock2
);
4278 gfc_init_block (&ifblock3
);
4279 gfc_add_modify (&ifblock3
, val
,
4280 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4282 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4283 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4284 gfc_add_modify (&ifblock3
, resvar
, res2
);
4285 res2
= gfc_finish_block (&ifblock3
);
4287 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4289 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4290 gfc_add_expr_to_block (&ifblock1
, tmp
);
4291 tmp
= gfc_finish_block (&ifblock1
);
4293 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
4295 gfc_build_const (type
, integer_zero_node
));
4297 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4298 gfc_add_expr_to_block (&block
, tmp
);
4302 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4303 gfc_add_modify (&block
, resvar
, tmp
);
4306 gfc_add_block_to_block (&block
, &arrayse
.post
);
4308 if (maskexpr
&& maskexpr
->rank
> 0)
4310 /* We enclose the above in if (mask) {...} . */
4312 tmp
= gfc_finish_block (&block
);
4313 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4314 build_empty_stmt (input_location
));
4317 tmp
= gfc_finish_block (&block
);
4318 gfc_add_expr_to_block (&body
, tmp
);
4320 gfc_trans_scalarizing_loops (ploop
, &body
);
4322 /* For a scalar mask, enclose the loop in an if statement. */
4323 if (maskexpr
&& maskexpr
->rank
== 0)
4325 gfc_init_block (&block
);
4326 gfc_add_block_to_block (&block
, &ploop
->pre
);
4327 gfc_add_block_to_block (&block
, &ploop
->post
);
4328 tmp
= gfc_finish_block (&block
);
4332 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4333 build_empty_stmt (input_location
));
4334 gfc_advance_se_ss_chain (se
);
4338 gcc_assert (expr
->rank
== 0);
4339 gfc_init_se (&maskse
, NULL
);
4340 gfc_conv_expr_val (&maskse
, maskexpr
);
4341 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4342 build_empty_stmt (input_location
));
4345 gfc_add_expr_to_block (&block
, tmp
);
4346 gfc_add_block_to_block (&se
->pre
, &block
);
4347 gcc_assert (se
->post
.head
== NULL
);
4351 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4352 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4355 if (expr
->rank
== 0)
4356 gfc_cleanup_loop (ploop
);
4360 /* result = scale * sqrt(result). */
4362 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4363 resvar
= build_call_expr_loc (input_location
,
4365 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4372 /* Inline implementation of the dot_product intrinsic. This function
4373 is based on gfc_conv_intrinsic_arith (the previous function). */
4375 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4383 gfc_actual_arglist
*actual
;
4384 gfc_ss
*arrayss1
, *arrayss2
;
4385 gfc_se arrayse1
, arrayse2
;
4386 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4388 type
= gfc_typenode_for_spec (&expr
->ts
);
4390 /* Initialize the result. */
4391 resvar
= gfc_create_var (type
, "val");
4392 if (expr
->ts
.type
== BT_LOGICAL
)
4393 tmp
= build_int_cst (type
, 0);
4395 tmp
= gfc_build_const (type
, integer_zero_node
);
4397 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4399 /* Walk argument #1. */
4400 actual
= expr
->value
.function
.actual
;
4401 arrayexpr1
= actual
->expr
;
4402 arrayss1
= gfc_walk_expr (arrayexpr1
);
4403 gcc_assert (arrayss1
!= gfc_ss_terminator
);
4405 /* Walk argument #2. */
4406 actual
= actual
->next
;
4407 arrayexpr2
= actual
->expr
;
4408 arrayss2
= gfc_walk_expr (arrayexpr2
);
4409 gcc_assert (arrayss2
!= gfc_ss_terminator
);
4411 /* Initialize the scalarizer. */
4412 gfc_init_loopinfo (&loop
);
4413 gfc_add_ss_to_loop (&loop
, arrayss1
);
4414 gfc_add_ss_to_loop (&loop
, arrayss2
);
4416 /* Initialize the loop. */
4417 gfc_conv_ss_startstride (&loop
);
4418 gfc_conv_loop_setup (&loop
, &expr
->where
);
4420 gfc_mark_ss_chain_used (arrayss1
, 1);
4421 gfc_mark_ss_chain_used (arrayss2
, 1);
4423 /* Generate the loop body. */
4424 gfc_start_scalarized_body (&loop
, &body
);
4425 gfc_init_block (&block
);
4427 /* Make the tree expression for [conjg(]array1[)]. */
4428 gfc_init_se (&arrayse1
, NULL
);
4429 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
4430 arrayse1
.ss
= arrayss1
;
4431 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
4432 if (expr
->ts
.type
== BT_COMPLEX
)
4433 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
4435 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
4437 /* Make the tree expression for array2. */
4438 gfc_init_se (&arrayse2
, NULL
);
4439 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
4440 arrayse2
.ss
= arrayss2
;
4441 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
4442 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
4444 /* Do the actual product and sum. */
4445 if (expr
->ts
.type
== BT_LOGICAL
)
4447 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
4448 arrayse1
.expr
, arrayse2
.expr
);
4449 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
4453 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
4455 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
4457 gfc_add_modify (&block
, resvar
, tmp
);
4459 /* Finish up the loop block and the loop. */
4460 tmp
= gfc_finish_block (&block
);
4461 gfc_add_expr_to_block (&body
, tmp
);
4463 gfc_trans_scalarizing_loops (&loop
, &body
);
4464 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4465 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4466 gfc_cleanup_loop (&loop
);
4472 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4473 we need to handle. For performance reasons we sometimes create two
4474 loops instead of one, where the second one is much simpler.
4475 Examples for minloc intrinsic:
4476 1) Result is an array, a call is generated
4477 2) Array mask is used and NaNs need to be supported:
4483 if (pos == 0) pos = S + (1 - from);
4484 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4491 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4495 3) NaNs need to be supported, but it is known at compile time or cheaply
4496 at runtime whether array is nonempty or not:
4501 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4504 if (from <= to) pos = 1;
4508 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4512 4) NaNs aren't supported, array mask is used:
4513 limit = infinities_supported ? Infinity : huge (limit);
4517 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4523 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4527 5) Same without array mask:
4528 limit = infinities_supported ? Infinity : huge (limit);
4529 pos = (from <= to) ? 1 : 0;
4532 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4535 For 3) and 5), if mask is scalar, this all goes into a conditional,
4536 setting pos = 0; in the else branch. */
4539 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4543 stmtblock_t ifblock
;
4544 stmtblock_t elseblock
;
4555 gfc_actual_arglist
*actual
;
4560 gfc_expr
*arrayexpr
;
4567 gfc_conv_intrinsic_funcall (se
, expr
);
4571 actual
= expr
->value
.function
.actual
;
4572 arrayexpr
= actual
->expr
;
4574 /* Special case for character maxloc. Remove unneeded actual
4575 arguments, then call a library function. */
4577 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
4579 gfc_actual_arglist
*a2
, *a3
, *a4
;
4584 if (a3
->expr
== NULL
)
4586 actual
->next
= NULL
;
4587 gfc_free_actual_arglist (a2
);
4591 actual
->next
= a3
; /* dim */
4594 gfc_free_actual_arglist (a4
);
4596 gfc_conv_intrinsic_funcall (se
, expr
);
4600 /* Initialize the result. */
4601 pos
= gfc_create_var (gfc_array_index_type
, "pos");
4602 offset
= gfc_create_var (gfc_array_index_type
, "offset");
4603 type
= gfc_typenode_for_spec (&expr
->ts
);
4605 /* Walk the arguments. */
4606 arrayss
= gfc_walk_expr (arrayexpr
);
4607 gcc_assert (arrayss
!= gfc_ss_terminator
);
4609 actual
= actual
->next
->next
;
4610 gcc_assert (actual
);
4611 maskexpr
= actual
->expr
;
4613 if (maskexpr
&& maskexpr
->rank
!= 0)
4615 maskss
= gfc_walk_expr (maskexpr
);
4616 gcc_assert (maskss
!= gfc_ss_terminator
);
4621 if (gfc_array_size (arrayexpr
, &asize
))
4623 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4625 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4626 logical_type_node
, nonempty
,
4627 gfc_index_zero_node
);
4632 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
4633 switch (arrayexpr
->ts
.type
)
4636 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
4640 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
4641 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
4642 arrayexpr
->ts
.kind
);
4649 /* We start with the most negative possible value for MAXLOC, and the most
4650 positive possible value for MINLOC. The most negative possible value is
4651 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4652 possible value is HUGE in both cases. */
4654 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4655 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
4656 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
4657 build_int_cst (TREE_TYPE (tmp
), 1));
4659 gfc_add_modify (&se
->pre
, limit
, tmp
);
4661 /* Initialize the scalarizer. */
4662 gfc_init_loopinfo (&loop
);
4663 gfc_add_ss_to_loop (&loop
, arrayss
);
4665 gfc_add_ss_to_loop (&loop
, maskss
);
4667 /* Initialize the loop. */
4668 gfc_conv_ss_startstride (&loop
);
4670 /* The code generated can have more than one loop in sequence (see the
4671 comment at the function header). This doesn't work well with the
4672 scalarizer, which changes arrays' offset when the scalarization loops
4673 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4674 are currently inlined in the scalar case only (for which loop is of rank
4675 one). As there is no dependency to care about in that case, there is no
4676 temporary, so that we can use the scalarizer temporary code to handle
4677 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4678 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4680 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4681 should eventually go away. We could either create two loops properly,
4682 or find another way to save/restore the array offsets between the two
4683 loops (without conflicting with temporary management), or use a single
4684 loop minmaxloc implementation. See PR 31067. */
4685 loop
.temp_dim
= loop
.dimen
;
4686 gfc_conv_loop_setup (&loop
, &expr
->where
);
4688 gcc_assert (loop
.dimen
== 1);
4689 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
4690 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4691 loop
.from
[0], loop
.to
[0]);
4695 /* Initialize the position to zero, following Fortran 2003. We are free
4696 to do this because Fortran 95 allows the result of an entirely false
4697 mask to be processor dependent. If we know at compile time the array
4698 is non-empty and no MASK is used, we can initialize to 1 to simplify
4700 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
4701 gfc_add_modify (&loop
.pre
, pos
,
4702 fold_build3_loc (input_location
, COND_EXPR
,
4703 gfc_array_index_type
,
4704 nonempty
, gfc_index_one_node
,
4705 gfc_index_zero_node
));
4708 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
4709 lab1
= gfc_build_label_decl (NULL_TREE
);
4710 TREE_USED (lab1
) = 1;
4711 lab2
= gfc_build_label_decl (NULL_TREE
);
4712 TREE_USED (lab2
) = 1;
4715 /* An offset must be added to the loop
4716 counter to obtain the required position. */
4717 gcc_assert (loop
.from
[0]);
4719 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4720 gfc_index_one_node
, loop
.from
[0]);
4721 gfc_add_modify (&loop
.pre
, offset
, tmp
);
4723 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
4725 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
4726 /* Generate the loop body. */
4727 gfc_start_scalarized_body (&loop
, &body
);
4729 /* If we have a mask, only check this element if the mask is set. */
4732 gfc_init_se (&maskse
, NULL
);
4733 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4735 gfc_conv_expr_val (&maskse
, maskexpr
);
4736 gfc_add_block_to_block (&body
, &maskse
.pre
);
4738 gfc_start_block (&block
);
4741 gfc_init_block (&block
);
4743 /* Compare with the current limit. */
4744 gfc_init_se (&arrayse
, NULL
);
4745 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4746 arrayse
.ss
= arrayss
;
4747 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4748 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4750 /* We do the following if this is a more extreme value. */
4751 gfc_start_block (&ifblock
);
4753 /* Assign the value to the limit... */
4754 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4756 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
4758 stmtblock_t ifblock2
;
4761 gfc_start_block (&ifblock2
);
4762 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4763 loop
.loopvar
[0], offset
);
4764 gfc_add_modify (&ifblock2
, pos
, tmp
);
4765 ifbody2
= gfc_finish_block (&ifblock2
);
4766 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pos
,
4767 gfc_index_zero_node
);
4768 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
4769 build_empty_stmt (input_location
));
4770 gfc_add_expr_to_block (&block
, tmp
);
4773 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4774 loop
.loopvar
[0], offset
);
4775 gfc_add_modify (&ifblock
, pos
, tmp
);
4778 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
4780 ifbody
= gfc_finish_block (&ifblock
);
4782 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
4785 cond
= fold_build2_loc (input_location
,
4786 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4787 logical_type_node
, arrayse
.expr
, limit
);
4789 cond
= fold_build2_loc (input_location
, op
, logical_type_node
,
4790 arrayse
.expr
, limit
);
4792 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
4793 build_empty_stmt (input_location
));
4795 gfc_add_expr_to_block (&block
, ifbody
);
4799 /* We enclose the above in if (mask) {...}. */
4800 tmp
= gfc_finish_block (&block
);
4802 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4803 build_empty_stmt (input_location
));
4806 tmp
= gfc_finish_block (&block
);
4807 gfc_add_expr_to_block (&body
, tmp
);
4811 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4813 if (HONOR_NANS (DECL_MODE (limit
)))
4815 if (nonempty
!= NULL
)
4817 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
4818 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
4819 build_empty_stmt (input_location
));
4820 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
4824 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
4825 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
4827 /* If we have a mask, only check this element if the mask is set. */
4830 gfc_init_se (&maskse
, NULL
);
4831 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4833 gfc_conv_expr_val (&maskse
, maskexpr
);
4834 gfc_add_block_to_block (&body
, &maskse
.pre
);
4836 gfc_start_block (&block
);
4839 gfc_init_block (&block
);
4841 /* Compare with the current limit. */
4842 gfc_init_se (&arrayse
, NULL
);
4843 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4844 arrayse
.ss
= arrayss
;
4845 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4846 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4848 /* We do the following if this is a more extreme value. */
4849 gfc_start_block (&ifblock
);
4851 /* Assign the value to the limit... */
4852 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4854 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4855 loop
.loopvar
[0], offset
);
4856 gfc_add_modify (&ifblock
, pos
, tmp
);
4858 ifbody
= gfc_finish_block (&ifblock
);
4860 cond
= fold_build2_loc (input_location
, op
, logical_type_node
,
4861 arrayse
.expr
, limit
);
4863 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4864 build_empty_stmt (input_location
));
4865 gfc_add_expr_to_block (&block
, tmp
);
4869 /* We enclose the above in if (mask) {...}. */
4870 tmp
= gfc_finish_block (&block
);
4872 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4873 build_empty_stmt (input_location
));
4876 tmp
= gfc_finish_block (&block
);
4877 gfc_add_expr_to_block (&body
, tmp
);
4878 /* Avoid initializing loopvar[0] again, it should be left where
4879 it finished by the first loop. */
4880 loop
.from
[0] = loop
.loopvar
[0];
4883 gfc_trans_scalarizing_loops (&loop
, &body
);
4886 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4888 /* For a scalar mask, enclose the loop in an if statement. */
4889 if (maskexpr
&& maskss
== NULL
)
4891 gfc_init_se (&maskse
, NULL
);
4892 gfc_conv_expr_val (&maskse
, maskexpr
);
4893 gfc_init_block (&block
);
4894 gfc_add_block_to_block (&block
, &loop
.pre
);
4895 gfc_add_block_to_block (&block
, &loop
.post
);
4896 tmp
= gfc_finish_block (&block
);
4898 /* For the else part of the scalar mask, just initialize
4899 the pos variable the same way as above. */
4901 gfc_init_block (&elseblock
);
4902 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4903 elsetmp
= gfc_finish_block (&elseblock
);
4905 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4906 gfc_add_expr_to_block (&block
, tmp
);
4907 gfc_add_block_to_block (&se
->pre
, &block
);
4911 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4912 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4914 gfc_cleanup_loop (&loop
);
4916 se
->expr
= convert (type
, pos
);
4919 /* Emit code for minval or maxval intrinsic. There are many different cases
4920 we need to handle. For performance reasons we sometimes create two
4921 loops instead of one, where the second one is much simpler.
4922 Examples for minval intrinsic:
4923 1) Result is an array, a call is generated
4924 2) Array mask is used and NaNs need to be supported, rank 1:
4929 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4932 limit = nonempty ? NaN : huge (limit);
4934 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4935 3) NaNs need to be supported, but it is known at compile time or cheaply
4936 at runtime whether array is nonempty or not, rank 1:
4939 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4940 limit = (from <= to) ? NaN : huge (limit);
4942 while (S <= to) { limit = min (a[S], limit); S++; }
4943 4) Array mask is used and NaNs need to be supported, rank > 1:
4952 if (fast) limit = min (a[S1][S2], limit);
4955 if (a[S1][S2] <= limit) {
4966 limit = nonempty ? NaN : huge (limit);
4967 5) NaNs need to be supported, but it is known at compile time or cheaply
4968 at runtime whether array is nonempty or not, rank > 1:
4975 if (fast) limit = min (a[S1][S2], limit);
4977 if (a[S1][S2] <= limit) {
4987 limit = (nonempty_array) ? NaN : huge (limit);
4988 6) NaNs aren't supported, but infinities are. Array mask is used:
4993 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4996 limit = nonempty ? limit : huge (limit);
4997 7) Same without array mask:
5000 while (S <= to) { limit = min (a[S], limit); S++; }
5001 limit = (from <= to) ? limit : huge (limit);
5002 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
5003 limit = huge (limit);
5005 while (S <= to) { limit = min (a[S], limit); S++); }
5007 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
5008 with array mask instead).
5009 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
5010 setting limit = huge (limit); in the else branch. */
5013 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5023 tree huge_cst
= NULL
, nan_cst
= NULL
;
5025 stmtblock_t block
, block2
;
5027 gfc_actual_arglist
*actual
;
5032 gfc_expr
*arrayexpr
;
5038 gfc_conv_intrinsic_funcall (se
, expr
);
5042 actual
= expr
->value
.function
.actual
;
5043 arrayexpr
= actual
->expr
;
5045 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5047 gfc_actual_arglist
*a2
, *a3
;
5048 a2
= actual
->next
; /* dim */
5049 a3
= a2
->next
; /* mask */
5050 if (a2
->expr
== NULL
|| expr
->rank
== 0)
5052 if (a3
->expr
== NULL
)
5053 actual
->next
= NULL
;
5059 gfc_free_actual_arglist (a2
);
5062 if (a3
->expr
== NULL
)
5065 gfc_free_actual_arglist (a3
);
5067 gfc_conv_intrinsic_funcall (se
, expr
);
5070 type
= gfc_typenode_for_spec (&expr
->ts
);
5071 /* Initialize the result. */
5072 limit
= gfc_create_var (type
, "limit");
5073 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
5074 switch (expr
->ts
.type
)
5077 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
5079 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5081 REAL_VALUE_TYPE real
;
5083 tmp
= build_real (type
, real
);
5087 if (HONOR_NANS (DECL_MODE (limit
)))
5088 nan_cst
= gfc_build_nan (type
, "");
5092 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
5099 /* We start with the most negative possible value for MAXVAL, and the most
5100 positive possible value for MINVAL. The most negative possible value is
5101 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5102 possible value is HUGE in both cases. */
5105 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5107 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
5108 TREE_TYPE (huge_cst
), huge_cst
);
5111 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
5112 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5113 tmp
, build_int_cst (type
, 1));
5115 gfc_add_modify (&se
->pre
, limit
, tmp
);
5117 /* Walk the arguments. */
5118 arrayss
= gfc_walk_expr (arrayexpr
);
5119 gcc_assert (arrayss
!= gfc_ss_terminator
);
5121 actual
= actual
->next
->next
;
5122 gcc_assert (actual
);
5123 maskexpr
= actual
->expr
;
5125 if (maskexpr
&& maskexpr
->rank
!= 0)
5127 maskss
= gfc_walk_expr (maskexpr
);
5128 gcc_assert (maskss
!= gfc_ss_terminator
);
5133 if (gfc_array_size (arrayexpr
, &asize
))
5135 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5137 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5138 logical_type_node
, nonempty
,
5139 gfc_index_zero_node
);
5144 /* Initialize the scalarizer. */
5145 gfc_init_loopinfo (&loop
);
5146 gfc_add_ss_to_loop (&loop
, arrayss
);
5148 gfc_add_ss_to_loop (&loop
, maskss
);
5150 /* Initialize the loop. */
5151 gfc_conv_ss_startstride (&loop
);
5153 /* The code generated can have more than one loop in sequence (see the
5154 comment at the function header). This doesn't work well with the
5155 scalarizer, which changes arrays' offset when the scalarization loops
5156 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5157 are currently inlined in the scalar case only. As there is no dependency
5158 to care about in that case, there is no temporary, so that we can use the
5159 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5160 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5161 gfc_trans_scalarized_loop_boundary even later to restore offset.
5162 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5163 should eventually go away. We could either create two loops properly,
5164 or find another way to save/restore the array offsets between the two
5165 loops (without conflicting with temporary management), or use a single
5166 loop minmaxval implementation. See PR 31067. */
5167 loop
.temp_dim
= loop
.dimen
;
5168 gfc_conv_loop_setup (&loop
, &expr
->where
);
5170 if (nonempty
== NULL
&& maskss
== NULL
5171 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5172 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5173 loop
.from
[0], loop
.to
[0]);
5174 nonempty_var
= NULL
;
5175 if (nonempty
== NULL
5176 && (HONOR_INFINITIES (DECL_MODE (limit
))
5177 || HONOR_NANS (DECL_MODE (limit
))))
5179 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
5180 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
5181 nonempty
= nonempty_var
;
5185 if (HONOR_NANS (DECL_MODE (limit
)))
5187 if (loop
.dimen
== 1)
5189 lab
= gfc_build_label_decl (NULL_TREE
);
5190 TREE_USED (lab
) = 1;
5194 fast
= gfc_create_var (logical_type_node
, "fast");
5195 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
5199 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5201 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5202 /* Generate the loop body. */
5203 gfc_start_scalarized_body (&loop
, &body
);
5205 /* If we have a mask, only add this element if the mask is set. */
5208 gfc_init_se (&maskse
, NULL
);
5209 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5211 gfc_conv_expr_val (&maskse
, maskexpr
);
5212 gfc_add_block_to_block (&body
, &maskse
.pre
);
5214 gfc_start_block (&block
);
5217 gfc_init_block (&block
);
5219 /* Compare with the current limit. */
5220 gfc_init_se (&arrayse
, NULL
);
5221 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5222 arrayse
.ss
= arrayss
;
5223 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5224 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5226 gfc_init_block (&block2
);
5229 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
5231 if (HONOR_NANS (DECL_MODE (limit
)))
5233 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5234 logical_type_node
, arrayse
.expr
, limit
);
5236 ifbody
= build1_v (GOTO_EXPR
, lab
);
5239 stmtblock_t ifblock
;
5241 gfc_init_block (&ifblock
);
5242 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5243 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
5244 ifbody
= gfc_finish_block (&ifblock
);
5246 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5247 build_empty_stmt (input_location
));
5248 gfc_add_expr_to_block (&block2
, tmp
);
5252 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5254 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5256 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5257 arrayse
.expr
, limit
);
5258 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5259 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5260 build_empty_stmt (input_location
));
5261 gfc_add_expr_to_block (&block2
, tmp
);
5265 tmp
= fold_build2_loc (input_location
,
5266 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5267 type
, arrayse
.expr
, limit
);
5268 gfc_add_modify (&block2
, limit
, tmp
);
5274 tree elsebody
= gfc_finish_block (&block2
);
5276 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5278 if (HONOR_NANS (DECL_MODE (limit
))
5279 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5281 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5282 arrayse
.expr
, limit
);
5283 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5284 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5285 build_empty_stmt (input_location
));
5289 tmp
= fold_build2_loc (input_location
,
5290 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5291 type
, arrayse
.expr
, limit
);
5292 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5294 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5295 gfc_add_expr_to_block (&block
, tmp
);
5298 gfc_add_block_to_block (&block
, &block2
);
5300 gfc_add_block_to_block (&block
, &arrayse
.post
);
5302 tmp
= gfc_finish_block (&block
);
5304 /* We enclose the above in if (mask) {...}. */
5305 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5306 build_empty_stmt (input_location
));
5307 gfc_add_expr_to_block (&body
, tmp
);
5311 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5313 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5315 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
5316 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
5318 /* If we have a mask, only add this element if the mask is set. */
5321 gfc_init_se (&maskse
, NULL
);
5322 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5324 gfc_conv_expr_val (&maskse
, maskexpr
);
5325 gfc_add_block_to_block (&body
, &maskse
.pre
);
5327 gfc_start_block (&block
);
5330 gfc_init_block (&block
);
5332 /* Compare with the current limit. */
5333 gfc_init_se (&arrayse
, NULL
);
5334 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5335 arrayse
.ss
= arrayss
;
5336 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5337 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5339 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5341 if (HONOR_NANS (DECL_MODE (limit
))
5342 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5344 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5345 arrayse
.expr
, limit
);
5346 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5347 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5348 build_empty_stmt (input_location
));
5349 gfc_add_expr_to_block (&block
, tmp
);
5353 tmp
= fold_build2_loc (input_location
,
5354 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5355 type
, arrayse
.expr
, limit
);
5356 gfc_add_modify (&block
, limit
, tmp
);
5359 gfc_add_block_to_block (&block
, &arrayse
.post
);
5361 tmp
= gfc_finish_block (&block
);
5363 /* We enclose the above in if (mask) {...}. */
5364 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5365 build_empty_stmt (input_location
));
5366 gfc_add_expr_to_block (&body
, tmp
);
5367 /* Avoid initializing loopvar[0] again, it should be left where
5368 it finished by the first loop. */
5369 loop
.from
[0] = loop
.loopvar
[0];
5371 gfc_trans_scalarizing_loops (&loop
, &body
);
5375 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5377 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5378 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
5380 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5382 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
5384 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
5386 gfc_add_modify (&loop
.pre
, limit
, tmp
);
5389 /* For a scalar mask, enclose the loop in an if statement. */
5390 if (maskexpr
&& maskss
== NULL
)
5394 gfc_init_se (&maskse
, NULL
);
5395 gfc_conv_expr_val (&maskse
, maskexpr
);
5396 gfc_init_block (&block
);
5397 gfc_add_block_to_block (&block
, &loop
.pre
);
5398 gfc_add_block_to_block (&block
, &loop
.post
);
5399 tmp
= gfc_finish_block (&block
);
5401 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5402 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
5404 else_stmt
= build_empty_stmt (input_location
);
5405 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
5406 gfc_add_expr_to_block (&block
, tmp
);
5407 gfc_add_block_to_block (&se
->pre
, &block
);
5411 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5412 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5415 gfc_cleanup_loop (&loop
);
5420 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5422 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
5428 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5429 type
= TREE_TYPE (args
[0]);
5431 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5432 build_int_cst (type
, 1), args
[1]);
5433 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
5434 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
5435 build_int_cst (type
, 0));
5436 type
= gfc_typenode_for_spec (&expr
->ts
);
5437 se
->expr
= convert (type
, tmp
);
5441 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5443 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5447 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5449 /* Convert both arguments to the unsigned type of the same size. */
5450 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
5451 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
5453 /* If they have unequal type size, convert to the larger one. */
5454 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
5455 > TYPE_PRECISION (TREE_TYPE (args
[1])))
5456 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
5457 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
5458 > TYPE_PRECISION (TREE_TYPE (args
[0])))
5459 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
5461 /* Now, we compare them. */
5462 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
5467 /* Generate code to perform the specified operation. */
5469 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5473 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5474 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
5480 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
5484 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5485 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5486 TREE_TYPE (arg
), arg
);
5489 /* Set or clear a single bit. */
5491 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
5498 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5499 type
= TREE_TYPE (args
[0]);
5501 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5502 build_int_cst (type
, 1), args
[1]);
5508 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
5510 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
5513 /* Extract a sequence of bits.
5514 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5516 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
5523 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5524 type
= TREE_TYPE (args
[0]);
5526 mask
= build_int_cst (type
, -1);
5527 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
5528 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
5530 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
5532 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
5536 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
5539 tree args
[2], type
, num_bits
, cond
;
5541 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5543 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5544 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5545 type
= TREE_TYPE (args
[0]);
5548 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
5550 gcc_assert (right_shift
);
5552 se
->expr
= fold_build2_loc (input_location
,
5553 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
5554 TREE_TYPE (args
[0]), args
[0], args
[1]);
5557 se
->expr
= fold_convert (type
, se
->expr
);
5559 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5560 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5562 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5563 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
5566 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5567 build_int_cst (type
, 0), se
->expr
);
5570 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5572 : ((shift >= 0) ? i << shift : i >> -shift)
5573 where all shifts are logical shifts. */
5575 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
5587 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5589 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5590 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5592 type
= TREE_TYPE (args
[0]);
5593 utype
= unsigned_type_for (type
);
5595 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
5598 /* Left shift if positive. */
5599 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
5601 /* Right shift if negative.
5602 We convert to an unsigned type because we want a logical shift.
5603 The standard doesn't define the case of shifting negative
5604 numbers, and we try to be compatible with other compilers, most
5605 notably g77, here. */
5606 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
5607 utype
, convert (utype
, args
[0]), width
));
5609 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
5610 build_int_cst (TREE_TYPE (args
[1]), 0));
5611 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
5613 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5614 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5616 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5617 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
5619 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5620 build_int_cst (type
, 0), tmp
);
5624 /* Circular shift. AKA rotate or barrel shift. */
5627 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
5635 unsigned int num_args
;
5637 num_args
= gfc_intrinsic_argument_list_length (expr
);
5638 args
= XALLOCAVEC (tree
, num_args
);
5640 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5644 /* Use a library function for the 3 parameter version. */
5645 tree int4type
= gfc_get_int_type (4);
5647 type
= TREE_TYPE (args
[0]);
5648 /* We convert the first argument to at least 4 bytes, and
5649 convert back afterwards. This removes the need for library
5650 functions for all argument sizes, and function will be
5651 aligned to at least 32 bits, so there's no loss. */
5652 if (expr
->ts
.kind
< 4)
5653 args
[0] = convert (int4type
, args
[0]);
5655 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5656 need loads of library functions. They cannot have values >
5657 BIT_SIZE (I) so the conversion is safe. */
5658 args
[1] = convert (int4type
, args
[1]);
5659 args
[2] = convert (int4type
, args
[2]);
5661 switch (expr
->ts
.kind
)
5666 tmp
= gfor_fndecl_math_ishftc4
;
5669 tmp
= gfor_fndecl_math_ishftc8
;
5672 tmp
= gfor_fndecl_math_ishftc16
;
5677 se
->expr
= build_call_expr_loc (input_location
,
5678 tmp
, 3, args
[0], args
[1], args
[2]);
5679 /* Convert the result back to the original type, if we extended
5680 the first argument's width above. */
5681 if (expr
->ts
.kind
< 4)
5682 se
->expr
= convert (type
, se
->expr
);
5686 type
= TREE_TYPE (args
[0]);
5688 /* Evaluate arguments only once. */
5689 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5690 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5692 /* Rotate left if positive. */
5693 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
5695 /* Rotate right if negative. */
5696 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
5698 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
5700 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
5701 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
5703 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
5705 /* Do nothing if shift == 0. */
5706 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
5708 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
5713 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5714 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5716 The conditional expression is necessary because the result of LEADZ(0)
5717 is defined, but the result of __builtin_clz(0) is undefined for most
5720 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5721 difference in bit size between the argument of LEADZ and the C int. */
5724 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
5736 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5737 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5739 /* Which variant of __builtin_clz* should we call? */
5740 if (argsize
<= INT_TYPE_SIZE
)
5742 arg_type
= unsigned_type_node
;
5743 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
5745 else if (argsize
<= LONG_TYPE_SIZE
)
5747 arg_type
= long_unsigned_type_node
;
5748 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
5750 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5752 arg_type
= long_long_unsigned_type_node
;
5753 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5757 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5758 arg_type
= gfc_build_uint_type (argsize
);
5762 /* Convert the actual argument twice: first, to the unsigned type of the
5763 same size; then, to the proper argument type for the built-in
5764 function. But the return type is of the default INTEGER kind. */
5765 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5766 arg
= fold_convert (arg_type
, arg
);
5767 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5768 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5770 /* Compute LEADZ for the case i .ne. 0. */
5773 s
= TYPE_PRECISION (arg_type
) - argsize
;
5774 tmp
= fold_convert (result_type
,
5775 build_call_expr_loc (input_location
, func
,
5777 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
5778 tmp
, build_int_cst (result_type
, s
));
5782 /* We end up here if the argument type is larger than 'long long'.
5783 We generate this code:
5785 if (x & (ULL_MAX << ULL_SIZE) != 0)
5786 return clzll ((unsigned long long) (x >> ULLSIZE));
5788 return ULL_SIZE + clzll ((unsigned long long) x);
5789 where ULL_MAX is the largest value that a ULL_MAX can hold
5790 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5791 is the bit-size of the long long type (64 in this example). */
5792 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5794 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5795 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5796 long_long_unsigned_type_node
,
5797 build_int_cst (long_long_unsigned_type_node
,
5800 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
5801 fold_convert (arg_type
, ullmax
), ullsize
);
5802 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
5804 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
5805 cond
, build_int_cst (arg_type
, 0));
5807 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5809 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5810 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5811 tmp1
= fold_convert (result_type
,
5812 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5814 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5815 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5816 tmp2
= fold_convert (result_type
,
5817 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5818 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5821 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5825 /* Build BIT_SIZE. */
5826 bit_size
= build_int_cst (result_type
, argsize
);
5828 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5829 arg
, build_int_cst (arg_type
, 0));
5830 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5835 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5837 The conditional expression is necessary because the result of TRAILZ(0)
5838 is defined, but the result of __builtin_ctz(0) is undefined for most
5842 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
5853 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5854 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5856 /* Which variant of __builtin_ctz* should we call? */
5857 if (argsize
<= INT_TYPE_SIZE
)
5859 arg_type
= unsigned_type_node
;
5860 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5862 else if (argsize
<= LONG_TYPE_SIZE
)
5864 arg_type
= long_unsigned_type_node
;
5865 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5867 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5869 arg_type
= long_long_unsigned_type_node
;
5870 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5874 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5875 arg_type
= gfc_build_uint_type (argsize
);
5879 /* Convert the actual argument twice: first, to the unsigned type of the
5880 same size; then, to the proper argument type for the built-in
5881 function. But the return type is of the default INTEGER kind. */
5882 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5883 arg
= fold_convert (arg_type
, arg
);
5884 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5885 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5887 /* Compute TRAILZ for the case i .ne. 0. */
5889 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5893 /* We end up here if the argument type is larger than 'long long'.
5894 We generate this code:
5896 if ((x & ULL_MAX) == 0)
5897 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5899 return ctzll ((unsigned long long) x);
5901 where ULL_MAX is the largest value that a ULL_MAX can hold
5902 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5903 is the bit-size of the long long type (64 in this example). */
5904 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5906 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5907 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5908 long_long_unsigned_type_node
,
5909 build_int_cst (long_long_unsigned_type_node
, 0));
5911 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5912 fold_convert (arg_type
, ullmax
));
5913 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
5914 build_int_cst (arg_type
, 0));
5916 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5918 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5919 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5920 tmp1
= fold_convert (result_type
,
5921 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5922 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5925 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5926 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5927 tmp2
= fold_convert (result_type
,
5928 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5930 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5934 /* Build BIT_SIZE. */
5935 bit_size
= build_int_cst (result_type
, argsize
);
5937 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5938 arg
, build_int_cst (arg_type
, 0));
5939 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5943 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5944 for types larger than "long long", we call the long long built-in for
5945 the lower and higher bits and combine the result. */
5948 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5956 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5957 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5958 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5960 /* Which variant of the builtin should we call? */
5961 if (argsize
<= INT_TYPE_SIZE
)
5963 arg_type
= unsigned_type_node
;
5964 func
= builtin_decl_explicit (parity
5966 : BUILT_IN_POPCOUNT
);
5968 else if (argsize
<= LONG_TYPE_SIZE
)
5970 arg_type
= long_unsigned_type_node
;
5971 func
= builtin_decl_explicit (parity
5973 : BUILT_IN_POPCOUNTL
);
5975 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5977 arg_type
= long_long_unsigned_type_node
;
5978 func
= builtin_decl_explicit (parity
5980 : BUILT_IN_POPCOUNTLL
);
5984 /* Our argument type is larger than 'long long', which mean none
5985 of the POPCOUNT builtins covers it. We thus call the 'long long'
5986 variant multiple times, and add the results. */
5987 tree utype
, arg2
, call1
, call2
;
5989 /* For now, we only cover the case where argsize is twice as large
5991 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5993 func
= builtin_decl_explicit (parity
5995 : BUILT_IN_POPCOUNTLL
);
5997 /* Convert it to an integer, and store into a variable. */
5998 utype
= gfc_build_uint_type (argsize
);
5999 arg
= fold_convert (utype
, arg
);
6000 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6002 /* Call the builtin twice. */
6003 call1
= build_call_expr_loc (input_location
, func
, 1,
6004 fold_convert (long_long_unsigned_type_node
,
6007 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
6008 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
6009 call2
= build_call_expr_loc (input_location
, func
, 1,
6010 fold_convert (long_long_unsigned_type_node
,
6013 /* Combine the results. */
6015 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
6018 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6024 /* Convert the actual argument twice: first, to the unsigned type of the
6025 same size; then, to the proper argument type for the built-in
6027 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6028 arg
= fold_convert (arg_type
, arg
);
6030 se
->expr
= fold_convert (result_type
,
6031 build_call_expr_loc (input_location
, func
, 1, arg
));
6035 /* Process an intrinsic with unspecified argument-types that has an optional
6036 argument (which could be of type character), e.g. EOSHIFT. For those, we
6037 need to append the string length of the optional argument if it is not
6038 present and the type is really character.
6039 primary specifies the position (starting at 1) of the non-optional argument
6040 specifying the type and optional gives the position of the optional
6041 argument in the arglist. */
6044 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
6045 unsigned primary
, unsigned optional
)
6047 gfc_actual_arglist
* prim_arg
;
6048 gfc_actual_arglist
* opt_arg
;
6050 gfc_actual_arglist
* arg
;
6052 vec
<tree
, va_gc
> *append_args
;
6054 /* Find the two arguments given as position. */
6058 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
6062 if (cur_pos
== primary
)
6064 if (cur_pos
== optional
)
6067 if (cur_pos
>= primary
&& cur_pos
>= optional
)
6070 gcc_assert (prim_arg
);
6071 gcc_assert (prim_arg
->expr
);
6072 gcc_assert (opt_arg
);
6074 /* If we do have type CHARACTER and the optional argument is really absent,
6075 append a dummy 0 as string length. */
6077 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
6081 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
6082 vec_alloc (append_args
, 1);
6083 append_args
->quick_push (dummy
);
6086 /* Build the call itself. */
6087 gcc_assert (!se
->ignore_optional
);
6088 sym
= gfc_get_symbol_for_expr (expr
, false);
6089 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6091 gfc_free_symbol (sym
);
6095 /* The length of a character string. */
6097 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
6106 gcc_assert (!se
->ss
);
6108 arg
= expr
->value
.function
.actual
->expr
;
6110 type
= gfc_typenode_for_spec (&expr
->ts
);
6111 switch (arg
->expr_type
)
6114 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
6118 /* Obtain the string length from the function used by
6119 trans-array.c(gfc_trans_array_constructor). */
6121 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
6125 if (arg
->ref
== NULL
6126 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6128 /* This doesn't catch all cases.
6129 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6130 and the surrounding thread. */
6131 sym
= arg
->symtree
->n
.sym
;
6132 decl
= gfc_get_symbol_decl (sym
);
6133 if (decl
== current_function_decl
&& sym
->attr
.function
6134 && (sym
->result
== sym
))
6135 decl
= gfc_get_fake_result_decl (sym
, 0);
6137 len
= sym
->ts
.u
.cl
->backend_decl
;
6145 /* Anybody stupid enough to do this deserves inefficient code. */
6146 gfc_init_se (&argse
, se
);
6148 gfc_conv_expr (&argse
, arg
);
6150 gfc_conv_expr_descriptor (&argse
, arg
);
6151 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6152 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6153 len
= argse
.string_length
;
6156 se
->expr
= convert (type
, len
);
6159 /* The length of a character string not including trailing blanks. */
6161 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6163 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6164 tree args
[2], type
, fndecl
;
6166 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6167 type
= gfc_typenode_for_spec (&expr
->ts
);
6170 fndecl
= gfor_fndecl_string_len_trim
;
6172 fndecl
= gfor_fndecl_string_len_trim_char4
;
6176 se
->expr
= build_call_expr_loc (input_location
,
6177 fndecl
, 2, args
[0], args
[1]);
6178 se
->expr
= convert (type
, se
->expr
);
6182 /* Returns the starting position of a substring within a string. */
6185 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6188 tree logical4_type_node
= gfc_get_logical_type (4);
6192 unsigned int num_args
;
6194 args
= XALLOCAVEC (tree
, 5);
6196 /* Get number of arguments; characters count double due to the
6197 string length argument. Kind= is not passed to the library
6198 and thus ignored. */
6199 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6204 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6205 type
= gfc_typenode_for_spec (&expr
->ts
);
6208 args
[4] = build_int_cst (logical4_type_node
, 0);
6210 args
[4] = convert (logical4_type_node
, args
[4]);
6212 fndecl
= build_addr (function
);
6213 se
->expr
= build_call_array_loc (input_location
,
6214 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6216 se
->expr
= convert (type
, se
->expr
);
6220 /* The ascii value for a single character. */
6222 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6224 tree args
[3], type
, pchartype
;
6227 nargs
= gfc_intrinsic_argument_list_length (expr
);
6228 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6229 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6230 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6231 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6232 type
= gfc_typenode_for_spec (&expr
->ts
);
6234 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6236 se
->expr
= convert (type
, se
->expr
);
6240 /* Intrinsic ISNAN calls __builtin_isnan. */
6243 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6247 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6248 se
->expr
= build_call_expr_loc (input_location
,
6249 builtin_decl_explicit (BUILT_IN_ISNAN
),
6251 STRIP_TYPE_NOPS (se
->expr
);
6252 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6256 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6257 their argument against a constant integer value. */
6260 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6264 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6265 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6266 gfc_typenode_for_spec (&expr
->ts
),
6267 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6272 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6275 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
6283 unsigned int num_args
;
6285 num_args
= gfc_intrinsic_argument_list_length (expr
);
6286 args
= XALLOCAVEC (tree
, num_args
);
6288 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6289 if (expr
->ts
.type
!= BT_CHARACTER
)
6297 /* We do the same as in the non-character case, but the argument
6298 list is different because of the string length arguments. We
6299 also have to set the string length for the result. */
6306 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
6308 se
->string_length
= len
;
6310 type
= TREE_TYPE (tsource
);
6311 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
6312 fold_convert (type
, fsource
));
6316 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6319 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
6321 tree args
[3], mask
, type
;
6323 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6324 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
6326 type
= TREE_TYPE (args
[0]);
6327 gcc_assert (TREE_TYPE (args
[1]) == type
);
6328 gcc_assert (TREE_TYPE (mask
) == type
);
6330 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
6331 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
6332 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6334 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
6339 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6340 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6343 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
6345 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
6348 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6349 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6351 type
= gfc_get_int_type (expr
->ts
.kind
);
6352 utype
= unsigned_type_for (type
);
6354 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
6355 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
6357 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
6358 build_int_cst (utype
, 0));
6362 /* Left-justified mask. */
6363 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
6365 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6366 fold_convert (utype
, res
));
6368 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6369 smaller than type width. */
6370 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6371 build_int_cst (TREE_TYPE (arg
), 0));
6372 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
6373 build_int_cst (utype
, 0), res
);
6377 /* Right-justified mask. */
6378 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6379 fold_convert (utype
, arg
));
6380 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
6382 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6383 strictly smaller than type width. */
6384 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6386 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
6387 cond
, allones
, res
);
6390 se
->expr
= fold_convert (type
, res
);
6394 /* FRACTION (s) is translated into:
6395 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6397 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
6399 tree arg
, type
, tmp
, res
, frexp
, cond
;
6401 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6403 type
= gfc_typenode_for_spec (&expr
->ts
);
6404 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6405 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6407 cond
= build_call_expr_loc (input_location
,
6408 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6411 tmp
= gfc_create_var (integer_type_node
, NULL
);
6412 res
= build_call_expr_loc (input_location
, frexp
, 2,
6413 fold_convert (type
, arg
),
6414 gfc_build_addr_expr (NULL_TREE
, tmp
));
6415 res
= fold_convert (type
, res
);
6417 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
6418 cond
, res
, gfc_build_nan (type
, ""));
6422 /* NEAREST (s, dir) is translated into
6423 tmp = copysign (HUGE_VAL, dir);
6424 return nextafter (s, tmp);
6427 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
6429 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
6431 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
6432 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
6434 type
= gfc_typenode_for_spec (&expr
->ts
);
6435 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6437 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
6438 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
6439 fold_convert (type
, args
[1]));
6440 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
6441 fold_convert (type
, args
[0]), tmp
);
6442 se
->expr
= fold_convert (type
, se
->expr
);
6446 /* SPACING (s) is translated into
6456 e = MAX_EXPR (e, emin);
6457 res = scalbn (1., e);
6461 where prec is the precision of s, gfc_real_kinds[k].digits,
6462 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6463 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6466 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
6468 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
6469 tree cond
, nan
, tmp
, frexp
, scalbn
;
6473 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6474 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
6475 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
6476 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
6478 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6479 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6481 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6482 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6484 type
= gfc_typenode_for_spec (&expr
->ts
);
6485 e
= gfc_create_var (integer_type_node
, NULL
);
6486 res
= gfc_create_var (type
, NULL
);
6489 /* Build the block for s /= 0. */
6490 gfc_start_block (&block
);
6491 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6492 gfc_build_addr_expr (NULL_TREE
, e
));
6493 gfc_add_expr_to_block (&block
, tmp
);
6495 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
6497 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
6498 integer_type_node
, tmp
, emin
));
6500 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
6501 build_real_from_int_cst (type
, integer_one_node
), e
);
6502 gfc_add_modify (&block
, res
, tmp
);
6504 /* Finish by building the IF statement for value zero. */
6505 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6506 build_real_from_int_cst (type
, integer_zero_node
));
6507 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
6508 gfc_finish_block (&block
));
6510 /* And deal with infinities and NaNs. */
6511 cond
= build_call_expr_loc (input_location
,
6512 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6514 nan
= gfc_build_nan (type
, "");
6515 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
6517 gfc_add_expr_to_block (&se
->pre
, tmp
);
6522 /* RRSPACING (s) is translated into
6531 x = scalbn (x, precision - e);
6538 where precision is gfc_real_kinds[k].digits. */
6541 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
6543 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
6547 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6548 prec
= gfc_real_kinds
[k
].digits
;
6550 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6551 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6552 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
6554 type
= gfc_typenode_for_spec (&expr
->ts
);
6555 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6556 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6558 e
= gfc_create_var (integer_type_node
, NULL
);
6559 x
= gfc_create_var (type
, NULL
);
6560 gfc_add_modify (&se
->pre
, x
,
6561 build_call_expr_loc (input_location
, fabs
, 1, arg
));
6564 gfc_start_block (&block
);
6565 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6566 gfc_build_addr_expr (NULL_TREE
, e
));
6567 gfc_add_expr_to_block (&block
, tmp
);
6569 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
6570 build_int_cst (integer_type_node
, prec
), e
);
6571 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
6572 gfc_add_modify (&block
, x
, tmp
);
6573 stmt
= gfc_finish_block (&block
);
6576 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
6577 build_real_from_int_cst (type
, integer_zero_node
));
6578 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
6580 /* And deal with infinities and NaNs. */
6581 cond
= build_call_expr_loc (input_location
,
6582 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6584 nan
= gfc_build_nan (type
, "");
6585 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
6587 gfc_add_expr_to_block (&se
->pre
, tmp
);
6588 se
->expr
= fold_convert (type
, x
);
6592 /* SCALE (s, i) is translated into scalbn (s, i). */
6594 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
6596 tree args
[2], type
, scalbn
;
6598 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6600 type
= gfc_typenode_for_spec (&expr
->ts
);
6601 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6602 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
6603 fold_convert (type
, args
[0]),
6604 fold_convert (integer_type_node
, args
[1]));
6605 se
->expr
= fold_convert (type
, se
->expr
);
6609 /* SET_EXPONENT (s, i) is translated into
6610 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6612 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
6614 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
6616 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6617 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6619 type
= gfc_typenode_for_spec (&expr
->ts
);
6620 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6621 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6623 tmp
= gfc_create_var (integer_type_node
, NULL
);
6624 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
6625 fold_convert (type
, args
[0]),
6626 gfc_build_addr_expr (NULL_TREE
, tmp
));
6627 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
6628 fold_convert (integer_type_node
, args
[1]));
6629 res
= fold_convert (type
, res
);
6631 /* Call to isfinite */
6632 cond
= build_call_expr_loc (input_location
,
6633 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6635 nan
= gfc_build_nan (type
, "");
6637 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6643 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
6645 gfc_actual_arglist
*actual
;
6652 gfc_init_se (&argse
, NULL
);
6653 actual
= expr
->value
.function
.actual
;
6655 if (actual
->expr
->ts
.type
== BT_CLASS
)
6656 gfc_add_class_array_ref (actual
->expr
);
6658 argse
.data_not_needed
= 1;
6659 if (gfc_is_class_array_function (actual
->expr
))
6661 /* For functions that return a class array conv_expr_descriptor is not
6662 able to get the descriptor right. Therefore this special case. */
6663 gfc_conv_expr_reference (&argse
, actual
->expr
);
6664 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6665 gfc_class_data_get (argse
.expr
));
6669 argse
.want_pointer
= 1;
6670 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
6672 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6673 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6674 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
6676 /* Build the call to size0. */
6677 fncall0
= build_call_expr_loc (input_location
,
6678 gfor_fndecl_size0
, 1, arg1
);
6680 actual
= actual
->next
;
6684 gfc_init_se (&argse
, NULL
);
6685 gfc_conv_expr_type (&argse
, actual
->expr
,
6686 gfc_array_index_type
);
6687 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6689 /* Unusually, for an intrinsic, size does not exclude
6690 an optional arg2, so we must test for it. */
6691 if (actual
->expr
->expr_type
== EXPR_VARIABLE
6692 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
6693 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
6696 /* Build the call to size1. */
6697 fncall1
= build_call_expr_loc (input_location
,
6698 gfor_fndecl_size1
, 2,
6701 gfc_init_se (&argse
, NULL
);
6702 argse
.want_pointer
= 1;
6703 argse
.data_not_needed
= 1;
6704 gfc_conv_expr (&argse
, actual
->expr
);
6705 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6706 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6707 argse
.expr
, null_pointer_node
);
6708 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6709 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
6710 pvoid_type_node
, tmp
, fncall1
, fncall0
);
6714 se
->expr
= NULL_TREE
;
6715 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6716 gfc_array_index_type
,
6717 argse
.expr
, gfc_index_one_node
);
6720 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
6722 argse
.expr
= gfc_index_zero_node
;
6723 se
->expr
= NULL_TREE
;
6728 if (se
->expr
== NULL_TREE
)
6730 tree ubound
, lbound
;
6732 arg1
= build_fold_indirect_ref_loc (input_location
,
6734 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
6735 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
6736 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6737 gfc_array_index_type
, ubound
, lbound
);
6738 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
6739 gfc_array_index_type
,
6740 se
->expr
, gfc_index_one_node
);
6741 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6742 gfc_array_index_type
, se
->expr
,
6743 gfc_index_zero_node
);
6746 type
= gfc_typenode_for_spec (&expr
->ts
);
6747 se
->expr
= convert (type
, se
->expr
);
6751 /* Helper function to compute the size of a character variable,
6752 excluding the terminating null characters. The result has
6753 gfc_array_index_type type. */
6756 size_of_string_in_bytes (int kind
, tree string_length
)
6759 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
6761 bytesize
= build_int_cst (gfc_array_index_type
,
6762 gfc_character_kinds
[i
].bit_size
/ 8);
6764 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6766 fold_convert (gfc_array_index_type
, string_length
));
6771 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
6782 gfc_init_se (&argse
, NULL
);
6783 arg
= expr
->value
.function
.actual
->expr
;
6785 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
6786 gfc_conv_expr_descriptor (&argse
, arg
);
6788 gfc_conv_expr_reference (&argse
, arg
);
6790 if (arg
->ts
.type
== BT_ASSUMED
)
6792 /* This only works if an array descriptor has been passed; thus, extract
6793 the size from the descriptor. */
6794 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
6795 == TYPE_PRECISION (size_type_node
));
6796 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
6797 tmp
= DECL_LANG_SPECIFIC (tmp
)
6798 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
6799 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
6800 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
6801 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6802 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
6803 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
6804 build_int_cst (TREE_TYPE (tmp
),
6805 GFC_DTYPE_SIZE_SHIFT
));
6806 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
6808 else if (arg
->ts
.type
== BT_CLASS
)
6810 /* Conv_expr_descriptor returns a component_ref to _data component of the
6811 class object. The class object may be a non-pointer object, e.g.
6812 located on the stack, or a memory location pointed to, e.g. a
6813 parameter, i.e., an indirect_ref. */
6815 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
6816 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
6817 && GFC_DECL_CLASS (TREE_OPERAND (
6818 TREE_OPERAND (argse
.expr
, 0), 0)))
6819 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
6820 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6821 else if (arg
->rank
> 0
6823 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
6824 /* The scalarizer added an additional temp. To get the class' vptr
6825 one has to look at the original backend_decl. */
6826 byte_size
= gfc_class_vtab_size_get (
6827 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6829 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
6833 if (arg
->ts
.type
== BT_CHARACTER
)
6834 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6838 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6841 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6842 byte_size
= fold_convert (gfc_array_index_type
,
6843 size_in_bytes (byte_size
));
6848 se
->expr
= byte_size
;
6851 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
6852 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
6854 if (arg
->rank
== -1)
6856 tree cond
, loop_var
, exit_label
;
6859 tmp
= fold_convert (gfc_array_index_type
,
6860 gfc_conv_descriptor_rank (argse
.expr
));
6861 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
6862 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
6863 exit_label
= gfc_build_label_decl (NULL_TREE
);
6870 source_bytes = source_bytes * array.dim[i].extent;
6874 gfc_start_block (&body
);
6875 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6877 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6878 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6879 cond
, tmp
, build_empty_stmt (input_location
));
6880 gfc_add_expr_to_block (&body
, tmp
);
6882 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6883 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6884 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6885 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6886 gfc_array_index_type
, tmp
, source_bytes
);
6887 gfc_add_modify (&body
, source_bytes
, tmp
);
6889 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6890 gfc_array_index_type
, loop_var
,
6891 gfc_index_one_node
);
6892 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6894 tmp
= gfc_finish_block (&body
);
6896 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6898 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6900 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6901 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6905 /* Obtain the size of the array in bytes. */
6906 for (n
= 0; n
< arg
->rank
; n
++)
6909 idx
= gfc_rank_cst
[n
];
6910 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6911 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6912 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6913 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6914 gfc_array_index_type
, tmp
, source_bytes
);
6915 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6918 se
->expr
= source_bytes
;
6921 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6926 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6930 tree type
, result_type
, tmp
;
6932 arg
= expr
->value
.function
.actual
->expr
;
6934 gfc_init_se (&argse
, NULL
);
6935 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6939 if (arg
->ts
.type
== BT_CLASS
)
6941 gfc_add_vptr_component (arg
);
6942 gfc_add_size_component (arg
);
6943 gfc_conv_expr (&argse
, arg
);
6944 tmp
= fold_convert (result_type
, argse
.expr
);
6948 gfc_conv_expr_reference (&argse
, arg
);
6949 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6954 argse
.want_pointer
= 0;
6955 gfc_conv_expr_descriptor (&argse
, arg
);
6956 if (arg
->ts
.type
== BT_CLASS
)
6959 tmp
= gfc_class_vtab_size_get (
6960 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6962 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6963 tmp
= fold_convert (result_type
, tmp
);
6966 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6969 /* Obtain the argument's word length. */
6970 if (arg
->ts
.type
== BT_CHARACTER
)
6971 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6973 tmp
= size_in_bytes (type
);
6974 tmp
= fold_convert (result_type
, tmp
);
6977 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6978 build_int_cst (result_type
, BITS_PER_UNIT
));
6979 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6983 /* Intrinsic string comparison functions. */
6986 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6990 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6993 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6994 expr
->value
.function
.actual
->expr
->ts
.kind
,
6996 se
->expr
= fold_build2_loc (input_location
, op
,
6997 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6998 build_int_cst (TREE_TYPE (se
->expr
), 0));
7001 /* Generate a call to the adjustl/adjustr library function. */
7003 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
7011 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
7014 type
= TREE_TYPE (args
[2]);
7015 var
= gfc_conv_string_tmp (se
, type
, len
);
7018 tmp
= build_call_expr_loc (input_location
,
7019 fndecl
, 3, args
[0], args
[1], args
[2]);
7020 gfc_add_expr_to_block (&se
->pre
, tmp
);
7022 se
->string_length
= len
;
7026 /* Generate code for the TRANSFER intrinsic:
7028 DEST = TRANSFER (SOURCE, MOLD)
7030 typeof<DEST> = typeof<MOLD>
7035 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
7037 typeof<DEST> = typeof<MOLD>
7039 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
7040 sizeof (DEST(0) * SIZE). */
7042 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
7058 gfc_actual_arglist
*arg
;
7060 gfc_array_info
*info
;
7064 gfc_expr
*source_expr
, *mold_expr
;
7068 info
= &se
->ss
->info
->data
.array
;
7070 /* Convert SOURCE. The output from this stage is:-
7071 source_bytes = length of the source in bytes
7072 source = pointer to the source data. */
7073 arg
= expr
->value
.function
.actual
;
7074 source_expr
= arg
->expr
;
7076 /* Ensure double transfer through LOGICAL preserves all
7078 if (arg
->expr
->expr_type
== EXPR_FUNCTION
7079 && arg
->expr
->value
.function
.esym
== NULL
7080 && arg
->expr
->value
.function
.isym
!= NULL
7081 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
7082 && arg
->expr
->ts
.type
== BT_LOGICAL
7083 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
7084 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
7086 gfc_init_se (&argse
, NULL
);
7088 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7090 /* Obtain the pointer to source and the length of source in bytes. */
7091 if (arg
->expr
->rank
== 0)
7093 gfc_conv_expr_reference (&argse
, arg
->expr
);
7094 if (arg
->expr
->ts
.type
== BT_CLASS
)
7095 source
= gfc_class_data_get (argse
.expr
);
7097 source
= argse
.expr
;
7099 /* Obtain the source word length. */
7100 switch (arg
->expr
->ts
.type
)
7103 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7104 argse
.string_length
);
7107 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7110 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7112 tmp
= fold_convert (gfc_array_index_type
,
7113 size_in_bytes (source_type
));
7119 argse
.want_pointer
= 0;
7120 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7121 source
= gfc_conv_descriptor_data_get (argse
.expr
);
7122 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7124 /* Repack the source if not simply contiguous. */
7125 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
7127 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
7129 if (warn_array_temporaries
)
7130 gfc_warning (OPT_Warray_temporaries
,
7131 "Creating array temporary at %L", &expr
->where
);
7133 source
= build_call_expr_loc (input_location
,
7134 gfor_fndecl_in_pack
, 1, tmp
);
7135 source
= gfc_evaluate_now (source
, &argse
.pre
);
7137 /* Free the temporary. */
7138 gfc_start_block (&block
);
7139 tmp
= gfc_call_free (source
);
7140 gfc_add_expr_to_block (&block
, tmp
);
7141 stmt
= gfc_finish_block (&block
);
7143 /* Clean up if it was repacked. */
7144 gfc_init_block (&block
);
7145 tmp
= gfc_conv_array_data (argse
.expr
);
7146 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7148 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7149 build_empty_stmt (input_location
));
7150 gfc_add_expr_to_block (&block
, tmp
);
7151 gfc_add_block_to_block (&block
, &se
->post
);
7152 gfc_init_block (&se
->post
);
7153 gfc_add_block_to_block (&se
->post
, &block
);
7156 /* Obtain the source word length. */
7157 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7158 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7159 argse
.string_length
);
7161 tmp
= fold_convert (gfc_array_index_type
,
7162 size_in_bytes (source_type
));
7164 /* Obtain the size of the array in bytes. */
7165 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7166 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7169 idx
= gfc_rank_cst
[n
];
7170 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7171 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7172 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7173 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7174 gfc_array_index_type
, upper
, lower
);
7175 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7176 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7177 gfc_array_index_type
, extent
,
7178 gfc_index_one_node
);
7179 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7180 gfc_array_index_type
, tmp
, source_bytes
);
7184 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7185 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7186 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7188 /* Now convert MOLD. The outputs are:
7189 mold_type = the TREE type of MOLD
7190 dest_word_len = destination word length in bytes. */
7192 mold_expr
= arg
->expr
;
7194 gfc_init_se (&argse
, NULL
);
7196 scalar_mold
= arg
->expr
->rank
== 0;
7198 if (arg
->expr
->rank
== 0)
7200 gfc_conv_expr_reference (&argse
, arg
->expr
);
7201 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7206 gfc_init_se (&argse
, NULL
);
7207 argse
.want_pointer
= 0;
7208 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7209 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7212 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7213 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7215 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7217 /* If this TRANSFER is nested in another TRANSFER, use a type
7218 that preserves all bits. */
7219 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7220 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7223 /* Obtain the destination word length. */
7224 switch (arg
->expr
->ts
.type
)
7227 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7228 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7231 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7234 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7237 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7238 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7240 /* Finally convert SIZE, if it is present. */
7242 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7246 gfc_init_se (&argse
, NULL
);
7247 gfc_conv_expr_reference (&argse
, arg
->expr
);
7248 tmp
= convert (gfc_array_index_type
,
7249 build_fold_indirect_ref_loc (input_location
,
7251 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7252 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7257 /* Separate array and scalar results. */
7258 if (scalar_mold
&& tmp
== NULL_TREE
)
7259 goto scalar_transfer
;
7261 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7262 if (tmp
!= NULL_TREE
)
7263 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7264 tmp
, dest_word_len
);
7268 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
7269 gfc_add_modify (&se
->pre
, size_words
,
7270 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
7271 gfc_array_index_type
,
7272 size_bytes
, dest_word_len
));
7274 /* Evaluate the bounds of the result. If the loop range exists, we have
7275 to check if it is too large. If so, we modify loop->to be consistent
7276 with min(size, size(source)). Otherwise, size is made consistent with
7277 the loop range, so that the right number of bytes is transferred.*/
7278 n
= se
->loop
->order
[0];
7279 if (se
->loop
->to
[n
] != NULL_TREE
)
7281 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7282 se
->loop
->to
[n
], se
->loop
->from
[n
]);
7283 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7284 tmp
, gfc_index_one_node
);
7285 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7287 gfc_add_modify (&se
->pre
, size_words
, tmp
);
7288 gfc_add_modify (&se
->pre
, size_bytes
,
7289 fold_build2_loc (input_location
, MULT_EXPR
,
7290 gfc_array_index_type
,
7291 size_words
, dest_word_len
));
7292 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7293 size_words
, se
->loop
->from
[n
]);
7294 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7295 upper
, gfc_index_one_node
);
7299 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7300 size_words
, gfc_index_one_node
);
7301 se
->loop
->from
[n
] = gfc_index_zero_node
;
7304 se
->loop
->to
[n
] = upper
;
7306 /* Build a destination descriptor, using the pointer, source, as the
7308 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
7309 NULL_TREE
, false, true, false, &expr
->where
);
7311 /* Cast the pointer to the result. */
7312 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7313 tmp
= fold_convert (pvoid_type_node
, tmp
);
7315 /* Use memcpy to do the transfer. */
7317 = build_call_expr_loc (input_location
,
7318 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
7319 fold_convert (pvoid_type_node
, source
),
7320 fold_convert (size_type_node
,
7321 fold_build2_loc (input_location
,
7323 gfc_array_index_type
,
7326 gfc_add_expr_to_block (&se
->pre
, tmp
);
7328 se
->expr
= info
->descriptor
;
7329 if (expr
->ts
.type
== BT_CHARACTER
)
7330 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7334 /* Deal with scalar results. */
7336 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7337 dest_word_len
, source_bytes
);
7338 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7339 extent
, gfc_index_zero_node
);
7341 if (expr
->ts
.type
== BT_CHARACTER
)
7343 tree direct
, indirect
, free
;
7345 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
7346 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
7349 /* If source is longer than the destination, use a pointer to
7350 the source directly. */
7351 gfc_init_block (&block
);
7352 gfc_add_modify (&block
, tmpdecl
, ptr
);
7353 direct
= gfc_finish_block (&block
);
7355 /* Otherwise, allocate a string with the length of the destination
7356 and copy the source into it. */
7357 gfc_init_block (&block
);
7358 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
7359 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
7360 gfc_add_modify (&block
, tmpdecl
,
7361 fold_convert (TREE_TYPE (ptr
), tmp
));
7362 tmp
= build_call_expr_loc (input_location
,
7363 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7364 fold_convert (pvoid_type_node
, tmpdecl
),
7365 fold_convert (pvoid_type_node
, ptr
),
7366 fold_convert (size_type_node
, extent
));
7367 gfc_add_expr_to_block (&block
, tmp
);
7368 indirect
= gfc_finish_block (&block
);
7370 /* Wrap it up with the condition. */
7371 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
7372 dest_word_len
, source_bytes
);
7373 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
7374 gfc_add_expr_to_block (&se
->pre
, tmp
);
7376 /* Free the temporary string, if necessary. */
7377 free
= gfc_call_free (tmpdecl
);
7378 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7379 dest_word_len
, source_bytes
);
7380 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
7381 gfc_add_expr_to_block (&se
->post
, tmp
);
7384 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7388 tmpdecl
= gfc_create_var (mold_type
, "transfer");
7390 ptr
= convert (build_pointer_type (mold_type
), source
);
7392 /* For CLASS results, allocate the needed memory first. */
7393 if (mold_expr
->ts
.type
== BT_CLASS
)
7396 cdata
= gfc_class_data_get (tmpdecl
);
7397 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
7398 gfc_add_modify (&se
->pre
, cdata
, tmp
);
7401 /* Use memcpy to do the transfer. */
7402 if (mold_expr
->ts
.type
== BT_CLASS
)
7403 tmp
= gfc_class_data_get (tmpdecl
);
7405 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
7407 tmp
= build_call_expr_loc (input_location
,
7408 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7409 fold_convert (pvoid_type_node
, tmp
),
7410 fold_convert (pvoid_type_node
, ptr
),
7411 fold_convert (size_type_node
, extent
));
7412 gfc_add_expr_to_block (&se
->pre
, tmp
);
7414 /* For CLASS results, set the _vptr. */
7415 if (mold_expr
->ts
.type
== BT_CLASS
)
7419 vptr
= gfc_class_vptr_get (tmpdecl
);
7420 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
7422 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7423 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
7431 /* Generate a call to caf_is_present. */
7434 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
7436 tree caf_reference
, caf_decl
, token
, image_index
;
7438 /* Compile the reference chain. */
7439 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
7440 gcc_assert (caf_reference
!= NULL_TREE
);
7442 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
7443 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
7444 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
7445 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
7446 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
7449 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
7450 3, token
, image_index
, caf_reference
);
7454 /* Test whether this ref-chain refs this image only. */
7457 caf_this_image_ref (gfc_ref
*ref
)
7459 for ( ; ref
; ref
= ref
->next
)
7460 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
7461 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
7467 /* Generate code for the ALLOCATED intrinsic.
7468 Generate inline code that directly check the address of the argument. */
7471 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
7473 gfc_actual_arglist
*arg1
;
7476 symbol_attribute caf_attr
;
7478 gfc_init_se (&arg1se
, NULL
);
7479 arg1
= expr
->value
.function
.actual
;
7481 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7483 /* Make sure that class array expressions have both a _data
7484 component reference and an array reference.... */
7485 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
7486 gfc_add_class_array_ref (arg1
->expr
);
7487 /* .... whilst scalars only need the _data component. */
7489 gfc_add_data_component (arg1
->expr
);
7492 /* When arg1 references an allocatable component in a coarray, then call
7493 the caf-library function caf_is_present (). */
7494 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
7495 && arg1
->expr
->value
.function
.isym
7496 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
7497 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
7499 gfc_clear_attr (&caf_attr
);
7500 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
7501 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
7502 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
7505 if (arg1
->expr
->rank
== 0)
7507 /* Allocatable scalar. */
7508 arg1se
.want_pointer
= 1;
7509 gfc_conv_expr (&arg1se
, arg1
->expr
);
7514 /* Allocatable array. */
7515 arg1se
.descriptor_only
= 1;
7516 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7517 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7520 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
7521 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7523 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7527 /* Generate code for the ASSOCIATED intrinsic.
7528 If both POINTER and TARGET are arrays, generate a call to library function
7529 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7530 In other cases, generate inline code that directly compare the address of
7531 POINTER with the address of TARGET. */
7534 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
7536 gfc_actual_arglist
*arg1
;
7537 gfc_actual_arglist
*arg2
;
7542 tree nonzero_charlen
;
7543 tree nonzero_arraylen
;
7547 gfc_init_se (&arg1se
, NULL
);
7548 gfc_init_se (&arg2se
, NULL
);
7549 arg1
= expr
->value
.function
.actual
;
7552 /* Check whether the expression is a scalar or not; we cannot use
7553 arg1->expr->rank as it can be nonzero for proc pointers. */
7554 ss
= gfc_walk_expr (arg1
->expr
);
7555 scalar
= ss
== gfc_ss_terminator
;
7557 gfc_free_ss_chain (ss
);
7561 /* No optional target. */
7564 /* A pointer to a scalar. */
7565 arg1se
.want_pointer
= 1;
7566 gfc_conv_expr (&arg1se
, arg1
->expr
);
7567 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7568 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7569 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7571 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7573 tmp2
= gfc_class_data_get (arg1se
.expr
);
7574 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7575 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7582 /* A pointer to an array. */
7583 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7584 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7586 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7587 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7588 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
7589 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
7594 /* An optional target. */
7595 if (arg2
->expr
->ts
.type
== BT_CLASS
)
7596 gfc_add_data_component (arg2
->expr
);
7598 nonzero_charlen
= NULL_TREE
;
7599 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
7600 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
7602 arg1
->expr
->ts
.u
.cl
->backend_decl
,
7604 (TREE_TYPE (arg1
->expr
->ts
.u
.cl
->backend_decl
)));
7607 /* A pointer to a scalar. */
7608 arg1se
.want_pointer
= 1;
7609 gfc_conv_expr (&arg1se
, arg1
->expr
);
7610 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7611 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7612 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7614 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7615 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
7617 arg2se
.want_pointer
= 1;
7618 gfc_conv_expr (&arg2se
, arg2
->expr
);
7619 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7620 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
7621 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
7623 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7624 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7625 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7626 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7627 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7628 arg1se
.expr
, arg2se
.expr
);
7629 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7630 arg1se
.expr
, null_pointer_node
);
7631 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7632 logical_type_node
, tmp
, tmp2
);
7636 /* An array pointer of zero length is not associated if target is
7638 arg1se
.descriptor_only
= 1;
7639 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
7640 if (arg1
->expr
->rank
== -1)
7642 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
7643 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7644 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
7647 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
7648 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
7649 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
7650 logical_type_node
, tmp
,
7651 build_int_cst (TREE_TYPE (tmp
), 0));
7653 /* A pointer to an array, call library function _gfor_associated. */
7654 arg1se
.want_pointer
= 1;
7655 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7657 arg2se
.want_pointer
= 1;
7658 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
7659 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7660 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7661 se
->expr
= build_call_expr_loc (input_location
,
7662 gfor_fndecl_associated
, 2,
7663 arg1se
.expr
, arg2se
.expr
);
7664 se
->expr
= convert (logical_type_node
, se
->expr
);
7665 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7666 logical_type_node
, se
->expr
,
7670 /* If target is present zero character length pointers cannot
7672 if (nonzero_charlen
!= NULL_TREE
)
7673 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7675 se
->expr
, nonzero_charlen
);
7678 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7682 /* Generate code for the SAME_TYPE_AS intrinsic.
7683 Generate inline code that directly checks the vindices. */
7686 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
7691 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
7693 gfc_init_se (&se1
, NULL
);
7694 gfc_init_se (&se2
, NULL
);
7696 a
= expr
->value
.function
.actual
->expr
;
7697 b
= expr
->value
.function
.actual
->next
->expr
;
7699 if (UNLIMITED_POLY (a
))
7701 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
7702 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7703 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7706 if (UNLIMITED_POLY (b
))
7708 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
7709 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7710 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7713 if (a
->ts
.type
== BT_CLASS
)
7715 gfc_add_vptr_component (a
);
7716 gfc_add_hash_component (a
);
7718 else if (a
->ts
.type
== BT_DERIVED
)
7719 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7720 a
->ts
.u
.derived
->hash_value
);
7722 if (b
->ts
.type
== BT_CLASS
)
7724 gfc_add_vptr_component (b
);
7725 gfc_add_hash_component (b
);
7727 else if (b
->ts
.type
== BT_DERIVED
)
7728 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7729 b
->ts
.u
.derived
->hash_value
);
7731 gfc_conv_expr (&se1
, a
);
7732 gfc_conv_expr (&se2
, b
);
7734 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
7735 logical_type_node
, se1
.expr
,
7736 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
7739 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7740 logical_type_node
, conda
, tmp
);
7743 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7744 logical_type_node
, condb
, tmp
);
7746 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7750 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
7753 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
7757 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7758 se
->expr
= build_call_expr_loc (input_location
,
7759 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
7760 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7764 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
7767 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
7771 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7773 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
7774 type
= gfc_get_int_type (4);
7775 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
7777 /* Convert it to the required type. */
7778 type
= gfc_typenode_for_spec (&expr
->ts
);
7779 se
->expr
= build_call_expr_loc (input_location
,
7780 gfor_fndecl_si_kind
, 1, arg
);
7781 se
->expr
= fold_convert (type
, se
->expr
);
7785 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
7788 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
7790 gfc_actual_arglist
*actual
;
7793 vec
<tree
, va_gc
> *args
= NULL
;
7795 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
7797 gfc_init_se (&argse
, se
);
7799 /* Pass a NULL pointer for an absent arg. */
7800 if (actual
->expr
== NULL
)
7801 argse
.expr
= null_pointer_node
;
7807 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
7809 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
7810 ts
.type
= BT_INTEGER
;
7811 ts
.kind
= gfc_c_int_kind
;
7812 gfc_convert_type (actual
->expr
, &ts
, 2);
7814 gfc_conv_expr_reference (&argse
, actual
->expr
);
7817 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7818 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7819 vec_safe_push (args
, argse
.expr
);
7822 /* Convert it to the required type. */
7823 type
= gfc_typenode_for_spec (&expr
->ts
);
7824 se
->expr
= build_call_expr_loc_vec (input_location
,
7825 gfor_fndecl_sr_kind
, args
);
7826 se
->expr
= fold_convert (type
, se
->expr
);
7830 /* Generate code for TRIM (A) intrinsic function. */
7833 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
7843 unsigned int num_args
;
7845 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
7846 args
= XALLOCAVEC (tree
, num_args
);
7848 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
7849 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
7850 len
= gfc_create_var (gfc_charlen_type_node
, "len");
7852 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
7853 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
7856 if (expr
->ts
.kind
== 1)
7857 function
= gfor_fndecl_string_trim
;
7858 else if (expr
->ts
.kind
== 4)
7859 function
= gfor_fndecl_string_trim_char4
;
7863 fndecl
= build_addr (function
);
7864 tmp
= build_call_array_loc (input_location
,
7865 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7867 gfc_add_expr_to_block (&se
->pre
, tmp
);
7869 /* Free the temporary afterwards, if necessary. */
7870 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7871 len
, build_int_cst (TREE_TYPE (len
), 0));
7872 tmp
= gfc_call_free (var
);
7873 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
7874 gfc_add_expr_to_block (&se
->post
, tmp
);
7877 se
->string_length
= len
;
7881 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
7884 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
7886 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
7887 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
7889 stmtblock_t block
, body
;
7892 /* We store in charsize the size of a character. */
7893 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
7894 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
7896 /* Get the arguments. */
7897 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7898 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
7900 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
7901 ncopies_type
= TREE_TYPE (ncopies
);
7903 /* Check that NCOPIES is not negative. */
7904 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
7905 build_int_cst (ncopies_type
, 0));
7906 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7907 "Argument NCOPIES of REPEAT intrinsic is negative "
7908 "(its value is %ld)",
7909 fold_convert (long_integer_type_node
, ncopies
));
7911 /* If the source length is zero, any non negative value of NCOPIES
7912 is valid, and nothing happens. */
7913 n
= gfc_create_var (ncopies_type
, "ncopies");
7914 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
7916 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
7917 build_int_cst (ncopies_type
, 0), ncopies
);
7918 gfc_add_modify (&se
->pre
, n
, tmp
);
7921 /* Check that ncopies is not too large: ncopies should be less than
7922 (or equal to) MAX / slen, where MAX is the maximal integer of
7923 the gfc_charlen_type_node type. If slen == 0, we need a special
7924 case to avoid the division by zero. */
7925 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
7926 fold_convert (sizetype
,
7927 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
7929 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
7930 ? sizetype
: ncopies_type
;
7931 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7932 fold_convert (largest
, ncopies
),
7933 fold_convert (largest
, max
));
7934 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
7936 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
7937 logical_false_node
, cond
);
7938 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7939 "Argument NCOPIES of REPEAT intrinsic is too large");
7941 /* Compute the destination length. */
7942 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7943 fold_convert (gfc_charlen_type_node
, slen
),
7944 fold_convert (gfc_charlen_type_node
, ncopies
));
7945 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
7946 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
7948 /* Generate the code to do the repeat operation:
7949 for (i = 0; i < ncopies; i++)
7950 memmove (dest + (i * slen * size), src, slen*size); */
7951 gfc_start_block (&block
);
7952 count
= gfc_create_var (sizetype
, "count");
7953 gfc_add_modify (&block
, count
, size_zero_node
);
7954 exit_label
= gfc_build_label_decl (NULL_TREE
);
7956 /* Start the loop body. */
7957 gfc_start_block (&body
);
7959 /* Exit the loop if count >= ncopies. */
7960 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
7961 fold_convert (sizetype
, ncopies
));
7962 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7963 TREE_USED (exit_label
) = 1;
7964 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7965 build_empty_stmt (input_location
));
7966 gfc_add_expr_to_block (&body
, tmp
);
7968 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7969 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
7971 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
7973 tmp
= fold_build_pointer_plus_loc (input_location
,
7974 fold_convert (pvoid_type_node
, dest
), tmp
);
7975 tmp
= build_call_expr_loc (input_location
,
7976 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7978 fold_build2_loc (input_location
, MULT_EXPR
,
7979 size_type_node
, slen
, size
));
7980 gfc_add_expr_to_block (&body
, tmp
);
7982 /* Increment count. */
7983 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
7984 count
, size_one_node
);
7985 gfc_add_modify (&body
, count
, tmp
);
7987 /* Build the loop. */
7988 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7989 gfc_add_expr_to_block (&block
, tmp
);
7991 /* Add the exit label. */
7992 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7993 gfc_add_expr_to_block (&block
, tmp
);
7995 /* Finish the block. */
7996 tmp
= gfc_finish_block (&block
);
7997 gfc_add_expr_to_block (&se
->pre
, tmp
);
7999 /* Set the result value. */
8001 se
->string_length
= dlen
;
8005 /* Generate code for the IARGC intrinsic. */
8008 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
8014 /* Call the library function. This always returns an INTEGER(4). */
8015 fndecl
= gfor_fndecl_iargc
;
8016 tmp
= build_call_expr_loc (input_location
,
8019 /* Convert it to the required type. */
8020 type
= gfc_typenode_for_spec (&expr
->ts
);
8021 tmp
= fold_convert (type
, tmp
);
8027 /* The loc intrinsic returns the address of its argument as
8028 gfc_index_integer_kind integer. */
8031 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
8036 gcc_assert (!se
->ss
);
8038 arg_expr
= expr
->value
.function
.actual
->expr
;
8039 if (arg_expr
->rank
== 0)
8041 if (arg_expr
->ts
.type
== BT_CLASS
)
8042 gfc_add_data_component (arg_expr
);
8043 gfc_conv_expr_reference (se
, arg_expr
);
8046 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
8047 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
8049 /* Create a temporary variable for loc return value. Without this,
8050 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
8051 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
8052 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
8053 se
->expr
= temp_var
;
8057 /* The following routine generates code for the intrinsic
8058 functions from the ISO_C_BINDING module:
8064 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
8066 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
8068 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
8070 if (arg
->expr
->rank
== 0)
8071 gfc_conv_expr_reference (se
, arg
->expr
);
8072 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
8073 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
8076 gfc_conv_expr_descriptor (se
, arg
->expr
);
8077 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
8080 /* TODO -- the following two lines shouldn't be necessary, but if
8081 they're removed, a bug is exposed later in the code path.
8082 This workaround was thus introduced, but will have to be
8083 removed; please see PR 35150 for details about the issue. */
8084 se
->expr
= convert (pvoid_type_node
, se
->expr
);
8085 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
8087 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
8088 gfc_conv_expr_reference (se
, arg
->expr
);
8089 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
8094 /* Build the addr_expr for the first argument. The argument is
8095 already an *address* so we don't need to set want_pointer in
8097 gfc_init_se (&arg1se
, NULL
);
8098 gfc_conv_expr (&arg1se
, arg
->expr
);
8099 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8100 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8102 /* See if we were given two arguments. */
8103 if (arg
->next
->expr
== NULL
)
8104 /* Only given one arg so generate a null and do a
8105 not-equal comparison against the first arg. */
8106 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8108 fold_convert (TREE_TYPE (arg1se
.expr
),
8109 null_pointer_node
));
8115 /* Given two arguments so build the arg2se from second arg. */
8116 gfc_init_se (&arg2se
, NULL
);
8117 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
8118 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8119 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8121 /* Generate test to compare that the two args are equal. */
8122 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8123 arg1se
.expr
, arg2se
.expr
);
8124 /* Generate test to ensure that the first arg is not null. */
8125 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
8127 arg1se
.expr
, null_pointer_node
);
8129 /* Finally, the generated test must check that both arg1 is not
8130 NULL and that it is equal to the second arg. */
8131 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8133 not_null_expr
, eq_expr
);
8141 /* The following routine generates code for the intrinsic
8142 subroutines from the ISO_C_BINDING module:
8144 * C_F_PROCPOINTER. */
8147 conv_isocbinding_subroutine (gfc_code
*code
)
8154 tree desc
, dim
, tmp
, stride
, offset
;
8155 stmtblock_t body
, block
;
8157 gfc_actual_arglist
*arg
= code
->ext
.actual
;
8159 gfc_init_se (&se
, NULL
);
8160 gfc_init_se (&cptrse
, NULL
);
8161 gfc_conv_expr (&cptrse
, arg
->expr
);
8162 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
8163 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
8165 gfc_init_se (&fptrse
, NULL
);
8166 if (arg
->next
->expr
->rank
== 0)
8168 fptrse
.want_pointer
= 1;
8169 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
8170 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
8171 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
8172 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8173 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
8174 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
8176 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8177 TREE_TYPE (fptrse
.expr
),
8179 fold_convert (TREE_TYPE (fptrse
.expr
),
8181 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
8182 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8183 return gfc_finish_block (&se
.pre
);
8186 gfc_start_block (&block
);
8188 /* Get the descriptor of the Fortran pointer. */
8189 fptrse
.descriptor_only
= 1;
8190 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
8191 gfc_add_block_to_block (&block
, &fptrse
.pre
);
8194 /* Set the span field. */
8195 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
8196 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8197 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
8199 /* Set data value, dtype, and offset. */
8200 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
8201 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
8202 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
8203 gfc_get_dtype (TREE_TYPE (desc
)));
8205 /* Start scalarization of the bounds, using the shape argument. */
8207 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
8208 gcc_assert (shape_ss
!= gfc_ss_terminator
);
8209 gfc_init_se (&shapese
, NULL
);
8211 gfc_init_loopinfo (&loop
);
8212 gfc_add_ss_to_loop (&loop
, shape_ss
);
8213 gfc_conv_ss_startstride (&loop
);
8214 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
8215 gfc_mark_ss_chain_used (shape_ss
, 1);
8217 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
8218 shapese
.ss
= shape_ss
;
8220 stride
= gfc_create_var (gfc_array_index_type
, "stride");
8221 offset
= gfc_create_var (gfc_array_index_type
, "offset");
8222 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
8223 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8226 gfc_start_scalarized_body (&loop
, &body
);
8228 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8229 loop
.loopvar
[0], loop
.from
[0]);
8231 /* Set bounds and stride. */
8232 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
8233 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
8235 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
8236 gfc_add_block_to_block (&body
, &shapese
.pre
);
8237 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
8238 gfc_add_block_to_block (&body
, &shapese
.post
);
8240 /* Calculate offset. */
8241 gfc_add_modify (&body
, offset
,
8242 fold_build2_loc (input_location
, PLUS_EXPR
,
8243 gfc_array_index_type
, offset
, stride
));
8244 /* Update stride. */
8245 gfc_add_modify (&body
, stride
,
8246 fold_build2_loc (input_location
, MULT_EXPR
,
8247 gfc_array_index_type
, stride
,
8248 fold_convert (gfc_array_index_type
,
8250 /* Finish scalarization loop. */
8251 gfc_trans_scalarizing_loops (&loop
, &body
);
8252 gfc_add_block_to_block (&block
, &loop
.pre
);
8253 gfc_add_block_to_block (&block
, &loop
.post
);
8254 gfc_add_block_to_block (&block
, &fptrse
.post
);
8255 gfc_cleanup_loop (&loop
);
8257 gfc_add_modify (&block
, offset
,
8258 fold_build1_loc (input_location
, NEGATE_EXPR
,
8259 gfc_array_index_type
, offset
));
8260 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
8262 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
8263 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8264 return gfc_finish_block (&se
.pre
);
8268 /* Save and restore floating-point state. */
8271 gfc_save_fp_state (stmtblock_t
*block
)
8273 tree type
, fpstate
, tmp
;
8275 type
= build_array_type (char_type_node
,
8276 build_range_type (size_type_node
, size_zero_node
,
8277 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
8278 fpstate
= gfc_create_var (type
, "fpstate");
8279 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
8281 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
8283 gfc_add_expr_to_block (block
, tmp
);
8290 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
8294 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
8296 gfc_add_expr_to_block (block
, tmp
);
8300 /* Generate code for arguments of IEEE functions. */
8303 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
8306 gfc_actual_arglist
*actual
;
8311 actual
= expr
->value
.function
.actual
;
8312 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
8314 gcc_assert (actual
);
8317 gfc_init_se (&argse
, se
);
8318 gfc_conv_expr_val (&argse
, e
);
8320 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8321 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8322 argarray
[arg
] = argse
.expr
;
8327 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8328 and IEEE_UNORDERED, which translate directly to GCC type-generic
8332 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
8333 enum built_in_function code
, int nargs
)
8336 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
8338 conv_ieee_function_args (se
, expr
, args
, nargs
);
8339 se
->expr
= build_call_expr_loc_array (input_location
,
8340 builtin_decl_explicit (code
),
8342 STRIP_TYPE_NOPS (se
->expr
);
8343 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8347 /* Generate code for IEEE_IS_NORMAL intrinsic:
8348 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8351 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
8353 tree arg
, isnormal
, iszero
;
8355 /* Convert arg, evaluate it only once. */
8356 conv_ieee_function_args (se
, expr
, &arg
, 1);
8357 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8359 isnormal
= build_call_expr_loc (input_location
,
8360 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
8362 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
8363 build_real_from_int_cst (TREE_TYPE (arg
),
8364 integer_zero_node
));
8365 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8366 logical_type_node
, isnormal
, iszero
);
8367 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8371 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8372 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8375 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
8377 tree arg
, signbit
, isnan
;
8379 /* Convert arg, evaluate it only once. */
8380 conv_ieee_function_args (se
, expr
, &arg
, 1);
8381 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8383 isnan
= build_call_expr_loc (input_location
,
8384 builtin_decl_explicit (BUILT_IN_ISNAN
),
8386 STRIP_TYPE_NOPS (isnan
);
8388 signbit
= build_call_expr_loc (input_location
,
8389 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8391 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8392 signbit
, integer_zero_node
);
8394 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8395 logical_type_node
, signbit
,
8396 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
8397 TREE_TYPE(isnan
), isnan
));
8399 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8403 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8406 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
8407 enum built_in_function code
)
8409 tree arg
, decl
, call
, fpstate
;
8412 conv_ieee_function_args (se
, expr
, &arg
, 1);
8413 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
8414 decl
= builtin_decl_for_precision (code
, argprec
);
8416 /* Save floating-point state. */
8417 fpstate
= gfc_save_fp_state (&se
->pre
);
8419 /* Make the function call. */
8420 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
8421 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
8423 /* Restore floating-point state. */
8424 gfc_restore_fp_state (&se
->post
, fpstate
);
8428 /* Generate code for IEEE_REM. */
8431 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
8433 tree args
[2], decl
, call
, fpstate
;
8436 conv_ieee_function_args (se
, expr
, args
, 2);
8438 /* If arguments have unequal size, convert them to the larger. */
8439 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
8440 > TYPE_PRECISION (TREE_TYPE (args
[1])))
8441 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8442 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
8443 > TYPE_PRECISION (TREE_TYPE (args
[0])))
8444 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
8446 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8447 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
8449 /* Save floating-point state. */
8450 fpstate
= gfc_save_fp_state (&se
->pre
);
8452 /* Make the function call. */
8453 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8454 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8456 /* Restore floating-point state. */
8457 gfc_restore_fp_state (&se
->post
, fpstate
);
8461 /* Generate code for IEEE_NEXT_AFTER. */
8464 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
8466 tree args
[2], decl
, call
, fpstate
;
8469 conv_ieee_function_args (se
, expr
, args
, 2);
8471 /* Result has the characteristics of first argument. */
8472 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8473 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8474 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
8476 /* Save floating-point state. */
8477 fpstate
= gfc_save_fp_state (&se
->pre
);
8479 /* Make the function call. */
8480 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8481 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8483 /* Restore floating-point state. */
8484 gfc_restore_fp_state (&se
->post
, fpstate
);
8488 /* Generate code for IEEE_SCALB. */
8491 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
8493 tree args
[2], decl
, call
, huge
, type
;
8496 conv_ieee_function_args (se
, expr
, args
, 2);
8498 /* Result has the characteristics of first argument. */
8499 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8500 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
8502 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
8504 /* We need to fold the integer into the range of a C int. */
8505 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
8506 type
= TREE_TYPE (args
[1]);
8508 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
8509 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
8511 huge
= fold_convert (type
, huge
);
8512 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
8514 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
8515 fold_build1_loc (input_location
, NEGATE_EXPR
,
8519 args
[1] = fold_convert (integer_type_node
, args
[1]);
8521 /* Make the function call. */
8522 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8523 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8527 /* Generate code for IEEE_COPY_SIGN. */
8530 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
8532 tree args
[2], decl
, sign
;
8535 conv_ieee_function_args (se
, expr
, args
, 2);
8537 /* Get the sign of the second argument. */
8538 sign
= build_call_expr_loc (input_location
,
8539 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8541 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8542 sign
, integer_zero_node
);
8544 /* Create a value of one, with the right sign. */
8545 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
8547 fold_build1_loc (input_location
, NEGATE_EXPR
,
8551 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
8553 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8554 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
8556 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8560 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8564 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
8566 const char *name
= expr
->value
.function
.name
;
8568 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8570 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
8571 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
8572 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
8573 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
8574 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
8575 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
8576 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
8577 conv_intrinsic_ieee_is_normal (se
, expr
);
8578 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
8579 conv_intrinsic_ieee_is_negative (se
, expr
);
8580 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
8581 conv_intrinsic_ieee_copy_sign (se
, expr
);
8582 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
8583 conv_intrinsic_ieee_scalb (se
, expr
);
8584 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
8585 conv_intrinsic_ieee_next_after (se
, expr
);
8586 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
8587 conv_intrinsic_ieee_rem (se
, expr
);
8588 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
8589 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
8590 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
8591 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
8593 /* It is not among the functions we translate directly. We return
8594 false, so a library function call is emitted. */
8603 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8606 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
8608 tree arg
, res
, restype
;
8610 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8611 arg
= fold_convert (size_type_node
, arg
);
8612 res
= build_call_expr_loc (input_location
,
8613 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
8614 restype
= gfc_typenode_for_spec (&expr
->ts
);
8615 se
->expr
= fold_convert (restype
, res
);
8619 /* Generate code for an intrinsic function. Some map directly to library
8620 calls, others get special handling. In some cases the name of the function
8621 used depends on the type specifiers. */
8624 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
8630 name
= &expr
->value
.function
.name
[2];
8634 lib
= gfc_is_intrinsic_libcall (expr
);
8638 se
->ignore_optional
= 1;
8640 switch (expr
->value
.function
.isym
->id
)
8642 case GFC_ISYM_EOSHIFT
:
8644 case GFC_ISYM_RESHAPE
:
8645 /* For all of those the first argument specifies the type and the
8646 third is optional. */
8647 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
8651 gfc_conv_intrinsic_funcall (se
, expr
);
8659 switch (expr
->value
.function
.isym
->id
)
8664 case GFC_ISYM_REPEAT
:
8665 gfc_conv_intrinsic_repeat (se
, expr
);
8669 gfc_conv_intrinsic_trim (se
, expr
);
8672 case GFC_ISYM_SC_KIND
:
8673 gfc_conv_intrinsic_sc_kind (se
, expr
);
8676 case GFC_ISYM_SI_KIND
:
8677 gfc_conv_intrinsic_si_kind (se
, expr
);
8680 case GFC_ISYM_SR_KIND
:
8681 gfc_conv_intrinsic_sr_kind (se
, expr
);
8684 case GFC_ISYM_EXPONENT
:
8685 gfc_conv_intrinsic_exponent (se
, expr
);
8689 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8691 fndecl
= gfor_fndecl_string_scan
;
8693 fndecl
= gfor_fndecl_string_scan_char4
;
8697 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8700 case GFC_ISYM_VERIFY
:
8701 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8703 fndecl
= gfor_fndecl_string_verify
;
8705 fndecl
= gfor_fndecl_string_verify_char4
;
8709 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8712 case GFC_ISYM_ALLOCATED
:
8713 gfc_conv_allocated (se
, expr
);
8716 case GFC_ISYM_ASSOCIATED
:
8717 gfc_conv_associated(se
, expr
);
8720 case GFC_ISYM_SAME_TYPE_AS
:
8721 gfc_conv_same_type_as (se
, expr
);
8725 gfc_conv_intrinsic_abs (se
, expr
);
8728 case GFC_ISYM_ADJUSTL
:
8729 if (expr
->ts
.kind
== 1)
8730 fndecl
= gfor_fndecl_adjustl
;
8731 else if (expr
->ts
.kind
== 4)
8732 fndecl
= gfor_fndecl_adjustl_char4
;
8736 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8739 case GFC_ISYM_ADJUSTR
:
8740 if (expr
->ts
.kind
== 1)
8741 fndecl
= gfor_fndecl_adjustr
;
8742 else if (expr
->ts
.kind
== 4)
8743 fndecl
= gfor_fndecl_adjustr_char4
;
8747 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8750 case GFC_ISYM_AIMAG
:
8751 gfc_conv_intrinsic_imagpart (se
, expr
);
8755 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
8759 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
8762 case GFC_ISYM_ANINT
:
8763 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
8767 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8771 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
8774 case GFC_ISYM_BTEST
:
8775 gfc_conv_intrinsic_btest (se
, expr
);
8779 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
8783 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
8787 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
8791 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
8794 case GFC_ISYM_C_ASSOCIATED
:
8795 case GFC_ISYM_C_FUNLOC
:
8796 case GFC_ISYM_C_LOC
:
8797 conv_isocbinding_function (se
, expr
);
8800 case GFC_ISYM_ACHAR
:
8802 gfc_conv_intrinsic_char (se
, expr
);
8805 case GFC_ISYM_CONVERSION
:
8807 case GFC_ISYM_LOGICAL
:
8809 gfc_conv_intrinsic_conversion (se
, expr
);
8812 /* Integer conversions are handled separately to make sure we get the
8813 correct rounding mode. */
8818 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
8822 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
8825 case GFC_ISYM_CEILING
:
8826 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
8829 case GFC_ISYM_FLOOR
:
8830 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
8834 gfc_conv_intrinsic_mod (se
, expr
, 0);
8837 case GFC_ISYM_MODULO
:
8838 gfc_conv_intrinsic_mod (se
, expr
, 1);
8841 case GFC_ISYM_CAF_GET
:
8842 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
8846 case GFC_ISYM_CMPLX
:
8847 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
8850 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
8851 gfc_conv_intrinsic_iargc (se
, expr
);
8854 case GFC_ISYM_COMPLEX
:
8855 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
8858 case GFC_ISYM_CONJG
:
8859 gfc_conv_intrinsic_conjg (se
, expr
);
8862 case GFC_ISYM_COUNT
:
8863 gfc_conv_intrinsic_count (se
, expr
);
8866 case GFC_ISYM_CTIME
:
8867 gfc_conv_intrinsic_ctime (se
, expr
);
8871 gfc_conv_intrinsic_dim (se
, expr
);
8874 case GFC_ISYM_DOT_PRODUCT
:
8875 gfc_conv_intrinsic_dot_product (se
, expr
);
8878 case GFC_ISYM_DPROD
:
8879 gfc_conv_intrinsic_dprod (se
, expr
);
8882 case GFC_ISYM_DSHIFTL
:
8883 gfc_conv_intrinsic_dshift (se
, expr
, true);
8886 case GFC_ISYM_DSHIFTR
:
8887 gfc_conv_intrinsic_dshift (se
, expr
, false);
8890 case GFC_ISYM_FDATE
:
8891 gfc_conv_intrinsic_fdate (se
, expr
);
8894 case GFC_ISYM_FRACTION
:
8895 gfc_conv_intrinsic_fraction (se
, expr
);
8899 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
8903 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8907 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
8910 case GFC_ISYM_IBCLR
:
8911 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
8914 case GFC_ISYM_IBITS
:
8915 gfc_conv_intrinsic_ibits (se
, expr
);
8918 case GFC_ISYM_IBSET
:
8919 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
8922 case GFC_ISYM_IACHAR
:
8923 case GFC_ISYM_ICHAR
:
8924 /* We assume ASCII character sequence. */
8925 gfc_conv_intrinsic_ichar (se
, expr
);
8928 case GFC_ISYM_IARGC
:
8929 gfc_conv_intrinsic_iargc (se
, expr
);
8933 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8936 case GFC_ISYM_INDEX
:
8937 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8939 fndecl
= gfor_fndecl_string_index
;
8941 fndecl
= gfor_fndecl_string_index_char4
;
8945 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8949 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8952 case GFC_ISYM_IPARITY
:
8953 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
8956 case GFC_ISYM_IS_IOSTAT_END
:
8957 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
8960 case GFC_ISYM_IS_IOSTAT_EOR
:
8961 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
8964 case GFC_ISYM_ISNAN
:
8965 gfc_conv_intrinsic_isnan (se
, expr
);
8968 case GFC_ISYM_LSHIFT
:
8969 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8972 case GFC_ISYM_RSHIFT
:
8973 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8976 case GFC_ISYM_SHIFTA
:
8977 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8980 case GFC_ISYM_SHIFTL
:
8981 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8984 case GFC_ISYM_SHIFTR
:
8985 gfc_conv_intrinsic_shift (se
, expr
, true, false);
8988 case GFC_ISYM_ISHFT
:
8989 gfc_conv_intrinsic_ishft (se
, expr
);
8992 case GFC_ISYM_ISHFTC
:
8993 gfc_conv_intrinsic_ishftc (se
, expr
);
8996 case GFC_ISYM_LEADZ
:
8997 gfc_conv_intrinsic_leadz (se
, expr
);
9000 case GFC_ISYM_TRAILZ
:
9001 gfc_conv_intrinsic_trailz (se
, expr
);
9004 case GFC_ISYM_POPCNT
:
9005 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
9008 case GFC_ISYM_POPPAR
:
9009 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
9012 case GFC_ISYM_LBOUND
:
9013 gfc_conv_intrinsic_bound (se
, expr
, 0);
9016 case GFC_ISYM_LCOBOUND
:
9017 conv_intrinsic_cobound (se
, expr
);
9020 case GFC_ISYM_TRANSPOSE
:
9021 /* The scalarizer has already been set up for reversed dimension access
9022 order ; now we just get the argument value normally. */
9023 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
9027 gfc_conv_intrinsic_len (se
, expr
);
9030 case GFC_ISYM_LEN_TRIM
:
9031 gfc_conv_intrinsic_len_trim (se
, expr
);
9035 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
9039 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
9043 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
9047 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
9050 case GFC_ISYM_MALLOC
:
9051 gfc_conv_intrinsic_malloc (se
, expr
);
9054 case GFC_ISYM_MASKL
:
9055 gfc_conv_intrinsic_mask (se
, expr
, 1);
9058 case GFC_ISYM_MASKR
:
9059 gfc_conv_intrinsic_mask (se
, expr
, 0);
9063 if (expr
->ts
.type
== BT_CHARACTER
)
9064 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
9066 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
9069 case GFC_ISYM_MAXLOC
:
9070 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9073 case GFC_ISYM_MAXVAL
:
9074 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
9077 case GFC_ISYM_MERGE
:
9078 gfc_conv_intrinsic_merge (se
, expr
);
9081 case GFC_ISYM_MERGE_BITS
:
9082 gfc_conv_intrinsic_merge_bits (se
, expr
);
9086 if (expr
->ts
.type
== BT_CHARACTER
)
9087 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
9089 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
9092 case GFC_ISYM_MINLOC
:
9093 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9096 case GFC_ISYM_MINVAL
:
9097 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
9100 case GFC_ISYM_NEAREST
:
9101 gfc_conv_intrinsic_nearest (se
, expr
);
9104 case GFC_ISYM_NORM2
:
9105 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
9109 gfc_conv_intrinsic_not (se
, expr
);
9113 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9116 case GFC_ISYM_PARITY
:
9117 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
9120 case GFC_ISYM_PRESENT
:
9121 gfc_conv_intrinsic_present (se
, expr
);
9124 case GFC_ISYM_PRODUCT
:
9125 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
9129 gfc_conv_intrinsic_rank (se
, expr
);
9132 case GFC_ISYM_RRSPACING
:
9133 gfc_conv_intrinsic_rrspacing (se
, expr
);
9136 case GFC_ISYM_SET_EXPONENT
:
9137 gfc_conv_intrinsic_set_exponent (se
, expr
);
9140 case GFC_ISYM_SCALE
:
9141 gfc_conv_intrinsic_scale (se
, expr
);
9145 gfc_conv_intrinsic_sign (se
, expr
);
9149 gfc_conv_intrinsic_size (se
, expr
);
9152 case GFC_ISYM_SIZEOF
:
9153 case GFC_ISYM_C_SIZEOF
:
9154 gfc_conv_intrinsic_sizeof (se
, expr
);
9157 case GFC_ISYM_STORAGE_SIZE
:
9158 gfc_conv_intrinsic_storage_size (se
, expr
);
9161 case GFC_ISYM_SPACING
:
9162 gfc_conv_intrinsic_spacing (se
, expr
);
9165 case GFC_ISYM_STRIDE
:
9166 conv_intrinsic_stride (se
, expr
);
9170 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
9173 case GFC_ISYM_TRANSFER
:
9174 if (se
->ss
&& se
->ss
->info
->useflags
)
9175 /* Access the previously obtained result. */
9176 gfc_conv_tmp_array_ref (se
);
9178 gfc_conv_intrinsic_transfer (se
, expr
);
9181 case GFC_ISYM_TTYNAM
:
9182 gfc_conv_intrinsic_ttynam (se
, expr
);
9185 case GFC_ISYM_UBOUND
:
9186 gfc_conv_intrinsic_bound (se
, expr
, 1);
9189 case GFC_ISYM_UCOBOUND
:
9190 conv_intrinsic_cobound (se
, expr
);
9194 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9198 gfc_conv_intrinsic_loc (se
, expr
);
9201 case GFC_ISYM_THIS_IMAGE
:
9202 /* For num_images() == 1, handle as LCOBOUND. */
9203 if (expr
->value
.function
.actual
->expr
9204 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
9205 conv_intrinsic_cobound (se
, expr
);
9207 trans_this_image (se
, expr
);
9210 case GFC_ISYM_IMAGE_INDEX
:
9211 trans_image_index (se
, expr
);
9214 case GFC_ISYM_IMAGE_STATUS
:
9215 conv_intrinsic_image_status (se
, expr
);
9218 case GFC_ISYM_NUM_IMAGES
:
9219 trans_num_images (se
, expr
);
9222 case GFC_ISYM_ACCESS
:
9223 case GFC_ISYM_CHDIR
:
9224 case GFC_ISYM_CHMOD
:
9225 case GFC_ISYM_DTIME
:
9226 case GFC_ISYM_ETIME
:
9227 case GFC_ISYM_EXTENDS_TYPE_OF
:
9229 case GFC_ISYM_FGETC
:
9232 case GFC_ISYM_FPUTC
:
9233 case GFC_ISYM_FSTAT
:
9234 case GFC_ISYM_FTELL
:
9235 case GFC_ISYM_GETCWD
:
9236 case GFC_ISYM_GETGID
:
9237 case GFC_ISYM_GETPID
:
9238 case GFC_ISYM_GETUID
:
9239 case GFC_ISYM_HOSTNM
:
9241 case GFC_ISYM_IERRNO
:
9242 case GFC_ISYM_IRAND
:
9243 case GFC_ISYM_ISATTY
:
9246 case GFC_ISYM_LSTAT
:
9247 case GFC_ISYM_MATMUL
:
9248 case GFC_ISYM_MCLOCK
:
9249 case GFC_ISYM_MCLOCK8
:
9251 case GFC_ISYM_RENAME
:
9252 case GFC_ISYM_SECOND
:
9253 case GFC_ISYM_SECNDS
:
9254 case GFC_ISYM_SIGNAL
:
9256 case GFC_ISYM_SYMLNK
:
9257 case GFC_ISYM_SYSTEM
:
9259 case GFC_ISYM_TIME8
:
9260 case GFC_ISYM_UMASK
:
9261 case GFC_ISYM_UNLINK
:
9263 gfc_conv_intrinsic_funcall (se
, expr
);
9266 case GFC_ISYM_EOSHIFT
:
9268 case GFC_ISYM_RESHAPE
:
9269 /* For those, expr->rank should always be >0 and thus the if above the
9270 switch should have matched. */
9275 gfc_conv_intrinsic_lib_function (se
, expr
);
9282 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
9284 gfc_ss
*arg_ss
, *tmp_ss
;
9285 gfc_actual_arglist
*arg
;
9287 arg
= expr
->value
.function
.actual
;
9289 gcc_assert (arg
->expr
);
9291 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
9292 gcc_assert (arg_ss
!= gfc_ss_terminator
);
9294 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
9296 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
9297 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
9299 gcc_assert (tmp_ss
->dimen
== 2);
9301 /* We just invert dimensions. */
9302 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
9305 /* Stop when tmp_ss points to the last valid element of the chain... */
9306 if (tmp_ss
->next
== gfc_ss_terminator
)
9310 /* ... so that we can attach the rest of the chain to it. */
9317 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9318 This has the side effect of reversing the nested list, so there is no
9319 need to call gfc_reverse_ss on it (the given list is assumed not to be
9323 nest_loop_dimension (gfc_ss
*ss
, int dim
)
9326 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
9327 gfc_loopinfo
*new_loop
;
9329 gcc_assert (ss
!= gfc_ss_terminator
);
9331 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
9333 new_ss
= gfc_get_ss ();
9334 new_ss
->next
= prev_ss
;
9335 new_ss
->parent
= ss
;
9336 new_ss
->info
= ss
->info
;
9337 new_ss
->info
->refcount
++;
9340 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
9341 && ss
->info
->type
!= GFC_SS_REFERENCE
);
9344 new_ss
->dim
[0] = ss
->dim
[dim
];
9346 gcc_assert (dim
< ss
->dimen
);
9348 ss_dim
= --ss
->dimen
;
9349 for (i
= dim
; i
< ss_dim
; i
++)
9350 ss
->dim
[i
] = ss
->dim
[i
+ 1];
9352 ss
->dim
[ss_dim
] = 0;
9358 ss
->nested_ss
->parent
= new_ss
;
9359 new_ss
->nested_ss
= ss
->nested_ss
;
9361 ss
->nested_ss
= new_ss
;
9364 new_loop
= gfc_get_loopinfo ();
9365 gfc_init_loopinfo (new_loop
);
9367 gcc_assert (prev_ss
!= NULL
);
9368 gcc_assert (prev_ss
!= gfc_ss_terminator
);
9369 gfc_add_ss_to_loop (new_loop
, prev_ss
);
9370 return new_ss
->parent
;
9374 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9375 is to be inlined. */
9378 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
9380 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
9381 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
9383 bool scalar_mask
= false;
9385 /* The rank of the result will be determined later. */
9386 arg1
= expr
->value
.function
.actual
;
9389 gcc_assert (arg3
!= NULL
);
9391 if (expr
->rank
== 0)
9394 tmp_ss
= gfc_ss_terminator
;
9400 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
9401 if (mask_ss
== tmp_ss
)
9407 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
9408 gcc_assert (array_ss
!= tmp_ss
);
9410 /* Odd thing: If the mask is scalar, it is used by the frontend after
9411 the array (to make an if around the nested loop). Thus it shall
9412 be after array_ss once the gfc_ss list is reversed. */
9414 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
9418 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9420 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
9421 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
9429 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
9432 switch (expr
->value
.function
.isym
->id
)
9434 case GFC_ISYM_PRODUCT
:
9436 return walk_inline_intrinsic_arith (ss
, expr
);
9438 case GFC_ISYM_TRANSPOSE
:
9439 return walk_inline_intrinsic_transpose (ss
, expr
);
9448 /* This generates code to execute before entering the scalarization loop.
9449 Currently does nothing. */
9452 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
9454 switch (ss
->info
->expr
->value
.function
.isym
->id
)
9456 case GFC_ISYM_UBOUND
:
9457 case GFC_ISYM_LBOUND
:
9458 case GFC_ISYM_UCOBOUND
:
9459 case GFC_ISYM_LCOBOUND
:
9460 case GFC_ISYM_THIS_IMAGE
:
9469 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9470 are expanded into code inside the scalarization loop. */
9473 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
9475 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
9476 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
9478 /* The two argument version returns a scalar. */
9479 if (expr
->value
.function
.actual
->next
->expr
)
9482 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
9486 /* Walk an intrinsic array libcall. */
9489 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
9491 gcc_assert (expr
->rank
> 0);
9492 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9496 /* Return whether the function call expression EXPR will be expanded
9497 inline by gfc_conv_intrinsic_function. */
9500 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
9502 gfc_actual_arglist
*args
;
9504 if (!expr
->value
.function
.isym
)
9507 switch (expr
->value
.function
.isym
->id
)
9509 case GFC_ISYM_PRODUCT
:
9511 /* Disable inline expansion if code size matters. */
9515 args
= expr
->value
.function
.actual
;
9516 /* We need to be able to subset the SUM argument at compile-time. */
9517 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
9522 case GFC_ISYM_TRANSPOSE
:
9531 /* Returns nonzero if the specified intrinsic function call maps directly to
9532 an external library call. Should only be used for functions that return
9536 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
9538 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
9539 gcc_assert (expr
->rank
> 0);
9541 if (gfc_inline_intrinsic_function_p (expr
))
9544 switch (expr
->value
.function
.isym
->id
)
9548 case GFC_ISYM_COUNT
:
9552 case GFC_ISYM_IPARITY
:
9553 case GFC_ISYM_MATMUL
:
9554 case GFC_ISYM_MAXLOC
:
9555 case GFC_ISYM_MAXVAL
:
9556 case GFC_ISYM_MINLOC
:
9557 case GFC_ISYM_MINVAL
:
9558 case GFC_ISYM_NORM2
:
9559 case GFC_ISYM_PARITY
:
9560 case GFC_ISYM_PRODUCT
:
9562 case GFC_ISYM_SHAPE
:
9563 case GFC_ISYM_SPREAD
:
9565 /* Ignore absent optional parameters. */
9568 case GFC_ISYM_CSHIFT
:
9569 case GFC_ISYM_EOSHIFT
:
9570 case GFC_ISYM_FAILED_IMAGES
:
9571 case GFC_ISYM_STOPPED_IMAGES
:
9573 case GFC_ISYM_RESHAPE
:
9574 case GFC_ISYM_UNPACK
:
9575 /* Pass absent optional parameters. */
9583 /* Walk an intrinsic function. */
9585 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
9586 gfc_intrinsic_sym
* isym
)
9590 if (isym
->elemental
)
9591 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9592 NULL
, GFC_SS_SCALAR
);
9594 if (expr
->rank
== 0)
9597 if (gfc_inline_intrinsic_function_p (expr
))
9598 return walk_inline_intrinsic_function (ss
, expr
);
9600 if (gfc_is_intrinsic_libcall (expr
))
9601 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9603 /* Special cases. */
9606 case GFC_ISYM_LBOUND
:
9607 case GFC_ISYM_LCOBOUND
:
9608 case GFC_ISYM_UBOUND
:
9609 case GFC_ISYM_UCOBOUND
:
9610 case GFC_ISYM_THIS_IMAGE
:
9611 return gfc_walk_intrinsic_bound (ss
, expr
);
9613 case GFC_ISYM_TRANSFER
:
9614 case GFC_ISYM_CAF_GET
:
9615 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9618 /* This probably meant someone forgot to add an intrinsic to the above
9619 list(s) when they implemented it, or something's gone horribly
9627 conv_co_collective (gfc_code
*code
)
9630 stmtblock_t block
, post_block
;
9631 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
9632 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
9634 gfc_start_block (&block
);
9635 gfc_init_block (&post_block
);
9637 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
9639 opr_expr
= code
->ext
.actual
->next
->expr
;
9640 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
9641 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9642 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
9647 image_idx_expr
= code
->ext
.actual
->next
->expr
;
9648 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9649 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9655 gfc_init_se (&argse
, NULL
);
9656 gfc_conv_expr (&argse
, stat_expr
);
9657 gfc_add_block_to_block (&block
, &argse
.pre
);
9658 gfc_add_block_to_block (&post_block
, &argse
.post
);
9660 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
9661 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
9663 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9666 stat
= null_pointer_node
;
9668 /* Early exit for GFC_FCOARRAY_SINGLE. */
9669 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9671 if (stat
!= NULL_TREE
)
9672 gfc_add_modify (&block
, stat
,
9673 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
9674 return gfc_finish_block (&block
);
9677 /* Handle the array. */
9678 gfc_init_se (&argse
, NULL
);
9679 if (code
->ext
.actual
->expr
->rank
== 0)
9681 symbol_attribute attr
;
9682 gfc_clear_attr (&attr
);
9683 gfc_init_se (&argse
, NULL
);
9684 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9685 gfc_add_block_to_block (&block
, &argse
.pre
);
9686 gfc_add_block_to_block (&post_block
, &argse
.post
);
9687 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
9688 array
= gfc_build_addr_expr (NULL_TREE
, array
);
9692 argse
.want_pointer
= 1;
9693 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
9696 gfc_add_block_to_block (&block
, &argse
.pre
);
9697 gfc_add_block_to_block (&post_block
, &argse
.post
);
9699 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
9700 strlen
= argse
.string_length
;
9702 strlen
= integer_zero_node
;
9707 gfc_init_se (&argse
, NULL
);
9708 gfc_conv_expr (&argse
, image_idx_expr
);
9709 gfc_add_block_to_block (&block
, &argse
.pre
);
9710 gfc_add_block_to_block (&post_block
, &argse
.post
);
9711 image_index
= fold_convert (integer_type_node
, argse
.expr
);
9714 image_index
= integer_zero_node
;
9719 gfc_init_se (&argse
, NULL
);
9720 gfc_conv_expr (&argse
, errmsg_expr
);
9721 gfc_add_block_to_block (&block
, &argse
.pre
);
9722 gfc_add_block_to_block (&post_block
, &argse
.post
);
9723 errmsg
= argse
.expr
;
9724 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
9728 errmsg
= null_pointer_node
;
9729 errmsg_len
= integer_zero_node
;
9732 /* Generate the function call. */
9733 switch (code
->resolved_isym
->id
)
9735 case GFC_ISYM_CO_BROADCAST
:
9736 fndecl
= gfor_fndecl_co_broadcast
;
9738 case GFC_ISYM_CO_MAX
:
9739 fndecl
= gfor_fndecl_co_max
;
9741 case GFC_ISYM_CO_MIN
:
9742 fndecl
= gfor_fndecl_co_min
;
9744 case GFC_ISYM_CO_REDUCE
:
9745 fndecl
= gfor_fndecl_co_reduce
;
9747 case GFC_ISYM_CO_SUM
:
9748 fndecl
= gfor_fndecl_co_sum
;
9754 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
9755 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
9756 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
9757 image_index
, stat
, errmsg
, errmsg_len
);
9758 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
9759 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
9760 stat
, errmsg
, strlen
, errmsg_len
);
9763 tree opr
, opr_flags
;
9765 // FIXME: Handle TS29113's bind(C) strings with descriptor.
9767 if (gfc_is_proc_ptr_comp (opr_expr
))
9769 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
9770 opr_flag_int
= sym
->attr
.dimension
9771 || (sym
->ts
.type
== BT_CHARACTER
9772 && !sym
->attr
.is_bind_c
)
9773 ? GFC_CAF_BYREF
: 0;
9774 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9775 && !sym
->attr
.is_bind_c
9776 ? GFC_CAF_HIDDENLEN
: 0;
9777 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
9781 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
9782 ? GFC_CAF_BYREF
: 0;
9783 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9784 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
9785 ? GFC_CAF_HIDDENLEN
: 0;
9786 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
9787 ? GFC_CAF_ARG_VALUE
: 0;
9789 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
9790 gfc_conv_expr (&argse
, opr_expr
);
9792 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
9793 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
9796 gfc_add_expr_to_block (&block
, fndecl
);
9797 gfc_add_block_to_block (&block
, &post_block
);
9799 return gfc_finish_block (&block
);
9804 conv_intrinsic_atomic_op (gfc_code
*code
)
9807 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
9808 stmtblock_t block
, post_block
;
9809 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9810 gfc_expr
*stat_expr
;
9811 built_in_function fn
;
9813 if (atom_expr
->expr_type
== EXPR_FUNCTION
9814 && atom_expr
->value
.function
.isym
9815 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9816 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9818 gfc_start_block (&block
);
9819 gfc_init_block (&post_block
);
9821 gfc_init_se (&argse
, NULL
);
9822 argse
.want_pointer
= 1;
9823 gfc_conv_expr (&argse
, atom_expr
);
9824 gfc_add_block_to_block (&block
, &argse
.pre
);
9825 gfc_add_block_to_block (&post_block
, &argse
.post
);
9828 gfc_init_se (&argse
, NULL
);
9829 if (flag_coarray
== GFC_FCOARRAY_LIB
9830 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9831 argse
.want_pointer
= 1;
9832 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9833 gfc_add_block_to_block (&block
, &argse
.pre
);
9834 gfc_add_block_to_block (&post_block
, &argse
.post
);
9837 switch (code
->resolved_isym
->id
)
9839 case GFC_ISYM_ATOMIC_ADD
:
9840 case GFC_ISYM_ATOMIC_AND
:
9841 case GFC_ISYM_ATOMIC_DEF
:
9842 case GFC_ISYM_ATOMIC_OR
:
9843 case GFC_ISYM_ATOMIC_XOR
:
9844 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9845 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9846 old
= null_pointer_node
;
9849 gfc_init_se (&argse
, NULL
);
9850 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9851 argse
.want_pointer
= 1;
9852 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9853 gfc_add_block_to_block (&block
, &argse
.pre
);
9854 gfc_add_block_to_block (&post_block
, &argse
.post
);
9856 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9860 if (stat_expr
!= NULL
)
9862 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
9863 gfc_init_se (&argse
, NULL
);
9864 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9865 argse
.want_pointer
= 1;
9866 gfc_conv_expr_val (&argse
, stat_expr
);
9867 gfc_add_block_to_block (&block
, &argse
.pre
);
9868 gfc_add_block_to_block (&post_block
, &argse
.post
);
9871 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9872 stat
= null_pointer_node
;
9874 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9876 tree image_index
, caf_decl
, offset
, token
;
9879 switch (code
->resolved_isym
->id
)
9881 case GFC_ISYM_ATOMIC_ADD
:
9882 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9883 op
= (int) GFC_CAF_ATOMIC_ADD
;
9885 case GFC_ISYM_ATOMIC_AND
:
9886 case GFC_ISYM_ATOMIC_FETCH_AND
:
9887 op
= (int) GFC_CAF_ATOMIC_AND
;
9889 case GFC_ISYM_ATOMIC_OR
:
9890 case GFC_ISYM_ATOMIC_FETCH_OR
:
9891 op
= (int) GFC_CAF_ATOMIC_OR
;
9893 case GFC_ISYM_ATOMIC_XOR
:
9894 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9895 op
= (int) GFC_CAF_ATOMIC_XOR
;
9897 case GFC_ISYM_ATOMIC_DEF
:
9898 op
= 0; /* Unused. */
9904 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9905 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9906 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9908 if (gfc_is_coindexed (atom_expr
))
9909 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9911 image_index
= integer_zero_node
;
9913 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9915 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9916 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
9917 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9920 gfc_init_se (&argse
, NULL
);
9921 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
9924 gfc_add_block_to_block (&block
, &argse
.pre
);
9925 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
9926 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
9927 token
, offset
, image_index
, value
, stat
,
9928 build_int_cst (integer_type_node
,
9929 (int) atom_expr
->ts
.type
),
9930 build_int_cst (integer_type_node
,
9931 (int) atom_expr
->ts
.kind
));
9933 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
9934 build_int_cst (integer_type_node
, op
),
9935 token
, offset
, image_index
, value
, old
, stat
,
9936 build_int_cst (integer_type_node
,
9937 (int) atom_expr
->ts
.type
),
9938 build_int_cst (integer_type_node
,
9939 (int) atom_expr
->ts
.kind
));
9941 gfc_add_expr_to_block (&block
, tmp
);
9942 gfc_add_block_to_block (&block
, &argse
.post
);
9943 gfc_add_block_to_block (&block
, &post_block
);
9944 return gfc_finish_block (&block
);
9948 switch (code
->resolved_isym
->id
)
9950 case GFC_ISYM_ATOMIC_ADD
:
9951 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9952 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
9954 case GFC_ISYM_ATOMIC_AND
:
9955 case GFC_ISYM_ATOMIC_FETCH_AND
:
9956 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
9958 case GFC_ISYM_ATOMIC_DEF
:
9959 fn
= BUILT_IN_ATOMIC_STORE_N
;
9961 case GFC_ISYM_ATOMIC_OR
:
9962 case GFC_ISYM_ATOMIC_FETCH_OR
:
9963 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
9965 case GFC_ISYM_ATOMIC_XOR
:
9966 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9967 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
9973 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9974 fn
= (built_in_function
) ((int) fn
9975 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9977 tmp
= builtin_decl_explicit (fn
);
9978 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
9979 tmp
= builtin_decl_explicit (fn
);
9981 switch (code
->resolved_isym
->id
)
9983 case GFC_ISYM_ATOMIC_ADD
:
9984 case GFC_ISYM_ATOMIC_AND
:
9985 case GFC_ISYM_ATOMIC_DEF
:
9986 case GFC_ISYM_ATOMIC_OR
:
9987 case GFC_ISYM_ATOMIC_XOR
:
9988 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9989 fold_convert (itype
, value
),
9990 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9991 gfc_add_expr_to_block (&block
, tmp
);
9994 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9995 fold_convert (itype
, value
),
9996 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9997 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
10001 if (stat
!= NULL_TREE
)
10002 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10003 gfc_add_block_to_block (&block
, &post_block
);
10004 return gfc_finish_block (&block
);
10009 conv_intrinsic_atomic_ref (gfc_code
*code
)
10012 tree tmp
, atom
, value
, stat
= NULL_TREE
;
10013 stmtblock_t block
, post_block
;
10014 built_in_function fn
;
10015 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
10017 if (atom_expr
->expr_type
== EXPR_FUNCTION
10018 && atom_expr
->value
.function
.isym
10019 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10020 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10022 gfc_start_block (&block
);
10023 gfc_init_block (&post_block
);
10024 gfc_init_se (&argse
, NULL
);
10025 argse
.want_pointer
= 1;
10026 gfc_conv_expr (&argse
, atom_expr
);
10027 gfc_add_block_to_block (&block
, &argse
.pre
);
10028 gfc_add_block_to_block (&post_block
, &argse
.post
);
10031 gfc_init_se (&argse
, NULL
);
10032 if (flag_coarray
== GFC_FCOARRAY_LIB
10033 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10034 argse
.want_pointer
= 1;
10035 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10036 gfc_add_block_to_block (&block
, &argse
.pre
);
10037 gfc_add_block_to_block (&post_block
, &argse
.post
);
10038 value
= argse
.expr
;
10041 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
10043 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10045 gfc_init_se (&argse
, NULL
);
10046 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10047 argse
.want_pointer
= 1;
10048 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10049 gfc_add_block_to_block (&block
, &argse
.pre
);
10050 gfc_add_block_to_block (&post_block
, &argse
.post
);
10053 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10054 stat
= null_pointer_node
;
10056 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10058 tree image_index
, caf_decl
, offset
, token
;
10059 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
10061 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10062 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10063 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10065 if (gfc_is_coindexed (atom_expr
))
10066 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10068 image_index
= integer_zero_node
;
10070 gfc_init_se (&argse
, NULL
);
10071 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10073 gfc_add_block_to_block (&block
, &argse
.pre
);
10075 /* Different type, need type conversion. */
10076 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10078 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10079 orig_value
= value
;
10080 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
10083 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
10084 token
, offset
, image_index
, value
, stat
,
10085 build_int_cst (integer_type_node
,
10086 (int) atom_expr
->ts
.type
),
10087 build_int_cst (integer_type_node
,
10088 (int) atom_expr
->ts
.kind
));
10089 gfc_add_expr_to_block (&block
, tmp
);
10090 if (vardecl
!= NULL_TREE
)
10091 gfc_add_modify (&block
, orig_value
,
10092 fold_convert (TREE_TYPE (orig_value
), vardecl
));
10093 gfc_add_block_to_block (&block
, &argse
.post
);
10094 gfc_add_block_to_block (&block
, &post_block
);
10095 return gfc_finish_block (&block
);
10098 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10099 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
10100 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10102 tmp
= builtin_decl_explicit (fn
);
10103 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
10104 build_int_cst (integer_type_node
,
10105 MEMMODEL_RELAXED
));
10106 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
10108 if (stat
!= NULL_TREE
)
10109 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10110 gfc_add_block_to_block (&block
, &post_block
);
10111 return gfc_finish_block (&block
);
10116 conv_intrinsic_atomic_cas (gfc_code
*code
)
10119 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
10120 stmtblock_t block
, post_block
;
10121 built_in_function fn
;
10122 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10124 if (atom_expr
->expr_type
== EXPR_FUNCTION
10125 && atom_expr
->value
.function
.isym
10126 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10127 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10129 gfc_init_block (&block
);
10130 gfc_init_block (&post_block
);
10131 gfc_init_se (&argse
, NULL
);
10132 argse
.want_pointer
= 1;
10133 gfc_conv_expr (&argse
, atom_expr
);
10136 gfc_init_se (&argse
, NULL
);
10137 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10138 argse
.want_pointer
= 1;
10139 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10140 gfc_add_block_to_block (&block
, &argse
.pre
);
10141 gfc_add_block_to_block (&post_block
, &argse
.post
);
10144 gfc_init_se (&argse
, NULL
);
10145 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10146 argse
.want_pointer
= 1;
10147 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10148 gfc_add_block_to_block (&block
, &argse
.pre
);
10149 gfc_add_block_to_block (&post_block
, &argse
.post
);
10152 gfc_init_se (&argse
, NULL
);
10153 if (flag_coarray
== GFC_FCOARRAY_LIB
10154 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
10155 == atom_expr
->ts
.kind
)
10156 argse
.want_pointer
= 1;
10157 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
10158 gfc_add_block_to_block (&block
, &argse
.pre
);
10159 gfc_add_block_to_block (&post_block
, &argse
.post
);
10160 new_val
= argse
.expr
;
10163 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
10165 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
10167 gfc_init_se (&argse
, NULL
);
10168 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10169 argse
.want_pointer
= 1;
10170 gfc_conv_expr_val (&argse
,
10171 code
->ext
.actual
->next
->next
->next
->next
->expr
);
10172 gfc_add_block_to_block (&block
, &argse
.pre
);
10173 gfc_add_block_to_block (&post_block
, &argse
.post
);
10176 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10177 stat
= null_pointer_node
;
10179 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10181 tree image_index
, caf_decl
, offset
, token
;
10183 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10184 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10185 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10187 if (gfc_is_coindexed (atom_expr
))
10188 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10190 image_index
= integer_zero_node
;
10192 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
10194 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
10195 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
10196 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10199 /* Convert a constant to a pointer. */
10200 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
10202 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
10203 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
10204 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10207 gfc_init_se (&argse
, NULL
);
10208 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10210 gfc_add_block_to_block (&block
, &argse
.pre
);
10212 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
10213 token
, offset
, image_index
, old
, comp
, new_val
,
10214 stat
, build_int_cst (integer_type_node
,
10215 (int) atom_expr
->ts
.type
),
10216 build_int_cst (integer_type_node
,
10217 (int) atom_expr
->ts
.kind
));
10218 gfc_add_expr_to_block (&block
, tmp
);
10219 gfc_add_block_to_block (&block
, &argse
.post
);
10220 gfc_add_block_to_block (&block
, &post_block
);
10221 return gfc_finish_block (&block
);
10224 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10225 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10226 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10228 tmp
= builtin_decl_explicit (fn
);
10230 gfc_add_modify (&block
, old
, comp
);
10231 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
10232 gfc_build_addr_expr (NULL
, old
),
10233 fold_convert (TREE_TYPE (old
), new_val
),
10234 boolean_false_node
,
10235 build_int_cst (NULL
, MEMMODEL_RELAXED
),
10236 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10237 gfc_add_expr_to_block (&block
, tmp
);
10239 if (stat
!= NULL_TREE
)
10240 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10241 gfc_add_block_to_block (&block
, &post_block
);
10242 return gfc_finish_block (&block
);
10246 conv_intrinsic_event_query (gfc_code
*code
)
10249 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
10250 tree count
= NULL_TREE
, count2
= NULL_TREE
;
10252 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
10254 if (code
->ext
.actual
->next
->next
->expr
)
10256 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10258 gfc_init_se (&argse
, NULL
);
10259 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10262 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10263 stat
= null_pointer_node
;
10265 if (code
->ext
.actual
->next
->expr
)
10267 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
10268 gfc_init_se (&argse
, NULL
);
10269 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
10270 count
= argse
.expr
;
10273 gfc_start_block (&se
.pre
);
10274 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10276 tree tmp
, token
, image_index
;
10277 tree index
= size_zero_node
;
10279 if (event_expr
->expr_type
== EXPR_FUNCTION
10280 && event_expr
->value
.function
.isym
10281 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10282 event_expr
= event_expr
->value
.function
.actual
->expr
;
10284 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
10286 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10287 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
10288 != INTMOD_ISO_FORTRAN_ENV
10289 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
10290 != ISOFORTRAN_EVENT_TYPE
)
10292 gfc_error ("Sorry, the event component of derived type at %L is not "
10293 "yet supported", &event_expr
->where
);
10297 if (gfc_is_coindexed (event_expr
))
10299 gfc_error ("The event variable at %L shall not be coindexed",
10300 &event_expr
->where
);
10304 image_index
= integer_zero_node
;
10306 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10309 /* For arrays, obtain the array index. */
10310 if (gfc_expr_attr (event_expr
).dimension
)
10312 tree desc
, tmp
, extent
, lbound
, ubound
;
10313 gfc_array_ref
*ar
, ar2
;
10316 /* TODO: Extend this, once DT components are supported. */
10317 ar
= &event_expr
->ref
->u
.ar
;
10319 memset (ar
, '\0', sizeof (*ar
));
10321 ar
->type
= AR_FULL
;
10323 gfc_init_se (&argse
, NULL
);
10324 argse
.descriptor_only
= 1;
10325 gfc_conv_expr_descriptor (&argse
, event_expr
);
10326 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
10330 extent
= integer_one_node
;
10331 for (i
= 0; i
< ar
->dimen
; i
++)
10333 gfc_init_se (&argse
, NULL
);
10334 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
10335 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
10336 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
10337 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10338 integer_type_node
, argse
.expr
,
10339 fold_convert(integer_type_node
, lbound
));
10340 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10341 integer_type_node
, extent
, tmp
);
10342 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
10343 integer_type_node
, index
, tmp
);
10344 if (i
< ar
->dimen
- 1)
10346 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
10347 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10348 tmp
= fold_convert (integer_type_node
, tmp
);
10349 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
10350 integer_type_node
, extent
, tmp
);
10355 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
10358 count
= gfc_create_var (integer_type_node
, "count");
10361 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
10364 stat
= gfc_create_var (integer_type_node
, "stat");
10367 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
10368 token
, index
, image_index
, count
10369 ? gfc_build_addr_expr (NULL
, count
) : count
,
10370 stat
!= null_pointer_node
10371 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
10372 gfc_add_expr_to_block (&se
.pre
, tmp
);
10374 if (count2
!= NULL_TREE
)
10375 gfc_add_modify (&se
.pre
, count2
,
10376 fold_convert (TREE_TYPE (count2
), count
));
10378 if (stat2
!= NULL_TREE
)
10379 gfc_add_modify (&se
.pre
, stat2
,
10380 fold_convert (TREE_TYPE (stat2
), stat
));
10382 return gfc_finish_block (&se
.pre
);
10385 gfc_init_se (&argse
, NULL
);
10386 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
10387 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
10389 if (stat
!= NULL_TREE
)
10390 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10392 return gfc_finish_block (&se
.pre
);
10396 conv_intrinsic_move_alloc (gfc_code
*code
)
10399 gfc_expr
*from_expr
, *to_expr
;
10400 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
10401 gfc_se from_se
, to_se
;
10405 gfc_start_block (&block
);
10407 from_expr
= code
->ext
.actual
->expr
;
10408 to_expr
= code
->ext
.actual
->next
->expr
;
10410 gfc_init_se (&from_se
, NULL
);
10411 gfc_init_se (&to_se
, NULL
);
10413 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
10414 || to_expr
->ts
.type
== BT_CLASS
);
10415 coarray
= gfc_get_corank (from_expr
) != 0;
10417 if (from_expr
->rank
== 0 && !coarray
)
10419 if (from_expr
->ts
.type
!= BT_CLASS
)
10420 from_expr2
= from_expr
;
10423 from_expr2
= gfc_copy_expr (from_expr
);
10424 gfc_add_data_component (from_expr2
);
10427 if (to_expr
->ts
.type
!= BT_CLASS
)
10428 to_expr2
= to_expr
;
10431 to_expr2
= gfc_copy_expr (to_expr
);
10432 gfc_add_data_component (to_expr2
);
10435 from_se
.want_pointer
= 1;
10436 to_se
.want_pointer
= 1;
10437 gfc_conv_expr (&from_se
, from_expr2
);
10438 gfc_conv_expr (&to_se
, to_expr2
);
10439 gfc_add_block_to_block (&block
, &from_se
.pre
);
10440 gfc_add_block_to_block (&block
, &to_se
.pre
);
10442 /* Deallocate "to". */
10443 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10444 true, to_expr
, to_expr
->ts
);
10445 gfc_add_expr_to_block (&block
, tmp
);
10447 /* Assign (_data) pointers. */
10448 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10449 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
10451 /* Set "from" to NULL. */
10452 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10453 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
10455 gfc_add_block_to_block (&block
, &from_se
.post
);
10456 gfc_add_block_to_block (&block
, &to_se
.post
);
10459 if (to_expr
->ts
.type
== BT_CLASS
)
10463 gfc_free_expr (to_expr2
);
10464 gfc_init_se (&to_se
, NULL
);
10465 to_se
.want_pointer
= 1;
10466 gfc_add_vptr_component (to_expr
);
10467 gfc_conv_expr (&to_se
, to_expr
);
10469 if (from_expr
->ts
.type
== BT_CLASS
)
10471 if (UNLIMITED_POLY (from_expr
))
10475 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10479 gfc_free_expr (from_expr2
);
10480 gfc_init_se (&from_se
, NULL
);
10481 from_se
.want_pointer
= 1;
10482 gfc_add_vptr_component (from_expr
);
10483 gfc_conv_expr (&from_se
, from_expr
);
10484 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10485 fold_convert (TREE_TYPE (to_se
.expr
),
10488 /* Reset _vptr component to declared type. */
10490 /* Unlimited polymorphic. */
10491 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10492 fold_convert (TREE_TYPE (from_se
.expr
),
10493 null_pointer_node
));
10496 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10497 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10498 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10503 vtab
= gfc_find_vtab (&from_expr
->ts
);
10505 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10506 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10507 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10511 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10513 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10514 fold_convert (TREE_TYPE (to_se
.string_length
),
10515 from_se
.string_length
));
10516 if (from_expr
->ts
.deferred
)
10517 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10518 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10521 return gfc_finish_block (&block
);
10524 /* Update _vptr component. */
10525 if (to_expr
->ts
.type
== BT_CLASS
)
10529 to_se
.want_pointer
= 1;
10530 to_expr2
= gfc_copy_expr (to_expr
);
10531 gfc_add_vptr_component (to_expr2
);
10532 gfc_conv_expr (&to_se
, to_expr2
);
10534 if (from_expr
->ts
.type
== BT_CLASS
)
10536 if (UNLIMITED_POLY (from_expr
))
10540 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10544 from_se
.want_pointer
= 1;
10545 from_expr2
= gfc_copy_expr (from_expr
);
10546 gfc_add_vptr_component (from_expr2
);
10547 gfc_conv_expr (&from_se
, from_expr2
);
10548 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10549 fold_convert (TREE_TYPE (to_se
.expr
),
10552 /* Reset _vptr component to declared type. */
10554 /* Unlimited polymorphic. */
10555 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10556 fold_convert (TREE_TYPE (from_se
.expr
),
10557 null_pointer_node
));
10560 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10561 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10562 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10567 vtab
= gfc_find_vtab (&from_expr
->ts
);
10569 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10570 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10571 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10574 gfc_free_expr (to_expr2
);
10575 gfc_init_se (&to_se
, NULL
);
10577 if (from_expr
->ts
.type
== BT_CLASS
)
10579 gfc_free_expr (from_expr2
);
10580 gfc_init_se (&from_se
, NULL
);
10585 /* Deallocate "to". */
10586 if (from_expr
->rank
== 0)
10588 to_se
.want_coarray
= 1;
10589 from_se
.want_coarray
= 1;
10591 gfc_conv_expr_descriptor (&to_se
, to_expr
);
10592 gfc_conv_expr_descriptor (&from_se
, from_expr
);
10594 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10595 is an image control "statement", cf. IR F08/0040 in 12-006A. */
10596 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10600 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10601 NULL_TREE
, NULL_TREE
, true, to_expr
,
10602 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
10603 gfc_add_expr_to_block (&block
, tmp
);
10605 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10606 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10607 logical_type_node
, tmp
,
10608 fold_convert (TREE_TYPE (tmp
),
10609 null_pointer_node
));
10610 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
10611 3, null_pointer_node
, null_pointer_node
,
10612 build_int_cst (integer_type_node
, 0));
10614 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
10615 tmp
, build_empty_stmt (input_location
));
10616 gfc_add_expr_to_block (&block
, tmp
);
10620 if (to_expr
->ts
.type
== BT_DERIVED
10621 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
10623 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
10624 to_se
.expr
, to_expr
->rank
);
10625 gfc_add_expr_to_block (&block
, tmp
);
10628 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10629 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10630 NULL_TREE
, true, to_expr
,
10631 GFC_CAF_COARRAY_NOCOARRAY
);
10632 gfc_add_expr_to_block (&block
, tmp
);
10635 /* Move the pointer and update the array descriptor data. */
10636 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
10638 /* Set "from" to NULL. */
10639 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
10640 gfc_add_modify_loc (input_location
, &block
, tmp
,
10641 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
10644 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10646 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10647 fold_convert (TREE_TYPE (to_se
.string_length
),
10648 from_se
.string_length
));
10649 if (from_expr
->ts
.deferred
)
10650 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10651 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10654 return gfc_finish_block (&block
);
10659 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
10663 gcc_assert (code
->resolved_isym
);
10665 switch (code
->resolved_isym
->id
)
10667 case GFC_ISYM_MOVE_ALLOC
:
10668 res
= conv_intrinsic_move_alloc (code
);
10671 case GFC_ISYM_ATOMIC_CAS
:
10672 res
= conv_intrinsic_atomic_cas (code
);
10675 case GFC_ISYM_ATOMIC_ADD
:
10676 case GFC_ISYM_ATOMIC_AND
:
10677 case GFC_ISYM_ATOMIC_DEF
:
10678 case GFC_ISYM_ATOMIC_OR
:
10679 case GFC_ISYM_ATOMIC_XOR
:
10680 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10681 case GFC_ISYM_ATOMIC_FETCH_AND
:
10682 case GFC_ISYM_ATOMIC_FETCH_OR
:
10683 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10684 res
= conv_intrinsic_atomic_op (code
);
10687 case GFC_ISYM_ATOMIC_REF
:
10688 res
= conv_intrinsic_atomic_ref (code
);
10691 case GFC_ISYM_EVENT_QUERY
:
10692 res
= conv_intrinsic_event_query (code
);
10695 case GFC_ISYM_C_F_POINTER
:
10696 case GFC_ISYM_C_F_PROCPOINTER
:
10697 res
= conv_isocbinding_subroutine (code
);
10700 case GFC_ISYM_CAF_SEND
:
10701 res
= conv_caf_send (code
);
10704 case GFC_ISYM_CO_BROADCAST
:
10705 case GFC_ISYM_CO_MIN
:
10706 case GFC_ISYM_CO_MAX
:
10707 case GFC_ISYM_CO_REDUCE
:
10708 case GFC_ISYM_CO_SUM
:
10709 res
= conv_co_collective (code
);
10712 case GFC_ISYM_FREE
:
10713 res
= conv_intrinsic_free (code
);
10716 case GFC_ISYM_SYSTEM_CLOCK
:
10717 res
= conv_intrinsic_system_clock (code
);
10728 #include "gt-fortran-trans-intrinsic.h"