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
, *tmp_team
;
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
, dst_team
;
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
;
1869 dst_team
= null_pointer_node
;
1872 gfc_init_se (&lhs_se
, NULL
);
1873 if (lhs_expr
->rank
== 0)
1875 if (lhs_expr
->ts
.type
== BT_CHARACTER
&& lhs_expr
->ts
.deferred
)
1877 lhs_se
.expr
= gfc_get_tree_for_caf_expr (lhs_expr
);
1878 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1882 symbol_attribute attr
;
1883 gfc_clear_attr (&attr
);
1884 gfc_conv_expr (&lhs_se
, lhs_expr
);
1885 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1886 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
,
1888 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1891 else if ((lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
1892 && lhs_caf_attr
.codimension
)
1894 lhs_se
.want_pointer
= 1;
1895 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1896 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1897 has the wrong type if component references are done. */
1898 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1899 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1900 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1901 gfc_get_dtype_rank_type (
1902 gfc_has_vector_subscript (lhs_expr
)
1903 ? gfc_find_array_ref (lhs_expr
)->dimen
1909 /* If has_vector, pass descriptor for whole array and the
1910 vector bounds separately. */
1911 gfc_array_ref
*ar
, ar2
;
1912 bool has_vector
= false;
1914 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1917 ar
= gfc_find_array_ref (lhs_expr
);
1919 memset (ar
, '\0', sizeof (*ar
));
1923 lhs_se
.want_pointer
= 1;
1924 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1925 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1926 has the wrong type if component references are done. */
1927 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1928 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1929 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1930 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1935 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1940 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1942 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1943 temporary and a loop. */
1944 if (!gfc_is_coindexed (lhs_expr
)
1945 && (!lhs_caf_attr
.codimension
1946 || !(lhs_expr
->rank
> 0
1947 && (lhs_caf_attr
.allocatable
|| lhs_caf_attr
.pointer
))))
1949 bool lhs_may_realloc
= lhs_expr
->rank
> 0 && lhs_caf_attr
.allocatable
;
1950 gcc_assert (gfc_is_coindexed (rhs_expr
));
1951 gfc_init_se (&rhs_se
, NULL
);
1952 if (lhs_expr
->rank
== 0 && lhs_caf_attr
.allocatable
)
1955 gfc_init_se (&scal_se
, NULL
);
1956 scal_se
.want_pointer
= 1;
1957 gfc_conv_expr (&scal_se
, lhs_expr
);
1958 /* Ensure scalar on lhs is allocated. */
1959 gfc_add_block_to_block (&block
, &scal_se
.pre
);
1961 gfc_allocate_using_malloc (&scal_se
.pre
, scal_se
.expr
,
1963 gfc_typenode_for_spec (&lhs_expr
->ts
)),
1965 tmp
= fold_build2 (EQ_EXPR
, logical_type_node
, scal_se
.expr
,
1967 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1968 tmp
, gfc_finish_block (&scal_se
.pre
),
1969 build_empty_stmt (input_location
));
1970 gfc_add_expr_to_block (&block
, tmp
);
1973 lhs_may_realloc
= lhs_may_realloc
1974 && gfc_full_array_ref_p (lhs_expr
->ref
, NULL
);
1975 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1976 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1977 may_require_tmp
, lhs_may_realloc
,
1979 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1980 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1981 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1982 return gfc_finish_block (&block
);
1985 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1987 /* Obtain token, offset and image index for the LHS. */
1988 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1989 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1990 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1991 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1993 if (lhs_caf_attr
.alloc_comp
)
1994 gfc_get_caf_token_offset (&lhs_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
1997 gfc_get_caf_token_offset (&lhs_se
, &token
, &offset
, caf_decl
, tmp
,
2002 gfc_init_se (&rhs_se
, NULL
);
2003 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
2004 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
2005 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
2006 if (rhs_expr
->rank
== 0)
2008 symbol_attribute attr
;
2009 gfc_clear_attr (&attr
);
2010 gfc_conv_expr (&rhs_se
, rhs_expr
);
2011 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
2012 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
2014 else if ((rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2015 && rhs_caf_attr
.codimension
)
2018 rhs_se
.want_pointer
= 1;
2019 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2020 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2021 has the wrong type if component references are done. */
2022 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2023 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2024 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2025 gfc_get_dtype_rank_type (
2026 gfc_has_vector_subscript (rhs_expr
)
2027 ? gfc_find_array_ref (rhs_expr
)->dimen
2033 /* If has_vector, pass descriptor for whole array and the
2034 vector bounds separately. */
2035 gfc_array_ref
*ar
, ar2
;
2036 bool has_vector
= false;
2039 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
2042 ar
= gfc_find_array_ref (rhs_expr
);
2044 memset (ar
, '\0', sizeof (*ar
));
2048 rhs_se
.want_pointer
= 1;
2049 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
2050 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2051 has the wrong type if component references are done. */
2052 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
2053 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
2054 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
2055 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
2060 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
2065 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
2067 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
2069 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2074 gfc_init_se (&stat_se
, NULL
);
2075 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2076 dst_stat
= stat_se
.expr
;
2077 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2078 gfc_add_block_to_block (&block
, &stat_se
.post
);
2081 tmp_team
= gfc_find_team_co (lhs_expr
);
2086 gfc_init_se (&team_se
, NULL
);
2087 gfc_conv_expr_reference (&team_se
, tmp_team
);
2088 dst_team
= team_se
.expr
;
2089 gfc_add_block_to_block (&block
, &team_se
.pre
);
2090 gfc_add_block_to_block (&block
, &team_se
.post
);
2093 if (!gfc_is_coindexed (rhs_expr
))
2095 if (lhs_caf_attr
.alloc_comp
|| lhs_caf_attr
.pointer_comp
)
2097 tree reference
, dst_realloc
;
2098 reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2099 dst_realloc
= lhs_caf_attr
.allocatable
? boolean_true_node
2100 : boolean_false_node
;
2101 tmp
= build_call_expr_loc (input_location
,
2102 gfor_fndecl_caf_send_by_ref
,
2103 9, token
, image_index
, rhs_se
.expr
,
2104 reference
, lhs_kind
, rhs_kind
,
2105 may_require_tmp
, dst_realloc
, src_stat
);
2108 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 11,
2109 token
, offset
, image_index
, lhs_se
.expr
, vec
,
2110 rhs_se
.expr
, lhs_kind
, rhs_kind
,
2111 may_require_tmp
, src_stat
, dst_team
);
2115 tree rhs_token
, rhs_offset
, rhs_image_index
;
2117 /* It guarantees memory consistency within the same segment. */
2118 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2119 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2120 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2121 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2122 ASM_VOLATILE_P (tmp
) = 1;
2123 gfc_add_expr_to_block (&block
, tmp
);
2125 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
2126 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
2127 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2128 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
2130 if (rhs_caf_attr
.alloc_comp
|| rhs_caf_attr
.pointer_comp
)
2132 tmp_stat
= gfc_find_stat_co (lhs_expr
);
2137 gfc_init_se (&stat_se
, NULL
);
2138 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
2139 src_stat
= stat_se
.expr
;
2140 gfc_add_block_to_block (&block
, &stat_se
.pre
);
2141 gfc_add_block_to_block (&block
, &stat_se
.post
);
2144 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, NULL
, caf_decl
,
2146 tree lhs_reference
, rhs_reference
;
2147 lhs_reference
= conv_expr_ref_to_caf_ref (&block
, lhs_expr
);
2148 rhs_reference
= conv_expr_ref_to_caf_ref (&block
, rhs_expr
);
2149 tmp
= build_call_expr_loc (input_location
,
2150 gfor_fndecl_caf_sendget_by_ref
, 11,
2151 token
, image_index
, lhs_reference
,
2152 rhs_token
, rhs_image_index
, rhs_reference
,
2153 lhs_kind
, rhs_kind
, may_require_tmp
,
2154 dst_stat
, src_stat
);
2158 gfc_get_caf_token_offset (&rhs_se
, &rhs_token
, &rhs_offset
, caf_decl
,
2160 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
,
2161 14, token
, offset
, image_index
,
2162 lhs_se
.expr
, vec
, rhs_token
, rhs_offset
,
2163 rhs_image_index
, tmp
, rhs_vec
, lhs_kind
,
2164 rhs_kind
, may_require_tmp
, src_stat
);
2167 gfc_add_expr_to_block (&block
, tmp
);
2168 gfc_add_block_to_block (&block
, &lhs_se
.post
);
2169 gfc_add_block_to_block (&block
, &rhs_se
.post
);
2171 /* It guarantees memory consistency within the same segment. */
2172 tmp
= gfc_build_string_const (strlen ("memory") + 1, "memory");
2173 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
2174 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
2175 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
2176 ASM_VOLATILE_P (tmp
) = 1;
2177 gfc_add_expr_to_block (&block
, tmp
);
2179 return gfc_finish_block (&block
);
2184 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
2187 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
2188 lbound
, ubound
, extent
, ml
;
2191 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
2193 if (expr
->value
.function
.actual
->expr
2194 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
2195 distance
= expr
->value
.function
.actual
->expr
;
2197 /* The case -fcoarray=single is handled elsewhere. */
2198 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
2200 /* Argument-free version: THIS_IMAGE(). */
2201 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
2205 gfc_init_se (&argse
, NULL
);
2206 gfc_conv_expr_val (&argse
, distance
);
2207 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2208 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2209 tmp
= fold_convert (integer_type_node
, argse
.expr
);
2212 tmp
= integer_zero_node
;
2213 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2215 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2220 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2222 type
= gfc_get_int_type (gfc_default_integer_kind
);
2223 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2224 rank
= expr
->value
.function
.actual
->expr
->rank
;
2226 /* Obtain the descriptor of the COARRAY. */
2227 gfc_init_se (&argse
, NULL
);
2228 argse
.want_coarray
= 1;
2229 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2230 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2231 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2236 /* Create an implicit second parameter from the loop variable. */
2237 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
2238 gcc_assert (corank
> 0);
2239 gcc_assert (se
->loop
->dimen
== 1);
2240 gcc_assert (se
->ss
->info
->expr
== expr
);
2242 dim_arg
= se
->loop
->loopvar
[0];
2243 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
2244 gfc_array_index_type
, dim_arg
,
2245 build_int_cst (TREE_TYPE (dim_arg
), 1));
2246 gfc_advance_se_ss_chain (se
);
2250 /* Use the passed DIM= argument. */
2251 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
2252 gfc_init_se (&argse
, NULL
);
2253 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
2254 gfc_array_index_type
);
2255 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2256 dim_arg
= argse
.expr
;
2258 if (INTEGER_CST_P (dim_arg
))
2260 if (wi::ltu_p (wi::to_wide (dim_arg
), 1)
2261 || wi::gtu_p (wi::to_wide (dim_arg
),
2262 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2263 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2264 "dimension index", expr
->value
.function
.isym
->name
,
2267 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2269 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
2270 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2272 build_int_cst (TREE_TYPE (dim_arg
), 1));
2273 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2274 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2276 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2277 logical_type_node
, cond
, tmp
);
2278 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2283 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2284 one always has a dim_arg argument.
2286 m = this_image() - 1
2289 sub(1) = m + lcobound(corank)
2293 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2296 extent = gfc_extent(i)
2304 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2305 : m + lcobound(corank)
2308 /* this_image () - 1. */
2309 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2311 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
2312 fold_convert (type
, tmp
), build_int_cst (type
, 1));
2315 /* sub(1) = m + lcobound(corank). */
2316 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2317 build_int_cst (TREE_TYPE (gfc_array_index_type
),
2319 lbound
= fold_convert (type
, lbound
);
2320 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2326 m
= gfc_create_var (type
, NULL
);
2327 ml
= gfc_create_var (type
, NULL
);
2328 loop_var
= gfc_create_var (integer_type_node
, NULL
);
2329 min_var
= gfc_create_var (integer_type_node
, NULL
);
2331 /* m = this_image () - 1. */
2332 gfc_add_modify (&se
->pre
, m
, tmp
);
2334 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2335 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2336 fold_convert (integer_type_node
, dim_arg
),
2337 build_int_cst (integer_type_node
, rank
- 1));
2338 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
2339 build_int_cst (integer_type_node
, rank
+ corank
- 2),
2341 gfc_add_modify (&se
->pre
, min_var
, tmp
);
2344 tmp
= build_int_cst (integer_type_node
, rank
);
2345 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
2347 exit_label
= gfc_build_label_decl (NULL_TREE
);
2348 TREE_USED (exit_label
) = 1;
2351 gfc_init_block (&loop
);
2354 gfc_add_modify (&loop
, ml
, m
);
2357 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
2358 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
2359 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2360 extent
= fold_convert (type
, extent
);
2363 gfc_add_modify (&loop
, m
,
2364 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
2367 /* Exit condition: if (i >= min_var) goto exit_label. */
2368 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, loop_var
,
2370 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2371 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
2372 build_empty_stmt (input_location
));
2373 gfc_add_expr_to_block (&loop
, tmp
);
2375 /* Increment loop variable: i++. */
2376 gfc_add_modify (&loop
, loop_var
,
2377 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2379 build_int_cst (integer_type_node
, 1)));
2381 /* Making the loop... actually loop! */
2382 tmp
= gfc_finish_block (&loop
);
2383 tmp
= build1_v (LOOP_EXPR
, tmp
);
2384 gfc_add_expr_to_block (&se
->pre
, tmp
);
2386 /* The exit label. */
2387 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2388 gfc_add_expr_to_block (&se
->pre
, tmp
);
2390 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2391 : m + lcobound(corank) */
2393 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, dim_arg
,
2394 build_int_cst (TREE_TYPE (dim_arg
), corank
));
2396 lbound
= gfc_conv_descriptor_lbound_get (desc
,
2397 fold_build2_loc (input_location
, PLUS_EXPR
,
2398 gfc_array_index_type
, dim_arg
,
2399 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
2400 lbound
= fold_convert (type
, lbound
);
2402 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
2403 fold_build2_loc (input_location
, MULT_EXPR
, type
,
2405 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
2407 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
2408 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2413 /* Convert a call to image_status. */
2416 conv_intrinsic_image_status (gfc_se
*se
, gfc_expr
*expr
)
2418 unsigned int num_args
;
2421 num_args
= gfc_intrinsic_argument_list_length (expr
);
2422 args
= XALLOCAVEC (tree
, num_args
);
2423 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2424 /* In args[0] the number of the image the status is desired for has to be
2427 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2430 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2431 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2432 fold_convert (integer_type_node
, arg
),
2434 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2435 tmp
, integer_zero_node
,
2436 build_int_cst (integer_type_node
,
2437 GFC_STAT_STOPPED_IMAGE
));
2439 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2440 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_image_status
, 2,
2441 args
[0], build_int_cst (integer_type_node
, -1));
2449 conv_intrinsic_team_number (gfc_se
*se
, gfc_expr
*expr
)
2451 unsigned int num_args
;
2455 num_args
= gfc_intrinsic_argument_list_length (expr
);
2456 args
= XALLOCAVEC (tree
, num_args
);
2457 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2460 GFC_FCOARRAY_SINGLE
&& expr
->value
.function
.actual
->expr
)
2464 arg
= gfc_evaluate_now (args
[0], &se
->pre
);
2465 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2466 fold_convert (integer_type_node
, arg
),
2468 tmp
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
2469 tmp
, integer_zero_node
,
2470 build_int_cst (integer_type_node
,
2471 GFC_STAT_STOPPED_IMAGE
));
2473 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2475 // the value -1 represents that no team has been created yet
2476 tmp
= build_int_cst (integer_type_node
, -1);
2478 else if (flag_coarray
== GFC_FCOARRAY_LIB
&& expr
->value
.function
.actual
->expr
)
2479 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2480 args
[0], build_int_cst (integer_type_node
, -1));
2481 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
2482 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_team_number
, 1,
2483 integer_zero_node
, build_int_cst (integer_type_node
, -1));
2492 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
2494 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
2496 gfc_se argse
, subse
;
2497 int rank
, corank
, codim
;
2499 type
= gfc_get_int_type (gfc_default_integer_kind
);
2500 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
2501 rank
= expr
->value
.function
.actual
->expr
->rank
;
2503 /* Obtain the descriptor of the COARRAY. */
2504 gfc_init_se (&argse
, NULL
);
2505 argse
.want_coarray
= 1;
2506 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2507 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2508 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2511 /* Obtain a handle to the SUB argument. */
2512 gfc_init_se (&subse
, NULL
);
2513 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
2514 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
2515 gfc_add_block_to_block (&se
->post
, &subse
.post
);
2516 subdesc
= build_fold_indirect_ref_loc (input_location
,
2517 gfc_conv_descriptor_data_get (subse
.expr
));
2519 /* Fortran 2008 does not require that the values remain in the cobounds,
2520 thus we need explicitly check this - and return 0 if they are exceeded. */
2522 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2523 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
2524 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2525 fold_convert (gfc_array_index_type
, tmp
),
2528 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2530 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2531 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2532 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2533 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2534 fold_convert (gfc_array_index_type
, tmp
),
2536 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2537 logical_type_node
, invalid_bound
, cond
);
2538 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2539 fold_convert (gfc_array_index_type
, tmp
),
2541 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2542 logical_type_node
, invalid_bound
, cond
);
2545 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
2547 /* See Fortran 2008, C.10 for the following algorithm. */
2549 /* coindex = sub(corank) - lcobound(n). */
2550 coindex
= fold_convert (gfc_array_index_type
,
2551 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
2553 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
2554 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2555 fold_convert (gfc_array_index_type
, coindex
),
2558 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
2560 tree extent
, ubound
;
2562 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2563 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2564 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
2565 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2567 /* coindex *= extent. */
2568 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
2569 gfc_array_index_type
, coindex
, extent
);
2571 /* coindex += sub(codim). */
2572 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
2573 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
2574 gfc_array_index_type
, coindex
,
2575 fold_convert (gfc_array_index_type
, tmp
));
2577 /* coindex -= lbound(codim). */
2578 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
2579 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
2580 gfc_array_index_type
, coindex
, lbound
);
2583 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
2584 fold_convert(type
, coindex
),
2585 build_int_cst (type
, 1));
2587 /* Return 0 if "coindex" exceeds num_images(). */
2589 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2590 num_images
= build_int_cst (type
, 1);
2593 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2595 build_int_cst (integer_type_node
, -1));
2596 num_images
= fold_convert (type
, tmp
);
2599 tmp
= gfc_create_var (type
, NULL
);
2600 gfc_add_modify (&se
->pre
, tmp
, coindex
);
2602 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, tmp
,
2604 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
2606 fold_convert (logical_type_node
, invalid_bound
));
2607 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2608 build_int_cst (type
, 0), tmp
);
2612 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
2614 tree tmp
, distance
, failed
;
2617 if (expr
->value
.function
.actual
->expr
)
2619 gfc_init_se (&argse
, NULL
);
2620 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
2621 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2622 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2623 distance
= fold_convert (integer_type_node
, argse
.expr
);
2626 distance
= integer_zero_node
;
2628 if (expr
->value
.function
.actual
->next
->expr
)
2630 gfc_init_se (&argse
, NULL
);
2631 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
2632 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2633 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2634 failed
= fold_convert (integer_type_node
, argse
.expr
);
2637 failed
= build_int_cst (integer_type_node
, -1);
2638 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
2640 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
2645 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
2649 gfc_init_se (&argse
, NULL
);
2650 argse
.data_not_needed
= 1;
2651 argse
.descriptor_only
= 1;
2653 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
2654 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2655 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2657 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
2658 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
2663 /* Evaluate a single upper or lower bound. */
2664 /* TODO: bound intrinsic generates way too much unnecessary code. */
2667 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
2669 gfc_actual_arglist
*arg
;
2670 gfc_actual_arglist
*arg2
;
2675 tree cond
, cond1
, cond3
, cond4
, size
;
2679 gfc_array_spec
* as
;
2680 bool assumed_rank_lb_one
;
2682 arg
= expr
->value
.function
.actual
;
2687 /* Create an implicit second parameter from the loop variable. */
2688 gcc_assert (!arg2
->expr
);
2689 gcc_assert (se
->loop
->dimen
== 1);
2690 gcc_assert (se
->ss
->info
->expr
== expr
);
2691 gfc_advance_se_ss_chain (se
);
2692 bound
= se
->loop
->loopvar
[0];
2693 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2694 gfc_array_index_type
, bound
,
2699 /* use the passed argument. */
2700 gcc_assert (arg2
->expr
);
2701 gfc_init_se (&argse
, NULL
);
2702 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2703 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2705 /* Convert from one based to zero based. */
2706 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2707 gfc_array_index_type
, bound
,
2708 gfc_index_one_node
);
2711 /* TODO: don't re-evaluate the descriptor on each iteration. */
2712 /* Get a descriptor for the first parameter. */
2713 gfc_init_se (&argse
, NULL
);
2714 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2715 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2716 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2720 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
2722 if (INTEGER_CST_P (bound
))
2724 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
2725 && wi::geu_p (wi::to_wide (bound
),
2726 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
2727 || wi::gtu_p (wi::to_wide (bound
), GFC_MAX_DIMENSIONS
))
2728 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2729 "dimension index", upper
? "UBOUND" : "LBOUND",
2733 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
2735 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2737 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2738 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2739 bound
, build_int_cst (TREE_TYPE (bound
), 0));
2740 if (as
&& as
->type
== AS_ASSUMED_RANK
)
2741 tmp
= gfc_conv_descriptor_rank (desc
);
2743 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
2744 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2745 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
2746 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2747 logical_type_node
, cond
, tmp
);
2748 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2753 /* Take care of the lbound shift for assumed-rank arrays, which are
2754 nonallocatable and nonpointers. Those has a lbound of 1. */
2755 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
2756 && ((arg
->expr
->ts
.type
!= BT_CLASS
2757 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
2758 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
2759 || (arg
->expr
->ts
.type
== BT_CLASS
2760 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
2761 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
2763 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2764 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2766 /* 13.14.53: Result value for LBOUND
2768 Case (i): For an array section or for an array expression other than a
2769 whole array or array structure component, LBOUND(ARRAY, DIM)
2770 has the value 1. For a whole array or array structure
2771 component, LBOUND(ARRAY, DIM) has the value:
2772 (a) equal to the lower bound for subscript DIM of ARRAY if
2773 dimension DIM of ARRAY does not have extent zero
2774 or if ARRAY is an assumed-size array of rank DIM,
2777 13.14.113: Result value for UBOUND
2779 Case (i): For an array section or for an array expression other than a
2780 whole array or array structure component, UBOUND(ARRAY, DIM)
2781 has the value equal to the number of elements in the given
2782 dimension; otherwise, it has a value equal to the upper bound
2783 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2784 not have size zero and has value zero if dimension DIM has
2787 if (!upper
&& assumed_rank_lb_one
)
2788 se
->expr
= gfc_index_one_node
;
2791 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
2793 cond1
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2795 cond3
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
2796 stride
, gfc_index_zero_node
);
2797 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2798 logical_type_node
, cond3
, cond1
);
2799 cond4
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2800 stride
, gfc_index_zero_node
);
2805 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2806 logical_type_node
, cond3
, cond4
);
2807 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2808 gfc_index_one_node
, lbound
);
2809 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2810 logical_type_node
, cond4
, cond5
);
2812 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2813 logical_type_node
, cond
, cond5
);
2815 if (assumed_rank_lb_one
)
2817 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2818 gfc_array_index_type
, ubound
, lbound
);
2819 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2820 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2825 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2826 gfc_array_index_type
, cond
,
2827 tmp
, gfc_index_zero_node
);
2831 if (as
->type
== AS_ASSUMED_SIZE
)
2832 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2833 bound
, build_int_cst (TREE_TYPE (bound
),
2834 arg
->expr
->rank
- 1));
2836 cond
= logical_false_node
;
2838 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2839 logical_type_node
, cond3
, cond4
);
2840 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2841 logical_type_node
, cond
, cond1
);
2843 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2844 gfc_array_index_type
, cond
,
2845 lbound
, gfc_index_one_node
);
2852 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2853 gfc_array_index_type
, ubound
, lbound
);
2854 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2855 gfc_array_index_type
, size
,
2856 gfc_index_one_node
);
2857 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2858 gfc_array_index_type
, se
->expr
,
2859 gfc_index_zero_node
);
2862 se
->expr
= gfc_index_one_node
;
2865 type
= gfc_typenode_for_spec (&expr
->ts
);
2866 se
->expr
= convert (type
, se
->expr
);
2871 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2873 gfc_actual_arglist
*arg
;
2874 gfc_actual_arglist
*arg2
;
2876 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2880 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2881 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2882 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2884 arg
= expr
->value
.function
.actual
;
2887 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2888 corank
= gfc_get_corank (arg
->expr
);
2890 gfc_init_se (&argse
, NULL
);
2891 argse
.want_coarray
= 1;
2893 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2894 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2895 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2900 /* Create an implicit second parameter from the loop variable. */
2901 gcc_assert (!arg2
->expr
);
2902 gcc_assert (corank
> 0);
2903 gcc_assert (se
->loop
->dimen
== 1);
2904 gcc_assert (se
->ss
->info
->expr
== expr
);
2906 bound
= se
->loop
->loopvar
[0];
2907 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2908 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2909 gfc_advance_se_ss_chain (se
);
2913 /* use the passed argument. */
2914 gcc_assert (arg2
->expr
);
2915 gfc_init_se (&argse
, NULL
);
2916 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2917 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2920 if (INTEGER_CST_P (bound
))
2922 if (wi::ltu_p (wi::to_wide (bound
), 1)
2923 || wi::gtu_p (wi::to_wide (bound
),
2924 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2925 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2926 "dimension index", expr
->value
.function
.isym
->name
,
2929 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2931 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2932 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2933 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2934 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2935 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2937 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2938 logical_type_node
, cond
, tmp
);
2939 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2944 /* Subtract 1 to get to zero based and add dimensions. */
2945 switch (arg
->expr
->rank
)
2948 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2949 gfc_array_index_type
, bound
,
2950 gfc_index_one_node
);
2954 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2955 gfc_array_index_type
, bound
,
2956 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2960 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2962 /* Handle UCOBOUND with special handling of the last codimension. */
2963 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2965 /* Last codimension: For -fcoarray=single just return
2966 the lcobound - otherwise add
2967 ceiling (real (num_images ()) / real (size)) - 1
2968 = (num_images () + size - 1) / size - 1
2969 = (num_images - 1) / size(),
2970 where size is the product of the extent of all but the last
2973 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2977 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2978 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2979 2, integer_zero_node
,
2980 build_int_cst (integer_type_node
, -1));
2981 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2982 gfc_array_index_type
,
2983 fold_convert (gfc_array_index_type
, tmp
),
2984 build_int_cst (gfc_array_index_type
, 1));
2985 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2986 gfc_array_index_type
, tmp
,
2987 fold_convert (gfc_array_index_type
, cosize
));
2988 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2989 gfc_array_index_type
, resbound
, tmp
);
2991 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2993 /* ubound = lbound + num_images() - 1. */
2994 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2995 2, integer_zero_node
,
2996 build_int_cst (integer_type_node
, -1));
2997 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2998 gfc_array_index_type
,
2999 fold_convert (gfc_array_index_type
, tmp
),
3000 build_int_cst (gfc_array_index_type
, 1));
3001 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
3002 gfc_array_index_type
, resbound
, tmp
);
3007 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3009 build_int_cst (TREE_TYPE (bound
),
3010 arg
->expr
->rank
+ corank
- 1));
3012 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
3013 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3014 gfc_array_index_type
, cond
,
3015 resbound
, resbound2
);
3018 se
->expr
= resbound
;
3021 se
->expr
= resbound
;
3023 type
= gfc_typenode_for_spec (&expr
->ts
);
3024 se
->expr
= convert (type
, se
->expr
);
3029 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
3031 gfc_actual_arglist
*array_arg
;
3032 gfc_actual_arglist
*dim_arg
;
3036 array_arg
= expr
->value
.function
.actual
;
3037 dim_arg
= array_arg
->next
;
3039 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
3041 gfc_init_se (&argse
, NULL
);
3042 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
3043 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3044 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3047 gcc_assert (dim_arg
->expr
);
3048 gfc_init_se (&argse
, NULL
);
3049 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
3050 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3051 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3052 argse
.expr
, gfc_index_one_node
);
3053 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
3057 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
3061 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3063 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
3067 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
3072 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
3073 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
3082 /* Create a complex value from one or two real components. */
3085 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
3091 unsigned int num_args
;
3093 num_args
= gfc_intrinsic_argument_list_length (expr
);
3094 args
= XALLOCAVEC (tree
, num_args
);
3096 type
= gfc_typenode_for_spec (&expr
->ts
);
3097 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3098 real
= convert (TREE_TYPE (type
), args
[0]);
3100 imag
= convert (TREE_TYPE (type
), args
[1]);
3101 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
3103 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
3104 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
3105 imag
= convert (TREE_TYPE (type
), imag
);
3108 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
3110 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
3114 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3115 MODULO(A, P) = A - FLOOR (A / P) * P
3117 The obvious algorithms above are numerically instable for large
3118 arguments, hence these intrinsics are instead implemented via calls
3119 to the fmod family of functions. It is the responsibility of the
3120 user to ensure that the second argument is non-zero. */
3123 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
3133 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3135 switch (expr
->ts
.type
)
3138 /* Integer case is easy, we've got a builtin op. */
3139 type
= TREE_TYPE (args
[0]);
3142 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
3145 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
3151 /* Check if we have a builtin fmod. */
3152 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
3154 /* The builtin should always be available. */
3155 gcc_assert (fmod
!= NULL_TREE
);
3157 tmp
= build_addr (fmod
);
3158 se
->expr
= build_call_array_loc (input_location
,
3159 TREE_TYPE (TREE_TYPE (fmod
)),
3164 type
= TREE_TYPE (args
[0]);
3166 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3167 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3170 modulo = arg - floor (arg/arg2) * arg2
3172 In order to calculate the result accurately, we use the fmod
3173 function as follows.
3175 res = fmod (arg, arg2);
3178 if ((arg < 0) xor (arg2 < 0))
3182 res = copysign (0., arg2);
3184 => As two nested ternary exprs:
3186 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3187 : copysign (0., arg2);
3191 zero
= gfc_build_const (type
, integer_zero_node
);
3192 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3193 if (!flag_signed_zeros
)
3195 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3197 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3199 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3200 logical_type_node
, test
, test2
);
3201 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3203 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3204 logical_type_node
, test
, test2
);
3205 test
= gfc_evaluate_now (test
, &se
->pre
);
3206 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3207 fold_build2_loc (input_location
,
3209 type
, tmp
, args
[1]),
3214 tree expr1
, copysign
, cscall
;
3215 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
3217 test
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3219 test2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
3221 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
3222 logical_type_node
, test
, test2
);
3223 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
3224 fold_build2_loc (input_location
,
3226 type
, tmp
, args
[1]),
3228 test
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3230 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
3232 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
3242 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3243 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3244 where the right shifts are logical (i.e. 0's are shifted in).
3245 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3246 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3248 DSHIFTL(I,J,BITSIZE) = J
3250 DSHIFTR(I,J,BITSIZE) = I. */
3253 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
3255 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
3256 tree args
[3], cond
, tmp
;
3259 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3261 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
3262 type
= TREE_TYPE (args
[0]);
3263 bitsize
= TYPE_PRECISION (type
);
3264 utype
= unsigned_type_for (type
);
3265 stype
= TREE_TYPE (args
[2]);
3267 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
3268 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
3269 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
3271 /* The generic case. */
3272 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
3273 build_int_cst (stype
, bitsize
), shift
);
3274 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3275 arg1
, dshiftl
? shift
: tmp
);
3277 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
3278 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
3279 right
= fold_convert (type
, right
);
3281 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
3283 /* Special cases. */
3284 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3285 build_int_cst (stype
, 0));
3286 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3287 dshiftl
? arg1
: arg2
, res
);
3289 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, shift
,
3290 build_int_cst (stype
, bitsize
));
3291 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3292 dshiftl
? arg2
: arg1
, res
);
3298 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3301 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
3309 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3310 type
= TREE_TYPE (args
[0]);
3312 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
3313 val
= gfc_evaluate_now (val
, &se
->pre
);
3315 zero
= gfc_build_const (type
, integer_zero_node
);
3316 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, val
, zero
);
3317 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
3321 /* SIGN(A, B) is absolute value of A times sign of B.
3322 The real value versions use library functions to ensure the correct
3323 handling of negative zero. Integer case implemented as:
3324 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3328 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
3334 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3335 if (expr
->ts
.type
== BT_REAL
)
3339 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
3340 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
3342 /* We explicitly have to ignore the minus sign. We do so by using
3343 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3345 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
3348 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
3349 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3351 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
3352 TREE_TYPE (args
[0]), cond
,
3353 build_call_expr_loc (input_location
, abs
, 1,
3355 build_call_expr_loc (input_location
, tmp
, 2,
3359 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
3364 /* Having excluded floating point types, we know we are now dealing
3365 with signed integer types. */
3366 type
= TREE_TYPE (args
[0]);
3368 /* Args[0] is used multiple times below. */
3369 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3371 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3372 the signs of A and B are the same, and of all ones if they differ. */
3373 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
3374 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
3375 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
3376 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3378 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3379 is all ones (i.e. -1). */
3380 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
3381 fold_build2_loc (input_location
, PLUS_EXPR
,
3382 type
, args
[0], tmp
), tmp
);
3386 /* Test for the presence of an optional argument. */
3389 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
3393 arg
= expr
->value
.function
.actual
->expr
;
3394 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
3395 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
3396 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
3400 /* Calculate the double precision product of two single precision values. */
3403 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
3408 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3410 /* Convert the args to double precision before multiplying. */
3411 type
= gfc_typenode_for_spec (&expr
->ts
);
3412 args
[0] = convert (type
, args
[0]);
3413 args
[1] = convert (type
, args
[1]);
3414 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
3419 /* Return a length one character string containing an ascii character. */
3422 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
3427 unsigned int num_args
;
3429 num_args
= gfc_intrinsic_argument_list_length (expr
);
3430 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
3432 type
= gfc_get_char_type (expr
->ts
.kind
);
3433 var
= gfc_create_var (type
, "char");
3435 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
3436 gfc_add_modify (&se
->pre
, var
, arg
[0]);
3437 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
3438 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3443 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
3451 unsigned int num_args
;
3453 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3454 args
= XALLOCAVEC (tree
, num_args
);
3456 var
= gfc_create_var (pchar_type_node
, "pstr");
3457 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3459 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3460 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3461 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3463 fndecl
= build_addr (gfor_fndecl_ctime
);
3464 tmp
= build_call_array_loc (input_location
,
3465 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
3466 fndecl
, num_args
, args
);
3467 gfc_add_expr_to_block (&se
->pre
, tmp
);
3469 /* Free the temporary afterwards, if necessary. */
3470 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3471 len
, build_int_cst (TREE_TYPE (len
), 0));
3472 tmp
= gfc_call_free (var
);
3473 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3474 gfc_add_expr_to_block (&se
->post
, tmp
);
3477 se
->string_length
= len
;
3482 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
3490 unsigned int num_args
;
3492 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3493 args
= XALLOCAVEC (tree
, num_args
);
3495 var
= gfc_create_var (pchar_type_node
, "pstr");
3496 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3498 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3499 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3500 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3502 fndecl
= build_addr (gfor_fndecl_fdate
);
3503 tmp
= build_call_array_loc (input_location
,
3504 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
3505 fndecl
, num_args
, args
);
3506 gfc_add_expr_to_block (&se
->pre
, tmp
);
3508 /* Free the temporary afterwards, if necessary. */
3509 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3510 len
, build_int_cst (TREE_TYPE (len
), 0));
3511 tmp
= gfc_call_free (var
);
3512 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3513 gfc_add_expr_to_block (&se
->post
, tmp
);
3516 se
->string_length
= len
;
3520 /* Generate a direct call to free() for the FREE subroutine. */
3523 conv_intrinsic_free (gfc_code
*code
)
3529 gfc_init_se (&argse
, NULL
);
3530 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
3531 arg
= fold_convert (ptr_type_node
, argse
.expr
);
3533 gfc_init_block (&block
);
3534 call
= build_call_expr_loc (input_location
,
3535 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
3536 gfc_add_expr_to_block (&block
, call
);
3537 return gfc_finish_block (&block
);
3541 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3545 conv_intrinsic_system_clock (gfc_code
*code
)
3548 gfc_se count_se
, count_rate_se
, count_max_se
;
3549 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
3553 gfc_expr
*count
= code
->ext
.actual
->expr
;
3554 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
3555 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
3557 /* Evaluate our arguments. */
3560 gfc_init_se (&count_se
, NULL
);
3561 gfc_conv_expr (&count_se
, count
);
3566 gfc_init_se (&count_rate_se
, NULL
);
3567 gfc_conv_expr (&count_rate_se
, count_rate
);
3572 gfc_init_se (&count_max_se
, NULL
);
3573 gfc_conv_expr (&count_max_se
, count_max
);
3576 /* Find the smallest kind found of the arguments. */
3578 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
3579 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
3581 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
3584 /* Prepare temporary variables. */
3589 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
3590 else if (least
== 4)
3591 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
3592 else if (count
->ts
.kind
== 1)
3593 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
3596 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
3603 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
3604 else if (least
== 4)
3605 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
3607 arg2
= integer_zero_node
;
3613 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
3614 else if (least
== 4)
3615 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
3617 arg3
= integer_zero_node
;
3620 /* Make the function call. */
3621 gfc_init_block (&block
);
3627 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3628 : null_pointer_node
;
3629 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3630 : null_pointer_node
;
3631 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3632 : null_pointer_node
;
3637 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3638 : null_pointer_node
;
3639 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3640 : null_pointer_node
;
3641 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3642 : null_pointer_node
;
3649 tmp
= build_call_expr_loc (input_location
,
3650 gfor_fndecl_system_clock4
, 3,
3651 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3652 : null_pointer_node
,
3653 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3654 : null_pointer_node
,
3655 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3656 : null_pointer_node
);
3657 gfc_add_expr_to_block (&block
, tmp
);
3659 /* Handle kind>=8, 10, or 16 arguments */
3662 tmp
= build_call_expr_loc (input_location
,
3663 gfor_fndecl_system_clock8
, 3,
3664 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
3665 : null_pointer_node
,
3666 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
3667 : null_pointer_node
,
3668 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
3669 : null_pointer_node
);
3670 gfc_add_expr_to_block (&block
, tmp
);
3674 /* And store values back if needed. */
3675 if (arg1
&& arg1
!= count_se
.expr
)
3676 gfc_add_modify (&block
, count_se
.expr
,
3677 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
3678 if (arg2
&& arg2
!= count_rate_se
.expr
)
3679 gfc_add_modify (&block
, count_rate_se
.expr
,
3680 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
3681 if (arg3
&& arg3
!= count_max_se
.expr
)
3682 gfc_add_modify (&block
, count_max_se
.expr
,
3683 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
3685 return gfc_finish_block (&block
);
3689 /* Return a character string containing the tty name. */
3692 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
3700 unsigned int num_args
;
3702 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
3703 args
= XALLOCAVEC (tree
, num_args
);
3705 var
= gfc_create_var (pchar_type_node
, "pstr");
3706 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3708 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
3709 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
3710 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
3712 fndecl
= build_addr (gfor_fndecl_ttynam
);
3713 tmp
= build_call_array_loc (input_location
,
3714 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
3715 fndecl
, num_args
, args
);
3716 gfc_add_expr_to_block (&se
->pre
, tmp
);
3718 /* Free the temporary afterwards, if necessary. */
3719 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3720 len
, build_int_cst (TREE_TYPE (len
), 0));
3721 tmp
= gfc_call_free (var
);
3722 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3723 gfc_add_expr_to_block (&se
->post
, tmp
);
3726 se
->string_length
= len
;
3730 /* Get the minimum/maximum value of all the parameters.
3731 minmax (a1, a2, a3, ...)
3734 if (a2 .op. mvar || isnan (mvar))
3736 if (a3 .op. mvar || isnan (mvar))
3743 /* TODO: Mismatching types can occur when specific names are used.
3744 These should be handled during resolution. */
3746 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3754 gfc_actual_arglist
*argexpr
;
3755 unsigned int i
, nargs
;
3757 nargs
= gfc_intrinsic_argument_list_length (expr
);
3758 args
= XALLOCAVEC (tree
, nargs
);
3760 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
3761 type
= gfc_typenode_for_spec (&expr
->ts
);
3763 argexpr
= expr
->value
.function
.actual
;
3764 if (TREE_TYPE (args
[0]) != type
)
3765 args
[0] = convert (type
, args
[0]);
3766 /* Only evaluate the argument once. */
3767 if (!VAR_P (args
[0]) && !TREE_CONSTANT (args
[0]))
3768 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3770 mvar
= gfc_create_var (type
, "M");
3771 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
3772 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
3778 /* Handle absent optional arguments by ignoring the comparison. */
3779 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
3780 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
3781 && TREE_CODE (val
) == INDIRECT_REF
)
3782 cond
= fold_build2_loc (input_location
,
3783 NE_EXPR
, logical_type_node
,
3784 TREE_OPERAND (val
, 0),
3785 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
3790 /* Only evaluate the argument once. */
3791 if (!VAR_P (val
) && !TREE_CONSTANT (val
))
3792 val
= gfc_evaluate_now (val
, &se
->pre
);
3795 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
3797 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
3798 convert (type
, val
), mvar
);
3800 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3801 __builtin_isnan might be made dependent on that module being loaded,
3802 to help performance of programs that don't rely on IEEE semantics. */
3803 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
3805 isnan
= build_call_expr_loc (input_location
,
3806 builtin_decl_explicit (BUILT_IN_ISNAN
),
3808 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3809 logical_type_node
, tmp
,
3810 fold_convert (logical_type_node
, isnan
));
3812 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
3813 build_empty_stmt (input_location
));
3815 if (cond
!= NULL_TREE
)
3816 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
3817 build_empty_stmt (input_location
));
3819 gfc_add_expr_to_block (&se
->pre
, tmp
);
3820 argexpr
= argexpr
->next
;
3826 /* Generate library calls for MIN and MAX intrinsics for character
3829 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
3832 tree var
, len
, fndecl
, tmp
, cond
, function
;
3835 nargs
= gfc_intrinsic_argument_list_length (expr
);
3836 args
= XALLOCAVEC (tree
, nargs
+ 4);
3837 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
3839 /* Create the result variables. */
3840 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3841 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3842 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3843 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3844 args
[2] = build_int_cst (integer_type_node
, op
);
3845 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3847 if (expr
->ts
.kind
== 1)
3848 function
= gfor_fndecl_string_minmax
;
3849 else if (expr
->ts
.kind
== 4)
3850 function
= gfor_fndecl_string_minmax_char4
;
3854 /* Make the function call. */
3855 fndecl
= build_addr (function
);
3856 tmp
= build_call_array_loc (input_location
,
3857 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3859 gfc_add_expr_to_block (&se
->pre
, tmp
);
3861 /* Free the temporary afterwards, if necessary. */
3862 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
3863 len
, build_int_cst (TREE_TYPE (len
), 0));
3864 tmp
= gfc_call_free (var
);
3865 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3866 gfc_add_expr_to_block (&se
->post
, tmp
);
3869 se
->string_length
= len
;
3873 /* Create a symbol node for this intrinsic. The symbol from the frontend
3874 has the generic name. */
3877 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3881 /* TODO: Add symbols for intrinsic function to the global namespace. */
3882 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3883 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3886 sym
->attr
.external
= 1;
3887 sym
->attr
.function
= 1;
3888 sym
->attr
.always_explicit
= 1;
3889 sym
->attr
.proc
= PROC_INTRINSIC
;
3890 sym
->attr
.flavor
= FL_PROCEDURE
;
3894 sym
->attr
.dimension
= 1;
3895 sym
->as
= gfc_get_array_spec ();
3896 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3897 sym
->as
->rank
= expr
->rank
;
3900 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3901 ignore_optional
? expr
->value
.function
.actual
3907 /* Generate a call to an external intrinsic function. */
3909 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3912 vec
<tree
, va_gc
> *append_args
;
3914 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3917 gcc_assert (expr
->rank
> 0);
3919 gcc_assert (expr
->rank
== 0);
3921 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3923 /* Calls to libgfortran_matmul need to be appended special arguments,
3924 to be able to call the BLAS ?gemm functions if required and possible. */
3926 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3927 && sym
->ts
.type
!= BT_LOGICAL
)
3929 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3931 if (flag_external_blas
3932 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3933 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3937 if (sym
->ts
.type
== BT_REAL
)
3939 if (sym
->ts
.kind
== 4)
3940 gemm_fndecl
= gfor_fndecl_sgemm
;
3942 gemm_fndecl
= gfor_fndecl_dgemm
;
3946 if (sym
->ts
.kind
== 4)
3947 gemm_fndecl
= gfor_fndecl_cgemm
;
3949 gemm_fndecl
= gfor_fndecl_zgemm
;
3952 vec_alloc (append_args
, 3);
3953 append_args
->quick_push (build_int_cst (cint
, 1));
3954 append_args
->quick_push (build_int_cst (cint
,
3955 flag_blas_matmul_limit
));
3956 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3961 vec_alloc (append_args
, 3);
3962 append_args
->quick_push (build_int_cst (cint
, 0));
3963 append_args
->quick_push (build_int_cst (cint
, 0));
3964 append_args
->quick_push (null_pointer_node
);
3968 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3970 gfc_free_symbol (sym
);
3973 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3993 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4002 gfc_actual_arglist
*actual
;
4009 gfc_conv_intrinsic_funcall (se
, expr
);
4013 actual
= expr
->value
.function
.actual
;
4014 type
= gfc_typenode_for_spec (&expr
->ts
);
4015 /* Initialize the result. */
4016 resvar
= gfc_create_var (type
, "test");
4018 tmp
= convert (type
, boolean_true_node
);
4020 tmp
= convert (type
, boolean_false_node
);
4021 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4023 /* Walk the arguments. */
4024 arrayss
= gfc_walk_expr (actual
->expr
);
4025 gcc_assert (arrayss
!= gfc_ss_terminator
);
4027 /* Initialize the scalarizer. */
4028 gfc_init_loopinfo (&loop
);
4029 exit_label
= gfc_build_label_decl (NULL_TREE
);
4030 TREE_USED (exit_label
) = 1;
4031 gfc_add_ss_to_loop (&loop
, arrayss
);
4033 /* Initialize the loop. */
4034 gfc_conv_ss_startstride (&loop
);
4035 gfc_conv_loop_setup (&loop
, &expr
->where
);
4037 gfc_mark_ss_chain_used (arrayss
, 1);
4038 /* Generate the loop body. */
4039 gfc_start_scalarized_body (&loop
, &body
);
4041 /* If the condition matches then set the return value. */
4042 gfc_start_block (&block
);
4044 tmp
= convert (type
, boolean_false_node
);
4046 tmp
= convert (type
, boolean_true_node
);
4047 gfc_add_modify (&block
, resvar
, tmp
);
4049 /* And break out of the loop. */
4050 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4051 gfc_add_expr_to_block (&block
, tmp
);
4053 found
= gfc_finish_block (&block
);
4055 /* Check this element. */
4056 gfc_init_se (&arrayse
, NULL
);
4057 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4058 arrayse
.ss
= arrayss
;
4059 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4061 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4062 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
, arrayse
.expr
,
4063 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
4064 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
4065 gfc_add_expr_to_block (&body
, tmp
);
4066 gfc_add_block_to_block (&body
, &arrayse
.post
);
4068 gfc_trans_scalarizing_loops (&loop
, &body
);
4070 /* Add the exit label. */
4071 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4072 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4074 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4075 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4076 gfc_cleanup_loop (&loop
);
4081 /* COUNT(A) = Number of true elements in A. */
4083 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
4090 gfc_actual_arglist
*actual
;
4096 gfc_conv_intrinsic_funcall (se
, expr
);
4100 actual
= expr
->value
.function
.actual
;
4102 type
= gfc_typenode_for_spec (&expr
->ts
);
4103 /* Initialize the result. */
4104 resvar
= gfc_create_var (type
, "count");
4105 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
4107 /* Walk the arguments. */
4108 arrayss
= gfc_walk_expr (actual
->expr
);
4109 gcc_assert (arrayss
!= gfc_ss_terminator
);
4111 /* Initialize the scalarizer. */
4112 gfc_init_loopinfo (&loop
);
4113 gfc_add_ss_to_loop (&loop
, arrayss
);
4115 /* Initialize the loop. */
4116 gfc_conv_ss_startstride (&loop
);
4117 gfc_conv_loop_setup (&loop
, &expr
->where
);
4119 gfc_mark_ss_chain_used (arrayss
, 1);
4120 /* Generate the loop body. */
4121 gfc_start_scalarized_body (&loop
, &body
);
4123 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
4124 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
4125 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
4127 gfc_init_se (&arrayse
, NULL
);
4128 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4129 arrayse
.ss
= arrayss
;
4130 gfc_conv_expr_val (&arrayse
, actual
->expr
);
4131 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
4132 build_empty_stmt (input_location
));
4134 gfc_add_block_to_block (&body
, &arrayse
.pre
);
4135 gfc_add_expr_to_block (&body
, tmp
);
4136 gfc_add_block_to_block (&body
, &arrayse
.post
);
4138 gfc_trans_scalarizing_loops (&loop
, &body
);
4140 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4141 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4142 gfc_cleanup_loop (&loop
);
4148 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4149 struct and return the corresponding loopinfo. */
4151 static gfc_loopinfo
*
4152 enter_nested_loop (gfc_se
*se
)
4154 se
->ss
= se
->ss
->nested_ss
;
4155 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
4157 return se
->ss
->loop
;
4161 /* Inline implementation of the sum and product intrinsics. */
4163 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
4167 tree scale
= NULL_TREE
;
4172 gfc_loopinfo loop
, *ploop
;
4173 gfc_actual_arglist
*arg_array
, *arg_mask
;
4174 gfc_ss
*arrayss
= NULL
;
4175 gfc_ss
*maskss
= NULL
;
4179 gfc_expr
*arrayexpr
;
4184 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
4190 type
= gfc_typenode_for_spec (&expr
->ts
);
4191 /* Initialize the result. */
4192 resvar
= gfc_create_var (type
, "val");
4197 scale
= gfc_create_var (type
, "scale");
4198 gfc_add_modify (&se
->pre
, scale
,
4199 gfc_build_const (type
, integer_one_node
));
4200 tmp
= gfc_build_const (type
, integer_zero_node
);
4202 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
4203 tmp
= gfc_build_const (type
, integer_zero_node
);
4204 else if (op
== NE_EXPR
)
4206 tmp
= convert (type
, boolean_false_node
);
4207 else if (op
== BIT_AND_EXPR
)
4208 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
4209 type
, integer_one_node
));
4211 tmp
= gfc_build_const (type
, integer_one_node
);
4213 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4215 arg_array
= expr
->value
.function
.actual
;
4217 arrayexpr
= arg_array
->expr
;
4219 if (op
== NE_EXPR
|| norm2
)
4220 /* PARITY and NORM2. */
4224 arg_mask
= arg_array
->next
->next
;
4225 gcc_assert (arg_mask
!= NULL
);
4226 maskexpr
= arg_mask
->expr
;
4229 if (expr
->rank
== 0)
4231 /* Walk the arguments. */
4232 arrayss
= gfc_walk_expr (arrayexpr
);
4233 gcc_assert (arrayss
!= gfc_ss_terminator
);
4235 if (maskexpr
&& maskexpr
->rank
> 0)
4237 maskss
= gfc_walk_expr (maskexpr
);
4238 gcc_assert (maskss
!= gfc_ss_terminator
);
4243 /* Initialize the scalarizer. */
4244 gfc_init_loopinfo (&loop
);
4245 gfc_add_ss_to_loop (&loop
, arrayss
);
4246 if (maskexpr
&& maskexpr
->rank
> 0)
4247 gfc_add_ss_to_loop (&loop
, maskss
);
4249 /* Initialize the loop. */
4250 gfc_conv_ss_startstride (&loop
);
4251 gfc_conv_loop_setup (&loop
, &expr
->where
);
4253 gfc_mark_ss_chain_used (arrayss
, 1);
4254 if (maskexpr
&& maskexpr
->rank
> 0)
4255 gfc_mark_ss_chain_used (maskss
, 1);
4260 /* All the work has been done in the parent loops. */
4261 ploop
= enter_nested_loop (se
);
4265 /* Generate the loop body. */
4266 gfc_start_scalarized_body (ploop
, &body
);
4268 /* If we have a mask, only add this element if the mask is set. */
4269 if (maskexpr
&& maskexpr
->rank
> 0)
4271 gfc_init_se (&maskse
, parent_se
);
4272 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
4273 if (expr
->rank
== 0)
4275 gfc_conv_expr_val (&maskse
, maskexpr
);
4276 gfc_add_block_to_block (&body
, &maskse
.pre
);
4278 gfc_start_block (&block
);
4281 gfc_init_block (&block
);
4283 /* Do the actual summation/product. */
4284 gfc_init_se (&arrayse
, parent_se
);
4285 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
4286 if (expr
->rank
== 0)
4287 arrayse
.ss
= arrayss
;
4288 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4289 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4293 /* if (x (i) != 0.0)
4299 result = 1.0 + result * val * val;
4305 result += val * val;
4308 tree res1
, res2
, cond
, absX
, val
;
4309 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
4311 gfc_init_block (&ifblock1
);
4313 absX
= gfc_create_var (type
, "absX");
4314 gfc_add_modify (&ifblock1
, absX
,
4315 fold_build1_loc (input_location
, ABS_EXPR
, type
,
4317 val
= gfc_create_var (type
, "val");
4318 gfc_add_expr_to_block (&ifblock1
, val
);
4320 gfc_init_block (&ifblock2
);
4321 gfc_add_modify (&ifblock2
, val
,
4322 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
4324 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4325 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
4326 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
4327 gfc_build_const (type
, integer_one_node
));
4328 gfc_add_modify (&ifblock2
, resvar
, res1
);
4329 gfc_add_modify (&ifblock2
, scale
, absX
);
4330 res1
= gfc_finish_block (&ifblock2
);
4332 gfc_init_block (&ifblock3
);
4333 gfc_add_modify (&ifblock3
, val
,
4334 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
4336 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
4337 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
4338 gfc_add_modify (&ifblock3
, resvar
, res2
);
4339 res2
= gfc_finish_block (&ifblock3
);
4341 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
4343 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
4344 gfc_add_expr_to_block (&ifblock1
, tmp
);
4345 tmp
= gfc_finish_block (&ifblock1
);
4347 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
4349 gfc_build_const (type
, integer_zero_node
));
4351 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
4352 gfc_add_expr_to_block (&block
, tmp
);
4356 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
4357 gfc_add_modify (&block
, resvar
, tmp
);
4360 gfc_add_block_to_block (&block
, &arrayse
.post
);
4362 if (maskexpr
&& maskexpr
->rank
> 0)
4364 /* We enclose the above in if (mask) {...} . */
4366 tmp
= gfc_finish_block (&block
);
4367 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4368 build_empty_stmt (input_location
));
4371 tmp
= gfc_finish_block (&block
);
4372 gfc_add_expr_to_block (&body
, tmp
);
4374 gfc_trans_scalarizing_loops (ploop
, &body
);
4376 /* For a scalar mask, enclose the loop in an if statement. */
4377 if (maskexpr
&& maskexpr
->rank
== 0)
4379 gfc_init_block (&block
);
4380 gfc_add_block_to_block (&block
, &ploop
->pre
);
4381 gfc_add_block_to_block (&block
, &ploop
->post
);
4382 tmp
= gfc_finish_block (&block
);
4386 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
4387 build_empty_stmt (input_location
));
4388 gfc_advance_se_ss_chain (se
);
4392 gcc_assert (expr
->rank
== 0);
4393 gfc_init_se (&maskse
, NULL
);
4394 gfc_conv_expr_val (&maskse
, maskexpr
);
4395 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4396 build_empty_stmt (input_location
));
4399 gfc_add_expr_to_block (&block
, tmp
);
4400 gfc_add_block_to_block (&se
->pre
, &block
);
4401 gcc_assert (se
->post
.head
== NULL
);
4405 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
4406 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
4409 if (expr
->rank
== 0)
4410 gfc_cleanup_loop (ploop
);
4414 /* result = scale * sqrt(result). */
4416 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
4417 resvar
= build_call_expr_loc (input_location
,
4419 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
4426 /* Inline implementation of the dot_product intrinsic. This function
4427 is based on gfc_conv_intrinsic_arith (the previous function). */
4429 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
4437 gfc_actual_arglist
*actual
;
4438 gfc_ss
*arrayss1
, *arrayss2
;
4439 gfc_se arrayse1
, arrayse2
;
4440 gfc_expr
*arrayexpr1
, *arrayexpr2
;
4442 type
= gfc_typenode_for_spec (&expr
->ts
);
4444 /* Initialize the result. */
4445 resvar
= gfc_create_var (type
, "val");
4446 if (expr
->ts
.type
== BT_LOGICAL
)
4447 tmp
= build_int_cst (type
, 0);
4449 tmp
= gfc_build_const (type
, integer_zero_node
);
4451 gfc_add_modify (&se
->pre
, resvar
, tmp
);
4453 /* Walk argument #1. */
4454 actual
= expr
->value
.function
.actual
;
4455 arrayexpr1
= actual
->expr
;
4456 arrayss1
= gfc_walk_expr (arrayexpr1
);
4457 gcc_assert (arrayss1
!= gfc_ss_terminator
);
4459 /* Walk argument #2. */
4460 actual
= actual
->next
;
4461 arrayexpr2
= actual
->expr
;
4462 arrayss2
= gfc_walk_expr (arrayexpr2
);
4463 gcc_assert (arrayss2
!= gfc_ss_terminator
);
4465 /* Initialize the scalarizer. */
4466 gfc_init_loopinfo (&loop
);
4467 gfc_add_ss_to_loop (&loop
, arrayss1
);
4468 gfc_add_ss_to_loop (&loop
, arrayss2
);
4470 /* Initialize the loop. */
4471 gfc_conv_ss_startstride (&loop
);
4472 gfc_conv_loop_setup (&loop
, &expr
->where
);
4474 gfc_mark_ss_chain_used (arrayss1
, 1);
4475 gfc_mark_ss_chain_used (arrayss2
, 1);
4477 /* Generate the loop body. */
4478 gfc_start_scalarized_body (&loop
, &body
);
4479 gfc_init_block (&block
);
4481 /* Make the tree expression for [conjg(]array1[)]. */
4482 gfc_init_se (&arrayse1
, NULL
);
4483 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
4484 arrayse1
.ss
= arrayss1
;
4485 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
4486 if (expr
->ts
.type
== BT_COMPLEX
)
4487 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
4489 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
4491 /* Make the tree expression for array2. */
4492 gfc_init_se (&arrayse2
, NULL
);
4493 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
4494 arrayse2
.ss
= arrayss2
;
4495 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
4496 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
4498 /* Do the actual product and sum. */
4499 if (expr
->ts
.type
== BT_LOGICAL
)
4501 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
4502 arrayse1
.expr
, arrayse2
.expr
);
4503 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
4507 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
4509 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
4511 gfc_add_modify (&block
, resvar
, tmp
);
4513 /* Finish up the loop block and the loop. */
4514 tmp
= gfc_finish_block (&block
);
4515 gfc_add_expr_to_block (&body
, tmp
);
4517 gfc_trans_scalarizing_loops (&loop
, &body
);
4518 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4519 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4520 gfc_cleanup_loop (&loop
);
4526 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4527 we need to handle. For performance reasons we sometimes create two
4528 loops instead of one, where the second one is much simpler.
4529 Examples for minloc intrinsic:
4530 1) Result is an array, a call is generated
4531 2) Array mask is used and NaNs need to be supported:
4537 if (pos == 0) pos = S + (1 - from);
4538 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4545 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4549 3) NaNs need to be supported, but it is known at compile time or cheaply
4550 at runtime whether array is nonempty or not:
4555 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4558 if (from <= to) pos = 1;
4562 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4566 4) NaNs aren't supported, array mask is used:
4567 limit = infinities_supported ? Infinity : huge (limit);
4571 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4577 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4581 5) Same without array mask:
4582 limit = infinities_supported ? Infinity : huge (limit);
4583 pos = (from <= to) ? 1 : 0;
4586 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4589 For 3) and 5), if mask is scalar, this all goes into a conditional,
4590 setting pos = 0; in the else branch. */
4593 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4597 stmtblock_t ifblock
;
4598 stmtblock_t elseblock
;
4609 gfc_actual_arglist
*actual
;
4614 gfc_expr
*arrayexpr
;
4619 actual
= expr
->value
.function
.actual
;
4621 /* The last argument, BACK, is passed by value. Ensure that
4622 by setting its name to %VAL. */
4623 for (gfc_actual_arglist
*a
= actual
; a
; a
= a
->next
)
4625 if (a
->next
== NULL
)
4631 gfc_conv_intrinsic_funcall (se
, expr
);
4635 arrayexpr
= actual
->expr
;
4637 /* Special case for character maxloc. Remove unneeded actual
4638 arguments, then call a library function. */
4640 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
4642 gfc_actual_arglist
*a
, *b
;
4647 if (b
->expr
== NULL
|| strcmp (b
->name
, "dim") == 0)
4651 gfc_free_actual_arglist (b
);
4656 gfc_conv_intrinsic_funcall (se
, expr
);
4660 /* Initialize the result. */
4661 pos
= gfc_create_var (gfc_array_index_type
, "pos");
4662 offset
= gfc_create_var (gfc_array_index_type
, "offset");
4663 type
= gfc_typenode_for_spec (&expr
->ts
);
4665 /* Walk the arguments. */
4666 arrayss
= gfc_walk_expr (arrayexpr
);
4667 gcc_assert (arrayss
!= gfc_ss_terminator
);
4669 actual
= actual
->next
->next
;
4670 gcc_assert (actual
);
4671 maskexpr
= actual
->expr
;
4673 if (maskexpr
&& maskexpr
->rank
!= 0)
4675 maskss
= gfc_walk_expr (maskexpr
);
4676 gcc_assert (maskss
!= gfc_ss_terminator
);
4681 if (gfc_array_size (arrayexpr
, &asize
))
4683 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4685 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4686 logical_type_node
, nonempty
,
4687 gfc_index_zero_node
);
4692 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
4693 switch (arrayexpr
->ts
.type
)
4696 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
4700 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
4701 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
4702 arrayexpr
->ts
.kind
);
4709 /* We start with the most negative possible value for MAXLOC, and the most
4710 positive possible value for MINLOC. The most negative possible value is
4711 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4712 possible value is HUGE in both cases. */
4714 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4715 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
4716 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
4717 build_int_cst (TREE_TYPE (tmp
), 1));
4719 gfc_add_modify (&se
->pre
, limit
, tmp
);
4721 /* Initialize the scalarizer. */
4722 gfc_init_loopinfo (&loop
);
4723 gfc_add_ss_to_loop (&loop
, arrayss
);
4725 gfc_add_ss_to_loop (&loop
, maskss
);
4727 /* Initialize the loop. */
4728 gfc_conv_ss_startstride (&loop
);
4730 /* The code generated can have more than one loop in sequence (see the
4731 comment at the function header). This doesn't work well with the
4732 scalarizer, which changes arrays' offset when the scalarization loops
4733 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4734 are currently inlined in the scalar case only (for which loop is of rank
4735 one). As there is no dependency to care about in that case, there is no
4736 temporary, so that we can use the scalarizer temporary code to handle
4737 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4738 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4740 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4741 should eventually go away. We could either create two loops properly,
4742 or find another way to save/restore the array offsets between the two
4743 loops (without conflicting with temporary management), or use a single
4744 loop minmaxloc implementation. See PR 31067. */
4745 loop
.temp_dim
= loop
.dimen
;
4746 gfc_conv_loop_setup (&loop
, &expr
->where
);
4748 gcc_assert (loop
.dimen
== 1);
4749 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
4750 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4751 loop
.from
[0], loop
.to
[0]);
4755 /* Initialize the position to zero, following Fortran 2003. We are free
4756 to do this because Fortran 95 allows the result of an entirely false
4757 mask to be processor dependent. If we know at compile time the array
4758 is non-empty and no MASK is used, we can initialize to 1 to simplify
4760 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
4761 gfc_add_modify (&loop
.pre
, pos
,
4762 fold_build3_loc (input_location
, COND_EXPR
,
4763 gfc_array_index_type
,
4764 nonempty
, gfc_index_one_node
,
4765 gfc_index_zero_node
));
4768 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
4769 lab1
= gfc_build_label_decl (NULL_TREE
);
4770 TREE_USED (lab1
) = 1;
4771 lab2
= gfc_build_label_decl (NULL_TREE
);
4772 TREE_USED (lab2
) = 1;
4775 /* An offset must be added to the loop
4776 counter to obtain the required position. */
4777 gcc_assert (loop
.from
[0]);
4779 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4780 gfc_index_one_node
, loop
.from
[0]);
4781 gfc_add_modify (&loop
.pre
, offset
, tmp
);
4783 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
4785 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
4786 /* Generate the loop body. */
4787 gfc_start_scalarized_body (&loop
, &body
);
4789 /* If we have a mask, only check this element if the mask is set. */
4792 gfc_init_se (&maskse
, NULL
);
4793 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4795 gfc_conv_expr_val (&maskse
, maskexpr
);
4796 gfc_add_block_to_block (&body
, &maskse
.pre
);
4798 gfc_start_block (&block
);
4801 gfc_init_block (&block
);
4803 /* Compare with the current limit. */
4804 gfc_init_se (&arrayse
, NULL
);
4805 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4806 arrayse
.ss
= arrayss
;
4807 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4808 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4810 /* We do the following if this is a more extreme value. */
4811 gfc_start_block (&ifblock
);
4813 /* Assign the value to the limit... */
4814 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4816 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
4818 stmtblock_t ifblock2
;
4821 gfc_start_block (&ifblock2
);
4822 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4823 loop
.loopvar
[0], offset
);
4824 gfc_add_modify (&ifblock2
, pos
, tmp
);
4825 ifbody2
= gfc_finish_block (&ifblock2
);
4826 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pos
,
4827 gfc_index_zero_node
);
4828 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
4829 build_empty_stmt (input_location
));
4830 gfc_add_expr_to_block (&block
, tmp
);
4833 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4834 loop
.loopvar
[0], offset
);
4835 gfc_add_modify (&ifblock
, pos
, tmp
);
4838 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
4840 ifbody
= gfc_finish_block (&ifblock
);
4842 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
4845 cond
= fold_build2_loc (input_location
,
4846 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4847 logical_type_node
, arrayse
.expr
, limit
);
4849 cond
= fold_build2_loc (input_location
, op
, logical_type_node
,
4850 arrayse
.expr
, limit
);
4852 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
4853 build_empty_stmt (input_location
));
4855 gfc_add_expr_to_block (&block
, ifbody
);
4859 /* We enclose the above in if (mask) {...}. */
4860 tmp
= gfc_finish_block (&block
);
4862 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4863 build_empty_stmt (input_location
));
4866 tmp
= gfc_finish_block (&block
);
4867 gfc_add_expr_to_block (&body
, tmp
);
4871 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4873 if (HONOR_NANS (DECL_MODE (limit
)))
4875 if (nonempty
!= NULL
)
4877 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
4878 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
4879 build_empty_stmt (input_location
));
4880 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
4884 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
4885 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
4887 /* If we have a mask, only check this element if the mask is set. */
4890 gfc_init_se (&maskse
, NULL
);
4891 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4893 gfc_conv_expr_val (&maskse
, maskexpr
);
4894 gfc_add_block_to_block (&body
, &maskse
.pre
);
4896 gfc_start_block (&block
);
4899 gfc_init_block (&block
);
4901 /* Compare with the current limit. */
4902 gfc_init_se (&arrayse
, NULL
);
4903 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4904 arrayse
.ss
= arrayss
;
4905 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4906 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4908 /* We do the following if this is a more extreme value. */
4909 gfc_start_block (&ifblock
);
4911 /* Assign the value to the limit... */
4912 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4914 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4915 loop
.loopvar
[0], offset
);
4916 gfc_add_modify (&ifblock
, pos
, tmp
);
4918 ifbody
= gfc_finish_block (&ifblock
);
4920 cond
= fold_build2_loc (input_location
, op
, logical_type_node
,
4921 arrayse
.expr
, limit
);
4923 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4924 build_empty_stmt (input_location
));
4925 gfc_add_expr_to_block (&block
, tmp
);
4929 /* We enclose the above in if (mask) {...}. */
4930 tmp
= gfc_finish_block (&block
);
4932 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4933 build_empty_stmt (input_location
));
4936 tmp
= gfc_finish_block (&block
);
4937 gfc_add_expr_to_block (&body
, tmp
);
4938 /* Avoid initializing loopvar[0] again, it should be left where
4939 it finished by the first loop. */
4940 loop
.from
[0] = loop
.loopvar
[0];
4943 gfc_trans_scalarizing_loops (&loop
, &body
);
4946 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4948 /* For a scalar mask, enclose the loop in an if statement. */
4949 if (maskexpr
&& maskss
== NULL
)
4951 gfc_init_se (&maskse
, NULL
);
4952 gfc_conv_expr_val (&maskse
, maskexpr
);
4953 gfc_init_block (&block
);
4954 gfc_add_block_to_block (&block
, &loop
.pre
);
4955 gfc_add_block_to_block (&block
, &loop
.post
);
4956 tmp
= gfc_finish_block (&block
);
4958 /* For the else part of the scalar mask, just initialize
4959 the pos variable the same way as above. */
4961 gfc_init_block (&elseblock
);
4962 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4963 elsetmp
= gfc_finish_block (&elseblock
);
4965 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4966 gfc_add_expr_to_block (&block
, tmp
);
4967 gfc_add_block_to_block (&se
->pre
, &block
);
4971 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4972 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4974 gfc_cleanup_loop (&loop
);
4976 se
->expr
= convert (type
, pos
);
4979 /* Emit code for minval or maxval intrinsic. There are many different cases
4980 we need to handle. For performance reasons we sometimes create two
4981 loops instead of one, where the second one is much simpler.
4982 Examples for minval intrinsic:
4983 1) Result is an array, a call is generated
4984 2) Array mask is used and NaNs need to be supported, rank 1:
4989 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4992 limit = nonempty ? NaN : huge (limit);
4994 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4995 3) NaNs need to be supported, but it is known at compile time or cheaply
4996 at runtime whether array is nonempty or not, rank 1:
4999 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
5000 limit = (from <= to) ? NaN : huge (limit);
5002 while (S <= to) { limit = min (a[S], limit); S++; }
5003 4) Array mask is used and NaNs need to be supported, rank > 1:
5012 if (fast) limit = min (a[S1][S2], limit);
5015 if (a[S1][S2] <= limit) {
5026 limit = nonempty ? NaN : huge (limit);
5027 5) NaNs need to be supported, but it is known at compile time or cheaply
5028 at runtime whether array is nonempty or not, rank > 1:
5035 if (fast) limit = min (a[S1][S2], limit);
5037 if (a[S1][S2] <= limit) {
5047 limit = (nonempty_array) ? NaN : huge (limit);
5048 6) NaNs aren't supported, but infinities are. Array mask is used:
5053 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
5056 limit = nonempty ? limit : huge (limit);
5057 7) Same without array mask:
5060 while (S <= to) { limit = min (a[S], limit); S++; }
5061 limit = (from <= to) ? limit : huge (limit);
5062 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
5063 limit = huge (limit);
5065 while (S <= to) { limit = min (a[S], limit); S++); }
5067 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
5068 with array mask instead).
5069 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
5070 setting limit = huge (limit); in the else branch. */
5073 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5083 tree huge_cst
= NULL
, nan_cst
= NULL
;
5085 stmtblock_t block
, block2
;
5087 gfc_actual_arglist
*actual
;
5092 gfc_expr
*arrayexpr
;
5098 gfc_conv_intrinsic_funcall (se
, expr
);
5102 actual
= expr
->value
.function
.actual
;
5103 arrayexpr
= actual
->expr
;
5105 if (arrayexpr
->ts
.type
== BT_CHARACTER
)
5107 gfc_actual_arglist
*a2
, *a3
;
5108 a2
= actual
->next
; /* dim */
5109 a3
= a2
->next
; /* mask */
5110 if (a2
->expr
== NULL
|| expr
->rank
== 0)
5112 if (a3
->expr
== NULL
)
5113 actual
->next
= NULL
;
5119 gfc_free_actual_arglist (a2
);
5122 if (a3
->expr
== NULL
)
5125 gfc_free_actual_arglist (a3
);
5127 gfc_conv_intrinsic_funcall (se
, expr
);
5130 type
= gfc_typenode_for_spec (&expr
->ts
);
5131 /* Initialize the result. */
5132 limit
= gfc_create_var (type
, "limit");
5133 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
5134 switch (expr
->ts
.type
)
5137 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
5139 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5141 REAL_VALUE_TYPE real
;
5143 tmp
= build_real (type
, real
);
5147 if (HONOR_NANS (DECL_MODE (limit
)))
5148 nan_cst
= gfc_build_nan (type
, "");
5152 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
5159 /* We start with the most negative possible value for MAXVAL, and the most
5160 positive possible value for MINVAL. The most negative possible value is
5161 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5162 possible value is HUGE in both cases. */
5165 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
5167 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
5168 TREE_TYPE (huge_cst
), huge_cst
);
5171 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
5172 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
5173 tmp
, build_int_cst (type
, 1));
5175 gfc_add_modify (&se
->pre
, limit
, tmp
);
5177 /* Walk the arguments. */
5178 arrayss
= gfc_walk_expr (arrayexpr
);
5179 gcc_assert (arrayss
!= gfc_ss_terminator
);
5181 actual
= actual
->next
->next
;
5182 gcc_assert (actual
);
5183 maskexpr
= actual
->expr
;
5185 if (maskexpr
&& maskexpr
->rank
!= 0)
5187 maskss
= gfc_walk_expr (maskexpr
);
5188 gcc_assert (maskss
!= gfc_ss_terminator
);
5193 if (gfc_array_size (arrayexpr
, &asize
))
5195 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
5197 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
5198 logical_type_node
, nonempty
,
5199 gfc_index_zero_node
);
5204 /* Initialize the scalarizer. */
5205 gfc_init_loopinfo (&loop
);
5206 gfc_add_ss_to_loop (&loop
, arrayss
);
5208 gfc_add_ss_to_loop (&loop
, maskss
);
5210 /* Initialize the loop. */
5211 gfc_conv_ss_startstride (&loop
);
5213 /* The code generated can have more than one loop in sequence (see the
5214 comment at the function header). This doesn't work well with the
5215 scalarizer, which changes arrays' offset when the scalarization loops
5216 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5217 are currently inlined in the scalar case only. As there is no dependency
5218 to care about in that case, there is no temporary, so that we can use the
5219 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5220 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5221 gfc_trans_scalarized_loop_boundary even later to restore offset.
5222 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5223 should eventually go away. We could either create two loops properly,
5224 or find another way to save/restore the array offsets between the two
5225 loops (without conflicting with temporary management), or use a single
5226 loop minmaxval implementation. See PR 31067. */
5227 loop
.temp_dim
= loop
.dimen
;
5228 gfc_conv_loop_setup (&loop
, &expr
->where
);
5230 if (nonempty
== NULL
&& maskss
== NULL
5231 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
5232 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
5233 loop
.from
[0], loop
.to
[0]);
5234 nonempty_var
= NULL
;
5235 if (nonempty
== NULL
5236 && (HONOR_INFINITIES (DECL_MODE (limit
))
5237 || HONOR_NANS (DECL_MODE (limit
))))
5239 nonempty_var
= gfc_create_var (logical_type_node
, "nonempty");
5240 gfc_add_modify (&se
->pre
, nonempty_var
, logical_false_node
);
5241 nonempty
= nonempty_var
;
5245 if (HONOR_NANS (DECL_MODE (limit
)))
5247 if (loop
.dimen
== 1)
5249 lab
= gfc_build_label_decl (NULL_TREE
);
5250 TREE_USED (lab
) = 1;
5254 fast
= gfc_create_var (logical_type_node
, "fast");
5255 gfc_add_modify (&se
->pre
, fast
, logical_false_node
);
5259 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
5261 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
5262 /* Generate the loop body. */
5263 gfc_start_scalarized_body (&loop
, &body
);
5265 /* If we have a mask, only add this element if the mask is set. */
5268 gfc_init_se (&maskse
, NULL
);
5269 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5271 gfc_conv_expr_val (&maskse
, maskexpr
);
5272 gfc_add_block_to_block (&body
, &maskse
.pre
);
5274 gfc_start_block (&block
);
5277 gfc_init_block (&block
);
5279 /* Compare with the current limit. */
5280 gfc_init_se (&arrayse
, NULL
);
5281 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5282 arrayse
.ss
= arrayss
;
5283 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5284 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5286 gfc_init_block (&block2
);
5289 gfc_add_modify (&block2
, nonempty_var
, logical_true_node
);
5291 if (HONOR_NANS (DECL_MODE (limit
)))
5293 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
5294 logical_type_node
, arrayse
.expr
, limit
);
5296 ifbody
= build1_v (GOTO_EXPR
, lab
);
5299 stmtblock_t ifblock
;
5301 gfc_init_block (&ifblock
);
5302 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
5303 gfc_add_modify (&ifblock
, fast
, logical_true_node
);
5304 ifbody
= gfc_finish_block (&ifblock
);
5306 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5307 build_empty_stmt (input_location
));
5308 gfc_add_expr_to_block (&block2
, tmp
);
5312 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5314 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5316 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5317 arrayse
.expr
, limit
);
5318 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5319 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5320 build_empty_stmt (input_location
));
5321 gfc_add_expr_to_block (&block2
, tmp
);
5325 tmp
= fold_build2_loc (input_location
,
5326 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5327 type
, arrayse
.expr
, limit
);
5328 gfc_add_modify (&block2
, limit
, tmp
);
5334 tree elsebody
= gfc_finish_block (&block2
);
5336 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5338 if (HONOR_NANS (DECL_MODE (limit
))
5339 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5341 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5342 arrayse
.expr
, limit
);
5343 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5344 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
5345 build_empty_stmt (input_location
));
5349 tmp
= fold_build2_loc (input_location
,
5350 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5351 type
, arrayse
.expr
, limit
);
5352 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5354 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
5355 gfc_add_expr_to_block (&block
, tmp
);
5358 gfc_add_block_to_block (&block
, &block2
);
5360 gfc_add_block_to_block (&block
, &arrayse
.post
);
5362 tmp
= gfc_finish_block (&block
);
5364 /* We enclose the above in if (mask) {...}. */
5365 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5366 build_empty_stmt (input_location
));
5367 gfc_add_expr_to_block (&body
, tmp
);
5371 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5373 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5375 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
5376 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
5378 /* If we have a mask, only add this element if the mask is set. */
5381 gfc_init_se (&maskse
, NULL
);
5382 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
5384 gfc_conv_expr_val (&maskse
, maskexpr
);
5385 gfc_add_block_to_block (&body
, &maskse
.pre
);
5387 gfc_start_block (&block
);
5390 gfc_init_block (&block
);
5392 /* Compare with the current limit. */
5393 gfc_init_se (&arrayse
, NULL
);
5394 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
5395 arrayse
.ss
= arrayss
;
5396 gfc_conv_expr_val (&arrayse
, arrayexpr
);
5397 gfc_add_block_to_block (&block
, &arrayse
.pre
);
5399 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5401 if (HONOR_NANS (DECL_MODE (limit
))
5402 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
5404 tmp
= fold_build2_loc (input_location
, op
, logical_type_node
,
5405 arrayse
.expr
, limit
);
5406 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
5407 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
5408 build_empty_stmt (input_location
));
5409 gfc_add_expr_to_block (&block
, tmp
);
5413 tmp
= fold_build2_loc (input_location
,
5414 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
5415 type
, arrayse
.expr
, limit
);
5416 gfc_add_modify (&block
, limit
, tmp
);
5419 gfc_add_block_to_block (&block
, &arrayse
.post
);
5421 tmp
= gfc_finish_block (&block
);
5423 /* We enclose the above in if (mask) {...}. */
5424 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
5425 build_empty_stmt (input_location
));
5426 gfc_add_expr_to_block (&body
, tmp
);
5427 /* Avoid initializing loopvar[0] again, it should be left where
5428 it finished by the first loop. */
5429 loop
.from
[0] = loop
.loopvar
[0];
5431 gfc_trans_scalarizing_loops (&loop
, &body
);
5435 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
5437 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
5438 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
5440 gfc_add_expr_to_block (&loop
.pre
, tmp
);
5442 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
5444 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
5446 gfc_add_modify (&loop
.pre
, limit
, tmp
);
5449 /* For a scalar mask, enclose the loop in an if statement. */
5450 if (maskexpr
&& maskss
== NULL
)
5454 gfc_init_se (&maskse
, NULL
);
5455 gfc_conv_expr_val (&maskse
, maskexpr
);
5456 gfc_init_block (&block
);
5457 gfc_add_block_to_block (&block
, &loop
.pre
);
5458 gfc_add_block_to_block (&block
, &loop
.post
);
5459 tmp
= gfc_finish_block (&block
);
5461 if (HONOR_INFINITIES (DECL_MODE (limit
)))
5462 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
5464 else_stmt
= build_empty_stmt (input_location
);
5465 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
5466 gfc_add_expr_to_block (&block
, tmp
);
5467 gfc_add_block_to_block (&se
->pre
, &block
);
5471 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5472 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5475 gfc_cleanup_loop (&loop
);
5480 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5482 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
5488 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5489 type
= TREE_TYPE (args
[0]);
5491 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5492 build_int_cst (type
, 1), args
[1]);
5493 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
5494 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
5495 build_int_cst (type
, 0));
5496 type
= gfc_typenode_for_spec (&expr
->ts
);
5497 se
->expr
= convert (type
, tmp
);
5501 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5503 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5507 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5509 /* Convert both arguments to the unsigned type of the same size. */
5510 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
5511 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
5513 /* If they have unequal type size, convert to the larger one. */
5514 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
5515 > TYPE_PRECISION (TREE_TYPE (args
[1])))
5516 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
5517 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
5518 > TYPE_PRECISION (TREE_TYPE (args
[0])))
5519 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
5521 /* Now, we compare them. */
5522 se
->expr
= fold_build2_loc (input_location
, op
, logical_type_node
,
5527 /* Generate code to perform the specified operation. */
5529 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5533 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5534 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
5540 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
5544 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5545 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5546 TREE_TYPE (arg
), arg
);
5549 /* Set or clear a single bit. */
5551 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
5558 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5559 type
= TREE_TYPE (args
[0]);
5561 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
5562 build_int_cst (type
, 1), args
[1]);
5568 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
5570 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
5573 /* Extract a sequence of bits.
5574 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5576 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
5583 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5584 type
= TREE_TYPE (args
[0]);
5586 mask
= build_int_cst (type
, -1);
5587 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
5588 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
5590 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
5592 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
5596 gfc_conv_intrinsic_shape (gfc_se
*se
, gfc_expr
*expr
)
5598 gfc_actual_arglist
*s
, *k
;
5601 /* Remove the KIND argument, if present. */
5602 s
= expr
->value
.function
.actual
;
5608 gfc_conv_intrinsic_funcall (se
, expr
);
5612 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
5615 tree args
[2], type
, num_bits
, cond
;
5617 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5619 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5620 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5621 type
= TREE_TYPE (args
[0]);
5624 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
5626 gcc_assert (right_shift
);
5628 se
->expr
= fold_build2_loc (input_location
,
5629 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
5630 TREE_TYPE (args
[0]), args
[0], args
[1]);
5633 se
->expr
= fold_convert (type
, se
->expr
);
5635 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5636 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5638 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5639 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
5642 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5643 build_int_cst (type
, 0), se
->expr
);
5646 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5648 : ((shift >= 0) ? i << shift : i >> -shift)
5649 where all shifts are logical shifts. */
5651 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
5663 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5665 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5666 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5668 type
= TREE_TYPE (args
[0]);
5669 utype
= unsigned_type_for (type
);
5671 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
5674 /* Left shift if positive. */
5675 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
5677 /* Right shift if negative.
5678 We convert to an unsigned type because we want a logical shift.
5679 The standard doesn't define the case of shifting negative
5680 numbers, and we try to be compatible with other compilers, most
5681 notably g77, here. */
5682 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
5683 utype
, convert (utype
, args
[0]), width
));
5685 tmp
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, args
[1],
5686 build_int_cst (TREE_TYPE (args
[1]), 0));
5687 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
5689 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5690 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5692 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
5693 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, width
,
5695 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5696 build_int_cst (type
, 0), tmp
);
5700 /* Circular shift. AKA rotate or barrel shift. */
5703 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
5711 unsigned int num_args
;
5713 num_args
= gfc_intrinsic_argument_list_length (expr
);
5714 args
= XALLOCAVEC (tree
, num_args
);
5716 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5720 /* Use a library function for the 3 parameter version. */
5721 tree int4type
= gfc_get_int_type (4);
5723 type
= TREE_TYPE (args
[0]);
5724 /* We convert the first argument to at least 4 bytes, and
5725 convert back afterwards. This removes the need for library
5726 functions for all argument sizes, and function will be
5727 aligned to at least 32 bits, so there's no loss. */
5728 if (expr
->ts
.kind
< 4)
5729 args
[0] = convert (int4type
, args
[0]);
5731 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5732 need loads of library functions. They cannot have values >
5733 BIT_SIZE (I) so the conversion is safe. */
5734 args
[1] = convert (int4type
, args
[1]);
5735 args
[2] = convert (int4type
, args
[2]);
5737 switch (expr
->ts
.kind
)
5742 tmp
= gfor_fndecl_math_ishftc4
;
5745 tmp
= gfor_fndecl_math_ishftc8
;
5748 tmp
= gfor_fndecl_math_ishftc16
;
5753 se
->expr
= build_call_expr_loc (input_location
,
5754 tmp
, 3, args
[0], args
[1], args
[2]);
5755 /* Convert the result back to the original type, if we extended
5756 the first argument's width above. */
5757 if (expr
->ts
.kind
< 4)
5758 se
->expr
= convert (type
, se
->expr
);
5762 type
= TREE_TYPE (args
[0]);
5764 /* Evaluate arguments only once. */
5765 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5766 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
5768 /* Rotate left if positive. */
5769 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
5771 /* Rotate right if negative. */
5772 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
5774 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
5776 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
5777 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, args
[1],
5779 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
5781 /* Do nothing if shift == 0. */
5782 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, args
[1],
5784 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
5789 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5790 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5792 The conditional expression is necessary because the result of LEADZ(0)
5793 is defined, but the result of __builtin_clz(0) is undefined for most
5796 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5797 difference in bit size between the argument of LEADZ and the C int. */
5800 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
5812 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5813 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5815 /* Which variant of __builtin_clz* should we call? */
5816 if (argsize
<= INT_TYPE_SIZE
)
5818 arg_type
= unsigned_type_node
;
5819 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
5821 else if (argsize
<= LONG_TYPE_SIZE
)
5823 arg_type
= long_unsigned_type_node
;
5824 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
5826 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5828 arg_type
= long_long_unsigned_type_node
;
5829 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5833 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5834 arg_type
= gfc_build_uint_type (argsize
);
5838 /* Convert the actual argument twice: first, to the unsigned type of the
5839 same size; then, to the proper argument type for the built-in
5840 function. But the return type is of the default INTEGER kind. */
5841 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5842 arg
= fold_convert (arg_type
, arg
);
5843 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5844 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5846 /* Compute LEADZ for the case i .ne. 0. */
5849 s
= TYPE_PRECISION (arg_type
) - argsize
;
5850 tmp
= fold_convert (result_type
,
5851 build_call_expr_loc (input_location
, func
,
5853 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
5854 tmp
, build_int_cst (result_type
, s
));
5858 /* We end up here if the argument type is larger than 'long long'.
5859 We generate this code:
5861 if (x & (ULL_MAX << ULL_SIZE) != 0)
5862 return clzll ((unsigned long long) (x >> ULLSIZE));
5864 return ULL_SIZE + clzll ((unsigned long long) x);
5865 where ULL_MAX is the largest value that a ULL_MAX can hold
5866 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5867 is the bit-size of the long long type (64 in this example). */
5868 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5870 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5871 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5872 long_long_unsigned_type_node
,
5873 build_int_cst (long_long_unsigned_type_node
,
5876 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
5877 fold_convert (arg_type
, ullmax
), ullsize
);
5878 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
5880 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
5881 cond
, build_int_cst (arg_type
, 0));
5883 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5885 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5886 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5887 tmp1
= fold_convert (result_type
,
5888 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5890 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5891 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5892 tmp2
= fold_convert (result_type
,
5893 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5894 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5897 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5901 /* Build BIT_SIZE. */
5902 bit_size
= build_int_cst (result_type
, argsize
);
5904 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5905 arg
, build_int_cst (arg_type
, 0));
5906 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5911 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5913 The conditional expression is necessary because the result of TRAILZ(0)
5914 is defined, but the result of __builtin_ctz(0) is undefined for most
5918 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
5929 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5930 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5932 /* Which variant of __builtin_ctz* should we call? */
5933 if (argsize
<= INT_TYPE_SIZE
)
5935 arg_type
= unsigned_type_node
;
5936 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5938 else if (argsize
<= LONG_TYPE_SIZE
)
5940 arg_type
= long_unsigned_type_node
;
5941 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5943 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5945 arg_type
= long_long_unsigned_type_node
;
5946 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5950 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5951 arg_type
= gfc_build_uint_type (argsize
);
5955 /* Convert the actual argument twice: first, to the unsigned type of the
5956 same size; then, to the proper argument type for the built-in
5957 function. But the return type is of the default INTEGER kind. */
5958 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5959 arg
= fold_convert (arg_type
, arg
);
5960 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5961 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5963 /* Compute TRAILZ for the case i .ne. 0. */
5965 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5969 /* We end up here if the argument type is larger than 'long long'.
5970 We generate this code:
5972 if ((x & ULL_MAX) == 0)
5973 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5975 return ctzll ((unsigned long long) x);
5977 where ULL_MAX is the largest value that a ULL_MAX can hold
5978 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5979 is the bit-size of the long long type (64 in this example). */
5980 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5982 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5983 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5984 long_long_unsigned_type_node
,
5985 build_int_cst (long_long_unsigned_type_node
, 0));
5987 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5988 fold_convert (arg_type
, ullmax
));
5989 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, cond
,
5990 build_int_cst (arg_type
, 0));
5992 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5994 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5995 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5996 tmp1
= fold_convert (result_type
,
5997 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5998 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6001 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
6002 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
6003 tmp2
= fold_convert (result_type
,
6004 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
6006 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
6010 /* Build BIT_SIZE. */
6011 bit_size
= build_int_cst (result_type
, argsize
);
6013 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6014 arg
, build_int_cst (arg_type
, 0));
6015 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
6019 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
6020 for types larger than "long long", we call the long long built-in for
6021 the lower and higher bits and combine the result. */
6024 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
6032 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6033 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
6034 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
6036 /* Which variant of the builtin should we call? */
6037 if (argsize
<= INT_TYPE_SIZE
)
6039 arg_type
= unsigned_type_node
;
6040 func
= builtin_decl_explicit (parity
6042 : BUILT_IN_POPCOUNT
);
6044 else if (argsize
<= LONG_TYPE_SIZE
)
6046 arg_type
= long_unsigned_type_node
;
6047 func
= builtin_decl_explicit (parity
6049 : BUILT_IN_POPCOUNTL
);
6051 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
6053 arg_type
= long_long_unsigned_type_node
;
6054 func
= builtin_decl_explicit (parity
6056 : BUILT_IN_POPCOUNTLL
);
6060 /* Our argument type is larger than 'long long', which mean none
6061 of the POPCOUNT builtins covers it. We thus call the 'long long'
6062 variant multiple times, and add the results. */
6063 tree utype
, arg2
, call1
, call2
;
6065 /* For now, we only cover the case where argsize is twice as large
6067 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
6069 func
= builtin_decl_explicit (parity
6071 : BUILT_IN_POPCOUNTLL
);
6073 /* Convert it to an integer, and store into a variable. */
6074 utype
= gfc_build_uint_type (argsize
);
6075 arg
= fold_convert (utype
, arg
);
6076 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6078 /* Call the builtin twice. */
6079 call1
= build_call_expr_loc (input_location
, func
, 1,
6080 fold_convert (long_long_unsigned_type_node
,
6083 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
6084 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
6085 call2
= build_call_expr_loc (input_location
, func
, 1,
6086 fold_convert (long_long_unsigned_type_node
,
6089 /* Combine the results. */
6091 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
6094 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
6100 /* Convert the actual argument twice: first, to the unsigned type of the
6101 same size; then, to the proper argument type for the built-in
6103 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
6104 arg
= fold_convert (arg_type
, arg
);
6106 se
->expr
= fold_convert (result_type
,
6107 build_call_expr_loc (input_location
, func
, 1, arg
));
6111 /* Process an intrinsic with unspecified argument-types that has an optional
6112 argument (which could be of type character), e.g. EOSHIFT. For those, we
6113 need to append the string length of the optional argument if it is not
6114 present and the type is really character.
6115 primary specifies the position (starting at 1) of the non-optional argument
6116 specifying the type and optional gives the position of the optional
6117 argument in the arglist. */
6120 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
6121 unsigned primary
, unsigned optional
)
6123 gfc_actual_arglist
* prim_arg
;
6124 gfc_actual_arglist
* opt_arg
;
6126 gfc_actual_arglist
* arg
;
6128 vec
<tree
, va_gc
> *append_args
;
6130 /* Find the two arguments given as position. */
6134 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
6138 if (cur_pos
== primary
)
6140 if (cur_pos
== optional
)
6143 if (cur_pos
>= primary
&& cur_pos
>= optional
)
6146 gcc_assert (prim_arg
);
6147 gcc_assert (prim_arg
->expr
);
6148 gcc_assert (opt_arg
);
6150 /* If we do have type CHARACTER and the optional argument is really absent,
6151 append a dummy 0 as string length. */
6153 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
6157 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
6158 vec_alloc (append_args
, 1);
6159 append_args
->quick_push (dummy
);
6162 /* Build the call itself. */
6163 gcc_assert (!se
->ignore_optional
);
6164 sym
= gfc_get_symbol_for_expr (expr
, false);
6165 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6167 gfc_free_symbol (sym
);
6170 /* The length of a character string. */
6172 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
6181 gcc_assert (!se
->ss
);
6183 arg
= expr
->value
.function
.actual
->expr
;
6185 type
= gfc_typenode_for_spec (&expr
->ts
);
6186 switch (arg
->expr_type
)
6189 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
6193 /* Obtain the string length from the function used by
6194 trans-array.c(gfc_trans_array_constructor). */
6196 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
6200 if (arg
->ref
== NULL
6201 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
6203 /* This doesn't catch all cases.
6204 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6205 and the surrounding thread. */
6206 sym
= arg
->symtree
->n
.sym
;
6207 decl
= gfc_get_symbol_decl (sym
);
6208 if (decl
== current_function_decl
&& sym
->attr
.function
6209 && (sym
->result
== sym
))
6210 decl
= gfc_get_fake_result_decl (sym
, 0);
6212 len
= sym
->ts
.u
.cl
->backend_decl
;
6220 /* Anybody stupid enough to do this deserves inefficient code. */
6221 gfc_init_se (&argse
, se
);
6223 gfc_conv_expr (&argse
, arg
);
6225 gfc_conv_expr_descriptor (&argse
, arg
);
6226 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6227 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6228 len
= argse
.string_length
;
6231 se
->expr
= convert (type
, len
);
6234 /* The length of a character string not including trailing blanks. */
6236 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
6238 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6239 tree args
[2], type
, fndecl
;
6241 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6242 type
= gfc_typenode_for_spec (&expr
->ts
);
6245 fndecl
= gfor_fndecl_string_len_trim
;
6247 fndecl
= gfor_fndecl_string_len_trim_char4
;
6251 se
->expr
= build_call_expr_loc (input_location
,
6252 fndecl
, 2, args
[0], args
[1]);
6253 se
->expr
= convert (type
, se
->expr
);
6257 /* Returns the starting position of a substring within a string. */
6260 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
6263 tree logical4_type_node
= gfc_get_logical_type (4);
6267 unsigned int num_args
;
6269 args
= XALLOCAVEC (tree
, 5);
6271 /* Get number of arguments; characters count double due to the
6272 string length argument. Kind= is not passed to the library
6273 and thus ignored. */
6274 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
6279 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6280 type
= gfc_typenode_for_spec (&expr
->ts
);
6283 args
[4] = build_int_cst (logical4_type_node
, 0);
6285 args
[4] = convert (logical4_type_node
, args
[4]);
6287 fndecl
= build_addr (function
);
6288 se
->expr
= build_call_array_loc (input_location
,
6289 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6291 se
->expr
= convert (type
, se
->expr
);
6295 /* The ascii value for a single character. */
6297 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
6299 tree args
[3], type
, pchartype
;
6302 nargs
= gfc_intrinsic_argument_list_length (expr
);
6303 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
6304 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
6305 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
6306 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
6307 type
= gfc_typenode_for_spec (&expr
->ts
);
6309 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6311 se
->expr
= convert (type
, se
->expr
);
6315 /* Intrinsic ISNAN calls __builtin_isnan. */
6318 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
6322 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6323 se
->expr
= build_call_expr_loc (input_location
,
6324 builtin_decl_explicit (BUILT_IN_ISNAN
),
6326 STRIP_TYPE_NOPS (se
->expr
);
6327 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6331 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6332 their argument against a constant integer value. */
6335 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
6339 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6340 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
6341 gfc_typenode_for_spec (&expr
->ts
),
6342 arg
, build_int_cst (TREE_TYPE (arg
), value
));
6347 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6350 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
6358 unsigned int num_args
;
6360 num_args
= gfc_intrinsic_argument_list_length (expr
);
6361 args
= XALLOCAVEC (tree
, num_args
);
6363 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
6364 if (expr
->ts
.type
!= BT_CHARACTER
)
6372 /* We do the same as in the non-character case, but the argument
6373 list is different because of the string length arguments. We
6374 also have to set the string length for the result. */
6381 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
6383 se
->string_length
= len
;
6385 type
= TREE_TYPE (tsource
);
6386 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
6387 fold_convert (type
, fsource
));
6391 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6394 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
6396 tree args
[3], mask
, type
;
6398 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6399 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
6401 type
= TREE_TYPE (args
[0]);
6402 gcc_assert (TREE_TYPE (args
[1]) == type
);
6403 gcc_assert (TREE_TYPE (mask
) == type
);
6405 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
6406 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
6407 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
6409 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
6414 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6415 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6418 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
6420 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
6423 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6424 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6426 type
= gfc_get_int_type (expr
->ts
.kind
);
6427 utype
= unsigned_type_for (type
);
6429 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
6430 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
6432 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
6433 build_int_cst (utype
, 0));
6437 /* Left-justified mask. */
6438 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
6440 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6441 fold_convert (utype
, res
));
6443 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6444 smaller than type width. */
6445 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6446 build_int_cst (TREE_TYPE (arg
), 0));
6447 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
6448 build_int_cst (utype
, 0), res
);
6452 /* Right-justified mask. */
6453 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
6454 fold_convert (utype
, arg
));
6455 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
6457 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6458 strictly smaller than type width. */
6459 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6461 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
6462 cond
, allones
, res
);
6465 se
->expr
= fold_convert (type
, res
);
6469 /* FRACTION (s) is translated into:
6470 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6472 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
6474 tree arg
, type
, tmp
, res
, frexp
, cond
;
6476 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6478 type
= gfc_typenode_for_spec (&expr
->ts
);
6479 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6480 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6482 cond
= build_call_expr_loc (input_location
,
6483 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6486 tmp
= gfc_create_var (integer_type_node
, NULL
);
6487 res
= build_call_expr_loc (input_location
, frexp
, 2,
6488 fold_convert (type
, arg
),
6489 gfc_build_addr_expr (NULL_TREE
, tmp
));
6490 res
= fold_convert (type
, res
);
6492 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
6493 cond
, res
, gfc_build_nan (type
, ""));
6497 /* NEAREST (s, dir) is translated into
6498 tmp = copysign (HUGE_VAL, dir);
6499 return nextafter (s, tmp);
6502 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
6504 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
6506 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
6507 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
6509 type
= gfc_typenode_for_spec (&expr
->ts
);
6510 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6512 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
6513 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
6514 fold_convert (type
, args
[1]));
6515 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
6516 fold_convert (type
, args
[0]), tmp
);
6517 se
->expr
= fold_convert (type
, se
->expr
);
6521 /* SPACING (s) is translated into
6531 e = MAX_EXPR (e, emin);
6532 res = scalbn (1., e);
6536 where prec is the precision of s, gfc_real_kinds[k].digits,
6537 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6538 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6541 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
6543 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
6544 tree cond
, nan
, tmp
, frexp
, scalbn
;
6548 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6549 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
6550 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
6551 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
6553 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6554 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6556 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6557 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6559 type
= gfc_typenode_for_spec (&expr
->ts
);
6560 e
= gfc_create_var (integer_type_node
, NULL
);
6561 res
= gfc_create_var (type
, NULL
);
6564 /* Build the block for s /= 0. */
6565 gfc_start_block (&block
);
6566 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6567 gfc_build_addr_expr (NULL_TREE
, e
));
6568 gfc_add_expr_to_block (&block
, tmp
);
6570 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
6572 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
6573 integer_type_node
, tmp
, emin
));
6575 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
6576 build_real_from_int_cst (type
, integer_one_node
), e
);
6577 gfc_add_modify (&block
, res
, tmp
);
6579 /* Finish by building the IF statement for value zero. */
6580 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
6581 build_real_from_int_cst (type
, integer_zero_node
));
6582 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
6583 gfc_finish_block (&block
));
6585 /* And deal with infinities and NaNs. */
6586 cond
= build_call_expr_loc (input_location
,
6587 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6589 nan
= gfc_build_nan (type
, "");
6590 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
6592 gfc_add_expr_to_block (&se
->pre
, tmp
);
6597 /* RRSPACING (s) is translated into
6606 x = scalbn (x, precision - e);
6613 where precision is gfc_real_kinds[k].digits. */
6616 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
6618 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
6622 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
6623 prec
= gfc_real_kinds
[k
].digits
;
6625 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6626 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6627 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
6629 type
= gfc_typenode_for_spec (&expr
->ts
);
6630 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6631 arg
= gfc_evaluate_now (arg
, &se
->pre
);
6633 e
= gfc_create_var (integer_type_node
, NULL
);
6634 x
= gfc_create_var (type
, NULL
);
6635 gfc_add_modify (&se
->pre
, x
,
6636 build_call_expr_loc (input_location
, fabs
, 1, arg
));
6639 gfc_start_block (&block
);
6640 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
6641 gfc_build_addr_expr (NULL_TREE
, e
));
6642 gfc_add_expr_to_block (&block
, tmp
);
6644 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
6645 build_int_cst (integer_type_node
, prec
), e
);
6646 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
6647 gfc_add_modify (&block
, x
, tmp
);
6648 stmt
= gfc_finish_block (&block
);
6651 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, x
,
6652 build_real_from_int_cst (type
, integer_zero_node
));
6653 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
6655 /* And deal with infinities and NaNs. */
6656 cond
= build_call_expr_loc (input_location
,
6657 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6659 nan
= gfc_build_nan (type
, "");
6660 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
6662 gfc_add_expr_to_block (&se
->pre
, tmp
);
6663 se
->expr
= fold_convert (type
, x
);
6667 /* SCALE (s, i) is translated into scalbn (s, i). */
6669 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
6671 tree args
[2], type
, scalbn
;
6673 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6675 type
= gfc_typenode_for_spec (&expr
->ts
);
6676 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6677 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
6678 fold_convert (type
, args
[0]),
6679 fold_convert (integer_type_node
, args
[1]));
6680 se
->expr
= fold_convert (type
, se
->expr
);
6684 /* SET_EXPONENT (s, i) is translated into
6685 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6687 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
6689 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
6691 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
6692 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
6694 type
= gfc_typenode_for_spec (&expr
->ts
);
6695 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6696 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
6698 tmp
= gfc_create_var (integer_type_node
, NULL
);
6699 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
6700 fold_convert (type
, args
[0]),
6701 gfc_build_addr_expr (NULL_TREE
, tmp
));
6702 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
6703 fold_convert (integer_type_node
, args
[1]));
6704 res
= fold_convert (type
, res
);
6706 /* Call to isfinite */
6707 cond
= build_call_expr_loc (input_location
,
6708 builtin_decl_explicit (BUILT_IN_ISFINITE
),
6710 nan
= gfc_build_nan (type
, "");
6712 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
6718 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
6720 gfc_actual_arglist
*actual
;
6727 gfc_init_se (&argse
, NULL
);
6728 actual
= expr
->value
.function
.actual
;
6730 if (actual
->expr
->ts
.type
== BT_CLASS
)
6731 gfc_add_class_array_ref (actual
->expr
);
6733 argse
.data_not_needed
= 1;
6734 if (gfc_is_class_array_function (actual
->expr
))
6736 /* For functions that return a class array conv_expr_descriptor is not
6737 able to get the descriptor right. Therefore this special case. */
6738 gfc_conv_expr_reference (&argse
, actual
->expr
);
6739 argse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6740 gfc_class_data_get (argse
.expr
));
6744 argse
.want_pointer
= 1;
6745 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
6747 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6748 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6749 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
6751 /* Build the call to size0. */
6752 fncall0
= build_call_expr_loc (input_location
,
6753 gfor_fndecl_size0
, 1, arg1
);
6755 actual
= actual
->next
;
6759 gfc_init_se (&argse
, NULL
);
6760 gfc_conv_expr_type (&argse
, actual
->expr
,
6761 gfc_array_index_type
);
6762 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6764 /* Unusually, for an intrinsic, size does not exclude
6765 an optional arg2, so we must test for it. */
6766 if (actual
->expr
->expr_type
== EXPR_VARIABLE
6767 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
6768 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
6771 /* Build the call to size1. */
6772 fncall1
= build_call_expr_loc (input_location
,
6773 gfor_fndecl_size1
, 2,
6776 gfc_init_se (&argse
, NULL
);
6777 argse
.want_pointer
= 1;
6778 argse
.data_not_needed
= 1;
6779 gfc_conv_expr (&argse
, actual
->expr
);
6780 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6781 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6782 argse
.expr
, null_pointer_node
);
6783 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6784 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
6785 pvoid_type_node
, tmp
, fncall1
, fncall0
);
6789 se
->expr
= NULL_TREE
;
6790 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6791 gfc_array_index_type
,
6792 argse
.expr
, gfc_index_one_node
);
6795 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
6797 argse
.expr
= gfc_index_zero_node
;
6798 se
->expr
= NULL_TREE
;
6803 if (se
->expr
== NULL_TREE
)
6805 tree ubound
, lbound
;
6807 arg1
= build_fold_indirect_ref_loc (input_location
,
6809 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
6810 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
6811 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
6812 gfc_array_index_type
, ubound
, lbound
);
6813 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
6814 gfc_array_index_type
,
6815 se
->expr
, gfc_index_one_node
);
6816 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
6817 gfc_array_index_type
, se
->expr
,
6818 gfc_index_zero_node
);
6821 type
= gfc_typenode_for_spec (&expr
->ts
);
6822 se
->expr
= convert (type
, se
->expr
);
6826 /* Helper function to compute the size of a character variable,
6827 excluding the terminating null characters. The result has
6828 gfc_array_index_type type. */
6831 size_of_string_in_bytes (int kind
, tree string_length
)
6834 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
6836 bytesize
= build_int_cst (gfc_array_index_type
,
6837 gfc_character_kinds
[i
].bit_size
/ 8);
6839 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6841 fold_convert (gfc_array_index_type
, string_length
));
6846 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
6858 gfc_init_se (&argse
, NULL
);
6859 arg
= expr
->value
.function
.actual
->expr
;
6861 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
6862 gfc_conv_expr_descriptor (&argse
, arg
);
6864 gfc_conv_expr_reference (&argse
, arg
);
6866 if (arg
->ts
.type
== BT_ASSUMED
)
6868 /* This only works if an array descriptor has been passed; thus, extract
6869 the size from the descriptor. */
6870 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
6871 == TYPE_PRECISION (size_type_node
));
6872 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
6873 tmp
= DECL_LANG_SPECIFIC (tmp
)
6874 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
6875 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
6876 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
6877 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6879 tmp
= gfc_conv_descriptor_dtype (tmp
);
6880 field
= gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
6881 GFC_DTYPE_ELEM_LEN
);
6882 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6883 tmp
, field
, NULL_TREE
);
6885 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
6887 else if (arg
->ts
.type
== BT_CLASS
)
6889 /* Conv_expr_descriptor returns a component_ref to _data component of the
6890 class object. The class object may be a non-pointer object, e.g.
6891 located on the stack, or a memory location pointed to, e.g. a
6892 parameter, i.e., an indirect_ref. */
6894 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
6895 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
6896 && GFC_DECL_CLASS (TREE_OPERAND (
6897 TREE_OPERAND (argse
.expr
, 0), 0)))
6898 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
6899 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6900 else if (arg
->rank
> 0
6902 && arg
->ref
&& arg
->ref
->type
== REF_COMPONENT
))
6903 /* The scalarizer added an additional temp. To get the class' vptr
6904 one has to look at the original backend_decl. */
6905 byte_size
= gfc_class_vtab_size_get (
6906 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6908 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
6912 if (arg
->ts
.type
== BT_CHARACTER
)
6913 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6917 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6920 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6921 byte_size
= fold_convert (gfc_array_index_type
,
6922 size_in_bytes (byte_size
));
6927 se
->expr
= byte_size
;
6930 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
6931 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
6933 if (arg
->rank
== -1)
6935 tree cond
, loop_var
, exit_label
;
6938 tmp
= fold_convert (gfc_array_index_type
,
6939 gfc_conv_descriptor_rank (argse
.expr
));
6940 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
6941 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
6942 exit_label
= gfc_build_label_decl (NULL_TREE
);
6949 source_bytes = source_bytes * array.dim[i].extent;
6953 gfc_start_block (&body
);
6954 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
6956 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6957 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6958 cond
, tmp
, build_empty_stmt (input_location
));
6959 gfc_add_expr_to_block (&body
, tmp
);
6961 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6962 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6963 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6964 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6965 gfc_array_index_type
, tmp
, source_bytes
);
6966 gfc_add_modify (&body
, source_bytes
, tmp
);
6968 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6969 gfc_array_index_type
, loop_var
,
6970 gfc_index_one_node
);
6971 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6973 tmp
= gfc_finish_block (&body
);
6975 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6977 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6979 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6980 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6984 /* Obtain the size of the array in bytes. */
6985 for (n
= 0; n
< arg
->rank
; n
++)
6988 idx
= gfc_rank_cst
[n
];
6989 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6990 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6991 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6992 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6993 gfc_array_index_type
, tmp
, source_bytes
);
6994 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6997 se
->expr
= source_bytes
;
7000 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7005 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
7009 tree type
, result_type
, tmp
;
7011 arg
= expr
->value
.function
.actual
->expr
;
7013 gfc_init_se (&argse
, NULL
);
7014 result_type
= gfc_get_int_type (expr
->ts
.kind
);
7018 if (arg
->ts
.type
== BT_CLASS
)
7020 gfc_add_vptr_component (arg
);
7021 gfc_add_size_component (arg
);
7022 gfc_conv_expr (&argse
, arg
);
7023 tmp
= fold_convert (result_type
, argse
.expr
);
7027 gfc_conv_expr_reference (&argse
, arg
);
7028 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7033 argse
.want_pointer
= 0;
7034 gfc_conv_expr_descriptor (&argse
, arg
);
7035 if (arg
->ts
.type
== BT_CLASS
)
7038 tmp
= gfc_class_vtab_size_get (
7039 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
7041 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
7042 tmp
= fold_convert (result_type
, tmp
);
7045 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7048 /* Obtain the argument's word length. */
7049 if (arg
->ts
.type
== BT_CHARACTER
)
7050 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
7052 tmp
= size_in_bytes (type
);
7053 tmp
= fold_convert (result_type
, tmp
);
7056 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
7057 build_int_cst (result_type
, BITS_PER_UNIT
));
7058 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7062 /* Intrinsic string comparison functions. */
7065 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
7069 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
7072 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
7073 expr
->value
.function
.actual
->expr
->ts
.kind
,
7075 se
->expr
= fold_build2_loc (input_location
, op
,
7076 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
7077 build_int_cst (TREE_TYPE (se
->expr
), 0));
7080 /* Generate a call to the adjustl/adjustr library function. */
7082 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
7090 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
7093 type
= TREE_TYPE (args
[2]);
7094 var
= gfc_conv_string_tmp (se
, type
, len
);
7097 tmp
= build_call_expr_loc (input_location
,
7098 fndecl
, 3, args
[0], args
[1], args
[2]);
7099 gfc_add_expr_to_block (&se
->pre
, tmp
);
7101 se
->string_length
= len
;
7105 /* Generate code for the TRANSFER intrinsic:
7107 DEST = TRANSFER (SOURCE, MOLD)
7109 typeof<DEST> = typeof<MOLD>
7114 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
7116 typeof<DEST> = typeof<MOLD>
7118 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
7119 sizeof (DEST(0) * SIZE). */
7121 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
7137 gfc_actual_arglist
*arg
;
7139 gfc_array_info
*info
;
7143 gfc_expr
*source_expr
, *mold_expr
;
7147 info
= &se
->ss
->info
->data
.array
;
7149 /* Convert SOURCE. The output from this stage is:-
7150 source_bytes = length of the source in bytes
7151 source = pointer to the source data. */
7152 arg
= expr
->value
.function
.actual
;
7153 source_expr
= arg
->expr
;
7155 /* Ensure double transfer through LOGICAL preserves all
7157 if (arg
->expr
->expr_type
== EXPR_FUNCTION
7158 && arg
->expr
->value
.function
.esym
== NULL
7159 && arg
->expr
->value
.function
.isym
!= NULL
7160 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
7161 && arg
->expr
->ts
.type
== BT_LOGICAL
7162 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
7163 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
7165 gfc_init_se (&argse
, NULL
);
7167 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7169 /* Obtain the pointer to source and the length of source in bytes. */
7170 if (arg
->expr
->rank
== 0)
7172 gfc_conv_expr_reference (&argse
, arg
->expr
);
7173 if (arg
->expr
->ts
.type
== BT_CLASS
)
7174 source
= gfc_class_data_get (argse
.expr
);
7176 source
= argse
.expr
;
7178 /* Obtain the source word length. */
7179 switch (arg
->expr
->ts
.type
)
7182 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7183 argse
.string_length
);
7186 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7189 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7191 tmp
= fold_convert (gfc_array_index_type
,
7192 size_in_bytes (source_type
));
7198 argse
.want_pointer
= 0;
7199 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7200 source
= gfc_conv_descriptor_data_get (argse
.expr
);
7201 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7203 /* Repack the source if not simply contiguous. */
7204 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
7206 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
7208 if (warn_array_temporaries
)
7209 gfc_warning (OPT_Warray_temporaries
,
7210 "Creating array temporary at %L", &expr
->where
);
7212 source
= build_call_expr_loc (input_location
,
7213 gfor_fndecl_in_pack
, 1, tmp
);
7214 source
= gfc_evaluate_now (source
, &argse
.pre
);
7216 /* Free the temporary. */
7217 gfc_start_block (&block
);
7218 tmp
= gfc_call_free (source
);
7219 gfc_add_expr_to_block (&block
, tmp
);
7220 stmt
= gfc_finish_block (&block
);
7222 /* Clean up if it was repacked. */
7223 gfc_init_block (&block
);
7224 tmp
= gfc_conv_array_data (argse
.expr
);
7225 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7227 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
7228 build_empty_stmt (input_location
));
7229 gfc_add_expr_to_block (&block
, tmp
);
7230 gfc_add_block_to_block (&block
, &se
->post
);
7231 gfc_init_block (&se
->post
);
7232 gfc_add_block_to_block (&se
->post
, &block
);
7235 /* Obtain the source word length. */
7236 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
7237 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
7238 argse
.string_length
);
7240 tmp
= fold_convert (gfc_array_index_type
,
7241 size_in_bytes (source_type
));
7243 /* Obtain the size of the array in bytes. */
7244 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
7245 for (n
= 0; n
< arg
->expr
->rank
; n
++)
7248 idx
= gfc_rank_cst
[n
];
7249 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7250 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
7251 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
7252 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7253 gfc_array_index_type
, upper
, lower
);
7254 gfc_add_modify (&argse
.pre
, extent
, tmp
);
7255 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7256 gfc_array_index_type
, extent
,
7257 gfc_index_one_node
);
7258 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7259 gfc_array_index_type
, tmp
, source_bytes
);
7263 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
7264 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7265 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7267 /* Now convert MOLD. The outputs are:
7268 mold_type = the TREE type of MOLD
7269 dest_word_len = destination word length in bytes. */
7271 mold_expr
= arg
->expr
;
7273 gfc_init_se (&argse
, NULL
);
7275 scalar_mold
= arg
->expr
->rank
== 0;
7277 if (arg
->expr
->rank
== 0)
7279 gfc_conv_expr_reference (&argse
, arg
->expr
);
7280 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
7285 gfc_init_se (&argse
, NULL
);
7286 argse
.want_pointer
= 0;
7287 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
7288 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
7291 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7292 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7294 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
7296 /* If this TRANSFER is nested in another TRANSFER, use a type
7297 that preserves all bits. */
7298 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
7299 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
7302 /* Obtain the destination word length. */
7303 switch (arg
->expr
->ts
.type
)
7306 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
7307 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
7310 tmp
= gfc_class_vtab_size_get (argse
.expr
);
7313 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
7316 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
7317 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
7319 /* Finally convert SIZE, if it is present. */
7321 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
7325 gfc_init_se (&argse
, NULL
);
7326 gfc_conv_expr_reference (&argse
, arg
->expr
);
7327 tmp
= convert (gfc_array_index_type
,
7328 build_fold_indirect_ref_loc (input_location
,
7330 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7331 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7336 /* Separate array and scalar results. */
7337 if (scalar_mold
&& tmp
== NULL_TREE
)
7338 goto scalar_transfer
;
7340 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
7341 if (tmp
!= NULL_TREE
)
7342 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7343 tmp
, dest_word_len
);
7347 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
7348 gfc_add_modify (&se
->pre
, size_words
,
7349 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
7350 gfc_array_index_type
,
7351 size_bytes
, dest_word_len
));
7353 /* Evaluate the bounds of the result. If the loop range exists, we have
7354 to check if it is too large. If so, we modify loop->to be consistent
7355 with min(size, size(source)). Otherwise, size is made consistent with
7356 the loop range, so that the right number of bytes is transferred.*/
7357 n
= se
->loop
->order
[0];
7358 if (se
->loop
->to
[n
] != NULL_TREE
)
7360 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7361 se
->loop
->to
[n
], se
->loop
->from
[n
]);
7362 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7363 tmp
, gfc_index_one_node
);
7364 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7366 gfc_add_modify (&se
->pre
, size_words
, tmp
);
7367 gfc_add_modify (&se
->pre
, size_bytes
,
7368 fold_build2_loc (input_location
, MULT_EXPR
,
7369 gfc_array_index_type
,
7370 size_words
, dest_word_len
));
7371 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7372 size_words
, se
->loop
->from
[n
]);
7373 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7374 upper
, gfc_index_one_node
);
7378 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7379 size_words
, gfc_index_one_node
);
7380 se
->loop
->from
[n
] = gfc_index_zero_node
;
7383 se
->loop
->to
[n
] = upper
;
7385 /* Build a destination descriptor, using the pointer, source, as the
7387 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
7388 NULL_TREE
, false, true, false, &expr
->where
);
7390 /* Cast the pointer to the result. */
7391 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7392 tmp
= fold_convert (pvoid_type_node
, tmp
);
7394 /* Use memcpy to do the transfer. */
7396 = build_call_expr_loc (input_location
,
7397 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
7398 fold_convert (pvoid_type_node
, source
),
7399 fold_convert (size_type_node
,
7400 fold_build2_loc (input_location
,
7402 gfc_array_index_type
,
7405 gfc_add_expr_to_block (&se
->pre
, tmp
);
7407 se
->expr
= info
->descriptor
;
7408 if (expr
->ts
.type
== BT_CHARACTER
)
7409 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7413 /* Deal with scalar results. */
7415 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
7416 dest_word_len
, source_bytes
);
7417 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
7418 extent
, gfc_index_zero_node
);
7420 if (expr
->ts
.type
== BT_CHARACTER
)
7422 tree direct
, indirect
, free
;
7424 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
7425 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
7428 /* If source is longer than the destination, use a pointer to
7429 the source directly. */
7430 gfc_init_block (&block
);
7431 gfc_add_modify (&block
, tmpdecl
, ptr
);
7432 direct
= gfc_finish_block (&block
);
7434 /* Otherwise, allocate a string with the length of the destination
7435 and copy the source into it. */
7436 gfc_init_block (&block
);
7437 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
7438 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
7439 gfc_add_modify (&block
, tmpdecl
,
7440 fold_convert (TREE_TYPE (ptr
), tmp
));
7441 tmp
= build_call_expr_loc (input_location
,
7442 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7443 fold_convert (pvoid_type_node
, tmpdecl
),
7444 fold_convert (pvoid_type_node
, ptr
),
7445 fold_convert (size_type_node
, extent
));
7446 gfc_add_expr_to_block (&block
, tmp
);
7447 indirect
= gfc_finish_block (&block
);
7449 /* Wrap it up with the condition. */
7450 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
7451 dest_word_len
, source_bytes
);
7452 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
7453 gfc_add_expr_to_block (&se
->pre
, tmp
);
7455 /* Free the temporary string, if necessary. */
7456 free
= gfc_call_free (tmpdecl
);
7457 tmp
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7458 dest_word_len
, source_bytes
);
7459 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
7460 gfc_add_expr_to_block (&se
->post
, tmp
);
7463 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
7467 tmpdecl
= gfc_create_var (mold_type
, "transfer");
7469 ptr
= convert (build_pointer_type (mold_type
), source
);
7471 /* For CLASS results, allocate the needed memory first. */
7472 if (mold_expr
->ts
.type
== BT_CLASS
)
7475 cdata
= gfc_class_data_get (tmpdecl
);
7476 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
7477 gfc_add_modify (&se
->pre
, cdata
, tmp
);
7480 /* Use memcpy to do the transfer. */
7481 if (mold_expr
->ts
.type
== BT_CLASS
)
7482 tmp
= gfc_class_data_get (tmpdecl
);
7484 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
7486 tmp
= build_call_expr_loc (input_location
,
7487 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
7488 fold_convert (pvoid_type_node
, tmp
),
7489 fold_convert (pvoid_type_node
, ptr
),
7490 fold_convert (size_type_node
, extent
));
7491 gfc_add_expr_to_block (&se
->pre
, tmp
);
7493 /* For CLASS results, set the _vptr. */
7494 if (mold_expr
->ts
.type
== BT_CLASS
)
7498 vptr
= gfc_class_vptr_get (tmpdecl
);
7499 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
7501 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7502 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
7510 /* Generate a call to caf_is_present. */
7513 trans_caf_is_present (gfc_se
*se
, gfc_expr
*expr
)
7515 tree caf_reference
, caf_decl
, token
, image_index
;
7517 /* Compile the reference chain. */
7518 caf_reference
= conv_expr_ref_to_caf_ref (&se
->pre
, expr
);
7519 gcc_assert (caf_reference
!= NULL_TREE
);
7521 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
7522 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
7523 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
7524 image_index
= gfc_caf_get_image_index (&se
->pre
, expr
, caf_decl
);
7525 gfc_get_caf_token_offset (se
, &token
, NULL
, caf_decl
, NULL
,
7528 return build_call_expr_loc (input_location
, gfor_fndecl_caf_is_present
,
7529 3, token
, image_index
, caf_reference
);
7533 /* Test whether this ref-chain refs this image only. */
7536 caf_this_image_ref (gfc_ref
*ref
)
7538 for ( ; ref
; ref
= ref
->next
)
7539 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
7540 return ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
;
7546 /* Generate code for the ALLOCATED intrinsic.
7547 Generate inline code that directly check the address of the argument. */
7550 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
7552 gfc_actual_arglist
*arg1
;
7555 symbol_attribute caf_attr
;
7557 gfc_init_se (&arg1se
, NULL
);
7558 arg1
= expr
->value
.function
.actual
;
7560 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7562 /* Make sure that class array expressions have both a _data
7563 component reference and an array reference.... */
7564 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
7565 gfc_add_class_array_ref (arg1
->expr
);
7566 /* .... whilst scalars only need the _data component. */
7568 gfc_add_data_component (arg1
->expr
);
7571 /* When arg1 references an allocatable component in a coarray, then call
7572 the caf-library function caf_is_present (). */
7573 if (flag_coarray
== GFC_FCOARRAY_LIB
&& arg1
->expr
->expr_type
== EXPR_FUNCTION
7574 && arg1
->expr
->value
.function
.isym
7575 && arg1
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
7576 caf_attr
= gfc_caf_attr (arg1
->expr
->value
.function
.actual
->expr
);
7578 gfc_clear_attr (&caf_attr
);
7579 if (flag_coarray
== GFC_FCOARRAY_LIB
&& caf_attr
.codimension
7580 && !caf_this_image_ref (arg1
->expr
->value
.function
.actual
->expr
->ref
))
7581 tmp
= trans_caf_is_present (se
, arg1
->expr
->value
.function
.actual
->expr
);
7584 if (arg1
->expr
->rank
== 0)
7586 /* Allocatable scalar. */
7587 arg1se
.want_pointer
= 1;
7588 gfc_conv_expr (&arg1se
, arg1
->expr
);
7593 /* Allocatable array. */
7594 arg1se
.descriptor_only
= 1;
7595 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7596 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7599 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
7600 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7602 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7606 /* Generate code for the ASSOCIATED intrinsic.
7607 If both POINTER and TARGET are arrays, generate a call to library function
7608 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7609 In other cases, generate inline code that directly compare the address of
7610 POINTER with the address of TARGET. */
7613 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
7615 gfc_actual_arglist
*arg1
;
7616 gfc_actual_arglist
*arg2
;
7621 tree nonzero_charlen
;
7622 tree nonzero_arraylen
;
7626 gfc_init_se (&arg1se
, NULL
);
7627 gfc_init_se (&arg2se
, NULL
);
7628 arg1
= expr
->value
.function
.actual
;
7631 /* Check whether the expression is a scalar or not; we cannot use
7632 arg1->expr->rank as it can be nonzero for proc pointers. */
7633 ss
= gfc_walk_expr (arg1
->expr
);
7634 scalar
= ss
== gfc_ss_terminator
;
7636 gfc_free_ss_chain (ss
);
7640 /* No optional target. */
7643 /* A pointer to a scalar. */
7644 arg1se
.want_pointer
= 1;
7645 gfc_conv_expr (&arg1se
, arg1
->expr
);
7646 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7647 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7648 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7650 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7652 tmp2
= gfc_class_data_get (arg1se
.expr
);
7653 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7654 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7661 /* A pointer to an array. */
7662 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7663 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
7665 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7666 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7667 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp2
,
7668 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
7673 /* An optional target. */
7674 if (arg2
->expr
->ts
.type
== BT_CLASS
)
7675 gfc_add_data_component (arg2
->expr
);
7677 nonzero_charlen
= NULL_TREE
;
7678 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
7679 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
7681 arg1
->expr
->ts
.u
.cl
->backend_decl
,
7683 (TREE_TYPE (arg1
->expr
->ts
.u
.cl
->backend_decl
)));
7686 /* A pointer to a scalar. */
7687 arg1se
.want_pointer
= 1;
7688 gfc_conv_expr (&arg1se
, arg1
->expr
);
7689 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7690 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
7691 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
7693 if (arg1
->expr
->ts
.type
== BT_CLASS
)
7694 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
7696 arg2se
.want_pointer
= 1;
7697 gfc_conv_expr (&arg2se
, arg2
->expr
);
7698 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7699 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
7700 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
7702 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7703 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7704 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7705 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7706 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7707 arg1se
.expr
, arg2se
.expr
);
7708 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7709 arg1se
.expr
, null_pointer_node
);
7710 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7711 logical_type_node
, tmp
, tmp2
);
7715 /* An array pointer of zero length is not associated if target is
7717 arg1se
.descriptor_only
= 1;
7718 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
7719 if (arg1
->expr
->rank
== -1)
7721 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
7722 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7723 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
7726 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
7727 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
7728 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
7729 logical_type_node
, tmp
,
7730 build_int_cst (TREE_TYPE (tmp
), 0));
7732 /* A pointer to an array, call library function _gfor_associated. */
7733 arg1se
.want_pointer
= 1;
7734 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
7736 arg2se
.want_pointer
= 1;
7737 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
7738 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7739 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7740 se
->expr
= build_call_expr_loc (input_location
,
7741 gfor_fndecl_associated
, 2,
7742 arg1se
.expr
, arg2se
.expr
);
7743 se
->expr
= convert (logical_type_node
, se
->expr
);
7744 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7745 logical_type_node
, se
->expr
,
7749 /* If target is present zero character length pointers cannot
7751 if (nonzero_charlen
!= NULL_TREE
)
7752 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7754 se
->expr
, nonzero_charlen
);
7757 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7761 /* Generate code for the SAME_TYPE_AS intrinsic.
7762 Generate inline code that directly checks the vindices. */
7765 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
7770 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
7772 gfc_init_se (&se1
, NULL
);
7773 gfc_init_se (&se2
, NULL
);
7775 a
= expr
->value
.function
.actual
->expr
;
7776 b
= expr
->value
.function
.actual
->next
->expr
;
7778 if (UNLIMITED_POLY (a
))
7780 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
7781 conda
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7782 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7785 if (UNLIMITED_POLY (b
))
7787 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
7788 condb
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7789 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
7792 if (a
->ts
.type
== BT_CLASS
)
7794 gfc_add_vptr_component (a
);
7795 gfc_add_hash_component (a
);
7797 else if (a
->ts
.type
== BT_DERIVED
)
7798 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7799 a
->ts
.u
.derived
->hash_value
);
7801 if (b
->ts
.type
== BT_CLASS
)
7803 gfc_add_vptr_component (b
);
7804 gfc_add_hash_component (b
);
7806 else if (b
->ts
.type
== BT_DERIVED
)
7807 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7808 b
->ts
.u
.derived
->hash_value
);
7810 gfc_conv_expr (&se1
, a
);
7811 gfc_conv_expr (&se2
, b
);
7813 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
7814 logical_type_node
, se1
.expr
,
7815 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
7818 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7819 logical_type_node
, conda
, tmp
);
7822 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7823 logical_type_node
, condb
, tmp
);
7825 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
7829 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
7832 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
7836 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
7837 se
->expr
= build_call_expr_loc (input_location
,
7838 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
7839 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7843 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
7846 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
7850 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7852 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
7853 type
= gfc_get_int_type (4);
7854 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
7856 /* Convert it to the required type. */
7857 type
= gfc_typenode_for_spec (&expr
->ts
);
7858 se
->expr
= build_call_expr_loc (input_location
,
7859 gfor_fndecl_si_kind
, 1, arg
);
7860 se
->expr
= fold_convert (type
, se
->expr
);
7864 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
7867 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
7869 gfc_actual_arglist
*actual
;
7872 vec
<tree
, va_gc
> *args
= NULL
;
7874 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
7876 gfc_init_se (&argse
, se
);
7878 /* Pass a NULL pointer for an absent arg. */
7879 if (actual
->expr
== NULL
)
7880 argse
.expr
= null_pointer_node
;
7886 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
7888 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
7889 ts
.type
= BT_INTEGER
;
7890 ts
.kind
= gfc_c_int_kind
;
7891 gfc_convert_type (actual
->expr
, &ts
, 2);
7893 gfc_conv_expr_reference (&argse
, actual
->expr
);
7896 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7897 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7898 vec_safe_push (args
, argse
.expr
);
7901 /* Convert it to the required type. */
7902 type
= gfc_typenode_for_spec (&expr
->ts
);
7903 se
->expr
= build_call_expr_loc_vec (input_location
,
7904 gfor_fndecl_sr_kind
, args
);
7905 se
->expr
= fold_convert (type
, se
->expr
);
7909 /* Generate code for TRIM (A) intrinsic function. */
7912 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
7922 unsigned int num_args
;
7924 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
7925 args
= XALLOCAVEC (tree
, num_args
);
7927 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
7928 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
7929 len
= gfc_create_var (gfc_charlen_type_node
, "len");
7931 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
7932 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
7935 if (expr
->ts
.kind
== 1)
7936 function
= gfor_fndecl_string_trim
;
7937 else if (expr
->ts
.kind
== 4)
7938 function
= gfor_fndecl_string_trim_char4
;
7942 fndecl
= build_addr (function
);
7943 tmp
= build_call_array_loc (input_location
,
7944 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
7946 gfc_add_expr_to_block (&se
->pre
, tmp
);
7948 /* Free the temporary afterwards, if necessary. */
7949 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
7950 len
, build_int_cst (TREE_TYPE (len
), 0));
7951 tmp
= gfc_call_free (var
);
7952 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
7953 gfc_add_expr_to_block (&se
->post
, tmp
);
7956 se
->string_length
= len
;
7960 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
7963 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
7965 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
7966 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
7968 stmtblock_t block
, body
;
7971 /* We store in charsize the size of a character. */
7972 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
7973 size
= build_int_cst (sizetype
, gfc_character_kinds
[i
].bit_size
/ 8);
7975 /* Get the arguments. */
7976 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7977 slen
= fold_convert (sizetype
, gfc_evaluate_now (args
[0], &se
->pre
));
7979 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
7980 ncopies_type
= TREE_TYPE (ncopies
);
7982 /* Check that NCOPIES is not negative. */
7983 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, ncopies
,
7984 build_int_cst (ncopies_type
, 0));
7985 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7986 "Argument NCOPIES of REPEAT intrinsic is negative "
7987 "(its value is %ld)",
7988 fold_convert (long_integer_type_node
, ncopies
));
7990 /* If the source length is zero, any non negative value of NCOPIES
7991 is valid, and nothing happens. */
7992 n
= gfc_create_var (ncopies_type
, "ncopies");
7993 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
7995 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
7996 build_int_cst (ncopies_type
, 0), ncopies
);
7997 gfc_add_modify (&se
->pre
, n
, tmp
);
8000 /* Check that ncopies is not too large: ncopies should be less than
8001 (or equal to) MAX / slen, where MAX is the maximal integer of
8002 the gfc_charlen_type_node type. If slen == 0, we need a special
8003 case to avoid the division by zero. */
8004 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, sizetype
,
8005 fold_convert (sizetype
,
8006 TYPE_MAX_VALUE (gfc_charlen_type_node
)),
8008 largest
= TYPE_PRECISION (sizetype
) > TYPE_PRECISION (ncopies_type
)
8009 ? sizetype
: ncopies_type
;
8010 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
8011 fold_convert (largest
, ncopies
),
8012 fold_convert (largest
, max
));
8013 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, slen
,
8015 cond
= fold_build3_loc (input_location
, COND_EXPR
, logical_type_node
, tmp
,
8016 logical_false_node
, cond
);
8017 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
8018 "Argument NCOPIES of REPEAT intrinsic is too large");
8020 /* Compute the destination length. */
8021 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
8022 fold_convert (gfc_charlen_type_node
, slen
),
8023 fold_convert (gfc_charlen_type_node
, ncopies
));
8024 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
8025 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
8027 /* Generate the code to do the repeat operation:
8028 for (i = 0; i < ncopies; i++)
8029 memmove (dest + (i * slen * size), src, slen*size); */
8030 gfc_start_block (&block
);
8031 count
= gfc_create_var (sizetype
, "count");
8032 gfc_add_modify (&block
, count
, size_zero_node
);
8033 exit_label
= gfc_build_label_decl (NULL_TREE
);
8035 /* Start the loop body. */
8036 gfc_start_block (&body
);
8038 /* Exit the loop if count >= ncopies. */
8039 cond
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
, count
,
8040 fold_convert (sizetype
, ncopies
));
8041 tmp
= build1_v (GOTO_EXPR
, exit_label
);
8042 TREE_USED (exit_label
) = 1;
8043 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
8044 build_empty_stmt (input_location
));
8045 gfc_add_expr_to_block (&body
, tmp
);
8047 /* Call memmove (dest + (i*slen*size), src, slen*size). */
8048 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, slen
,
8050 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, sizetype
, tmp
,
8052 tmp
= fold_build_pointer_plus_loc (input_location
,
8053 fold_convert (pvoid_type_node
, dest
), tmp
);
8054 tmp
= build_call_expr_loc (input_location
,
8055 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
8057 fold_build2_loc (input_location
, MULT_EXPR
,
8058 size_type_node
, slen
, size
));
8059 gfc_add_expr_to_block (&body
, tmp
);
8061 /* Increment count. */
8062 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, sizetype
,
8063 count
, size_one_node
);
8064 gfc_add_modify (&body
, count
, tmp
);
8066 /* Build the loop. */
8067 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
8068 gfc_add_expr_to_block (&block
, tmp
);
8070 /* Add the exit label. */
8071 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8072 gfc_add_expr_to_block (&block
, tmp
);
8074 /* Finish the block. */
8075 tmp
= gfc_finish_block (&block
);
8076 gfc_add_expr_to_block (&se
->pre
, tmp
);
8078 /* Set the result value. */
8080 se
->string_length
= dlen
;
8084 /* Generate code for the IARGC intrinsic. */
8087 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
8093 /* Call the library function. This always returns an INTEGER(4). */
8094 fndecl
= gfor_fndecl_iargc
;
8095 tmp
= build_call_expr_loc (input_location
,
8098 /* Convert it to the required type. */
8099 type
= gfc_typenode_for_spec (&expr
->ts
);
8100 tmp
= fold_convert (type
, tmp
);
8106 /* The loc intrinsic returns the address of its argument as
8107 gfc_index_integer_kind integer. */
8110 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
8115 gcc_assert (!se
->ss
);
8117 arg_expr
= expr
->value
.function
.actual
->expr
;
8118 if (arg_expr
->rank
== 0)
8120 if (arg_expr
->ts
.type
== BT_CLASS
)
8121 gfc_add_data_component (arg_expr
);
8122 gfc_conv_expr_reference (se
, arg_expr
);
8125 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
8126 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
8128 /* Create a temporary variable for loc return value. Without this,
8129 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
8130 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
8131 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
8132 se
->expr
= temp_var
;
8136 /* The following routine generates code for the intrinsic
8137 functions from the ISO_C_BINDING module:
8143 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
8145 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
8147 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
8149 if (arg
->expr
->rank
== 0)
8150 gfc_conv_expr_reference (se
, arg
->expr
);
8151 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
8152 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
8155 gfc_conv_expr_descriptor (se
, arg
->expr
);
8156 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
8159 /* TODO -- the following two lines shouldn't be necessary, but if
8160 they're removed, a bug is exposed later in the code path.
8161 This workaround was thus introduced, but will have to be
8162 removed; please see PR 35150 for details about the issue. */
8163 se
->expr
= convert (pvoid_type_node
, se
->expr
);
8164 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
8166 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
8167 gfc_conv_expr_reference (se
, arg
->expr
);
8168 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
8173 /* Build the addr_expr for the first argument. The argument is
8174 already an *address* so we don't need to set want_pointer in
8176 gfc_init_se (&arg1se
, NULL
);
8177 gfc_conv_expr (&arg1se
, arg
->expr
);
8178 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
8179 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
8181 /* See if we were given two arguments. */
8182 if (arg
->next
->expr
== NULL
)
8183 /* Only given one arg so generate a null and do a
8184 not-equal comparison against the first arg. */
8185 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8187 fold_convert (TREE_TYPE (arg1se
.expr
),
8188 null_pointer_node
));
8194 /* Given two arguments so build the arg2se from second arg. */
8195 gfc_init_se (&arg2se
, NULL
);
8196 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
8197 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
8198 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
8200 /* Generate test to compare that the two args are equal. */
8201 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8202 arg1se
.expr
, arg2se
.expr
);
8203 /* Generate test to ensure that the first arg is not null. */
8204 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
8206 arg1se
.expr
, null_pointer_node
);
8208 /* Finally, the generated test must check that both arg1 is not
8209 NULL and that it is equal to the second arg. */
8210 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8212 not_null_expr
, eq_expr
);
8220 /* The following routine generates code for the intrinsic
8221 subroutines from the ISO_C_BINDING module:
8223 * C_F_PROCPOINTER. */
8226 conv_isocbinding_subroutine (gfc_code
*code
)
8233 tree desc
, dim
, tmp
, stride
, offset
;
8234 stmtblock_t body
, block
;
8236 gfc_actual_arglist
*arg
= code
->ext
.actual
;
8238 gfc_init_se (&se
, NULL
);
8239 gfc_init_se (&cptrse
, NULL
);
8240 gfc_conv_expr (&cptrse
, arg
->expr
);
8241 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
8242 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
8244 gfc_init_se (&fptrse
, NULL
);
8245 if (arg
->next
->expr
->rank
== 0)
8247 fptrse
.want_pointer
= 1;
8248 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
8249 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
8250 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
8251 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
8252 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
8253 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
8255 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
8256 TREE_TYPE (fptrse
.expr
),
8258 fold_convert (TREE_TYPE (fptrse
.expr
),
8260 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
8261 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8262 return gfc_finish_block (&se
.pre
);
8265 gfc_start_block (&block
);
8267 /* Get the descriptor of the Fortran pointer. */
8268 fptrse
.descriptor_only
= 1;
8269 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
8270 gfc_add_block_to_block (&block
, &fptrse
.pre
);
8273 /* Set the span field. */
8274 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc
)));
8275 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8276 gfc_conv_descriptor_span_set (&block
, desc
, tmp
);
8278 /* Set data value, dtype, and offset. */
8279 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
8280 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
8281 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
8282 gfc_get_dtype (TREE_TYPE (desc
)));
8284 /* Start scalarization of the bounds, using the shape argument. */
8286 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
8287 gcc_assert (shape_ss
!= gfc_ss_terminator
);
8288 gfc_init_se (&shapese
, NULL
);
8290 gfc_init_loopinfo (&loop
);
8291 gfc_add_ss_to_loop (&loop
, shape_ss
);
8292 gfc_conv_ss_startstride (&loop
);
8293 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
8294 gfc_mark_ss_chain_used (shape_ss
, 1);
8296 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
8297 shapese
.ss
= shape_ss
;
8299 stride
= gfc_create_var (gfc_array_index_type
, "stride");
8300 offset
= gfc_create_var (gfc_array_index_type
, "offset");
8301 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
8302 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8305 gfc_start_scalarized_body (&loop
, &body
);
8307 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8308 loop
.loopvar
[0], loop
.from
[0]);
8310 /* Set bounds and stride. */
8311 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
8312 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
8314 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
8315 gfc_add_block_to_block (&body
, &shapese
.pre
);
8316 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
8317 gfc_add_block_to_block (&body
, &shapese
.post
);
8319 /* Calculate offset. */
8320 gfc_add_modify (&body
, offset
,
8321 fold_build2_loc (input_location
, PLUS_EXPR
,
8322 gfc_array_index_type
, offset
, stride
));
8323 /* Update stride. */
8324 gfc_add_modify (&body
, stride
,
8325 fold_build2_loc (input_location
, MULT_EXPR
,
8326 gfc_array_index_type
, stride
,
8327 fold_convert (gfc_array_index_type
,
8329 /* Finish scalarization loop. */
8330 gfc_trans_scalarizing_loops (&loop
, &body
);
8331 gfc_add_block_to_block (&block
, &loop
.pre
);
8332 gfc_add_block_to_block (&block
, &loop
.post
);
8333 gfc_add_block_to_block (&block
, &fptrse
.post
);
8334 gfc_cleanup_loop (&loop
);
8336 gfc_add_modify (&block
, offset
,
8337 fold_build1_loc (input_location
, NEGATE_EXPR
,
8338 gfc_array_index_type
, offset
));
8339 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
8341 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
8342 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8343 return gfc_finish_block (&se
.pre
);
8347 /* Save and restore floating-point state. */
8350 gfc_save_fp_state (stmtblock_t
*block
)
8352 tree type
, fpstate
, tmp
;
8354 type
= build_array_type (char_type_node
,
8355 build_range_type (size_type_node
, size_zero_node
,
8356 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
8357 fpstate
= gfc_create_var (type
, "fpstate");
8358 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
8360 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
8362 gfc_add_expr_to_block (block
, tmp
);
8369 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
8373 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
8375 gfc_add_expr_to_block (block
, tmp
);
8379 /* Generate code for arguments of IEEE functions. */
8382 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
8385 gfc_actual_arglist
*actual
;
8390 actual
= expr
->value
.function
.actual
;
8391 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
8393 gcc_assert (actual
);
8396 gfc_init_se (&argse
, se
);
8397 gfc_conv_expr_val (&argse
, e
);
8399 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
8400 gfc_add_block_to_block (&se
->post
, &argse
.post
);
8401 argarray
[arg
] = argse
.expr
;
8406 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8407 and IEEE_UNORDERED, which translate directly to GCC type-generic
8411 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
8412 enum built_in_function code
, int nargs
)
8415 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
8417 conv_ieee_function_args (se
, expr
, args
, nargs
);
8418 se
->expr
= build_call_expr_loc_array (input_location
,
8419 builtin_decl_explicit (code
),
8421 STRIP_TYPE_NOPS (se
->expr
);
8422 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8426 /* Generate code for IEEE_IS_NORMAL intrinsic:
8427 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8430 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
8432 tree arg
, isnormal
, iszero
;
8434 /* Convert arg, evaluate it only once. */
8435 conv_ieee_function_args (se
, expr
, &arg
, 1);
8436 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8438 isnormal
= build_call_expr_loc (input_location
,
8439 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
8441 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, arg
,
8442 build_real_from_int_cst (TREE_TYPE (arg
),
8443 integer_zero_node
));
8444 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8445 logical_type_node
, isnormal
, iszero
);
8446 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8450 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8451 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8454 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
8456 tree arg
, signbit
, isnan
;
8458 /* Convert arg, evaluate it only once. */
8459 conv_ieee_function_args (se
, expr
, &arg
, 1);
8460 arg
= gfc_evaluate_now (arg
, &se
->pre
);
8462 isnan
= build_call_expr_loc (input_location
,
8463 builtin_decl_explicit (BUILT_IN_ISNAN
),
8465 STRIP_TYPE_NOPS (isnan
);
8467 signbit
= build_call_expr_loc (input_location
,
8468 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8470 signbit
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8471 signbit
, integer_zero_node
);
8473 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
8474 logical_type_node
, signbit
,
8475 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
8476 TREE_TYPE(isnan
), isnan
));
8478 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
8482 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8485 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
8486 enum built_in_function code
)
8488 tree arg
, decl
, call
, fpstate
;
8491 conv_ieee_function_args (se
, expr
, &arg
, 1);
8492 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
8493 decl
= builtin_decl_for_precision (code
, argprec
);
8495 /* Save floating-point state. */
8496 fpstate
= gfc_save_fp_state (&se
->pre
);
8498 /* Make the function call. */
8499 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
8500 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
8502 /* Restore floating-point state. */
8503 gfc_restore_fp_state (&se
->post
, fpstate
);
8507 /* Generate code for IEEE_REM. */
8510 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
8512 tree args
[2], decl
, call
, fpstate
;
8515 conv_ieee_function_args (se
, expr
, args
, 2);
8517 /* If arguments have unequal size, convert them to the larger. */
8518 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
8519 > TYPE_PRECISION (TREE_TYPE (args
[1])))
8520 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8521 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
8522 > TYPE_PRECISION (TREE_TYPE (args
[0])))
8523 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
8525 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8526 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
8528 /* Save floating-point state. */
8529 fpstate
= gfc_save_fp_state (&se
->pre
);
8531 /* Make the function call. */
8532 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8533 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8535 /* Restore floating-point state. */
8536 gfc_restore_fp_state (&se
->post
, fpstate
);
8540 /* Generate code for IEEE_NEXT_AFTER. */
8543 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
8545 tree args
[2], decl
, call
, fpstate
;
8548 conv_ieee_function_args (se
, expr
, args
, 2);
8550 /* Result has the characteristics of first argument. */
8551 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
8552 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8553 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
8555 /* Save floating-point state. */
8556 fpstate
= gfc_save_fp_state (&se
->pre
);
8558 /* Make the function call. */
8559 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8560 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8562 /* Restore floating-point state. */
8563 gfc_restore_fp_state (&se
->post
, fpstate
);
8567 /* Generate code for IEEE_SCALB. */
8570 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
8572 tree args
[2], decl
, call
, huge
, type
;
8575 conv_ieee_function_args (se
, expr
, args
, 2);
8577 /* Result has the characteristics of first argument. */
8578 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8579 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
8581 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
8583 /* We need to fold the integer into the range of a C int. */
8584 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
8585 type
= TREE_TYPE (args
[1]);
8587 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
8588 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
8590 huge
= fold_convert (type
, huge
);
8591 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
8593 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
8594 fold_build1_loc (input_location
, NEGATE_EXPR
,
8598 args
[1] = fold_convert (integer_type_node
, args
[1]);
8600 /* Make the function call. */
8601 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8602 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
8606 /* Generate code for IEEE_COPY_SIGN. */
8609 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
8611 tree args
[2], decl
, sign
;
8614 conv_ieee_function_args (se
, expr
, args
, 2);
8616 /* Get the sign of the second argument. */
8617 sign
= build_call_expr_loc (input_location
,
8618 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
8620 sign
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
8621 sign
, integer_zero_node
);
8623 /* Create a value of one, with the right sign. */
8624 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
8626 fold_build1_loc (input_location
, NEGATE_EXPR
,
8630 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
8632 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
8633 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
8635 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
8639 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8643 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
8645 const char *name
= expr
->value
.function
.name
;
8647 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8649 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
8650 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
8651 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
8652 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
8653 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
8654 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
8655 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
8656 conv_intrinsic_ieee_is_normal (se
, expr
);
8657 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
8658 conv_intrinsic_ieee_is_negative (se
, expr
);
8659 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
8660 conv_intrinsic_ieee_copy_sign (se
, expr
);
8661 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
8662 conv_intrinsic_ieee_scalb (se
, expr
);
8663 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
8664 conv_intrinsic_ieee_next_after (se
, expr
);
8665 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
8666 conv_intrinsic_ieee_rem (se
, expr
);
8667 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
8668 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
8669 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
8670 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
8672 /* It is not among the functions we translate directly. We return
8673 false, so a library function call is emitted. */
8682 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8685 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
8687 tree arg
, res
, restype
;
8689 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
8690 arg
= fold_convert (size_type_node
, arg
);
8691 res
= build_call_expr_loc (input_location
,
8692 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
8693 restype
= gfc_typenode_for_spec (&expr
->ts
);
8694 se
->expr
= fold_convert (restype
, res
);
8698 /* Generate code for an intrinsic function. Some map directly to library
8699 calls, others get special handling. In some cases the name of the function
8700 used depends on the type specifiers. */
8703 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
8709 name
= &expr
->value
.function
.name
[2];
8713 lib
= gfc_is_intrinsic_libcall (expr
);
8717 se
->ignore_optional
= 1;
8719 switch (expr
->value
.function
.isym
->id
)
8721 case GFC_ISYM_EOSHIFT
:
8723 case GFC_ISYM_RESHAPE
:
8724 /* For all of those the first argument specifies the type and the
8725 third is optional. */
8726 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
8729 case GFC_ISYM_MINLOC
:
8730 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8733 case GFC_ISYM_MAXLOC
:
8734 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8737 case GFC_ISYM_SHAPE
:
8738 gfc_conv_intrinsic_shape (se
, expr
);
8742 gfc_conv_intrinsic_funcall (se
, expr
);
8750 switch (expr
->value
.function
.isym
->id
)
8755 case GFC_ISYM_REPEAT
:
8756 gfc_conv_intrinsic_repeat (se
, expr
);
8760 gfc_conv_intrinsic_trim (se
, expr
);
8763 case GFC_ISYM_SC_KIND
:
8764 gfc_conv_intrinsic_sc_kind (se
, expr
);
8767 case GFC_ISYM_SI_KIND
:
8768 gfc_conv_intrinsic_si_kind (se
, expr
);
8771 case GFC_ISYM_SR_KIND
:
8772 gfc_conv_intrinsic_sr_kind (se
, expr
);
8775 case GFC_ISYM_EXPONENT
:
8776 gfc_conv_intrinsic_exponent (se
, expr
);
8780 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8782 fndecl
= gfor_fndecl_string_scan
;
8784 fndecl
= gfor_fndecl_string_scan_char4
;
8788 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8791 case GFC_ISYM_VERIFY
:
8792 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8794 fndecl
= gfor_fndecl_string_verify
;
8796 fndecl
= gfor_fndecl_string_verify_char4
;
8800 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8803 case GFC_ISYM_ALLOCATED
:
8804 gfc_conv_allocated (se
, expr
);
8807 case GFC_ISYM_ASSOCIATED
:
8808 gfc_conv_associated(se
, expr
);
8811 case GFC_ISYM_SAME_TYPE_AS
:
8812 gfc_conv_same_type_as (se
, expr
);
8816 gfc_conv_intrinsic_abs (se
, expr
);
8819 case GFC_ISYM_ADJUSTL
:
8820 if (expr
->ts
.kind
== 1)
8821 fndecl
= gfor_fndecl_adjustl
;
8822 else if (expr
->ts
.kind
== 4)
8823 fndecl
= gfor_fndecl_adjustl_char4
;
8827 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8830 case GFC_ISYM_ADJUSTR
:
8831 if (expr
->ts
.kind
== 1)
8832 fndecl
= gfor_fndecl_adjustr
;
8833 else if (expr
->ts
.kind
== 4)
8834 fndecl
= gfor_fndecl_adjustr_char4
;
8838 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
8841 case GFC_ISYM_AIMAG
:
8842 gfc_conv_intrinsic_imagpart (se
, expr
);
8846 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
8850 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
8853 case GFC_ISYM_ANINT
:
8854 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
8858 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8862 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
8865 case GFC_ISYM_BTEST
:
8866 gfc_conv_intrinsic_btest (se
, expr
);
8870 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
8874 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
8878 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
8882 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
8885 case GFC_ISYM_C_ASSOCIATED
:
8886 case GFC_ISYM_C_FUNLOC
:
8887 case GFC_ISYM_C_LOC
:
8888 conv_isocbinding_function (se
, expr
);
8891 case GFC_ISYM_ACHAR
:
8893 gfc_conv_intrinsic_char (se
, expr
);
8896 case GFC_ISYM_CONVERSION
:
8898 case GFC_ISYM_LOGICAL
:
8900 gfc_conv_intrinsic_conversion (se
, expr
);
8903 /* Integer conversions are handled separately to make sure we get the
8904 correct rounding mode. */
8909 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
8913 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
8916 case GFC_ISYM_CEILING
:
8917 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
8920 case GFC_ISYM_FLOOR
:
8921 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
8925 gfc_conv_intrinsic_mod (se
, expr
, 0);
8928 case GFC_ISYM_MODULO
:
8929 gfc_conv_intrinsic_mod (se
, expr
, 1);
8932 case GFC_ISYM_CAF_GET
:
8933 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
8937 case GFC_ISYM_CMPLX
:
8938 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
8941 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
8942 gfc_conv_intrinsic_iargc (se
, expr
);
8945 case GFC_ISYM_COMPLEX
:
8946 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
8949 case GFC_ISYM_CONJG
:
8950 gfc_conv_intrinsic_conjg (se
, expr
);
8953 case GFC_ISYM_COUNT
:
8954 gfc_conv_intrinsic_count (se
, expr
);
8957 case GFC_ISYM_CTIME
:
8958 gfc_conv_intrinsic_ctime (se
, expr
);
8962 gfc_conv_intrinsic_dim (se
, expr
);
8965 case GFC_ISYM_DOT_PRODUCT
:
8966 gfc_conv_intrinsic_dot_product (se
, expr
);
8969 case GFC_ISYM_DPROD
:
8970 gfc_conv_intrinsic_dprod (se
, expr
);
8973 case GFC_ISYM_DSHIFTL
:
8974 gfc_conv_intrinsic_dshift (se
, expr
, true);
8977 case GFC_ISYM_DSHIFTR
:
8978 gfc_conv_intrinsic_dshift (se
, expr
, false);
8981 case GFC_ISYM_FDATE
:
8982 gfc_conv_intrinsic_fdate (se
, expr
);
8985 case GFC_ISYM_FRACTION
:
8986 gfc_conv_intrinsic_fraction (se
, expr
);
8990 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
8994 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8998 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
9001 case GFC_ISYM_IBCLR
:
9002 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
9005 case GFC_ISYM_IBITS
:
9006 gfc_conv_intrinsic_ibits (se
, expr
);
9009 case GFC_ISYM_IBSET
:
9010 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
9013 case GFC_ISYM_IACHAR
:
9014 case GFC_ISYM_ICHAR
:
9015 /* We assume ASCII character sequence. */
9016 gfc_conv_intrinsic_ichar (se
, expr
);
9019 case GFC_ISYM_IARGC
:
9020 gfc_conv_intrinsic_iargc (se
, expr
);
9024 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9027 case GFC_ISYM_INDEX
:
9028 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
9030 fndecl
= gfor_fndecl_string_index
;
9032 fndecl
= gfor_fndecl_string_index_char4
;
9036 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
9040 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9043 case GFC_ISYM_IPARITY
:
9044 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
9047 case GFC_ISYM_IS_IOSTAT_END
:
9048 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
9051 case GFC_ISYM_IS_IOSTAT_EOR
:
9052 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
9055 case GFC_ISYM_ISNAN
:
9056 gfc_conv_intrinsic_isnan (se
, expr
);
9059 case GFC_ISYM_LSHIFT
:
9060 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9063 case GFC_ISYM_RSHIFT
:
9064 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9067 case GFC_ISYM_SHIFTA
:
9068 gfc_conv_intrinsic_shift (se
, expr
, true, true);
9071 case GFC_ISYM_SHIFTL
:
9072 gfc_conv_intrinsic_shift (se
, expr
, false, false);
9075 case GFC_ISYM_SHIFTR
:
9076 gfc_conv_intrinsic_shift (se
, expr
, true, false);
9079 case GFC_ISYM_ISHFT
:
9080 gfc_conv_intrinsic_ishft (se
, expr
);
9083 case GFC_ISYM_ISHFTC
:
9084 gfc_conv_intrinsic_ishftc (se
, expr
);
9087 case GFC_ISYM_LEADZ
:
9088 gfc_conv_intrinsic_leadz (se
, expr
);
9091 case GFC_ISYM_TRAILZ
:
9092 gfc_conv_intrinsic_trailz (se
, expr
);
9095 case GFC_ISYM_POPCNT
:
9096 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
9099 case GFC_ISYM_POPPAR
:
9100 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
9103 case GFC_ISYM_LBOUND
:
9104 gfc_conv_intrinsic_bound (se
, expr
, 0);
9107 case GFC_ISYM_LCOBOUND
:
9108 conv_intrinsic_cobound (se
, expr
);
9111 case GFC_ISYM_TRANSPOSE
:
9112 /* The scalarizer has already been set up for reversed dimension access
9113 order ; now we just get the argument value normally. */
9114 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
9118 gfc_conv_intrinsic_len (se
, expr
);
9121 case GFC_ISYM_LEN_TRIM
:
9122 gfc_conv_intrinsic_len_trim (se
, expr
);
9126 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
9130 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
9134 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
9138 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
9141 case GFC_ISYM_MALLOC
:
9142 gfc_conv_intrinsic_malloc (se
, expr
);
9145 case GFC_ISYM_MASKL
:
9146 gfc_conv_intrinsic_mask (se
, expr
, 1);
9149 case GFC_ISYM_MASKR
:
9150 gfc_conv_intrinsic_mask (se
, expr
, 0);
9154 if (expr
->ts
.type
== BT_CHARACTER
)
9155 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
9157 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
9160 case GFC_ISYM_MAXLOC
:
9161 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
9164 case GFC_ISYM_MAXVAL
:
9165 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
9168 case GFC_ISYM_MERGE
:
9169 gfc_conv_intrinsic_merge (se
, expr
);
9172 case GFC_ISYM_MERGE_BITS
:
9173 gfc_conv_intrinsic_merge_bits (se
, expr
);
9177 if (expr
->ts
.type
== BT_CHARACTER
)
9178 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
9180 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
9183 case GFC_ISYM_MINLOC
:
9184 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
9187 case GFC_ISYM_MINVAL
:
9188 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
9191 case GFC_ISYM_NEAREST
:
9192 gfc_conv_intrinsic_nearest (se
, expr
);
9195 case GFC_ISYM_NORM2
:
9196 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
9200 gfc_conv_intrinsic_not (se
, expr
);
9204 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
9207 case GFC_ISYM_PARITY
:
9208 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
9211 case GFC_ISYM_PRESENT
:
9212 gfc_conv_intrinsic_present (se
, expr
);
9215 case GFC_ISYM_PRODUCT
:
9216 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
9220 gfc_conv_intrinsic_rank (se
, expr
);
9223 case GFC_ISYM_RRSPACING
:
9224 gfc_conv_intrinsic_rrspacing (se
, expr
);
9227 case GFC_ISYM_SET_EXPONENT
:
9228 gfc_conv_intrinsic_set_exponent (se
, expr
);
9231 case GFC_ISYM_SCALE
:
9232 gfc_conv_intrinsic_scale (se
, expr
);
9236 gfc_conv_intrinsic_sign (se
, expr
);
9240 gfc_conv_intrinsic_size (se
, expr
);
9243 case GFC_ISYM_SIZEOF
:
9244 case GFC_ISYM_C_SIZEOF
:
9245 gfc_conv_intrinsic_sizeof (se
, expr
);
9248 case GFC_ISYM_STORAGE_SIZE
:
9249 gfc_conv_intrinsic_storage_size (se
, expr
);
9252 case GFC_ISYM_SPACING
:
9253 gfc_conv_intrinsic_spacing (se
, expr
);
9256 case GFC_ISYM_STRIDE
:
9257 conv_intrinsic_stride (se
, expr
);
9261 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
9264 case GFC_ISYM_TEAM_NUMBER
:
9265 conv_intrinsic_team_number (se
, expr
);
9268 case GFC_ISYM_TRANSFER
:
9269 if (se
->ss
&& se
->ss
->info
->useflags
)
9270 /* Access the previously obtained result. */
9271 gfc_conv_tmp_array_ref (se
);
9273 gfc_conv_intrinsic_transfer (se
, expr
);
9276 case GFC_ISYM_TTYNAM
:
9277 gfc_conv_intrinsic_ttynam (se
, expr
);
9280 case GFC_ISYM_UBOUND
:
9281 gfc_conv_intrinsic_bound (se
, expr
, 1);
9284 case GFC_ISYM_UCOBOUND
:
9285 conv_intrinsic_cobound (se
, expr
);
9289 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
9293 gfc_conv_intrinsic_loc (se
, expr
);
9296 case GFC_ISYM_THIS_IMAGE
:
9297 /* For num_images() == 1, handle as LCOBOUND. */
9298 if (expr
->value
.function
.actual
->expr
9299 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
9300 conv_intrinsic_cobound (se
, expr
);
9302 trans_this_image (se
, expr
);
9305 case GFC_ISYM_IMAGE_INDEX
:
9306 trans_image_index (se
, expr
);
9309 case GFC_ISYM_IMAGE_STATUS
:
9310 conv_intrinsic_image_status (se
, expr
);
9313 case GFC_ISYM_NUM_IMAGES
:
9314 trans_num_images (se
, expr
);
9317 case GFC_ISYM_ACCESS
:
9318 case GFC_ISYM_CHDIR
:
9319 case GFC_ISYM_CHMOD
:
9320 case GFC_ISYM_DTIME
:
9321 case GFC_ISYM_ETIME
:
9322 case GFC_ISYM_EXTENDS_TYPE_OF
:
9324 case GFC_ISYM_FGETC
:
9327 case GFC_ISYM_FPUTC
:
9328 case GFC_ISYM_FSTAT
:
9329 case GFC_ISYM_FTELL
:
9330 case GFC_ISYM_GETCWD
:
9331 case GFC_ISYM_GETGID
:
9332 case GFC_ISYM_GETPID
:
9333 case GFC_ISYM_GETUID
:
9334 case GFC_ISYM_HOSTNM
:
9336 case GFC_ISYM_IERRNO
:
9337 case GFC_ISYM_IRAND
:
9338 case GFC_ISYM_ISATTY
:
9341 case GFC_ISYM_LSTAT
:
9342 case GFC_ISYM_MATMUL
:
9343 case GFC_ISYM_MCLOCK
:
9344 case GFC_ISYM_MCLOCK8
:
9346 case GFC_ISYM_RENAME
:
9347 case GFC_ISYM_SECOND
:
9348 case GFC_ISYM_SECNDS
:
9349 case GFC_ISYM_SIGNAL
:
9351 case GFC_ISYM_SYMLNK
:
9352 case GFC_ISYM_SYSTEM
:
9354 case GFC_ISYM_TIME8
:
9355 case GFC_ISYM_UMASK
:
9356 case GFC_ISYM_UNLINK
:
9358 gfc_conv_intrinsic_funcall (se
, expr
);
9361 case GFC_ISYM_EOSHIFT
:
9363 case GFC_ISYM_RESHAPE
:
9364 /* For those, expr->rank should always be >0 and thus the if above the
9365 switch should have matched. */
9370 gfc_conv_intrinsic_lib_function (se
, expr
);
9377 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
9379 gfc_ss
*arg_ss
, *tmp_ss
;
9380 gfc_actual_arglist
*arg
;
9382 arg
= expr
->value
.function
.actual
;
9384 gcc_assert (arg
->expr
);
9386 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
9387 gcc_assert (arg_ss
!= gfc_ss_terminator
);
9389 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
9391 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
9392 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
9394 gcc_assert (tmp_ss
->dimen
== 2);
9396 /* We just invert dimensions. */
9397 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
9400 /* Stop when tmp_ss points to the last valid element of the chain... */
9401 if (tmp_ss
->next
== gfc_ss_terminator
)
9405 /* ... so that we can attach the rest of the chain to it. */
9412 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9413 This has the side effect of reversing the nested list, so there is no
9414 need to call gfc_reverse_ss on it (the given list is assumed not to be
9418 nest_loop_dimension (gfc_ss
*ss
, int dim
)
9421 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
9422 gfc_loopinfo
*new_loop
;
9424 gcc_assert (ss
!= gfc_ss_terminator
);
9426 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
9428 new_ss
= gfc_get_ss ();
9429 new_ss
->next
= prev_ss
;
9430 new_ss
->parent
= ss
;
9431 new_ss
->info
= ss
->info
;
9432 new_ss
->info
->refcount
++;
9435 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
9436 && ss
->info
->type
!= GFC_SS_REFERENCE
);
9439 new_ss
->dim
[0] = ss
->dim
[dim
];
9441 gcc_assert (dim
< ss
->dimen
);
9443 ss_dim
= --ss
->dimen
;
9444 for (i
= dim
; i
< ss_dim
; i
++)
9445 ss
->dim
[i
] = ss
->dim
[i
+ 1];
9447 ss
->dim
[ss_dim
] = 0;
9453 ss
->nested_ss
->parent
= new_ss
;
9454 new_ss
->nested_ss
= ss
->nested_ss
;
9456 ss
->nested_ss
= new_ss
;
9459 new_loop
= gfc_get_loopinfo ();
9460 gfc_init_loopinfo (new_loop
);
9462 gcc_assert (prev_ss
!= NULL
);
9463 gcc_assert (prev_ss
!= gfc_ss_terminator
);
9464 gfc_add_ss_to_loop (new_loop
, prev_ss
);
9465 return new_ss
->parent
;
9469 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9470 is to be inlined. */
9473 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
9475 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
9476 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
9478 bool scalar_mask
= false;
9480 /* The rank of the result will be determined later. */
9481 arg1
= expr
->value
.function
.actual
;
9484 gcc_assert (arg3
!= NULL
);
9486 if (expr
->rank
== 0)
9489 tmp_ss
= gfc_ss_terminator
;
9495 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
9496 if (mask_ss
== tmp_ss
)
9502 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
9503 gcc_assert (array_ss
!= tmp_ss
);
9505 /* Odd thing: If the mask is scalar, it is used by the frontend after
9506 the array (to make an if around the nested loop). Thus it shall
9507 be after array_ss once the gfc_ss list is reversed. */
9509 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
9513 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9515 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
9516 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
9524 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
9527 switch (expr
->value
.function
.isym
->id
)
9529 case GFC_ISYM_PRODUCT
:
9531 return walk_inline_intrinsic_arith (ss
, expr
);
9533 case GFC_ISYM_TRANSPOSE
:
9534 return walk_inline_intrinsic_transpose (ss
, expr
);
9543 /* This generates code to execute before entering the scalarization loop.
9544 Currently does nothing. */
9547 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
9549 switch (ss
->info
->expr
->value
.function
.isym
->id
)
9551 case GFC_ISYM_UBOUND
:
9552 case GFC_ISYM_LBOUND
:
9553 case GFC_ISYM_UCOBOUND
:
9554 case GFC_ISYM_LCOBOUND
:
9555 case GFC_ISYM_THIS_IMAGE
:
9564 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9565 are expanded into code inside the scalarization loop. */
9568 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
9570 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
9571 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
9573 /* The two argument version returns a scalar. */
9574 if (expr
->value
.function
.actual
->next
->expr
)
9577 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
9581 /* Walk an intrinsic array libcall. */
9584 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
9586 gcc_assert (expr
->rank
> 0);
9587 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
9591 /* Return whether the function call expression EXPR will be expanded
9592 inline by gfc_conv_intrinsic_function. */
9595 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
9597 gfc_actual_arglist
*args
;
9599 if (!expr
->value
.function
.isym
)
9602 switch (expr
->value
.function
.isym
->id
)
9604 case GFC_ISYM_PRODUCT
:
9606 /* Disable inline expansion if code size matters. */
9610 args
= expr
->value
.function
.actual
;
9611 /* We need to be able to subset the SUM argument at compile-time. */
9612 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
9617 case GFC_ISYM_TRANSPOSE
:
9626 /* Returns nonzero if the specified intrinsic function call maps directly to
9627 an external library call. Should only be used for functions that return
9631 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
9633 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
9634 gcc_assert (expr
->rank
> 0);
9636 if (gfc_inline_intrinsic_function_p (expr
))
9639 switch (expr
->value
.function
.isym
->id
)
9643 case GFC_ISYM_COUNT
:
9647 case GFC_ISYM_IPARITY
:
9648 case GFC_ISYM_MATMUL
:
9649 case GFC_ISYM_MAXLOC
:
9650 case GFC_ISYM_MAXVAL
:
9651 case GFC_ISYM_MINLOC
:
9652 case GFC_ISYM_MINVAL
:
9653 case GFC_ISYM_NORM2
:
9654 case GFC_ISYM_PARITY
:
9655 case GFC_ISYM_PRODUCT
:
9657 case GFC_ISYM_SHAPE
:
9658 case GFC_ISYM_SPREAD
:
9660 /* Ignore absent optional parameters. */
9663 case GFC_ISYM_CSHIFT
:
9664 case GFC_ISYM_EOSHIFT
:
9665 case GFC_ISYM_GET_TEAM
:
9666 case GFC_ISYM_FAILED_IMAGES
:
9667 case GFC_ISYM_STOPPED_IMAGES
:
9669 case GFC_ISYM_RESHAPE
:
9670 case GFC_ISYM_UNPACK
:
9671 /* Pass absent optional parameters. */
9679 /* Walk an intrinsic function. */
9681 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
9682 gfc_intrinsic_sym
* isym
)
9686 if (isym
->elemental
)
9687 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
9688 NULL
, GFC_SS_SCALAR
);
9690 if (expr
->rank
== 0)
9693 if (gfc_inline_intrinsic_function_p (expr
))
9694 return walk_inline_intrinsic_function (ss
, expr
);
9696 if (gfc_is_intrinsic_libcall (expr
))
9697 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9699 /* Special cases. */
9702 case GFC_ISYM_LBOUND
:
9703 case GFC_ISYM_LCOBOUND
:
9704 case GFC_ISYM_UBOUND
:
9705 case GFC_ISYM_UCOBOUND
:
9706 case GFC_ISYM_THIS_IMAGE
:
9707 return gfc_walk_intrinsic_bound (ss
, expr
);
9709 case GFC_ISYM_TRANSFER
:
9710 case GFC_ISYM_CAF_GET
:
9711 return gfc_walk_intrinsic_libfunc (ss
, expr
);
9714 /* This probably meant someone forgot to add an intrinsic to the above
9715 list(s) when they implemented it, or something's gone horribly
9723 conv_co_collective (gfc_code
*code
)
9726 stmtblock_t block
, post_block
;
9727 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
9728 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
9730 gfc_start_block (&block
);
9731 gfc_init_block (&post_block
);
9733 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
9735 opr_expr
= code
->ext
.actual
->next
->expr
;
9736 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
9737 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9738 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
9743 image_idx_expr
= code
->ext
.actual
->next
->expr
;
9744 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9745 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9751 gfc_init_se (&argse
, NULL
);
9752 gfc_conv_expr (&argse
, stat_expr
);
9753 gfc_add_block_to_block (&block
, &argse
.pre
);
9754 gfc_add_block_to_block (&post_block
, &argse
.post
);
9756 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
9757 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
9759 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9762 stat
= null_pointer_node
;
9764 /* Early exit for GFC_FCOARRAY_SINGLE. */
9765 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
9767 if (stat
!= NULL_TREE
)
9768 gfc_add_modify (&block
, stat
,
9769 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
9770 return gfc_finish_block (&block
);
9773 /* Handle the array. */
9774 gfc_init_se (&argse
, NULL
);
9775 if (code
->ext
.actual
->expr
->rank
== 0)
9777 symbol_attribute attr
;
9778 gfc_clear_attr (&attr
);
9779 gfc_init_se (&argse
, NULL
);
9780 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9781 gfc_add_block_to_block (&block
, &argse
.pre
);
9782 gfc_add_block_to_block (&post_block
, &argse
.post
);
9783 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
9784 array
= gfc_build_addr_expr (NULL_TREE
, array
);
9788 argse
.want_pointer
= 1;
9789 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
9792 gfc_add_block_to_block (&block
, &argse
.pre
);
9793 gfc_add_block_to_block (&post_block
, &argse
.post
);
9795 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
9796 strlen
= argse
.string_length
;
9798 strlen
= integer_zero_node
;
9803 gfc_init_se (&argse
, NULL
);
9804 gfc_conv_expr (&argse
, image_idx_expr
);
9805 gfc_add_block_to_block (&block
, &argse
.pre
);
9806 gfc_add_block_to_block (&post_block
, &argse
.post
);
9807 image_index
= fold_convert (integer_type_node
, argse
.expr
);
9810 image_index
= integer_zero_node
;
9815 gfc_init_se (&argse
, NULL
);
9816 gfc_conv_expr (&argse
, errmsg_expr
);
9817 gfc_add_block_to_block (&block
, &argse
.pre
);
9818 gfc_add_block_to_block (&post_block
, &argse
.post
);
9819 errmsg
= argse
.expr
;
9820 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
9824 errmsg
= null_pointer_node
;
9825 errmsg_len
= integer_zero_node
;
9828 /* Generate the function call. */
9829 switch (code
->resolved_isym
->id
)
9831 case GFC_ISYM_CO_BROADCAST
:
9832 fndecl
= gfor_fndecl_co_broadcast
;
9834 case GFC_ISYM_CO_MAX
:
9835 fndecl
= gfor_fndecl_co_max
;
9837 case GFC_ISYM_CO_MIN
:
9838 fndecl
= gfor_fndecl_co_min
;
9840 case GFC_ISYM_CO_REDUCE
:
9841 fndecl
= gfor_fndecl_co_reduce
;
9843 case GFC_ISYM_CO_SUM
:
9844 fndecl
= gfor_fndecl_co_sum
;
9850 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
9851 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
9852 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
9853 image_index
, stat
, errmsg
, errmsg_len
);
9854 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
9855 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
9856 stat
, errmsg
, strlen
, errmsg_len
);
9859 tree opr
, opr_flags
;
9861 // FIXME: Handle TS29113's bind(C) strings with descriptor.
9863 if (gfc_is_proc_ptr_comp (opr_expr
))
9865 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
9866 opr_flag_int
= sym
->attr
.dimension
9867 || (sym
->ts
.type
== BT_CHARACTER
9868 && !sym
->attr
.is_bind_c
)
9869 ? GFC_CAF_BYREF
: 0;
9870 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9871 && !sym
->attr
.is_bind_c
9872 ? GFC_CAF_HIDDENLEN
: 0;
9873 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
9877 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
9878 ? GFC_CAF_BYREF
: 0;
9879 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
9880 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
9881 ? GFC_CAF_HIDDENLEN
: 0;
9882 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
9883 ? GFC_CAF_ARG_VALUE
: 0;
9885 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
9886 gfc_conv_expr (&argse
, opr_expr
);
9888 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
9889 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
9892 gfc_add_expr_to_block (&block
, fndecl
);
9893 gfc_add_block_to_block (&block
, &post_block
);
9895 return gfc_finish_block (&block
);
9900 conv_intrinsic_atomic_op (gfc_code
*code
)
9903 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
9904 stmtblock_t block
, post_block
;
9905 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9906 gfc_expr
*stat_expr
;
9907 built_in_function fn
;
9909 if (atom_expr
->expr_type
== EXPR_FUNCTION
9910 && atom_expr
->value
.function
.isym
9911 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9912 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9914 gfc_start_block (&block
);
9915 gfc_init_block (&post_block
);
9917 gfc_init_se (&argse
, NULL
);
9918 argse
.want_pointer
= 1;
9919 gfc_conv_expr (&argse
, atom_expr
);
9920 gfc_add_block_to_block (&block
, &argse
.pre
);
9921 gfc_add_block_to_block (&post_block
, &argse
.post
);
9924 gfc_init_se (&argse
, NULL
);
9925 if (flag_coarray
== GFC_FCOARRAY_LIB
9926 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9927 argse
.want_pointer
= 1;
9928 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9929 gfc_add_block_to_block (&block
, &argse
.pre
);
9930 gfc_add_block_to_block (&post_block
, &argse
.post
);
9933 switch (code
->resolved_isym
->id
)
9935 case GFC_ISYM_ATOMIC_ADD
:
9936 case GFC_ISYM_ATOMIC_AND
:
9937 case GFC_ISYM_ATOMIC_DEF
:
9938 case GFC_ISYM_ATOMIC_OR
:
9939 case GFC_ISYM_ATOMIC_XOR
:
9940 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
9941 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9942 old
= null_pointer_node
;
9945 gfc_init_se (&argse
, NULL
);
9946 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9947 argse
.want_pointer
= 1;
9948 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9949 gfc_add_block_to_block (&block
, &argse
.pre
);
9950 gfc_add_block_to_block (&post_block
, &argse
.post
);
9952 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
9956 if (stat_expr
!= NULL
)
9958 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
9959 gfc_init_se (&argse
, NULL
);
9960 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9961 argse
.want_pointer
= 1;
9962 gfc_conv_expr_val (&argse
, stat_expr
);
9963 gfc_add_block_to_block (&block
, &argse
.pre
);
9964 gfc_add_block_to_block (&post_block
, &argse
.post
);
9967 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9968 stat
= null_pointer_node
;
9970 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9972 tree image_index
, caf_decl
, offset
, token
;
9975 switch (code
->resolved_isym
->id
)
9977 case GFC_ISYM_ATOMIC_ADD
:
9978 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9979 op
= (int) GFC_CAF_ATOMIC_ADD
;
9981 case GFC_ISYM_ATOMIC_AND
:
9982 case GFC_ISYM_ATOMIC_FETCH_AND
:
9983 op
= (int) GFC_CAF_ATOMIC_AND
;
9985 case GFC_ISYM_ATOMIC_OR
:
9986 case GFC_ISYM_ATOMIC_FETCH_OR
:
9987 op
= (int) GFC_CAF_ATOMIC_OR
;
9989 case GFC_ISYM_ATOMIC_XOR
:
9990 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9991 op
= (int) GFC_CAF_ATOMIC_XOR
;
9993 case GFC_ISYM_ATOMIC_DEF
:
9994 op
= 0; /* Unused. */
10000 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10001 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10002 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10004 if (gfc_is_coindexed (atom_expr
))
10005 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10007 image_index
= integer_zero_node
;
10009 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10011 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10012 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
10013 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10016 gfc_init_se (&argse
, NULL
);
10017 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10020 gfc_add_block_to_block (&block
, &argse
.pre
);
10021 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
10022 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
10023 token
, offset
, image_index
, value
, stat
,
10024 build_int_cst (integer_type_node
,
10025 (int) atom_expr
->ts
.type
),
10026 build_int_cst (integer_type_node
,
10027 (int) atom_expr
->ts
.kind
));
10029 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
10030 build_int_cst (integer_type_node
, op
),
10031 token
, offset
, image_index
, value
, old
, stat
,
10032 build_int_cst (integer_type_node
,
10033 (int) atom_expr
->ts
.type
),
10034 build_int_cst (integer_type_node
,
10035 (int) atom_expr
->ts
.kind
));
10037 gfc_add_expr_to_block (&block
, tmp
);
10038 gfc_add_block_to_block (&block
, &argse
.post
);
10039 gfc_add_block_to_block (&block
, &post_block
);
10040 return gfc_finish_block (&block
);
10044 switch (code
->resolved_isym
->id
)
10046 case GFC_ISYM_ATOMIC_ADD
:
10047 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10048 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
10050 case GFC_ISYM_ATOMIC_AND
:
10051 case GFC_ISYM_ATOMIC_FETCH_AND
:
10052 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
10054 case GFC_ISYM_ATOMIC_DEF
:
10055 fn
= BUILT_IN_ATOMIC_STORE_N
;
10057 case GFC_ISYM_ATOMIC_OR
:
10058 case GFC_ISYM_ATOMIC_FETCH_OR
:
10059 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
10061 case GFC_ISYM_ATOMIC_XOR
:
10062 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10063 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
10066 gcc_unreachable ();
10069 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10070 fn
= (built_in_function
) ((int) fn
10071 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10073 tmp
= builtin_decl_explicit (fn
);
10074 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
10075 tmp
= builtin_decl_explicit (fn
);
10077 switch (code
->resolved_isym
->id
)
10079 case GFC_ISYM_ATOMIC_ADD
:
10080 case GFC_ISYM_ATOMIC_AND
:
10081 case GFC_ISYM_ATOMIC_DEF
:
10082 case GFC_ISYM_ATOMIC_OR
:
10083 case GFC_ISYM_ATOMIC_XOR
:
10084 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10085 fold_convert (itype
, value
),
10086 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10087 gfc_add_expr_to_block (&block
, tmp
);
10090 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
10091 fold_convert (itype
, value
),
10092 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10093 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
10097 if (stat
!= NULL_TREE
)
10098 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10099 gfc_add_block_to_block (&block
, &post_block
);
10100 return gfc_finish_block (&block
);
10105 conv_intrinsic_atomic_ref (gfc_code
*code
)
10108 tree tmp
, atom
, value
, stat
= NULL_TREE
;
10109 stmtblock_t block
, post_block
;
10110 built_in_function fn
;
10111 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
10113 if (atom_expr
->expr_type
== EXPR_FUNCTION
10114 && atom_expr
->value
.function
.isym
10115 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10116 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10118 gfc_start_block (&block
);
10119 gfc_init_block (&post_block
);
10120 gfc_init_se (&argse
, NULL
);
10121 argse
.want_pointer
= 1;
10122 gfc_conv_expr (&argse
, atom_expr
);
10123 gfc_add_block_to_block (&block
, &argse
.pre
);
10124 gfc_add_block_to_block (&post_block
, &argse
.post
);
10127 gfc_init_se (&argse
, NULL
);
10128 if (flag_coarray
== GFC_FCOARRAY_LIB
10129 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
10130 argse
.want_pointer
= 1;
10131 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
10132 gfc_add_block_to_block (&block
, &argse
.pre
);
10133 gfc_add_block_to_block (&post_block
, &argse
.post
);
10134 value
= argse
.expr
;
10137 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
10139 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10141 gfc_init_se (&argse
, NULL
);
10142 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10143 argse
.want_pointer
= 1;
10144 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10145 gfc_add_block_to_block (&block
, &argse
.pre
);
10146 gfc_add_block_to_block (&post_block
, &argse
.post
);
10149 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10150 stat
= null_pointer_node
;
10152 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10154 tree image_index
, caf_decl
, offset
, token
;
10155 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
10157 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10158 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10159 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10161 if (gfc_is_coindexed (atom_expr
))
10162 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10164 image_index
= integer_zero_node
;
10166 gfc_init_se (&argse
, NULL
);
10167 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10169 gfc_add_block_to_block (&block
, &argse
.pre
);
10171 /* Different type, need type conversion. */
10172 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
10174 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
10175 orig_value
= value
;
10176 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
10179 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
10180 token
, offset
, image_index
, value
, stat
,
10181 build_int_cst (integer_type_node
,
10182 (int) atom_expr
->ts
.type
),
10183 build_int_cst (integer_type_node
,
10184 (int) atom_expr
->ts
.kind
));
10185 gfc_add_expr_to_block (&block
, tmp
);
10186 if (vardecl
!= NULL_TREE
)
10187 gfc_add_modify (&block
, orig_value
,
10188 fold_convert (TREE_TYPE (orig_value
), vardecl
));
10189 gfc_add_block_to_block (&block
, &argse
.post
);
10190 gfc_add_block_to_block (&block
, &post_block
);
10191 return gfc_finish_block (&block
);
10194 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10195 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
10196 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10198 tmp
= builtin_decl_explicit (fn
);
10199 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
10200 build_int_cst (integer_type_node
,
10201 MEMMODEL_RELAXED
));
10202 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
10204 if (stat
!= NULL_TREE
)
10205 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10206 gfc_add_block_to_block (&block
, &post_block
);
10207 return gfc_finish_block (&block
);
10212 conv_intrinsic_atomic_cas (gfc_code
*code
)
10215 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
10216 stmtblock_t block
, post_block
;
10217 built_in_function fn
;
10218 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
10220 if (atom_expr
->expr_type
== EXPR_FUNCTION
10221 && atom_expr
->value
.function
.isym
10222 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10223 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
10225 gfc_init_block (&block
);
10226 gfc_init_block (&post_block
);
10227 gfc_init_se (&argse
, NULL
);
10228 argse
.want_pointer
= 1;
10229 gfc_conv_expr (&argse
, atom_expr
);
10232 gfc_init_se (&argse
, NULL
);
10233 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10234 argse
.want_pointer
= 1;
10235 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
10236 gfc_add_block_to_block (&block
, &argse
.pre
);
10237 gfc_add_block_to_block (&post_block
, &argse
.post
);
10240 gfc_init_se (&argse
, NULL
);
10241 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10242 argse
.want_pointer
= 1;
10243 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
10244 gfc_add_block_to_block (&block
, &argse
.pre
);
10245 gfc_add_block_to_block (&post_block
, &argse
.post
);
10248 gfc_init_se (&argse
, NULL
);
10249 if (flag_coarray
== GFC_FCOARRAY_LIB
10250 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
10251 == atom_expr
->ts
.kind
)
10252 argse
.want_pointer
= 1;
10253 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
10254 gfc_add_block_to_block (&block
, &argse
.pre
);
10255 gfc_add_block_to_block (&post_block
, &argse
.post
);
10256 new_val
= argse
.expr
;
10259 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
10261 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
10263 gfc_init_se (&argse
, NULL
);
10264 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10265 argse
.want_pointer
= 1;
10266 gfc_conv_expr_val (&argse
,
10267 code
->ext
.actual
->next
->next
->next
->next
->expr
);
10268 gfc_add_block_to_block (&block
, &argse
.pre
);
10269 gfc_add_block_to_block (&post_block
, &argse
.post
);
10272 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10273 stat
= null_pointer_node
;
10275 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10277 tree image_index
, caf_decl
, offset
, token
;
10279 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
10280 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
10281 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
10283 if (gfc_is_coindexed (atom_expr
))
10284 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
10286 image_index
= integer_zero_node
;
10288 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
10290 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
10291 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
10292 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10295 /* Convert a constant to a pointer. */
10296 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
10298 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
10299 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
10300 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10303 gfc_init_se (&argse
, NULL
);
10304 gfc_get_caf_token_offset (&argse
, &token
, &offset
, caf_decl
, atom
,
10306 gfc_add_block_to_block (&block
, &argse
.pre
);
10308 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
10309 token
, offset
, image_index
, old
, comp
, new_val
,
10310 stat
, build_int_cst (integer_type_node
,
10311 (int) atom_expr
->ts
.type
),
10312 build_int_cst (integer_type_node
,
10313 (int) atom_expr
->ts
.kind
));
10314 gfc_add_expr_to_block (&block
, tmp
);
10315 gfc_add_block_to_block (&block
, &argse
.post
);
10316 gfc_add_block_to_block (&block
, &post_block
);
10317 return gfc_finish_block (&block
);
10320 tmp
= TREE_TYPE (TREE_TYPE (atom
));
10321 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10322 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
10324 tmp
= builtin_decl_explicit (fn
);
10326 gfc_add_modify (&block
, old
, comp
);
10327 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
10328 gfc_build_addr_expr (NULL
, old
),
10329 fold_convert (TREE_TYPE (old
), new_val
),
10330 boolean_false_node
,
10331 build_int_cst (NULL
, MEMMODEL_RELAXED
),
10332 build_int_cst (NULL
, MEMMODEL_RELAXED
));
10333 gfc_add_expr_to_block (&block
, tmp
);
10335 if (stat
!= NULL_TREE
)
10336 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10337 gfc_add_block_to_block (&block
, &post_block
);
10338 return gfc_finish_block (&block
);
10342 conv_intrinsic_event_query (gfc_code
*code
)
10345 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
10346 tree count
= NULL_TREE
, count2
= NULL_TREE
;
10348 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
10350 if (code
->ext
.actual
->next
->next
->expr
)
10352 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
10354 gfc_init_se (&argse
, NULL
);
10355 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
10358 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
10359 stat
= null_pointer_node
;
10361 if (code
->ext
.actual
->next
->expr
)
10363 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
10364 gfc_init_se (&argse
, NULL
);
10365 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
10366 count
= argse
.expr
;
10369 gfc_start_block (&se
.pre
);
10370 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10372 tree tmp
, token
, image_index
;
10373 tree index
= size_zero_node
;
10375 if (event_expr
->expr_type
== EXPR_FUNCTION
10376 && event_expr
->value
.function
.isym
10377 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10378 event_expr
= event_expr
->value
.function
.actual
->expr
;
10380 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
10382 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10383 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
10384 != INTMOD_ISO_FORTRAN_ENV
10385 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
10386 != ISOFORTRAN_EVENT_TYPE
)
10388 gfc_error ("Sorry, the event component of derived type at %L is not "
10389 "yet supported", &event_expr
->where
);
10393 if (gfc_is_coindexed (event_expr
))
10395 gfc_error ("The event variable at %L shall not be coindexed",
10396 &event_expr
->where
);
10400 image_index
= integer_zero_node
;
10402 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10405 /* For arrays, obtain the array index. */
10406 if (gfc_expr_attr (event_expr
).dimension
)
10408 tree desc
, tmp
, extent
, lbound
, ubound
;
10409 gfc_array_ref
*ar
, ar2
;
10412 /* TODO: Extend this, once DT components are supported. */
10413 ar
= &event_expr
->ref
->u
.ar
;
10415 memset (ar
, '\0', sizeof (*ar
));
10417 ar
->type
= AR_FULL
;
10419 gfc_init_se (&argse
, NULL
);
10420 argse
.descriptor_only
= 1;
10421 gfc_conv_expr_descriptor (&argse
, event_expr
);
10422 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
10426 extent
= integer_one_node
;
10427 for (i
= 0; i
< ar
->dimen
; i
++)
10429 gfc_init_se (&argse
, NULL
);
10430 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
10431 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
10432 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
10433 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10434 integer_type_node
, argse
.expr
,
10435 fold_convert(integer_type_node
, lbound
));
10436 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10437 integer_type_node
, extent
, tmp
);
10438 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
10439 integer_type_node
, index
, tmp
);
10440 if (i
< ar
->dimen
- 1)
10442 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
10443 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10444 tmp
= fold_convert (integer_type_node
, tmp
);
10445 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
10446 integer_type_node
, extent
, tmp
);
10451 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
10454 count
= gfc_create_var (integer_type_node
, "count");
10457 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
10460 stat
= gfc_create_var (integer_type_node
, "stat");
10463 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
10464 token
, index
, image_index
, count
10465 ? gfc_build_addr_expr (NULL
, count
) : count
,
10466 stat
!= null_pointer_node
10467 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
10468 gfc_add_expr_to_block (&se
.pre
, tmp
);
10470 if (count2
!= NULL_TREE
)
10471 gfc_add_modify (&se
.pre
, count2
,
10472 fold_convert (TREE_TYPE (count2
), count
));
10474 if (stat2
!= NULL_TREE
)
10475 gfc_add_modify (&se
.pre
, stat2
,
10476 fold_convert (TREE_TYPE (stat2
), stat
));
10478 return gfc_finish_block (&se
.pre
);
10481 gfc_init_se (&argse
, NULL
);
10482 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
10483 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
10485 if (stat
!= NULL_TREE
)
10486 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
10488 return gfc_finish_block (&se
.pre
);
10492 conv_intrinsic_move_alloc (gfc_code
*code
)
10495 gfc_expr
*from_expr
, *to_expr
;
10496 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
10497 gfc_se from_se
, to_se
;
10501 gfc_start_block (&block
);
10503 from_expr
= code
->ext
.actual
->expr
;
10504 to_expr
= code
->ext
.actual
->next
->expr
;
10506 gfc_init_se (&from_se
, NULL
);
10507 gfc_init_se (&to_se
, NULL
);
10509 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
10510 || to_expr
->ts
.type
== BT_CLASS
);
10511 coarray
= gfc_get_corank (from_expr
) != 0;
10513 if (from_expr
->rank
== 0 && !coarray
)
10515 if (from_expr
->ts
.type
!= BT_CLASS
)
10516 from_expr2
= from_expr
;
10519 from_expr2
= gfc_copy_expr (from_expr
);
10520 gfc_add_data_component (from_expr2
);
10523 if (to_expr
->ts
.type
!= BT_CLASS
)
10524 to_expr2
= to_expr
;
10527 to_expr2
= gfc_copy_expr (to_expr
);
10528 gfc_add_data_component (to_expr2
);
10531 from_se
.want_pointer
= 1;
10532 to_se
.want_pointer
= 1;
10533 gfc_conv_expr (&from_se
, from_expr2
);
10534 gfc_conv_expr (&to_se
, to_expr2
);
10535 gfc_add_block_to_block (&block
, &from_se
.pre
);
10536 gfc_add_block_to_block (&block
, &to_se
.pre
);
10538 /* Deallocate "to". */
10539 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10540 true, to_expr
, to_expr
->ts
);
10541 gfc_add_expr_to_block (&block
, tmp
);
10543 /* Assign (_data) pointers. */
10544 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10545 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
10547 /* Set "from" to NULL. */
10548 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10549 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
10551 gfc_add_block_to_block (&block
, &from_se
.post
);
10552 gfc_add_block_to_block (&block
, &to_se
.post
);
10555 if (to_expr
->ts
.type
== BT_CLASS
)
10559 gfc_free_expr (to_expr2
);
10560 gfc_init_se (&to_se
, NULL
);
10561 to_se
.want_pointer
= 1;
10562 gfc_add_vptr_component (to_expr
);
10563 gfc_conv_expr (&to_se
, to_expr
);
10565 if (from_expr
->ts
.type
== BT_CLASS
)
10567 if (UNLIMITED_POLY (from_expr
))
10571 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10575 gfc_free_expr (from_expr2
);
10576 gfc_init_se (&from_se
, NULL
);
10577 from_se
.want_pointer
= 1;
10578 gfc_add_vptr_component (from_expr
);
10579 gfc_conv_expr (&from_se
, from_expr
);
10580 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10581 fold_convert (TREE_TYPE (to_se
.expr
),
10584 /* Reset _vptr component to declared type. */
10586 /* Unlimited polymorphic. */
10587 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10588 fold_convert (TREE_TYPE (from_se
.expr
),
10589 null_pointer_node
));
10592 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10593 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10594 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10599 vtab
= gfc_find_vtab (&from_expr
->ts
);
10601 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10602 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10603 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10607 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10609 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10610 fold_convert (TREE_TYPE (to_se
.string_length
),
10611 from_se
.string_length
));
10612 if (from_expr
->ts
.deferred
)
10613 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10614 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10617 return gfc_finish_block (&block
);
10620 /* Update _vptr component. */
10621 if (to_expr
->ts
.type
== BT_CLASS
)
10625 to_se
.want_pointer
= 1;
10626 to_expr2
= gfc_copy_expr (to_expr
);
10627 gfc_add_vptr_component (to_expr2
);
10628 gfc_conv_expr (&to_se
, to_expr2
);
10630 if (from_expr
->ts
.type
== BT_CLASS
)
10632 if (UNLIMITED_POLY (from_expr
))
10636 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
10640 from_se
.want_pointer
= 1;
10641 from_expr2
= gfc_copy_expr (from_expr
);
10642 gfc_add_vptr_component (from_expr2
);
10643 gfc_conv_expr (&from_se
, from_expr2
);
10644 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10645 fold_convert (TREE_TYPE (to_se
.expr
),
10648 /* Reset _vptr component to declared type. */
10650 /* Unlimited polymorphic. */
10651 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10652 fold_convert (TREE_TYPE (from_se
.expr
),
10653 null_pointer_node
));
10656 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10657 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
10658 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
10663 vtab
= gfc_find_vtab (&from_expr
->ts
);
10665 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
10666 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
10667 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
10670 gfc_free_expr (to_expr2
);
10671 gfc_init_se (&to_se
, NULL
);
10673 if (from_expr
->ts
.type
== BT_CLASS
)
10675 gfc_free_expr (from_expr2
);
10676 gfc_init_se (&from_se
, NULL
);
10681 /* Deallocate "to". */
10682 if (from_expr
->rank
== 0)
10684 to_se
.want_coarray
= 1;
10685 from_se
.want_coarray
= 1;
10687 gfc_conv_expr_descriptor (&to_se
, to_expr
);
10688 gfc_conv_expr_descriptor (&from_se
, from_expr
);
10690 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10691 is an image control "statement", cf. IR F08/0040 in 12-006A. */
10692 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10696 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
10697 NULL_TREE
, NULL_TREE
, true, to_expr
,
10698 GFC_CAF_COARRAY_DEALLOCATE_ONLY
);
10699 gfc_add_expr_to_block (&block
, tmp
);
10701 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10702 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10703 logical_type_node
, tmp
,
10704 fold_convert (TREE_TYPE (tmp
),
10705 null_pointer_node
));
10706 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
10707 3, null_pointer_node
, null_pointer_node
,
10708 build_int_cst (integer_type_node
, 0));
10710 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
10711 tmp
, build_empty_stmt (input_location
));
10712 gfc_add_expr_to_block (&block
, tmp
);
10716 if (to_expr
->ts
.type
== BT_DERIVED
10717 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
10719 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
10720 to_se
.expr
, to_expr
->rank
);
10721 gfc_add_expr_to_block (&block
, tmp
);
10724 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
10725 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
10726 NULL_TREE
, true, to_expr
,
10727 GFC_CAF_COARRAY_NOCOARRAY
);
10728 gfc_add_expr_to_block (&block
, tmp
);
10731 /* Move the pointer and update the array descriptor data. */
10732 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
10734 /* Set "from" to NULL. */
10735 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
10736 gfc_add_modify_loc (input_location
, &block
, tmp
,
10737 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
10740 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
10742 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
10743 fold_convert (TREE_TYPE (to_se
.string_length
),
10744 from_se
.string_length
));
10745 if (from_expr
->ts
.deferred
)
10746 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
10747 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
10750 return gfc_finish_block (&block
);
10755 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
10759 gcc_assert (code
->resolved_isym
);
10761 switch (code
->resolved_isym
->id
)
10763 case GFC_ISYM_MOVE_ALLOC
:
10764 res
= conv_intrinsic_move_alloc (code
);
10767 case GFC_ISYM_ATOMIC_CAS
:
10768 res
= conv_intrinsic_atomic_cas (code
);
10771 case GFC_ISYM_ATOMIC_ADD
:
10772 case GFC_ISYM_ATOMIC_AND
:
10773 case GFC_ISYM_ATOMIC_DEF
:
10774 case GFC_ISYM_ATOMIC_OR
:
10775 case GFC_ISYM_ATOMIC_XOR
:
10776 case GFC_ISYM_ATOMIC_FETCH_ADD
:
10777 case GFC_ISYM_ATOMIC_FETCH_AND
:
10778 case GFC_ISYM_ATOMIC_FETCH_OR
:
10779 case GFC_ISYM_ATOMIC_FETCH_XOR
:
10780 res
= conv_intrinsic_atomic_op (code
);
10783 case GFC_ISYM_ATOMIC_REF
:
10784 res
= conv_intrinsic_atomic_ref (code
);
10787 case GFC_ISYM_EVENT_QUERY
:
10788 res
= conv_intrinsic_event_query (code
);
10791 case GFC_ISYM_C_F_POINTER
:
10792 case GFC_ISYM_C_F_PROCPOINTER
:
10793 res
= conv_isocbinding_subroutine (code
);
10796 case GFC_ISYM_CAF_SEND
:
10797 res
= conv_caf_send (code
);
10800 case GFC_ISYM_CO_BROADCAST
:
10801 case GFC_ISYM_CO_MIN
:
10802 case GFC_ISYM_CO_MAX
:
10803 case GFC_ISYM_CO_REDUCE
:
10804 case GFC_ISYM_CO_SUM
:
10805 res
= conv_co_collective (code
);
10808 case GFC_ISYM_FREE
:
10809 res
= conv_intrinsic_free (code
);
10812 case GFC_ISYM_SYSTEM_CLOCK
:
10813 res
= conv_intrinsic_system_clock (code
);
10824 #include "gt-fortran-trans-intrinsic.h"