1 /* Intrinsic translation
2 Copyright (C) 2002-2015 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"
27 #include "tm.h" /* For UNITS_PER_WORD. */
31 #include "stringpool.h"
32 #include "fold-const.h"
33 #include "tree-nested.h"
34 #include "stor-layout.h"
35 #include "toplev.h" /* For rest_of_decl_compilation. */
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 #include "dependency.h" /* For CAF array alias analysis. */
41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 /* This maps Fortran intrinsic math functions to external library or GCC
45 typedef struct GTY(()) gfc_intrinsic_map_t
{
46 /* The explicit enum is required to work around inadequacies in the
47 garbage collection/gengtype parsing mechanism. */
50 /* Enum value from the "language-independent", aka C-centric, part
51 of gcc, or END_BUILTINS of no such value set. */
52 enum built_in_function float_built_in
;
53 enum built_in_function double_built_in
;
54 enum built_in_function long_double_built_in
;
55 enum built_in_function complex_float_built_in
;
56 enum built_in_function complex_double_built_in
;
57 enum built_in_function complex_long_double_built_in
;
59 /* True if the naming pattern is to prepend "c" for complex and
60 append "f" for kind=4. False if the naming pattern is to
61 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
64 /* True if a complex version of the function exists. */
65 bool complex_available
;
67 /* True if the function should be marked const. */
70 /* The base library name of this function. */
73 /* Cache decls created for the various operand types. */
85 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
86 defines complex variants of all of the entries in mathbuiltins.def
88 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
89 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
90 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
91 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
92 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
94 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
97 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
101 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
102 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
104 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
106 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
107 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
108 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
112 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
114 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
115 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
116 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
117 #include "mathbuiltins.def"
119 /* Functions in libgfortran. */
120 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
123 LIB_FUNCTION (NONE
, NULL
, false)
128 #undef DEFINE_MATH_BUILTIN
129 #undef DEFINE_MATH_BUILTIN_C
132 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
135 /* Find the correct variant of a given builtin from its argument. */
137 builtin_decl_for_precision (enum built_in_function base_built_in
,
140 enum built_in_function i
= END_BUILTINS
;
142 gfc_intrinsic_map_t
*m
;
143 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
146 if (precision
== TYPE_PRECISION (float_type_node
))
147 i
= m
->float_built_in
;
148 else if (precision
== TYPE_PRECISION (double_type_node
))
149 i
= m
->double_built_in
;
150 else if (precision
== TYPE_PRECISION (long_double_type_node
))
151 i
= m
->long_double_built_in
;
152 else if (precision
== TYPE_PRECISION (float128_type_node
))
154 /* Special treatment, because it is not exactly a built-in, but
155 a library function. */
156 return m
->real16_decl
;
159 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
164 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
167 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
169 if (gfc_real_kinds
[i
].c_float128
)
171 /* For __float128, the story is a bit different, because we return
172 a decl to a library function rather than a built-in. */
173 gfc_intrinsic_map_t
*m
;
174 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
177 return m
->real16_decl
;
180 return builtin_decl_for_precision (double_built_in
,
181 gfc_real_kinds
[i
].mode_precision
);
185 /* Evaluate the arguments to an intrinsic function. The value
186 of NARGS may be less than the actual number of arguments in EXPR
187 to allow optional "KIND" arguments that are not included in the
188 generated code to be ignored. */
191 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
192 tree
*argarray
, int nargs
)
194 gfc_actual_arglist
*actual
;
196 gfc_intrinsic_arg
*formal
;
200 formal
= expr
->value
.function
.isym
->formal
;
201 actual
= expr
->value
.function
.actual
;
203 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
204 actual
= actual
->next
,
205 formal
= formal
? formal
->next
: NULL
)
209 /* Skip omitted optional arguments. */
216 /* Evaluate the parameter. This will substitute scalarized
217 references automatically. */
218 gfc_init_se (&argse
, se
);
220 if (e
->ts
.type
== BT_CHARACTER
)
222 gfc_conv_expr (&argse
, e
);
223 gfc_conv_string_parameter (&argse
);
224 argarray
[curr_arg
++] = argse
.string_length
;
225 gcc_assert (curr_arg
< nargs
);
228 gfc_conv_expr_val (&argse
, e
);
230 /* If an optional argument is itself an optional dummy argument,
231 check its presence and substitute a null if absent. */
232 if (e
->expr_type
== EXPR_VARIABLE
233 && e
->symtree
->n
.sym
->attr
.optional
236 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
238 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
239 gfc_add_block_to_block (&se
->post
, &argse
.post
);
240 argarray
[curr_arg
] = argse
.expr
;
244 /* Count the number of actual arguments to the intrinsic function EXPR
245 including any "hidden" string length arguments. */
248 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
251 gfc_actual_arglist
*actual
;
253 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
258 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
268 /* Conversions between different types are output by the frontend as
269 intrinsic functions. We implement these directly with inline code. */
272 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
278 nargs
= gfc_intrinsic_argument_list_length (expr
);
279 args
= XALLOCAVEC (tree
, nargs
);
281 /* Evaluate all the arguments passed. Whilst we're only interested in the
282 first one here, there are other parts of the front-end that assume this
283 and will trigger an ICE if it's not the case. */
284 type
= gfc_typenode_for_spec (&expr
->ts
);
285 gcc_assert (expr
->value
.function
.actual
->expr
);
286 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
288 /* Conversion between character kinds involves a call to a library
290 if (expr
->ts
.type
== BT_CHARACTER
)
292 tree fndecl
, var
, addr
, tmp
;
294 if (expr
->ts
.kind
== 1
295 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
296 fndecl
= gfor_fndecl_convert_char4_to_char1
;
297 else if (expr
->ts
.kind
== 4
298 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
299 fndecl
= gfor_fndecl_convert_char1_to_char4
;
303 /* Create the variable storing the converted value. */
304 type
= gfc_get_pchar_type (expr
->ts
.kind
);
305 var
= gfc_create_var (type
, "str");
306 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
308 /* Call the library function that will perform the conversion. */
309 gcc_assert (nargs
>= 2);
310 tmp
= build_call_expr_loc (input_location
,
311 fndecl
, 3, addr
, args
[0], args
[1]);
312 gfc_add_expr_to_block (&se
->pre
, tmp
);
314 /* Free the temporary afterwards. */
315 tmp
= gfc_call_free (var
);
316 gfc_add_expr_to_block (&se
->post
, tmp
);
319 se
->string_length
= args
[0];
324 /* Conversion from complex to non-complex involves taking the real
325 component of the value. */
326 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
327 && expr
->ts
.type
!= BT_COMPLEX
)
331 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
332 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
336 se
->expr
= convert (type
, args
[0]);
339 /* This is needed because the gcc backend only implements
340 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
341 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
342 Similarly for CEILING. */
345 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
352 argtype
= TREE_TYPE (arg
);
353 arg
= gfc_evaluate_now (arg
, pblock
);
355 intval
= convert (type
, arg
);
356 intval
= gfc_evaluate_now (intval
, pblock
);
358 tmp
= convert (argtype
, intval
);
359 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
360 boolean_type_node
, tmp
, arg
);
362 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
363 intval
, build_int_cst (type
, 1));
364 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
369 /* Round to nearest integer, away from zero. */
372 build_round_expr (tree arg
, tree restype
)
376 int argprec
, resprec
;
378 argtype
= TREE_TYPE (arg
);
379 argprec
= TYPE_PRECISION (argtype
);
380 resprec
= TYPE_PRECISION (restype
);
382 /* Depending on the type of the result, choose the int intrinsic
383 (iround, available only as a builtin, therefore cannot use it for
384 __float128), long int intrinsic (lround family) or long long
385 intrinsic (llround). We might also need to convert the result
387 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
388 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
389 else if (resprec
<= LONG_TYPE_SIZE
)
390 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
391 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
392 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
396 return fold_convert (restype
, build_call_expr_loc (input_location
,
401 /* Convert a real to an integer using a specific rounding mode.
402 Ideally we would just build the corresponding GENERIC node,
403 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
406 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
407 enum rounding_mode op
)
412 return build_fixbound_expr (pblock
, arg
, type
, 0);
416 return build_fixbound_expr (pblock
, arg
, type
, 1);
420 return build_round_expr (arg
, type
);
424 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
433 /* Round a real value using the specified rounding mode.
434 We use a temporary integer of that same kind size as the result.
435 Values larger than those that can be represented by this kind are
436 unchanged, as they will not be accurate enough to represent the
438 huge = HUGE (KIND (a))
439 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
443 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
455 kind
= expr
->ts
.kind
;
456 nargs
= gfc_intrinsic_argument_list_length (expr
);
459 /* We have builtin functions for some cases. */
463 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
467 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
474 /* Evaluate the argument. */
475 gcc_assert (expr
->value
.function
.actual
->expr
);
476 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
478 /* Use a builtin function if one exists. */
479 if (decl
!= NULL_TREE
)
481 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
485 /* This code is probably redundant, but we'll keep it lying around just
487 type
= gfc_typenode_for_spec (&expr
->ts
);
488 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
490 /* Test if the value is too large to handle sensibly. */
491 gfc_set_model_kind (kind
);
493 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
494 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
495 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
496 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
499 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
500 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
501 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
503 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
505 itype
= gfc_get_int_type (kind
);
507 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
508 tmp
= convert (type
, tmp
);
509 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
515 /* Convert to an integer using the specified rounding mode. */
518 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
524 nargs
= gfc_intrinsic_argument_list_length (expr
);
525 args
= XALLOCAVEC (tree
, nargs
);
527 /* Evaluate the argument, we process all arguments even though we only
528 use the first one for code generation purposes. */
529 type
= gfc_typenode_for_spec (&expr
->ts
);
530 gcc_assert (expr
->value
.function
.actual
->expr
);
531 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
533 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
535 /* Conversion to a different integer kind. */
536 se
->expr
= convert (type
, args
[0]);
540 /* Conversion from complex to non-complex involves taking the real
541 component of the value. */
542 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
543 && expr
->ts
.type
!= BT_COMPLEX
)
547 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
548 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
552 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
557 /* Get the imaginary component of a value. */
560 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
564 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
565 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
566 TREE_TYPE (TREE_TYPE (arg
)), arg
);
570 /* Get the complex conjugate of a value. */
573 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
577 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
578 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
584 define_quad_builtin (const char *name
, tree type
, bool is_const
)
587 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
590 /* Mark the decl as external. */
591 DECL_EXTERNAL (fndecl
) = 1;
592 TREE_PUBLIC (fndecl
) = 1;
594 /* Mark it __attribute__((const)). */
595 TREE_READONLY (fndecl
) = is_const
;
597 rest_of_decl_compilation (fndecl
, 1, 0);
604 /* Initialize function decls for library functions. The external functions
605 are created as required. Builtin functions are added here. */
608 gfc_build_intrinsic_lib_fndecls (void)
610 gfc_intrinsic_map_t
*m
;
611 tree quad_decls
[END_BUILTINS
+ 1];
613 if (gfc_real16_is_float128
)
615 /* If we have soft-float types, we create the decls for their
616 C99-like library functions. For now, we only handle __float128
617 q-suffixed functions. */
619 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
620 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
622 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
624 type
= float128_type_node
;
625 complex_type
= complex_float128_type_node
;
626 /* type (*) (type) */
627 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
629 func_iround
= build_function_type_list (integer_type_node
,
631 /* long (*) (type) */
632 func_lround
= build_function_type_list (long_integer_type_node
,
634 /* long long (*) (type) */
635 func_llround
= build_function_type_list (long_long_integer_type_node
,
637 /* type (*) (type, type) */
638 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
639 /* type (*) (type, &int) */
641 = build_function_type_list (type
,
643 build_pointer_type (integer_type_node
),
645 /* type (*) (type, int) */
646 func_scalbn
= build_function_type_list (type
,
647 type
, integer_type_node
, NULL_TREE
);
648 /* type (*) (complex type) */
649 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
650 /* complex type (*) (complex type, complex type) */
652 = build_function_type_list (complex_type
,
653 complex_type
, complex_type
, NULL_TREE
);
655 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
656 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
657 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
659 /* Only these built-ins are actually needed here. These are used directly
660 from the code, when calling builtin_decl_for_precision() or
661 builtin_decl_for_float_type(). The others are all constructed by
662 gfc_get_intrinsic_lib_fndecl(). */
663 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
664 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
666 #include "mathbuiltins.def"
670 #undef DEFINE_MATH_BUILTIN
671 #undef DEFINE_MATH_BUILTIN_C
673 /* There is one built-in we defined manually, because it gets called
674 with builtin_decl_for_precision() or builtin_decl_for_float_type()
675 even though it is not an OTHER_BUILTIN: it is SQRT. */
676 quad_decls
[BUILT_IN_SQRT
] = define_quad_builtin ("sqrtq", func_1
, true);
680 /* Add GCC builtin functions. */
681 for (m
= gfc_intrinsic_map
;
682 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
684 if (m
->float_built_in
!= END_BUILTINS
)
685 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
686 if (m
->complex_float_built_in
!= END_BUILTINS
)
687 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
688 if (m
->double_built_in
!= END_BUILTINS
)
689 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
690 if (m
->complex_double_built_in
!= END_BUILTINS
)
691 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
693 /* If real(kind=10) exists, it is always long double. */
694 if (m
->long_double_built_in
!= END_BUILTINS
)
695 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
696 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
698 = builtin_decl_explicit (m
->complex_long_double_built_in
);
700 if (!gfc_real16_is_float128
)
702 if (m
->long_double_built_in
!= END_BUILTINS
)
703 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
704 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
706 = builtin_decl_explicit (m
->complex_long_double_built_in
);
708 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
710 /* Quad-precision function calls are constructed when first
711 needed by builtin_decl_for_precision(), except for those
712 that will be used directly (define by OTHER_BUILTIN). */
713 m
->real16_decl
= quad_decls
[m
->double_built_in
];
715 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
717 /* Same thing for the complex ones. */
718 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
724 /* Create a fndecl for a simple intrinsic library function. */
727 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
730 vec
<tree
, va_gc
> *argtypes
;
732 gfc_actual_arglist
*actual
;
735 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
738 if (ts
->type
== BT_REAL
)
743 pdecl
= &m
->real4_decl
;
746 pdecl
= &m
->real8_decl
;
749 pdecl
= &m
->real10_decl
;
752 pdecl
= &m
->real16_decl
;
758 else if (ts
->type
== BT_COMPLEX
)
760 gcc_assert (m
->complex_available
);
765 pdecl
= &m
->complex4_decl
;
768 pdecl
= &m
->complex8_decl
;
771 pdecl
= &m
->complex10_decl
;
774 pdecl
= &m
->complex16_decl
;
788 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
789 if (gfc_real_kinds
[n
].c_float
)
790 snprintf (name
, sizeof (name
), "%s%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
792 else if (gfc_real_kinds
[n
].c_double
)
793 snprintf (name
, sizeof (name
), "%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
795 else if (gfc_real_kinds
[n
].c_long_double
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
798 else if (gfc_real_kinds
[n
].c_float128
)
799 snprintf (name
, sizeof (name
), "%s%s%s",
800 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
806 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
807 ts
->type
== BT_COMPLEX
? 'c' : 'r',
812 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
814 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
815 vec_safe_push (argtypes
, type
);
817 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
818 fndecl
= build_decl (input_location
,
819 FUNCTION_DECL
, get_identifier (name
), type
);
821 /* Mark the decl as external. */
822 DECL_EXTERNAL (fndecl
) = 1;
823 TREE_PUBLIC (fndecl
) = 1;
825 /* Mark it __attribute__((const)), if possible. */
826 TREE_READONLY (fndecl
) = m
->is_constant
;
828 rest_of_decl_compilation (fndecl
, 1, 0);
835 /* Convert an intrinsic function into an external or builtin call. */
838 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
840 gfc_intrinsic_map_t
*m
;
844 unsigned int num_args
;
847 id
= expr
->value
.function
.isym
->id
;
848 /* Find the entry for this function. */
849 for (m
= gfc_intrinsic_map
;
850 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
856 if (m
->id
== GFC_ISYM_NONE
)
858 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
859 expr
->value
.function
.name
, id
);
862 /* Get the decl and generate the call. */
863 num_args
= gfc_intrinsic_argument_list_length (expr
);
864 args
= XALLOCAVEC (tree
, num_args
);
866 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
867 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
868 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
870 fndecl
= build_addr (fndecl
);
871 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
875 /* If bounds-checking is enabled, create code to verify at runtime that the
876 string lengths for both expressions are the same (needed for e.g. MERGE).
877 If bounds-checking is not enabled, does nothing. */
880 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
881 tree a
, tree b
, stmtblock_t
* target
)
886 /* If bounds-checking is disabled, do nothing. */
887 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
890 /* Compare the two string lengths. */
891 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
893 /* Output the runtime-check. */
894 name
= gfc_build_cstring_const (intr_name
);
895 name
= gfc_build_addr_expr (pchar_type_node
, name
);
896 gfc_trans_runtime_check (true, false, cond
, target
, where
,
897 "Unequal character lengths (%ld/%ld) in %s",
898 fold_convert (long_integer_type_node
, a
),
899 fold_convert (long_integer_type_node
, b
), name
);
903 /* The EXPONENT(X) intrinsic function is translated into
905 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
906 so that if X is a NaN or infinity, the result is HUGE(0).
910 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
912 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
915 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
916 expr
->value
.function
.actual
->expr
->ts
.kind
);
918 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
919 arg
= gfc_evaluate_now (arg
, &se
->pre
);
921 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
922 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
923 cond
= build_call_expr_loc (input_location
,
924 builtin_decl_explicit (BUILT_IN_ISFINITE
),
927 res
= gfc_create_var (integer_type_node
, NULL
);
928 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
929 gfc_build_addr_expr (NULL_TREE
, res
));
930 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
932 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
935 type
= gfc_typenode_for_spec (&expr
->ts
);
936 se
->expr
= fold_convert (type
, se
->expr
);
940 /* Fill in the following structure
941 struct caf_vector_t {
942 size_t nvec; // size of the vector
949 ptrdiff_t lower_bound;
950 ptrdiff_t upper_bound;
957 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
958 tree lower
, tree upper
, tree stride
,
959 tree vector
, int kind
, tree nvec
)
961 tree field
, type
, tmp
;
963 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
964 type
= TREE_TYPE (desc
);
966 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
967 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
968 desc
, field
, NULL_TREE
);
969 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
972 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
973 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
974 desc
, field
, NULL_TREE
);
975 type
= TREE_TYPE (desc
);
977 /* Access the inner struct. */
978 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
979 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
980 desc
, field
, NULL_TREE
);
981 type
= TREE_TYPE (desc
);
983 if (vector
!= NULL_TREE
)
985 /* Set dim.lower/upper/stride. */
986 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
987 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
988 desc
, field
, NULL_TREE
);
989 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
990 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
991 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
992 desc
, field
, NULL_TREE
);
993 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
997 /* Set vector and kind. */
998 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
999 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1000 desc
, field
, NULL_TREE
);
1001 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1003 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1004 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1005 desc
, field
, NULL_TREE
);
1006 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1008 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1009 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1010 desc
, field
, NULL_TREE
);
1011 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1017 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1020 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1021 tree lbound
, ubound
, tmp
;
1024 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1026 for (i
= 0; i
< ar
->dimen
; i
++)
1027 switch (ar
->dimen_type
[i
])
1032 gfc_init_se (&argse
, NULL
);
1033 gfc_conv_expr (&argse
, ar
->end
[i
]);
1034 gfc_add_block_to_block (block
, &argse
.pre
);
1035 upper
= gfc_evaluate_now (argse
.expr
, block
);
1038 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1041 gfc_init_se (&argse
, NULL
);
1042 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1043 gfc_add_block_to_block (block
, &argse
.pre
);
1044 stride
= gfc_evaluate_now (argse
.expr
, block
);
1047 stride
= gfc_index_one_node
;
1053 gfc_init_se (&argse
, NULL
);
1054 gfc_conv_expr (&argse
, ar
->start
[i
]);
1055 gfc_add_block_to_block (block
, &argse
.pre
);
1056 lower
= gfc_evaluate_now (argse
.expr
, block
);
1059 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1060 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1063 stride
= gfc_index_one_node
;
1066 nvec
= size_zero_node
;
1067 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1072 gfc_init_se (&argse
, NULL
);
1073 argse
.descriptor_only
= 1;
1074 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1075 gfc_add_block_to_block (block
, &argse
.pre
);
1076 vector
= argse
.expr
;
1077 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1078 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1079 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1080 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1081 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1082 TREE_TYPE (nvec
), nvec
, tmp
);
1083 lower
= gfc_index_zero_node
;
1084 upper
= gfc_index_zero_node
;
1085 stride
= gfc_index_zero_node
;
1086 vector
= gfc_conv_descriptor_data_get (vector
);
1087 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1088 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1093 return gfc_build_addr_expr (NULL_TREE
, var
);
1097 /* Get data from a remote coarray. */
1100 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1101 tree may_require_tmp
)
1103 gfc_expr
*array_expr
;
1105 tree caf_decl
, token
, offset
, image_index
, tmp
;
1106 tree res_var
, dst_var
, type
, kind
, vec
;
1108 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1110 if (se
->ss
&& se
->ss
->info
->useflags
)
1112 /* Access the previously obtained result. */
1113 gfc_conv_tmp_array_ref (se
);
1117 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1118 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1119 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1124 vec
= null_pointer_node
;
1126 gfc_init_se (&argse
, NULL
);
1127 if (array_expr
->rank
== 0)
1129 symbol_attribute attr
;
1131 gfc_clear_attr (&attr
);
1132 gfc_conv_expr (&argse
, array_expr
);
1134 if (lhs
== NULL_TREE
)
1136 gfc_clear_attr (&attr
);
1137 if (array_expr
->ts
.type
== BT_CHARACTER
)
1138 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1139 argse
.string_length
);
1141 res_var
= gfc_create_var (type
, "caf_res");
1142 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1143 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1145 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1146 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1150 /* If has_vector, pass descriptor for whole array and the
1151 vector bounds separately. */
1152 gfc_array_ref
*ar
, ar2
;
1153 bool has_vector
= false;
1155 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1158 ar
= gfc_find_array_ref (expr
);
1160 memset (ar
, '\0', sizeof (*ar
));
1164 gfc_conv_expr_descriptor (&argse
, array_expr
);
1165 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1166 has the wrong type if component references are done. */
1167 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1168 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1173 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1177 if (lhs
== NULL_TREE
)
1179 /* Create temporary. */
1180 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1181 if (se
->loop
->to
[n
] == NULL_TREE
)
1184 gfc_conv_descriptor_lbound_get (argse
.expr
, gfc_rank_cst
[n
]);
1186 gfc_conv_descriptor_ubound_get (argse
.expr
, gfc_rank_cst
[n
]);
1188 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1189 NULL_TREE
, false, true, false,
1190 &array_expr
->where
);
1191 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1192 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1194 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1197 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1198 if (lhs_kind
== NULL_TREE
)
1201 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1202 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1204 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1205 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1206 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1207 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1208 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, argse
.expr
, array_expr
);
1210 /* No overlap possible as we have generated a temporary. */
1211 if (lhs
== NULL_TREE
)
1212 may_require_tmp
= boolean_false_node
;
1214 /* It guarantees memory consistency within the same segment */
1215 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1216 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1217 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1218 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1219 ASM_VOLATILE_P (tmp
) = 1;
1220 gfc_add_expr_to_block (&se
->pre
, tmp
);
1222 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 9,
1223 token
, offset
, image_index
, argse
.expr
, vec
,
1224 dst_var
, kind
, lhs_kind
, may_require_tmp
);
1225 gfc_add_expr_to_block (&se
->pre
, tmp
);
1228 gfc_advance_se_ss_chain (se
);
1231 if (array_expr
->ts
.type
== BT_CHARACTER
)
1232 se
->string_length
= argse
.string_length
;
1236 /* Send data to a remove coarray. */
1239 conv_caf_send (gfc_code
*code
) {
1240 gfc_expr
*lhs_expr
, *rhs_expr
;
1241 gfc_se lhs_se
, rhs_se
;
1243 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1244 tree may_require_tmp
;
1245 tree lhs_type
= NULL_TREE
;
1246 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1248 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1250 lhs_expr
= code
->ext
.actual
->expr
;
1251 rhs_expr
= code
->ext
.actual
->next
->expr
;
1252 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1253 ? boolean_false_node
: boolean_true_node
;
1254 gfc_init_block (&block
);
1257 gfc_init_se (&lhs_se
, NULL
);
1258 if (lhs_expr
->rank
== 0)
1260 symbol_attribute attr
;
1261 gfc_clear_attr (&attr
);
1262 gfc_conv_expr (&lhs_se
, lhs_expr
);
1263 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1264 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1265 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1269 /* If has_vector, pass descriptor for whole array and the
1270 vector bounds separately. */
1271 gfc_array_ref
*ar
, ar2
;
1272 bool has_vector
= false;
1274 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1277 ar
= gfc_find_array_ref (lhs_expr
);
1279 memset (ar
, '\0', sizeof (*ar
));
1283 lhs_se
.want_pointer
= 1;
1284 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1285 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1286 has the wrong type if component references are done. */
1287 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1288 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1289 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1290 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1295 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1300 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1301 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1303 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1304 temporary and a loop. */
1305 if (!gfc_is_coindexed (lhs_expr
))
1307 gcc_assert (gfc_is_coindexed (rhs_expr
));
1308 gfc_init_se (&rhs_se
, NULL
);
1309 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1311 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1312 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1313 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1314 return gfc_finish_block (&block
);
1317 /* Obtain token, offset and image index for the LHS. */
1319 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1320 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1321 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1322 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1323 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, lhs_se
.expr
, lhs_expr
);
1326 gfc_init_se (&rhs_se
, NULL
);
1327 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1328 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1329 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1330 if (rhs_expr
->rank
== 0)
1332 symbol_attribute attr
;
1333 gfc_clear_attr (&attr
);
1334 gfc_conv_expr (&rhs_se
, rhs_expr
);
1335 if (!gfc_is_coindexed (rhs_expr
) && rhs_expr
->ts
.type
!= BT_CHARACTER
)
1336 rhs_se
.expr
= fold_convert (lhs_type
, rhs_se
.expr
);
1337 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
1338 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
1342 /* If has_vector, pass descriptor for whole array and the
1343 vector bounds separately. */
1344 gfc_array_ref
*ar
, ar2
;
1345 bool has_vector
= false;
1348 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
1351 ar
= gfc_find_array_ref (rhs_expr
);
1353 memset (ar
, '\0', sizeof (*ar
));
1357 rhs_se
.want_pointer
= 1;
1358 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
1359 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1360 has the wrong type if component references are done. */
1361 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
1362 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
1363 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1364 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1369 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
1374 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1376 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
1378 if (!gfc_is_coindexed (rhs_expr
))
1379 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 9, token
,
1380 offset
, image_index
, lhs_se
.expr
, vec
,
1381 rhs_se
.expr
, lhs_kind
, rhs_kind
, may_require_tmp
);
1384 tree rhs_token
, rhs_offset
, rhs_image_index
;
1386 /* It guarantees memory consistency within the same segment */
1387 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1388 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1389 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1390 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1391 ASM_VOLATILE_P (tmp
) = 1;
1392 gfc_add_expr_to_block (&block
, tmp
);
1394 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
1395 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1396 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1397 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
1398 gfc_get_caf_token_offset (&rhs_token
, &rhs_offset
, caf_decl
, rhs_se
.expr
,
1400 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
, 13,
1401 token
, offset
, image_index
, lhs_se
.expr
, vec
,
1402 rhs_token
, rhs_offset
, rhs_image_index
,
1403 rhs_se
.expr
, rhs_vec
, lhs_kind
, rhs_kind
,
1406 gfc_add_expr_to_block (&block
, tmp
);
1407 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1408 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1410 /* It guarantees memory consistency within the same segment */
1411 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1412 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1413 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1414 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1415 ASM_VOLATILE_P (tmp
) = 1;
1416 gfc_add_expr_to_block (&block
, tmp
);
1418 return gfc_finish_block (&block
);
1423 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
1426 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
1427 lbound
, ubound
, extent
, ml
;
1430 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
1432 if (expr
->value
.function
.actual
->expr
1433 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
1434 distance
= expr
->value
.function
.actual
->expr
;
1436 /* The case -fcoarray=single is handled elsewhere. */
1437 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
1439 /* Argument-free version: THIS_IMAGE(). */
1440 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
1444 gfc_init_se (&argse
, NULL
);
1445 gfc_conv_expr_val (&argse
, distance
);
1446 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1447 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1448 tmp
= fold_convert (integer_type_node
, argse
.expr
);
1451 tmp
= integer_zero_node
;
1452 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1454 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1459 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1461 type
= gfc_get_int_type (gfc_default_integer_kind
);
1462 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1463 rank
= expr
->value
.function
.actual
->expr
->rank
;
1465 /* Obtain the descriptor of the COARRAY. */
1466 gfc_init_se (&argse
, NULL
);
1467 argse
.want_coarray
= 1;
1468 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1469 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1470 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1475 /* Create an implicit second parameter from the loop variable. */
1476 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
1477 gcc_assert (corank
> 0);
1478 gcc_assert (se
->loop
->dimen
== 1);
1479 gcc_assert (se
->ss
->info
->expr
== expr
);
1481 dim_arg
= se
->loop
->loopvar
[0];
1482 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
1483 gfc_array_index_type
, dim_arg
,
1484 build_int_cst (TREE_TYPE (dim_arg
), 1));
1485 gfc_advance_se_ss_chain (se
);
1489 /* Use the passed DIM= argument. */
1490 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
1491 gfc_init_se (&argse
, NULL
);
1492 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
1493 gfc_array_index_type
);
1494 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1495 dim_arg
= argse
.expr
;
1497 if (INTEGER_CST_P (dim_arg
))
1499 if (wi::ltu_p (dim_arg
, 1)
1500 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
1501 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1502 "dimension index", expr
->value
.function
.isym
->name
,
1505 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1507 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1508 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1510 build_int_cst (TREE_TYPE (dim_arg
), 1));
1511 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1512 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1514 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1515 boolean_type_node
, cond
, tmp
);
1516 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1521 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1522 one always has a dim_arg argument.
1524 m = this_image() - 1
1527 sub(1) = m + lcobound(corank)
1531 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1534 extent = gfc_extent(i)
1542 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1543 : m + lcobound(corank)
1546 /* this_image () - 1. */
1547 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1549 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
1550 fold_convert (type
, tmp
), build_int_cst (type
, 1));
1553 /* sub(1) = m + lcobound(corank). */
1554 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1555 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1557 lbound
= fold_convert (type
, lbound
);
1558 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1564 m
= gfc_create_var (type
, NULL
);
1565 ml
= gfc_create_var (type
, NULL
);
1566 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1567 min_var
= gfc_create_var (integer_type_node
, NULL
);
1569 /* m = this_image () - 1. */
1570 gfc_add_modify (&se
->pre
, m
, tmp
);
1572 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1573 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1574 fold_convert (integer_type_node
, dim_arg
),
1575 build_int_cst (integer_type_node
, rank
- 1));
1576 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1577 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1579 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1582 tmp
= build_int_cst (integer_type_node
, rank
);
1583 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1585 exit_label
= gfc_build_label_decl (NULL_TREE
);
1586 TREE_USED (exit_label
) = 1;
1589 gfc_init_block (&loop
);
1592 gfc_add_modify (&loop
, ml
, m
);
1595 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1596 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1597 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1598 extent
= fold_convert (type
, extent
);
1601 gfc_add_modify (&loop
, m
,
1602 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1605 /* Exit condition: if (i >= min_var) goto exit_label. */
1606 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1608 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1609 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1610 build_empty_stmt (input_location
));
1611 gfc_add_expr_to_block (&loop
, tmp
);
1613 /* Increment loop variable: i++. */
1614 gfc_add_modify (&loop
, loop_var
,
1615 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1617 build_int_cst (integer_type_node
, 1)));
1619 /* Making the loop... actually loop! */
1620 tmp
= gfc_finish_block (&loop
);
1621 tmp
= build1_v (LOOP_EXPR
, tmp
);
1622 gfc_add_expr_to_block (&se
->pre
, tmp
);
1624 /* The exit label. */
1625 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1626 gfc_add_expr_to_block (&se
->pre
, tmp
);
1628 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1629 : m + lcobound(corank) */
1631 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1632 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1634 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1635 fold_build2_loc (input_location
, PLUS_EXPR
,
1636 gfc_array_index_type
, dim_arg
,
1637 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1638 lbound
= fold_convert (type
, lbound
);
1640 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1641 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1643 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1645 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1646 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1652 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1654 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1656 gfc_se argse
, subse
;
1657 int rank
, corank
, codim
;
1659 type
= gfc_get_int_type (gfc_default_integer_kind
);
1660 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1661 rank
= expr
->value
.function
.actual
->expr
->rank
;
1663 /* Obtain the descriptor of the COARRAY. */
1664 gfc_init_se (&argse
, NULL
);
1665 argse
.want_coarray
= 1;
1666 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1667 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1668 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1671 /* Obtain a handle to the SUB argument. */
1672 gfc_init_se (&subse
, NULL
);
1673 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1674 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1675 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1676 subdesc
= build_fold_indirect_ref_loc (input_location
,
1677 gfc_conv_descriptor_data_get (subse
.expr
));
1679 /* Fortran 2008 does not require that the values remain in the cobounds,
1680 thus we need explicitly check this - and return 0 if they are exceeded. */
1682 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1683 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1684 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1685 fold_convert (gfc_array_index_type
, tmp
),
1688 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1690 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1691 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1692 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1693 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1694 fold_convert (gfc_array_index_type
, tmp
),
1696 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1697 boolean_type_node
, invalid_bound
, cond
);
1698 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1699 fold_convert (gfc_array_index_type
, tmp
),
1701 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1702 boolean_type_node
, invalid_bound
, cond
);
1705 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
1707 /* See Fortran 2008, C.10 for the following algorithm. */
1709 /* coindex = sub(corank) - lcobound(n). */
1710 coindex
= fold_convert (gfc_array_index_type
,
1711 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1713 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1714 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1715 fold_convert (gfc_array_index_type
, coindex
),
1718 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1720 tree extent
, ubound
;
1722 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1723 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1724 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1725 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1727 /* coindex *= extent. */
1728 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1729 gfc_array_index_type
, coindex
, extent
);
1731 /* coindex += sub(codim). */
1732 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1733 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1734 gfc_array_index_type
, coindex
,
1735 fold_convert (gfc_array_index_type
, tmp
));
1737 /* coindex -= lbound(codim). */
1738 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1739 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1740 gfc_array_index_type
, coindex
, lbound
);
1743 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1744 fold_convert(type
, coindex
),
1745 build_int_cst (type
, 1));
1747 /* Return 0 if "coindex" exceeds num_images(). */
1749 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
1750 num_images
= build_int_cst (type
, 1);
1753 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1755 build_int_cst (integer_type_node
, -1));
1756 num_images
= fold_convert (type
, tmp
);
1759 tmp
= gfc_create_var (type
, NULL
);
1760 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1762 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1764 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1766 fold_convert (boolean_type_node
, invalid_bound
));
1767 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1768 build_int_cst (type
, 0), tmp
);
1773 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
1775 tree tmp
, distance
, failed
;
1778 if (expr
->value
.function
.actual
->expr
)
1780 gfc_init_se (&argse
, NULL
);
1781 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
1782 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1783 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1784 distance
= fold_convert (integer_type_node
, argse
.expr
);
1787 distance
= integer_zero_node
;
1789 if (expr
->value
.function
.actual
->next
->expr
)
1791 gfc_init_se (&argse
, NULL
);
1792 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
1793 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1794 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1795 failed
= fold_convert (integer_type_node
, argse
.expr
);
1798 failed
= build_int_cst (integer_type_node
, -1);
1800 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1802 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
1807 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1811 gfc_init_se (&argse
, NULL
);
1812 argse
.data_not_needed
= 1;
1813 argse
.descriptor_only
= 1;
1815 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1816 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1817 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1819 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1823 /* Evaluate a single upper or lower bound. */
1824 /* TODO: bound intrinsic generates way too much unnecessary code. */
1827 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1829 gfc_actual_arglist
*arg
;
1830 gfc_actual_arglist
*arg2
;
1835 tree cond
, cond1
, cond3
, cond4
, size
;
1839 gfc_array_spec
* as
;
1840 bool assumed_rank_lb_one
;
1842 arg
= expr
->value
.function
.actual
;
1847 /* Create an implicit second parameter from the loop variable. */
1848 gcc_assert (!arg2
->expr
);
1849 gcc_assert (se
->loop
->dimen
== 1);
1850 gcc_assert (se
->ss
->info
->expr
== expr
);
1851 gfc_advance_se_ss_chain (se
);
1852 bound
= se
->loop
->loopvar
[0];
1853 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1854 gfc_array_index_type
, bound
,
1859 /* use the passed argument. */
1860 gcc_assert (arg2
->expr
);
1861 gfc_init_se (&argse
, NULL
);
1862 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1863 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1865 /* Convert from one based to zero based. */
1866 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1867 gfc_array_index_type
, bound
,
1868 gfc_index_one_node
);
1871 /* TODO: don't re-evaluate the descriptor on each iteration. */
1872 /* Get a descriptor for the first parameter. */
1873 gfc_init_se (&argse
, NULL
);
1874 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1875 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1876 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1880 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1882 if (INTEGER_CST_P (bound
))
1884 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1885 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
1886 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
1887 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1888 "dimension index", upper
? "UBOUND" : "LBOUND",
1892 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1894 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1896 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1897 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1898 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1899 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1900 tmp
= gfc_conv_descriptor_rank (desc
);
1902 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1903 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1904 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1905 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1906 boolean_type_node
, cond
, tmp
);
1907 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1912 /* Take care of the lbound shift for assumed-rank arrays, which are
1913 nonallocatable and nonpointers. Those has a lbound of 1. */
1914 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1915 && ((arg
->expr
->ts
.type
!= BT_CLASS
1916 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1917 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1918 || (arg
->expr
->ts
.type
== BT_CLASS
1919 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1920 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1922 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1923 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1925 /* 13.14.53: Result value for LBOUND
1927 Case (i): For an array section or for an array expression other than a
1928 whole array or array structure component, LBOUND(ARRAY, DIM)
1929 has the value 1. For a whole array or array structure
1930 component, LBOUND(ARRAY, DIM) has the value:
1931 (a) equal to the lower bound for subscript DIM of ARRAY if
1932 dimension DIM of ARRAY does not have extent zero
1933 or if ARRAY is an assumed-size array of rank DIM,
1936 13.14.113: Result value for UBOUND
1938 Case (i): For an array section or for an array expression other than a
1939 whole array or array structure component, UBOUND(ARRAY, DIM)
1940 has the value equal to the number of elements in the given
1941 dimension; otherwise, it has a value equal to the upper bound
1942 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1943 not have size zero and has value zero if dimension DIM has
1946 if (!upper
&& assumed_rank_lb_one
)
1947 se
->expr
= gfc_index_one_node
;
1950 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1952 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1954 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1955 stride
, gfc_index_zero_node
);
1956 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1957 boolean_type_node
, cond3
, cond1
);
1958 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1959 stride
, gfc_index_zero_node
);
1964 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1965 boolean_type_node
, cond3
, cond4
);
1966 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1967 gfc_index_one_node
, lbound
);
1968 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1969 boolean_type_node
, cond4
, cond5
);
1971 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1972 boolean_type_node
, cond
, cond5
);
1974 if (assumed_rank_lb_one
)
1976 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1977 gfc_array_index_type
, ubound
, lbound
);
1978 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1979 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1984 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1985 gfc_array_index_type
, cond
,
1986 tmp
, gfc_index_zero_node
);
1990 if (as
->type
== AS_ASSUMED_SIZE
)
1991 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1992 bound
, build_int_cst (TREE_TYPE (bound
),
1993 arg
->expr
->rank
- 1));
1995 cond
= boolean_false_node
;
1997 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1998 boolean_type_node
, cond3
, cond4
);
1999 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2000 boolean_type_node
, cond
, cond1
);
2002 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2003 gfc_array_index_type
, cond
,
2004 lbound
, gfc_index_one_node
);
2011 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2012 gfc_array_index_type
, ubound
, lbound
);
2013 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2014 gfc_array_index_type
, size
,
2015 gfc_index_one_node
);
2016 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2017 gfc_array_index_type
, se
->expr
,
2018 gfc_index_zero_node
);
2021 se
->expr
= gfc_index_one_node
;
2024 type
= gfc_typenode_for_spec (&expr
->ts
);
2025 se
->expr
= convert (type
, se
->expr
);
2030 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2032 gfc_actual_arglist
*arg
;
2033 gfc_actual_arglist
*arg2
;
2035 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2039 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2040 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2041 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2043 arg
= expr
->value
.function
.actual
;
2046 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2047 corank
= gfc_get_corank (arg
->expr
);
2049 gfc_init_se (&argse
, NULL
);
2050 argse
.want_coarray
= 1;
2052 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2053 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2054 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2059 /* Create an implicit second parameter from the loop variable. */
2060 gcc_assert (!arg2
->expr
);
2061 gcc_assert (corank
> 0);
2062 gcc_assert (se
->loop
->dimen
== 1);
2063 gcc_assert (se
->ss
->info
->expr
== expr
);
2065 bound
= se
->loop
->loopvar
[0];
2066 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2067 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2068 gfc_advance_se_ss_chain (se
);
2072 /* use the passed argument. */
2073 gcc_assert (arg2
->expr
);
2074 gfc_init_se (&argse
, NULL
);
2075 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2076 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2079 if (INTEGER_CST_P (bound
))
2081 if (wi::ltu_p (bound
, 1)
2082 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2083 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2084 "dimension index", expr
->value
.function
.isym
->name
,
2087 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2089 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2090 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2091 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2092 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2093 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2095 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2096 boolean_type_node
, cond
, tmp
);
2097 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2102 /* Subtract 1 to get to zero based and add dimensions. */
2103 switch (arg
->expr
->rank
)
2106 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2107 gfc_array_index_type
, bound
,
2108 gfc_index_one_node
);
2112 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2113 gfc_array_index_type
, bound
,
2114 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2118 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2120 /* Handle UCOBOUND with special handling of the last codimension. */
2121 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2123 /* Last codimension: For -fcoarray=single just return
2124 the lcobound - otherwise add
2125 ceiling (real (num_images ()) / real (size)) - 1
2126 = (num_images () + size - 1) / size - 1
2127 = (num_images - 1) / size(),
2128 where size is the product of the extent of all but the last
2131 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2135 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2136 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2137 2, integer_zero_node
,
2138 build_int_cst (integer_type_node
, -1));
2139 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2140 gfc_array_index_type
,
2141 fold_convert (gfc_array_index_type
, tmp
),
2142 build_int_cst (gfc_array_index_type
, 1));
2143 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2144 gfc_array_index_type
, tmp
,
2145 fold_convert (gfc_array_index_type
, cosize
));
2146 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2147 gfc_array_index_type
, resbound
, tmp
);
2149 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2151 /* ubound = lbound + num_images() - 1. */
2152 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2153 2, integer_zero_node
,
2154 build_int_cst (integer_type_node
, -1));
2155 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2156 gfc_array_index_type
,
2157 fold_convert (gfc_array_index_type
, tmp
),
2158 build_int_cst (gfc_array_index_type
, 1));
2159 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2160 gfc_array_index_type
, resbound
, tmp
);
2165 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2167 build_int_cst (TREE_TYPE (bound
),
2168 arg
->expr
->rank
+ corank
- 1));
2170 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2171 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2172 gfc_array_index_type
, cond
,
2173 resbound
, resbound2
);
2176 se
->expr
= resbound
;
2179 se
->expr
= resbound
;
2181 type
= gfc_typenode_for_spec (&expr
->ts
);
2182 se
->expr
= convert (type
, se
->expr
);
2187 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2189 gfc_actual_arglist
*array_arg
;
2190 gfc_actual_arglist
*dim_arg
;
2194 array_arg
= expr
->value
.function
.actual
;
2195 dim_arg
= array_arg
->next
;
2197 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2199 gfc_init_se (&argse
, NULL
);
2200 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2201 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2202 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2205 gcc_assert (dim_arg
->expr
);
2206 gfc_init_se (&argse
, NULL
);
2207 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2208 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2209 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2210 argse
.expr
, gfc_index_one_node
);
2211 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2216 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2220 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2222 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
2226 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
2231 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
2232 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
2241 /* Create a complex value from one or two real components. */
2244 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
2250 unsigned int num_args
;
2252 num_args
= gfc_intrinsic_argument_list_length (expr
);
2253 args
= XALLOCAVEC (tree
, num_args
);
2255 type
= gfc_typenode_for_spec (&expr
->ts
);
2256 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2257 real
= convert (TREE_TYPE (type
), args
[0]);
2259 imag
= convert (TREE_TYPE (type
), args
[1]);
2260 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
2262 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2263 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
2264 imag
= convert (TREE_TYPE (type
), imag
);
2267 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
2269 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
2273 /* Remainder function MOD(A, P) = A - INT(A / P) * P
2274 MODULO(A, P) = A - FLOOR (A / P) * P
2276 The obvious algorithms above are numerically instable for large
2277 arguments, hence these intrinsics are instead implemented via calls
2278 to the fmod family of functions. It is the responsibility of the
2279 user to ensure that the second argument is non-zero. */
2282 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
2292 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2294 switch (expr
->ts
.type
)
2297 /* Integer case is easy, we've got a builtin op. */
2298 type
= TREE_TYPE (args
[0]);
2301 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
2304 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
2310 /* Check if we have a builtin fmod. */
2311 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
2313 /* The builtin should always be available. */
2314 gcc_assert (fmod
!= NULL_TREE
);
2316 tmp
= build_addr (fmod
);
2317 se
->expr
= build_call_array_loc (input_location
,
2318 TREE_TYPE (TREE_TYPE (fmod
)),
2323 type
= TREE_TYPE (args
[0]);
2325 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2326 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
2329 modulo = arg - floor (arg/arg2) * arg2
2331 In order to calculate the result accurately, we use the fmod
2332 function as follows.
2334 res = fmod (arg, arg2);
2337 if ((arg < 0) xor (arg2 < 0))
2341 res = copysign (0., arg2);
2343 => As two nested ternary exprs:
2345 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2346 : copysign (0., arg2);
2350 zero
= gfc_build_const (type
, integer_zero_node
);
2351 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2352 if (!flag_signed_zeros
)
2354 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2356 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2358 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2359 boolean_type_node
, test
, test2
);
2360 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2362 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2363 boolean_type_node
, test
, test2
);
2364 test
= gfc_evaluate_now (test
, &se
->pre
);
2365 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2366 fold_build2_loc (input_location
,
2368 type
, tmp
, args
[1]),
2373 tree expr1
, copysign
, cscall
;
2374 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
2376 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2378 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2380 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2381 boolean_type_node
, test
, test2
);
2382 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
2383 fold_build2_loc (input_location
,
2385 type
, tmp
, args
[1]),
2387 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2389 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
2391 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2401 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2402 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2403 where the right shifts are logical (i.e. 0's are shifted in).
2404 Because SHIFT_EXPR's want shifts strictly smaller than the integral
2405 type width, we have to special-case both S == 0 and S == BITSIZE(J):
2407 DSHIFTL(I,J,BITSIZE) = J
2409 DSHIFTR(I,J,BITSIZE) = I. */
2412 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
2414 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
2415 tree args
[3], cond
, tmp
;
2418 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2420 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
2421 type
= TREE_TYPE (args
[0]);
2422 bitsize
= TYPE_PRECISION (type
);
2423 utype
= unsigned_type_for (type
);
2424 stype
= TREE_TYPE (args
[2]);
2426 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
2427 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
2428 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
2430 /* The generic case. */
2431 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
2432 build_int_cst (stype
, bitsize
), shift
);
2433 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
2434 arg1
, dshiftl
? shift
: tmp
);
2436 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
2437 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
2438 right
= fold_convert (type
, right
);
2440 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
2442 /* Special cases. */
2443 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2444 build_int_cst (stype
, 0));
2445 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2446 dshiftl
? arg1
: arg2
, res
);
2448 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2449 build_int_cst (stype
, bitsize
));
2450 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2451 dshiftl
? arg2
: arg1
, res
);
2457 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
2460 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
2468 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2469 type
= TREE_TYPE (args
[0]);
2471 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
2472 val
= gfc_evaluate_now (val
, &se
->pre
);
2474 zero
= gfc_build_const (type
, integer_zero_node
);
2475 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
2476 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
2480 /* SIGN(A, B) is absolute value of A times sign of B.
2481 The real value versions use library functions to ensure the correct
2482 handling of negative zero. Integer case implemented as:
2483 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
2487 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
2493 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2494 if (expr
->ts
.type
== BT_REAL
)
2498 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
2499 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
2501 /* We explicitly have to ignore the minus sign. We do so by using
2502 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
2504 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
2507 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
2508 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2510 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2511 TREE_TYPE (args
[0]), cond
,
2512 build_call_expr_loc (input_location
, abs
, 1,
2514 build_call_expr_loc (input_location
, tmp
, 2,
2518 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
2523 /* Having excluded floating point types, we know we are now dealing
2524 with signed integer types. */
2525 type
= TREE_TYPE (args
[0]);
2527 /* Args[0] is used multiple times below. */
2528 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2530 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2531 the signs of A and B are the same, and of all ones if they differ. */
2532 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2533 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2534 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2535 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2537 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2538 is all ones (i.e. -1). */
2539 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2540 fold_build2_loc (input_location
, PLUS_EXPR
,
2541 type
, args
[0], tmp
), tmp
);
2545 /* Test for the presence of an optional argument. */
2548 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2552 arg
= expr
->value
.function
.actual
->expr
;
2553 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2554 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2555 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2559 /* Calculate the double precision product of two single precision values. */
2562 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2567 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2569 /* Convert the args to double precision before multiplying. */
2570 type
= gfc_typenode_for_spec (&expr
->ts
);
2571 args
[0] = convert (type
, args
[0]);
2572 args
[1] = convert (type
, args
[1]);
2573 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2578 /* Return a length one character string containing an ascii character. */
2581 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2586 unsigned int num_args
;
2588 num_args
= gfc_intrinsic_argument_list_length (expr
);
2589 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2591 type
= gfc_get_char_type (expr
->ts
.kind
);
2592 var
= gfc_create_var (type
, "char");
2594 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2595 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2596 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2597 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2602 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2610 unsigned int num_args
;
2612 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2613 args
= XALLOCAVEC (tree
, num_args
);
2615 var
= gfc_create_var (pchar_type_node
, "pstr");
2616 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2618 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2619 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2620 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2622 fndecl
= build_addr (gfor_fndecl_ctime
);
2623 tmp
= build_call_array_loc (input_location
,
2624 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2625 fndecl
, num_args
, args
);
2626 gfc_add_expr_to_block (&se
->pre
, tmp
);
2628 /* Free the temporary afterwards, if necessary. */
2629 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2630 len
, build_int_cst (TREE_TYPE (len
), 0));
2631 tmp
= gfc_call_free (var
);
2632 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2633 gfc_add_expr_to_block (&se
->post
, tmp
);
2636 se
->string_length
= len
;
2641 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2649 unsigned int num_args
;
2651 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2652 args
= XALLOCAVEC (tree
, num_args
);
2654 var
= gfc_create_var (pchar_type_node
, "pstr");
2655 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2657 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2658 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2659 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2661 fndecl
= build_addr (gfor_fndecl_fdate
);
2662 tmp
= build_call_array_loc (input_location
,
2663 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2664 fndecl
, num_args
, args
);
2665 gfc_add_expr_to_block (&se
->pre
, tmp
);
2667 /* Free the temporary afterwards, if necessary. */
2668 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2669 len
, build_int_cst (TREE_TYPE (len
), 0));
2670 tmp
= gfc_call_free (var
);
2671 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2672 gfc_add_expr_to_block (&se
->post
, tmp
);
2675 se
->string_length
= len
;
2679 /* Generate a direct call to free() for the FREE subroutine. */
2682 conv_intrinsic_free (gfc_code
*code
)
2688 gfc_init_se (&argse
, NULL
);
2689 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
2690 arg
= fold_convert (ptr_type_node
, argse
.expr
);
2692 gfc_init_block (&block
);
2693 call
= build_call_expr_loc (input_location
,
2694 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
2695 gfc_add_expr_to_block (&block
, call
);
2696 return gfc_finish_block (&block
);
2700 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
2704 conv_intrinsic_system_clock (gfc_code
*code
)
2707 gfc_se count_se
, count_rate_se
, count_max_se
;
2708 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
2712 gfc_expr
*count
= code
->ext
.actual
->expr
;
2713 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
2714 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
2716 /* Evaluate our arguments. */
2719 gfc_init_se (&count_se
, NULL
);
2720 gfc_conv_expr (&count_se
, count
);
2725 gfc_init_se (&count_rate_se
, NULL
);
2726 gfc_conv_expr (&count_rate_se
, count_rate
);
2731 gfc_init_se (&count_max_se
, NULL
);
2732 gfc_conv_expr (&count_max_se
, count_max
);
2735 /* Find the smallest kind found of the arguments. */
2737 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
2738 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
2740 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
2743 /* Prepare temporary variables. */
2748 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
2749 else if (least
== 4)
2750 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
2751 else if (count
->ts
.kind
== 1)
2752 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
2755 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
2762 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
2763 else if (least
== 4)
2764 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
2766 arg2
= integer_zero_node
;
2772 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
2773 else if (least
== 4)
2774 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
2776 arg3
= integer_zero_node
;
2779 /* Make the function call. */
2780 gfc_init_block (&block
);
2786 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2787 : null_pointer_node
;
2788 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2789 : null_pointer_node
;
2790 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2791 : null_pointer_node
;
2796 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2797 : null_pointer_node
;
2798 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2799 : null_pointer_node
;
2800 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2801 : null_pointer_node
;
2808 tmp
= build_call_expr_loc (input_location
,
2809 gfor_fndecl_system_clock4
, 3,
2810 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2811 : null_pointer_node
,
2812 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2813 : null_pointer_node
,
2814 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2815 : null_pointer_node
);
2816 gfc_add_expr_to_block (&block
, tmp
);
2818 /* Handle kind>=8, 10, or 16 arguments */
2821 tmp
= build_call_expr_loc (input_location
,
2822 gfor_fndecl_system_clock8
, 3,
2823 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2824 : null_pointer_node
,
2825 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2826 : null_pointer_node
,
2827 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2828 : null_pointer_node
);
2829 gfc_add_expr_to_block (&block
, tmp
);
2833 /* And store values back if needed. */
2834 if (arg1
&& arg1
!= count_se
.expr
)
2835 gfc_add_modify (&block
, count_se
.expr
,
2836 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
2837 if (arg2
&& arg2
!= count_rate_se
.expr
)
2838 gfc_add_modify (&block
, count_rate_se
.expr
,
2839 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
2840 if (arg3
&& arg3
!= count_max_se
.expr
)
2841 gfc_add_modify (&block
, count_max_se
.expr
,
2842 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
2844 return gfc_finish_block (&block
);
2848 /* Return a character string containing the tty name. */
2851 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2859 unsigned int num_args
;
2861 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2862 args
= XALLOCAVEC (tree
, num_args
);
2864 var
= gfc_create_var (pchar_type_node
, "pstr");
2865 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2867 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2868 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2869 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2871 fndecl
= build_addr (gfor_fndecl_ttynam
);
2872 tmp
= build_call_array_loc (input_location
,
2873 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2874 fndecl
, num_args
, args
);
2875 gfc_add_expr_to_block (&se
->pre
, tmp
);
2877 /* Free the temporary afterwards, if necessary. */
2878 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2879 len
, build_int_cst (TREE_TYPE (len
), 0));
2880 tmp
= gfc_call_free (var
);
2881 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2882 gfc_add_expr_to_block (&se
->post
, tmp
);
2885 se
->string_length
= len
;
2889 /* Get the minimum/maximum value of all the parameters.
2890 minmax (a1, a2, a3, ...)
2893 if (a2 .op. mvar || isnan (mvar))
2895 if (a3 .op. mvar || isnan (mvar))
2902 /* TODO: Mismatching types can occur when specific names are used.
2903 These should be handled during resolution. */
2905 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2913 gfc_actual_arglist
*argexpr
;
2914 unsigned int i
, nargs
;
2916 nargs
= gfc_intrinsic_argument_list_length (expr
);
2917 args
= XALLOCAVEC (tree
, nargs
);
2919 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2920 type
= gfc_typenode_for_spec (&expr
->ts
);
2922 argexpr
= expr
->value
.function
.actual
;
2923 if (TREE_TYPE (args
[0]) != type
)
2924 args
[0] = convert (type
, args
[0]);
2925 /* Only evaluate the argument once. */
2926 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2927 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2929 mvar
= gfc_create_var (type
, "M");
2930 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2931 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2937 /* Handle absent optional arguments by ignoring the comparison. */
2938 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2939 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2940 && TREE_CODE (val
) == INDIRECT_REF
)
2941 cond
= fold_build2_loc (input_location
,
2942 NE_EXPR
, boolean_type_node
,
2943 TREE_OPERAND (val
, 0),
2944 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2949 /* Only evaluate the argument once. */
2950 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2951 val
= gfc_evaluate_now (val
, &se
->pre
);
2954 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2956 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2957 convert (type
, val
), mvar
);
2959 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2960 __builtin_isnan might be made dependent on that module being loaded,
2961 to help performance of programs that don't rely on IEEE semantics. */
2962 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2964 isnan
= build_call_expr_loc (input_location
,
2965 builtin_decl_explicit (BUILT_IN_ISNAN
),
2967 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2968 boolean_type_node
, tmp
,
2969 fold_convert (boolean_type_node
, isnan
));
2971 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2972 build_empty_stmt (input_location
));
2974 if (cond
!= NULL_TREE
)
2975 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2976 build_empty_stmt (input_location
));
2978 gfc_add_expr_to_block (&se
->pre
, tmp
);
2979 argexpr
= argexpr
->next
;
2985 /* Generate library calls for MIN and MAX intrinsics for character
2988 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2991 tree var
, len
, fndecl
, tmp
, cond
, function
;
2994 nargs
= gfc_intrinsic_argument_list_length (expr
);
2995 args
= XALLOCAVEC (tree
, nargs
+ 4);
2996 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2998 /* Create the result variables. */
2999 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3000 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3001 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3002 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3003 args
[2] = build_int_cst (integer_type_node
, op
);
3004 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3006 if (expr
->ts
.kind
== 1)
3007 function
= gfor_fndecl_string_minmax
;
3008 else if (expr
->ts
.kind
== 4)
3009 function
= gfor_fndecl_string_minmax_char4
;
3013 /* Make the function call. */
3014 fndecl
= build_addr (function
);
3015 tmp
= build_call_array_loc (input_location
,
3016 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3018 gfc_add_expr_to_block (&se
->pre
, tmp
);
3020 /* Free the temporary afterwards, if necessary. */
3021 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3022 len
, build_int_cst (TREE_TYPE (len
), 0));
3023 tmp
= gfc_call_free (var
);
3024 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3025 gfc_add_expr_to_block (&se
->post
, tmp
);
3028 se
->string_length
= len
;
3032 /* Create a symbol node for this intrinsic. The symbol from the frontend
3033 has the generic name. */
3036 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3040 /* TODO: Add symbols for intrinsic function to the global namespace. */
3041 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3042 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3045 sym
->attr
.external
= 1;
3046 sym
->attr
.function
= 1;
3047 sym
->attr
.always_explicit
= 1;
3048 sym
->attr
.proc
= PROC_INTRINSIC
;
3049 sym
->attr
.flavor
= FL_PROCEDURE
;
3053 sym
->attr
.dimension
= 1;
3054 sym
->as
= gfc_get_array_spec ();
3055 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3056 sym
->as
->rank
= expr
->rank
;
3059 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3060 ignore_optional
? expr
->value
.function
.actual
3066 /* Generate a call to an external intrinsic function. */
3068 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3071 vec
<tree
, va_gc
> *append_args
;
3073 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3076 gcc_assert (expr
->rank
> 0);
3078 gcc_assert (expr
->rank
== 0);
3080 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3082 /* Calls to libgfortran_matmul need to be appended special arguments,
3083 to be able to call the BLAS ?gemm functions if required and possible. */
3085 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3086 && sym
->ts
.type
!= BT_LOGICAL
)
3088 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3090 if (flag_external_blas
3091 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3092 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3096 if (sym
->ts
.type
== BT_REAL
)
3098 if (sym
->ts
.kind
== 4)
3099 gemm_fndecl
= gfor_fndecl_sgemm
;
3101 gemm_fndecl
= gfor_fndecl_dgemm
;
3105 if (sym
->ts
.kind
== 4)
3106 gemm_fndecl
= gfor_fndecl_cgemm
;
3108 gemm_fndecl
= gfor_fndecl_zgemm
;
3111 vec_alloc (append_args
, 3);
3112 append_args
->quick_push (build_int_cst (cint
, 1));
3113 append_args
->quick_push (build_int_cst (cint
,
3114 flag_blas_matmul_limit
));
3115 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3120 vec_alloc (append_args
, 3);
3121 append_args
->quick_push (build_int_cst (cint
, 0));
3122 append_args
->quick_push (build_int_cst (cint
, 0));
3123 append_args
->quick_push (null_pointer_node
);
3127 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3129 gfc_free_symbol (sym
);
3132 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3152 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3161 gfc_actual_arglist
*actual
;
3168 gfc_conv_intrinsic_funcall (se
, expr
);
3172 actual
= expr
->value
.function
.actual
;
3173 type
= gfc_typenode_for_spec (&expr
->ts
);
3174 /* Initialize the result. */
3175 resvar
= gfc_create_var (type
, "test");
3177 tmp
= convert (type
, boolean_true_node
);
3179 tmp
= convert (type
, boolean_false_node
);
3180 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3182 /* Walk the arguments. */
3183 arrayss
= gfc_walk_expr (actual
->expr
);
3184 gcc_assert (arrayss
!= gfc_ss_terminator
);
3186 /* Initialize the scalarizer. */
3187 gfc_init_loopinfo (&loop
);
3188 exit_label
= gfc_build_label_decl (NULL_TREE
);
3189 TREE_USED (exit_label
) = 1;
3190 gfc_add_ss_to_loop (&loop
, arrayss
);
3192 /* Initialize the loop. */
3193 gfc_conv_ss_startstride (&loop
);
3194 gfc_conv_loop_setup (&loop
, &expr
->where
);
3196 gfc_mark_ss_chain_used (arrayss
, 1);
3197 /* Generate the loop body. */
3198 gfc_start_scalarized_body (&loop
, &body
);
3200 /* If the condition matches then set the return value. */
3201 gfc_start_block (&block
);
3203 tmp
= convert (type
, boolean_false_node
);
3205 tmp
= convert (type
, boolean_true_node
);
3206 gfc_add_modify (&block
, resvar
, tmp
);
3208 /* And break out of the loop. */
3209 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3210 gfc_add_expr_to_block (&block
, tmp
);
3212 found
= gfc_finish_block (&block
);
3214 /* Check this element. */
3215 gfc_init_se (&arrayse
, NULL
);
3216 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3217 arrayse
.ss
= arrayss
;
3218 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3220 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3221 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3222 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3223 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3224 gfc_add_expr_to_block (&body
, tmp
);
3225 gfc_add_block_to_block (&body
, &arrayse
.post
);
3227 gfc_trans_scalarizing_loops (&loop
, &body
);
3229 /* Add the exit label. */
3230 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3231 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3233 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3234 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3235 gfc_cleanup_loop (&loop
);
3240 /* COUNT(A) = Number of true elements in A. */
3242 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
3249 gfc_actual_arglist
*actual
;
3255 gfc_conv_intrinsic_funcall (se
, expr
);
3259 actual
= expr
->value
.function
.actual
;
3261 type
= gfc_typenode_for_spec (&expr
->ts
);
3262 /* Initialize the result. */
3263 resvar
= gfc_create_var (type
, "count");
3264 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
3266 /* Walk the arguments. */
3267 arrayss
= gfc_walk_expr (actual
->expr
);
3268 gcc_assert (arrayss
!= gfc_ss_terminator
);
3270 /* Initialize the scalarizer. */
3271 gfc_init_loopinfo (&loop
);
3272 gfc_add_ss_to_loop (&loop
, arrayss
);
3274 /* Initialize the loop. */
3275 gfc_conv_ss_startstride (&loop
);
3276 gfc_conv_loop_setup (&loop
, &expr
->where
);
3278 gfc_mark_ss_chain_used (arrayss
, 1);
3279 /* Generate the loop body. */
3280 gfc_start_scalarized_body (&loop
, &body
);
3282 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
3283 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
3284 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
3286 gfc_init_se (&arrayse
, NULL
);
3287 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3288 arrayse
.ss
= arrayss
;
3289 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3290 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
3291 build_empty_stmt (input_location
));
3293 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3294 gfc_add_expr_to_block (&body
, tmp
);
3295 gfc_add_block_to_block (&body
, &arrayse
.post
);
3297 gfc_trans_scalarizing_loops (&loop
, &body
);
3299 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3300 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3301 gfc_cleanup_loop (&loop
);
3307 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
3308 struct and return the corresponding loopinfo. */
3310 static gfc_loopinfo
*
3311 enter_nested_loop (gfc_se
*se
)
3313 se
->ss
= se
->ss
->nested_ss
;
3314 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
3316 return se
->ss
->loop
;
3320 /* Inline implementation of the sum and product intrinsics. */
3322 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
3326 tree scale
= NULL_TREE
;
3331 gfc_loopinfo loop
, *ploop
;
3332 gfc_actual_arglist
*arg_array
, *arg_mask
;
3333 gfc_ss
*arrayss
= NULL
;
3334 gfc_ss
*maskss
= NULL
;
3338 gfc_expr
*arrayexpr
;
3343 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
3349 type
= gfc_typenode_for_spec (&expr
->ts
);
3350 /* Initialize the result. */
3351 resvar
= gfc_create_var (type
, "val");
3356 scale
= gfc_create_var (type
, "scale");
3357 gfc_add_modify (&se
->pre
, scale
,
3358 gfc_build_const (type
, integer_one_node
));
3359 tmp
= gfc_build_const (type
, integer_zero_node
);
3361 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
3362 tmp
= gfc_build_const (type
, integer_zero_node
);
3363 else if (op
== NE_EXPR
)
3365 tmp
= convert (type
, boolean_false_node
);
3366 else if (op
== BIT_AND_EXPR
)
3367 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
3368 type
, integer_one_node
));
3370 tmp
= gfc_build_const (type
, integer_one_node
);
3372 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3374 arg_array
= expr
->value
.function
.actual
;
3376 arrayexpr
= arg_array
->expr
;
3378 if (op
== NE_EXPR
|| norm2
)
3379 /* PARITY and NORM2. */
3383 arg_mask
= arg_array
->next
->next
;
3384 gcc_assert (arg_mask
!= NULL
);
3385 maskexpr
= arg_mask
->expr
;
3388 if (expr
->rank
== 0)
3390 /* Walk the arguments. */
3391 arrayss
= gfc_walk_expr (arrayexpr
);
3392 gcc_assert (arrayss
!= gfc_ss_terminator
);
3394 if (maskexpr
&& maskexpr
->rank
> 0)
3396 maskss
= gfc_walk_expr (maskexpr
);
3397 gcc_assert (maskss
!= gfc_ss_terminator
);
3402 /* Initialize the scalarizer. */
3403 gfc_init_loopinfo (&loop
);
3404 gfc_add_ss_to_loop (&loop
, arrayss
);
3405 if (maskexpr
&& maskexpr
->rank
> 0)
3406 gfc_add_ss_to_loop (&loop
, maskss
);
3408 /* Initialize the loop. */
3409 gfc_conv_ss_startstride (&loop
);
3410 gfc_conv_loop_setup (&loop
, &expr
->where
);
3412 gfc_mark_ss_chain_used (arrayss
, 1);
3413 if (maskexpr
&& maskexpr
->rank
> 0)
3414 gfc_mark_ss_chain_used (maskss
, 1);
3419 /* All the work has been done in the parent loops. */
3420 ploop
= enter_nested_loop (se
);
3424 /* Generate the loop body. */
3425 gfc_start_scalarized_body (ploop
, &body
);
3427 /* If we have a mask, only add this element if the mask is set. */
3428 if (maskexpr
&& maskexpr
->rank
> 0)
3430 gfc_init_se (&maskse
, parent_se
);
3431 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
3432 if (expr
->rank
== 0)
3434 gfc_conv_expr_val (&maskse
, maskexpr
);
3435 gfc_add_block_to_block (&body
, &maskse
.pre
);
3437 gfc_start_block (&block
);
3440 gfc_init_block (&block
);
3442 /* Do the actual summation/product. */
3443 gfc_init_se (&arrayse
, parent_se
);
3444 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
3445 if (expr
->rank
== 0)
3446 arrayse
.ss
= arrayss
;
3447 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3448 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3452 /* if (x (i) != 0.0)
3458 result = 1.0 + result * val * val;
3464 result += val * val;
3467 tree res1
, res2
, cond
, absX
, val
;
3468 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
3470 gfc_init_block (&ifblock1
);
3472 absX
= gfc_create_var (type
, "absX");
3473 gfc_add_modify (&ifblock1
, absX
,
3474 fold_build1_loc (input_location
, ABS_EXPR
, type
,
3476 val
= gfc_create_var (type
, "val");
3477 gfc_add_expr_to_block (&ifblock1
, val
);
3479 gfc_init_block (&ifblock2
);
3480 gfc_add_modify (&ifblock2
, val
,
3481 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
3483 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3484 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
3485 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
3486 gfc_build_const (type
, integer_one_node
));
3487 gfc_add_modify (&ifblock2
, resvar
, res1
);
3488 gfc_add_modify (&ifblock2
, scale
, absX
);
3489 res1
= gfc_finish_block (&ifblock2
);
3491 gfc_init_block (&ifblock3
);
3492 gfc_add_modify (&ifblock3
, val
,
3493 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
3495 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3496 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
3497 gfc_add_modify (&ifblock3
, resvar
, res2
);
3498 res2
= gfc_finish_block (&ifblock3
);
3500 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3502 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
3503 gfc_add_expr_to_block (&ifblock1
, tmp
);
3504 tmp
= gfc_finish_block (&ifblock1
);
3506 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3508 gfc_build_const (type
, integer_zero_node
));
3510 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3511 gfc_add_expr_to_block (&block
, tmp
);
3515 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
3516 gfc_add_modify (&block
, resvar
, tmp
);
3519 gfc_add_block_to_block (&block
, &arrayse
.post
);
3521 if (maskexpr
&& maskexpr
->rank
> 0)
3523 /* We enclose the above in if (mask) {...} . */
3525 tmp
= gfc_finish_block (&block
);
3526 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3527 build_empty_stmt (input_location
));
3530 tmp
= gfc_finish_block (&block
);
3531 gfc_add_expr_to_block (&body
, tmp
);
3533 gfc_trans_scalarizing_loops (ploop
, &body
);
3535 /* For a scalar mask, enclose the loop in an if statement. */
3536 if (maskexpr
&& maskexpr
->rank
== 0)
3538 gfc_init_block (&block
);
3539 gfc_add_block_to_block (&block
, &ploop
->pre
);
3540 gfc_add_block_to_block (&block
, &ploop
->post
);
3541 tmp
= gfc_finish_block (&block
);
3545 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
3546 build_empty_stmt (input_location
));
3547 gfc_advance_se_ss_chain (se
);
3551 gcc_assert (expr
->rank
== 0);
3552 gfc_init_se (&maskse
, NULL
);
3553 gfc_conv_expr_val (&maskse
, maskexpr
);
3554 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3555 build_empty_stmt (input_location
));
3558 gfc_add_expr_to_block (&block
, tmp
);
3559 gfc_add_block_to_block (&se
->pre
, &block
);
3560 gcc_assert (se
->post
.head
== NULL
);
3564 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
3565 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
3568 if (expr
->rank
== 0)
3569 gfc_cleanup_loop (ploop
);
3573 /* result = scale * sqrt(result). */
3575 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
3576 resvar
= build_call_expr_loc (input_location
,
3578 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
3585 /* Inline implementation of the dot_product intrinsic. This function
3586 is based on gfc_conv_intrinsic_arith (the previous function). */
3588 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
3596 gfc_actual_arglist
*actual
;
3597 gfc_ss
*arrayss1
, *arrayss2
;
3598 gfc_se arrayse1
, arrayse2
;
3599 gfc_expr
*arrayexpr1
, *arrayexpr2
;
3601 type
= gfc_typenode_for_spec (&expr
->ts
);
3603 /* Initialize the result. */
3604 resvar
= gfc_create_var (type
, "val");
3605 if (expr
->ts
.type
== BT_LOGICAL
)
3606 tmp
= build_int_cst (type
, 0);
3608 tmp
= gfc_build_const (type
, integer_zero_node
);
3610 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3612 /* Walk argument #1. */
3613 actual
= expr
->value
.function
.actual
;
3614 arrayexpr1
= actual
->expr
;
3615 arrayss1
= gfc_walk_expr (arrayexpr1
);
3616 gcc_assert (arrayss1
!= gfc_ss_terminator
);
3618 /* Walk argument #2. */
3619 actual
= actual
->next
;
3620 arrayexpr2
= actual
->expr
;
3621 arrayss2
= gfc_walk_expr (arrayexpr2
);
3622 gcc_assert (arrayss2
!= gfc_ss_terminator
);
3624 /* Initialize the scalarizer. */
3625 gfc_init_loopinfo (&loop
);
3626 gfc_add_ss_to_loop (&loop
, arrayss1
);
3627 gfc_add_ss_to_loop (&loop
, arrayss2
);
3629 /* Initialize the loop. */
3630 gfc_conv_ss_startstride (&loop
);
3631 gfc_conv_loop_setup (&loop
, &expr
->where
);
3633 gfc_mark_ss_chain_used (arrayss1
, 1);
3634 gfc_mark_ss_chain_used (arrayss2
, 1);
3636 /* Generate the loop body. */
3637 gfc_start_scalarized_body (&loop
, &body
);
3638 gfc_init_block (&block
);
3640 /* Make the tree expression for [conjg(]array1[)]. */
3641 gfc_init_se (&arrayse1
, NULL
);
3642 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
3643 arrayse1
.ss
= arrayss1
;
3644 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
3645 if (expr
->ts
.type
== BT_COMPLEX
)
3646 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
3648 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
3650 /* Make the tree expression for array2. */
3651 gfc_init_se (&arrayse2
, NULL
);
3652 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
3653 arrayse2
.ss
= arrayss2
;
3654 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
3655 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
3657 /* Do the actual product and sum. */
3658 if (expr
->ts
.type
== BT_LOGICAL
)
3660 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
3661 arrayse1
.expr
, arrayse2
.expr
);
3662 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
3666 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
3668 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
3670 gfc_add_modify (&block
, resvar
, tmp
);
3672 /* Finish up the loop block and the loop. */
3673 tmp
= gfc_finish_block (&block
);
3674 gfc_add_expr_to_block (&body
, tmp
);
3676 gfc_trans_scalarizing_loops (&loop
, &body
);
3677 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3678 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3679 gfc_cleanup_loop (&loop
);
3685 /* Emit code for minloc or maxloc intrinsic. There are many different cases
3686 we need to handle. For performance reasons we sometimes create two
3687 loops instead of one, where the second one is much simpler.
3688 Examples for minloc intrinsic:
3689 1) Result is an array, a call is generated
3690 2) Array mask is used and NaNs need to be supported:
3696 if (pos == 0) pos = S + (1 - from);
3697 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3704 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3708 3) NaNs need to be supported, but it is known at compile time or cheaply
3709 at runtime whether array is nonempty or not:
3714 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3717 if (from <= to) pos = 1;
3721 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3725 4) NaNs aren't supported, array mask is used:
3726 limit = infinities_supported ? Infinity : huge (limit);
3730 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3736 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3740 5) Same without array mask:
3741 limit = infinities_supported ? Infinity : huge (limit);
3742 pos = (from <= to) ? 1 : 0;
3745 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3748 For 3) and 5), if mask is scalar, this all goes into a conditional,
3749 setting pos = 0; in the else branch. */
3752 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3756 stmtblock_t ifblock
;
3757 stmtblock_t elseblock
;
3768 gfc_actual_arglist
*actual
;
3773 gfc_expr
*arrayexpr
;
3780 gfc_conv_intrinsic_funcall (se
, expr
);
3784 /* Initialize the result. */
3785 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3786 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3787 type
= gfc_typenode_for_spec (&expr
->ts
);
3789 /* Walk the arguments. */
3790 actual
= expr
->value
.function
.actual
;
3791 arrayexpr
= actual
->expr
;
3792 arrayss
= gfc_walk_expr (arrayexpr
);
3793 gcc_assert (arrayss
!= gfc_ss_terminator
);
3795 actual
= actual
->next
->next
;
3796 gcc_assert (actual
);
3797 maskexpr
= actual
->expr
;
3799 if (maskexpr
&& maskexpr
->rank
!= 0)
3801 maskss
= gfc_walk_expr (maskexpr
);
3802 gcc_assert (maskss
!= gfc_ss_terminator
);
3807 if (gfc_array_size (arrayexpr
, &asize
))
3809 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3811 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3812 boolean_type_node
, nonempty
,
3813 gfc_index_zero_node
);
3818 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3819 switch (arrayexpr
->ts
.type
)
3822 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3826 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3827 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3828 arrayexpr
->ts
.kind
);
3835 /* We start with the most negative possible value for MAXLOC, and the most
3836 positive possible value for MINLOC. The most negative possible value is
3837 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3838 possible value is HUGE in both cases. */
3840 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3841 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
3842 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3843 build_int_cst (TREE_TYPE (tmp
), 1));
3845 gfc_add_modify (&se
->pre
, limit
, tmp
);
3847 /* Initialize the scalarizer. */
3848 gfc_init_loopinfo (&loop
);
3849 gfc_add_ss_to_loop (&loop
, arrayss
);
3851 gfc_add_ss_to_loop (&loop
, maskss
);
3853 /* Initialize the loop. */
3854 gfc_conv_ss_startstride (&loop
);
3856 /* The code generated can have more than one loop in sequence (see the
3857 comment at the function header). This doesn't work well with the
3858 scalarizer, which changes arrays' offset when the scalarization loops
3859 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3860 are currently inlined in the scalar case only (for which loop is of rank
3861 one). As there is no dependency to care about in that case, there is no
3862 temporary, so that we can use the scalarizer temporary code to handle
3863 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3864 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3866 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3867 should eventually go away. We could either create two loops properly,
3868 or find another way to save/restore the array offsets between the two
3869 loops (without conflicting with temporary management), or use a single
3870 loop minmaxloc implementation. See PR 31067. */
3871 loop
.temp_dim
= loop
.dimen
;
3872 gfc_conv_loop_setup (&loop
, &expr
->where
);
3874 gcc_assert (loop
.dimen
== 1);
3875 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3876 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3877 loop
.from
[0], loop
.to
[0]);
3881 /* Initialize the position to zero, following Fortran 2003. We are free
3882 to do this because Fortran 95 allows the result of an entirely false
3883 mask to be processor dependent. If we know at compile time the array
3884 is non-empty and no MASK is used, we can initialize to 1 to simplify
3886 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3887 gfc_add_modify (&loop
.pre
, pos
,
3888 fold_build3_loc (input_location
, COND_EXPR
,
3889 gfc_array_index_type
,
3890 nonempty
, gfc_index_one_node
,
3891 gfc_index_zero_node
));
3894 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3895 lab1
= gfc_build_label_decl (NULL_TREE
);
3896 TREE_USED (lab1
) = 1;
3897 lab2
= gfc_build_label_decl (NULL_TREE
);
3898 TREE_USED (lab2
) = 1;
3901 /* An offset must be added to the loop
3902 counter to obtain the required position. */
3903 gcc_assert (loop
.from
[0]);
3905 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3906 gfc_index_one_node
, loop
.from
[0]);
3907 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3909 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3911 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3912 /* Generate the loop body. */
3913 gfc_start_scalarized_body (&loop
, &body
);
3915 /* If we have a mask, only check this element if the mask is set. */
3918 gfc_init_se (&maskse
, NULL
);
3919 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3921 gfc_conv_expr_val (&maskse
, maskexpr
);
3922 gfc_add_block_to_block (&body
, &maskse
.pre
);
3924 gfc_start_block (&block
);
3927 gfc_init_block (&block
);
3929 /* Compare with the current limit. */
3930 gfc_init_se (&arrayse
, NULL
);
3931 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3932 arrayse
.ss
= arrayss
;
3933 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3934 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3936 /* We do the following if this is a more extreme value. */
3937 gfc_start_block (&ifblock
);
3939 /* Assign the value to the limit... */
3940 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3942 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3944 stmtblock_t ifblock2
;
3947 gfc_start_block (&ifblock2
);
3948 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3949 loop
.loopvar
[0], offset
);
3950 gfc_add_modify (&ifblock2
, pos
, tmp
);
3951 ifbody2
= gfc_finish_block (&ifblock2
);
3952 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3953 gfc_index_zero_node
);
3954 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3955 build_empty_stmt (input_location
));
3956 gfc_add_expr_to_block (&block
, tmp
);
3959 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3960 loop
.loopvar
[0], offset
);
3961 gfc_add_modify (&ifblock
, pos
, tmp
);
3964 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3966 ifbody
= gfc_finish_block (&ifblock
);
3968 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3971 cond
= fold_build2_loc (input_location
,
3972 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3973 boolean_type_node
, arrayse
.expr
, limit
);
3975 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3976 arrayse
.expr
, limit
);
3978 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3979 build_empty_stmt (input_location
));
3981 gfc_add_expr_to_block (&block
, ifbody
);
3985 /* We enclose the above in if (mask) {...}. */
3986 tmp
= gfc_finish_block (&block
);
3988 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3989 build_empty_stmt (input_location
));
3992 tmp
= gfc_finish_block (&block
);
3993 gfc_add_expr_to_block (&body
, tmp
);
3997 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3999 if (HONOR_NANS (DECL_MODE (limit
)))
4001 if (nonempty
!= NULL
)
4003 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
4004 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
4005 build_empty_stmt (input_location
));
4006 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
4010 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
4011 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
4013 /* If we have a mask, only check this element if the mask is set. */
4016 gfc_init_se (&maskse
, NULL
);
4017 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4019 gfc_conv_expr_val (&maskse
, maskexpr
);
4020 gfc_add_block_to_block (&body
, &maskse
.pre
);
4022 gfc_start_block (&block
);
4025 gfc_init_block (&block
);
4027 /* Compare with the current limit. */
4028 gfc_init_se (&arrayse
, NULL
);
4029 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4030 arrayse
.ss
= arrayss
;
4031 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4032 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4034 /* We do the following if this is a more extreme value. */
4035 gfc_start_block (&ifblock
);
4037 /* Assign the value to the limit... */
4038 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4040 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4041 loop
.loopvar
[0], offset
);
4042 gfc_add_modify (&ifblock
, pos
, tmp
);
4044 ifbody
= gfc_finish_block (&ifblock
);
4046 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4047 arrayse
.expr
, limit
);
4049 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4050 build_empty_stmt (input_location
));
4051 gfc_add_expr_to_block (&block
, tmp
);
4055 /* We enclose the above in if (mask) {...}. */
4056 tmp
= gfc_finish_block (&block
);
4058 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4059 build_empty_stmt (input_location
));
4062 tmp
= gfc_finish_block (&block
);
4063 gfc_add_expr_to_block (&body
, tmp
);
4064 /* Avoid initializing loopvar[0] again, it should be left where
4065 it finished by the first loop. */
4066 loop
.from
[0] = loop
.loopvar
[0];
4069 gfc_trans_scalarizing_loops (&loop
, &body
);
4072 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4074 /* For a scalar mask, enclose the loop in an if statement. */
4075 if (maskexpr
&& maskss
== NULL
)
4077 gfc_init_se (&maskse
, NULL
);
4078 gfc_conv_expr_val (&maskse
, maskexpr
);
4079 gfc_init_block (&block
);
4080 gfc_add_block_to_block (&block
, &loop
.pre
);
4081 gfc_add_block_to_block (&block
, &loop
.post
);
4082 tmp
= gfc_finish_block (&block
);
4084 /* For the else part of the scalar mask, just initialize
4085 the pos variable the same way as above. */
4087 gfc_init_block (&elseblock
);
4088 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4089 elsetmp
= gfc_finish_block (&elseblock
);
4091 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4092 gfc_add_expr_to_block (&block
, tmp
);
4093 gfc_add_block_to_block (&se
->pre
, &block
);
4097 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4098 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4100 gfc_cleanup_loop (&loop
);
4102 se
->expr
= convert (type
, pos
);
4105 /* Emit code for minval or maxval intrinsic. There are many different cases
4106 we need to handle. For performance reasons we sometimes create two
4107 loops instead of one, where the second one is much simpler.
4108 Examples for minval intrinsic:
4109 1) Result is an array, a call is generated
4110 2) Array mask is used and NaNs need to be supported, rank 1:
4115 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4118 limit = nonempty ? NaN : huge (limit);
4120 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4121 3) NaNs need to be supported, but it is known at compile time or cheaply
4122 at runtime whether array is nonempty or not, rank 1:
4125 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4126 limit = (from <= to) ? NaN : huge (limit);
4128 while (S <= to) { limit = min (a[S], limit); S++; }
4129 4) Array mask is used and NaNs need to be supported, rank > 1:
4138 if (fast) limit = min (a[S1][S2], limit);
4141 if (a[S1][S2] <= limit) {
4152 limit = nonempty ? NaN : huge (limit);
4153 5) NaNs need to be supported, but it is known at compile time or cheaply
4154 at runtime whether array is nonempty or not, rank > 1:
4161 if (fast) limit = min (a[S1][S2], limit);
4163 if (a[S1][S2] <= limit) {
4173 limit = (nonempty_array) ? NaN : huge (limit);
4174 6) NaNs aren't supported, but infinities are. Array mask is used:
4179 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4182 limit = nonempty ? limit : huge (limit);
4183 7) Same without array mask:
4186 while (S <= to) { limit = min (a[S], limit); S++; }
4187 limit = (from <= to) ? limit : huge (limit);
4188 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4189 limit = huge (limit);
4191 while (S <= to) { limit = min (a[S], limit); S++); }
4193 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4194 with array mask instead).
4195 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4196 setting limit = huge (limit); in the else branch. */
4199 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4209 tree huge_cst
= NULL
, nan_cst
= NULL
;
4211 stmtblock_t block
, block2
;
4213 gfc_actual_arglist
*actual
;
4218 gfc_expr
*arrayexpr
;
4224 gfc_conv_intrinsic_funcall (se
, expr
);
4228 type
= gfc_typenode_for_spec (&expr
->ts
);
4229 /* Initialize the result. */
4230 limit
= gfc_create_var (type
, "limit");
4231 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
4232 switch (expr
->ts
.type
)
4235 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
4237 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4239 REAL_VALUE_TYPE real
;
4241 tmp
= build_real (type
, real
);
4245 if (HONOR_NANS (DECL_MODE (limit
)))
4246 nan_cst
= gfc_build_nan (type
, "");
4250 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
4257 /* We start with the most negative possible value for MAXVAL, and the most
4258 positive possible value for MINVAL. The most negative possible value is
4259 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4260 possible value is HUGE in both cases. */
4263 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4265 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
4266 TREE_TYPE (huge_cst
), huge_cst
);
4269 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
4270 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
4271 tmp
, build_int_cst (type
, 1));
4273 gfc_add_modify (&se
->pre
, limit
, tmp
);
4275 /* Walk the arguments. */
4276 actual
= expr
->value
.function
.actual
;
4277 arrayexpr
= actual
->expr
;
4278 arrayss
= gfc_walk_expr (arrayexpr
);
4279 gcc_assert (arrayss
!= gfc_ss_terminator
);
4281 actual
= actual
->next
->next
;
4282 gcc_assert (actual
);
4283 maskexpr
= actual
->expr
;
4285 if (maskexpr
&& maskexpr
->rank
!= 0)
4287 maskss
= gfc_walk_expr (maskexpr
);
4288 gcc_assert (maskss
!= gfc_ss_terminator
);
4293 if (gfc_array_size (arrayexpr
, &asize
))
4295 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4297 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4298 boolean_type_node
, nonempty
,
4299 gfc_index_zero_node
);
4304 /* Initialize the scalarizer. */
4305 gfc_init_loopinfo (&loop
);
4306 gfc_add_ss_to_loop (&loop
, arrayss
);
4308 gfc_add_ss_to_loop (&loop
, maskss
);
4310 /* Initialize the loop. */
4311 gfc_conv_ss_startstride (&loop
);
4313 /* The code generated can have more than one loop in sequence (see the
4314 comment at the function header). This doesn't work well with the
4315 scalarizer, which changes arrays' offset when the scalarization loops
4316 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
4317 are currently inlined in the scalar case only. As there is no dependency
4318 to care about in that case, there is no temporary, so that we can use the
4319 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
4320 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
4321 gfc_trans_scalarized_loop_boundary even later to restore offset.
4322 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
4323 should eventually go away. We could either create two loops properly,
4324 or find another way to save/restore the array offsets between the two
4325 loops (without conflicting with temporary management), or use a single
4326 loop minmaxval implementation. See PR 31067. */
4327 loop
.temp_dim
= loop
.dimen
;
4328 gfc_conv_loop_setup (&loop
, &expr
->where
);
4330 if (nonempty
== NULL
&& maskss
== NULL
4331 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
4332 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4333 loop
.from
[0], loop
.to
[0]);
4334 nonempty_var
= NULL
;
4335 if (nonempty
== NULL
4336 && (HONOR_INFINITIES (DECL_MODE (limit
))
4337 || HONOR_NANS (DECL_MODE (limit
))))
4339 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
4340 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
4341 nonempty
= nonempty_var
;
4345 if (HONOR_NANS (DECL_MODE (limit
)))
4347 if (loop
.dimen
== 1)
4349 lab
= gfc_build_label_decl (NULL_TREE
);
4350 TREE_USED (lab
) = 1;
4354 fast
= gfc_create_var (boolean_type_node
, "fast");
4355 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
4359 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
4361 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
4362 /* Generate the loop body. */
4363 gfc_start_scalarized_body (&loop
, &body
);
4365 /* If we have a mask, only add this element if the mask is set. */
4368 gfc_init_se (&maskse
, NULL
);
4369 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4371 gfc_conv_expr_val (&maskse
, maskexpr
);
4372 gfc_add_block_to_block (&body
, &maskse
.pre
);
4374 gfc_start_block (&block
);
4377 gfc_init_block (&block
);
4379 /* Compare with the current limit. */
4380 gfc_init_se (&arrayse
, NULL
);
4381 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4382 arrayse
.ss
= arrayss
;
4383 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4384 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4386 gfc_init_block (&block2
);
4389 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
4391 if (HONOR_NANS (DECL_MODE (limit
)))
4393 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4394 boolean_type_node
, arrayse
.expr
, limit
);
4396 ifbody
= build1_v (GOTO_EXPR
, lab
);
4399 stmtblock_t ifblock
;
4401 gfc_init_block (&ifblock
);
4402 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4403 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
4404 ifbody
= gfc_finish_block (&ifblock
);
4406 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4407 build_empty_stmt (input_location
));
4408 gfc_add_expr_to_block (&block2
, tmp
);
4412 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4414 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4416 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4417 arrayse
.expr
, limit
);
4418 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4419 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4420 build_empty_stmt (input_location
));
4421 gfc_add_expr_to_block (&block2
, tmp
);
4425 tmp
= fold_build2_loc (input_location
,
4426 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4427 type
, arrayse
.expr
, limit
);
4428 gfc_add_modify (&block2
, limit
, tmp
);
4434 tree elsebody
= gfc_finish_block (&block2
);
4436 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4438 if (HONOR_NANS (DECL_MODE (limit
))
4439 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4441 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4442 arrayse
.expr
, limit
);
4443 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4444 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
4445 build_empty_stmt (input_location
));
4449 tmp
= fold_build2_loc (input_location
,
4450 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4451 type
, arrayse
.expr
, limit
);
4452 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4454 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
4455 gfc_add_expr_to_block (&block
, tmp
);
4458 gfc_add_block_to_block (&block
, &block2
);
4460 gfc_add_block_to_block (&block
, &arrayse
.post
);
4462 tmp
= gfc_finish_block (&block
);
4464 /* We enclose the above in if (mask) {...}. */
4465 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4466 build_empty_stmt (input_location
));
4467 gfc_add_expr_to_block (&body
, tmp
);
4471 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4473 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4475 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
4476 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
4478 /* If we have a mask, only add this element if the mask is set. */
4481 gfc_init_se (&maskse
, NULL
);
4482 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4484 gfc_conv_expr_val (&maskse
, maskexpr
);
4485 gfc_add_block_to_block (&body
, &maskse
.pre
);
4487 gfc_start_block (&block
);
4490 gfc_init_block (&block
);
4492 /* Compare with the current limit. */
4493 gfc_init_se (&arrayse
, NULL
);
4494 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4495 arrayse
.ss
= arrayss
;
4496 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4497 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4499 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4501 if (HONOR_NANS (DECL_MODE (limit
))
4502 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4504 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4505 arrayse
.expr
, limit
);
4506 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4507 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4508 build_empty_stmt (input_location
));
4509 gfc_add_expr_to_block (&block
, tmp
);
4513 tmp
= fold_build2_loc (input_location
,
4514 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4515 type
, arrayse
.expr
, limit
);
4516 gfc_add_modify (&block
, limit
, tmp
);
4519 gfc_add_block_to_block (&block
, &arrayse
.post
);
4521 tmp
= gfc_finish_block (&block
);
4523 /* We enclose the above in if (mask) {...}. */
4524 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4525 build_empty_stmt (input_location
));
4526 gfc_add_expr_to_block (&body
, tmp
);
4527 /* Avoid initializing loopvar[0] again, it should be left where
4528 it finished by the first loop. */
4529 loop
.from
[0] = loop
.loopvar
[0];
4531 gfc_trans_scalarizing_loops (&loop
, &body
);
4535 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4537 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4538 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
4540 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4542 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
4544 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
4546 gfc_add_modify (&loop
.pre
, limit
, tmp
);
4549 /* For a scalar mask, enclose the loop in an if statement. */
4550 if (maskexpr
&& maskss
== NULL
)
4554 gfc_init_se (&maskse
, NULL
);
4555 gfc_conv_expr_val (&maskse
, maskexpr
);
4556 gfc_init_block (&block
);
4557 gfc_add_block_to_block (&block
, &loop
.pre
);
4558 gfc_add_block_to_block (&block
, &loop
.post
);
4559 tmp
= gfc_finish_block (&block
);
4561 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4562 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
4564 else_stmt
= build_empty_stmt (input_location
);
4565 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
4566 gfc_add_expr_to_block (&block
, tmp
);
4567 gfc_add_block_to_block (&se
->pre
, &block
);
4571 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4572 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4575 gfc_cleanup_loop (&loop
);
4580 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
4582 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
4588 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4589 type
= TREE_TYPE (args
[0]);
4591 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4592 build_int_cst (type
, 1), args
[1]);
4593 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
4594 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
4595 build_int_cst (type
, 0));
4596 type
= gfc_typenode_for_spec (&expr
->ts
);
4597 se
->expr
= convert (type
, tmp
);
4601 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
4603 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4607 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4609 /* Convert both arguments to the unsigned type of the same size. */
4610 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
4611 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
4613 /* If they have unequal type size, convert to the larger one. */
4614 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
4615 > TYPE_PRECISION (TREE_TYPE (args
[1])))
4616 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
4617 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
4618 > TYPE_PRECISION (TREE_TYPE (args
[0])))
4619 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
4621 /* Now, we compare them. */
4622 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4627 /* Generate code to perform the specified operation. */
4629 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4633 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4634 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
4640 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
4644 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4645 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4646 TREE_TYPE (arg
), arg
);
4649 /* Set or clear a single bit. */
4651 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
4658 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4659 type
= TREE_TYPE (args
[0]);
4661 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4662 build_int_cst (type
, 1), args
[1]);
4668 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
4670 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
4673 /* Extract a sequence of bits.
4674 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
4676 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
4683 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4684 type
= TREE_TYPE (args
[0]);
4686 mask
= build_int_cst (type
, -1);
4687 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
4688 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
4690 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
4692 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4696 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4699 tree args
[2], type
, num_bits
, cond
;
4701 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4703 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4704 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4705 type
= TREE_TYPE (args
[0]);
4708 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4710 gcc_assert (right_shift
);
4712 se
->expr
= fold_build2_loc (input_location
,
4713 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4714 TREE_TYPE (args
[0]), args
[0], args
[1]);
4717 se
->expr
= fold_convert (type
, se
->expr
);
4719 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4720 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4722 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4723 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4726 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4727 build_int_cst (type
, 0), se
->expr
);
4730 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4732 : ((shift >= 0) ? i << shift : i >> -shift)
4733 where all shifts are logical shifts. */
4735 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4747 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4749 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4750 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4752 type
= TREE_TYPE (args
[0]);
4753 utype
= unsigned_type_for (type
);
4755 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4758 /* Left shift if positive. */
4759 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4761 /* Right shift if negative.
4762 We convert to an unsigned type because we want a logical shift.
4763 The standard doesn't define the case of shifting negative
4764 numbers, and we try to be compatible with other compilers, most
4765 notably g77, here. */
4766 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4767 utype
, convert (utype
, args
[0]), width
));
4769 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4770 build_int_cst (TREE_TYPE (args
[1]), 0));
4771 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4773 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4774 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4776 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4777 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4779 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4780 build_int_cst (type
, 0), tmp
);
4784 /* Circular shift. AKA rotate or barrel shift. */
4787 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4795 unsigned int num_args
;
4797 num_args
= gfc_intrinsic_argument_list_length (expr
);
4798 args
= XALLOCAVEC (tree
, num_args
);
4800 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4804 /* Use a library function for the 3 parameter version. */
4805 tree int4type
= gfc_get_int_type (4);
4807 type
= TREE_TYPE (args
[0]);
4808 /* We convert the first argument to at least 4 bytes, and
4809 convert back afterwards. This removes the need for library
4810 functions for all argument sizes, and function will be
4811 aligned to at least 32 bits, so there's no loss. */
4812 if (expr
->ts
.kind
< 4)
4813 args
[0] = convert (int4type
, args
[0]);
4815 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4816 need loads of library functions. They cannot have values >
4817 BIT_SIZE (I) so the conversion is safe. */
4818 args
[1] = convert (int4type
, args
[1]);
4819 args
[2] = convert (int4type
, args
[2]);
4821 switch (expr
->ts
.kind
)
4826 tmp
= gfor_fndecl_math_ishftc4
;
4829 tmp
= gfor_fndecl_math_ishftc8
;
4832 tmp
= gfor_fndecl_math_ishftc16
;
4837 se
->expr
= build_call_expr_loc (input_location
,
4838 tmp
, 3, args
[0], args
[1], args
[2]);
4839 /* Convert the result back to the original type, if we extended
4840 the first argument's width above. */
4841 if (expr
->ts
.kind
< 4)
4842 se
->expr
= convert (type
, se
->expr
);
4846 type
= TREE_TYPE (args
[0]);
4848 /* Evaluate arguments only once. */
4849 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4850 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4852 /* Rotate left if positive. */
4853 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4855 /* Rotate right if negative. */
4856 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4858 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4860 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4861 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4863 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4865 /* Do nothing if shift == 0. */
4866 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4868 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4873 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4874 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4876 The conditional expression is necessary because the result of LEADZ(0)
4877 is defined, but the result of __builtin_clz(0) is undefined for most
4880 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4881 difference in bit size between the argument of LEADZ and the C int. */
4884 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4896 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4897 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4899 /* Which variant of __builtin_clz* should we call? */
4900 if (argsize
<= INT_TYPE_SIZE
)
4902 arg_type
= unsigned_type_node
;
4903 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4905 else if (argsize
<= LONG_TYPE_SIZE
)
4907 arg_type
= long_unsigned_type_node
;
4908 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4910 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4912 arg_type
= long_long_unsigned_type_node
;
4913 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4917 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4918 arg_type
= gfc_build_uint_type (argsize
);
4922 /* Convert the actual argument twice: first, to the unsigned type of the
4923 same size; then, to the proper argument type for the built-in
4924 function. But the return type is of the default INTEGER kind. */
4925 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4926 arg
= fold_convert (arg_type
, arg
);
4927 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4928 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4930 /* Compute LEADZ for the case i .ne. 0. */
4933 s
= TYPE_PRECISION (arg_type
) - argsize
;
4934 tmp
= fold_convert (result_type
,
4935 build_call_expr_loc (input_location
, func
,
4937 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4938 tmp
, build_int_cst (result_type
, s
));
4942 /* We end up here if the argument type is larger than 'long long'.
4943 We generate this code:
4945 if (x & (ULL_MAX << ULL_SIZE) != 0)
4946 return clzll ((unsigned long long) (x >> ULLSIZE));
4948 return ULL_SIZE + clzll ((unsigned long long) x);
4949 where ULL_MAX is the largest value that a ULL_MAX can hold
4950 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4951 is the bit-size of the long long type (64 in this example). */
4952 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4954 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4955 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4956 long_long_unsigned_type_node
,
4957 build_int_cst (long_long_unsigned_type_node
,
4960 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4961 fold_convert (arg_type
, ullmax
), ullsize
);
4962 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4964 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4965 cond
, build_int_cst (arg_type
, 0));
4967 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4969 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4970 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4971 tmp1
= fold_convert (result_type
,
4972 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4974 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4975 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4976 tmp2
= fold_convert (result_type
,
4977 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4978 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4981 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4985 /* Build BIT_SIZE. */
4986 bit_size
= build_int_cst (result_type
, argsize
);
4988 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4989 arg
, build_int_cst (arg_type
, 0));
4990 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4995 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4997 The conditional expression is necessary because the result of TRAILZ(0)
4998 is defined, but the result of __builtin_ctz(0) is undefined for most
5002 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
5013 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5014 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5016 /* Which variant of __builtin_ctz* should we call? */
5017 if (argsize
<= INT_TYPE_SIZE
)
5019 arg_type
= unsigned_type_node
;
5020 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5022 else if (argsize
<= LONG_TYPE_SIZE
)
5024 arg_type
= long_unsigned_type_node
;
5025 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5027 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5029 arg_type
= long_long_unsigned_type_node
;
5030 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5034 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5035 arg_type
= gfc_build_uint_type (argsize
);
5039 /* Convert the actual argument twice: first, to the unsigned type of the
5040 same size; then, to the proper argument type for the built-in
5041 function. But the return type is of the default INTEGER kind. */
5042 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5043 arg
= fold_convert (arg_type
, arg
);
5044 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5045 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5047 /* Compute TRAILZ for the case i .ne. 0. */
5049 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5053 /* We end up here if the argument type is larger than 'long long'.
5054 We generate this code:
5056 if ((x & ULL_MAX) == 0)
5057 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5059 return ctzll ((unsigned long long) x);
5061 where ULL_MAX is the largest value that a ULL_MAX can hold
5062 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5063 is the bit-size of the long long type (64 in this example). */
5064 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5066 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5067 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5068 long_long_unsigned_type_node
,
5069 build_int_cst (long_long_unsigned_type_node
, 0));
5071 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5072 fold_convert (arg_type
, ullmax
));
5073 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
5074 build_int_cst (arg_type
, 0));
5076 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5078 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5079 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5080 tmp1
= fold_convert (result_type
,
5081 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5082 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5085 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5086 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5087 tmp2
= fold_convert (result_type
,
5088 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5090 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5094 /* Build BIT_SIZE. */
5095 bit_size
= build_int_cst (result_type
, argsize
);
5097 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5098 arg
, build_int_cst (arg_type
, 0));
5099 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5103 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5104 for types larger than "long long", we call the long long built-in for
5105 the lower and higher bits and combine the result. */
5108 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5116 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5117 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5118 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5120 /* Which variant of the builtin should we call? */
5121 if (argsize
<= INT_TYPE_SIZE
)
5123 arg_type
= unsigned_type_node
;
5124 func
= builtin_decl_explicit (parity
5126 : BUILT_IN_POPCOUNT
);
5128 else if (argsize
<= LONG_TYPE_SIZE
)
5130 arg_type
= long_unsigned_type_node
;
5131 func
= builtin_decl_explicit (parity
5133 : BUILT_IN_POPCOUNTL
);
5135 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5137 arg_type
= long_long_unsigned_type_node
;
5138 func
= builtin_decl_explicit (parity
5140 : BUILT_IN_POPCOUNTLL
);
5144 /* Our argument type is larger than 'long long', which mean none
5145 of the POPCOUNT builtins covers it. We thus call the 'long long'
5146 variant multiple times, and add the results. */
5147 tree utype
, arg2
, call1
, call2
;
5149 /* For now, we only cover the case where argsize is twice as large
5151 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5153 func
= builtin_decl_explicit (parity
5155 : BUILT_IN_POPCOUNTLL
);
5157 /* Convert it to an integer, and store into a variable. */
5158 utype
= gfc_build_uint_type (argsize
);
5159 arg
= fold_convert (utype
, arg
);
5160 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5162 /* Call the builtin twice. */
5163 call1
= build_call_expr_loc (input_location
, func
, 1,
5164 fold_convert (long_long_unsigned_type_node
,
5167 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5168 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5169 call2
= build_call_expr_loc (input_location
, func
, 1,
5170 fold_convert (long_long_unsigned_type_node
,
5173 /* Combine the results. */
5175 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5178 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5184 /* Convert the actual argument twice: first, to the unsigned type of the
5185 same size; then, to the proper argument type for the built-in
5187 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5188 arg
= fold_convert (arg_type
, arg
);
5190 se
->expr
= fold_convert (result_type
,
5191 build_call_expr_loc (input_location
, func
, 1, arg
));
5195 /* Process an intrinsic with unspecified argument-types that has an optional
5196 argument (which could be of type character), e.g. EOSHIFT. For those, we
5197 need to append the string length of the optional argument if it is not
5198 present and the type is really character.
5199 primary specifies the position (starting at 1) of the non-optional argument
5200 specifying the type and optional gives the position of the optional
5201 argument in the arglist. */
5204 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5205 unsigned primary
, unsigned optional
)
5207 gfc_actual_arglist
* prim_arg
;
5208 gfc_actual_arglist
* opt_arg
;
5210 gfc_actual_arglist
* arg
;
5212 vec
<tree
, va_gc
> *append_args
;
5214 /* Find the two arguments given as position. */
5218 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5222 if (cur_pos
== primary
)
5224 if (cur_pos
== optional
)
5227 if (cur_pos
>= primary
&& cur_pos
>= optional
)
5230 gcc_assert (prim_arg
);
5231 gcc_assert (prim_arg
->expr
);
5232 gcc_assert (opt_arg
);
5234 /* If we do have type CHARACTER and the optional argument is really absent,
5235 append a dummy 0 as string length. */
5237 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
5241 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
5242 vec_alloc (append_args
, 1);
5243 append_args
->quick_push (dummy
);
5246 /* Build the call itself. */
5247 gcc_assert (!se
->ignore_optional
);
5248 sym
= gfc_get_symbol_for_expr (expr
, false);
5249 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5251 gfc_free_symbol (sym
);
5255 /* The length of a character string. */
5257 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
5266 gcc_assert (!se
->ss
);
5268 arg
= expr
->value
.function
.actual
->expr
;
5270 type
= gfc_typenode_for_spec (&expr
->ts
);
5271 switch (arg
->expr_type
)
5274 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
5278 /* Obtain the string length from the function used by
5279 trans-array.c(gfc_trans_array_constructor). */
5281 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
5285 if (arg
->ref
== NULL
5286 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
5288 /* This doesn't catch all cases.
5289 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
5290 and the surrounding thread. */
5291 sym
= arg
->symtree
->n
.sym
;
5292 decl
= gfc_get_symbol_decl (sym
);
5293 if (decl
== current_function_decl
&& sym
->attr
.function
5294 && (sym
->result
== sym
))
5295 decl
= gfc_get_fake_result_decl (sym
, 0);
5297 len
= sym
->ts
.u
.cl
->backend_decl
;
5302 /* Otherwise fall through. */
5305 /* Anybody stupid enough to do this deserves inefficient code. */
5306 gfc_init_se (&argse
, se
);
5308 gfc_conv_expr (&argse
, arg
);
5310 gfc_conv_expr_descriptor (&argse
, arg
);
5311 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5312 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5313 len
= argse
.string_length
;
5316 se
->expr
= convert (type
, len
);
5319 /* The length of a character string not including trailing blanks. */
5321 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
5323 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5324 tree args
[2], type
, fndecl
;
5326 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5327 type
= gfc_typenode_for_spec (&expr
->ts
);
5330 fndecl
= gfor_fndecl_string_len_trim
;
5332 fndecl
= gfor_fndecl_string_len_trim_char4
;
5336 se
->expr
= build_call_expr_loc (input_location
,
5337 fndecl
, 2, args
[0], args
[1]);
5338 se
->expr
= convert (type
, se
->expr
);
5342 /* Returns the starting position of a substring within a string. */
5345 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
5348 tree logical4_type_node
= gfc_get_logical_type (4);
5352 unsigned int num_args
;
5354 args
= XALLOCAVEC (tree
, 5);
5356 /* Get number of arguments; characters count double due to the
5357 string length argument. Kind= is not passed to the library
5358 and thus ignored. */
5359 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
5364 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5365 type
= gfc_typenode_for_spec (&expr
->ts
);
5368 args
[4] = build_int_cst (logical4_type_node
, 0);
5370 args
[4] = convert (logical4_type_node
, args
[4]);
5372 fndecl
= build_addr (function
);
5373 se
->expr
= build_call_array_loc (input_location
,
5374 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
5376 se
->expr
= convert (type
, se
->expr
);
5380 /* The ascii value for a single character. */
5382 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
5384 tree args
[3], type
, pchartype
;
5387 nargs
= gfc_intrinsic_argument_list_length (expr
);
5388 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
5389 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
5390 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
5391 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
5392 type
= gfc_typenode_for_spec (&expr
->ts
);
5394 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5396 se
->expr
= convert (type
, se
->expr
);
5400 /* Intrinsic ISNAN calls __builtin_isnan. */
5403 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
5407 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5408 se
->expr
= build_call_expr_loc (input_location
,
5409 builtin_decl_explicit (BUILT_IN_ISNAN
),
5411 STRIP_TYPE_NOPS (se
->expr
);
5412 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5416 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
5417 their argument against a constant integer value. */
5420 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
5424 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5425 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
5426 gfc_typenode_for_spec (&expr
->ts
),
5427 arg
, build_int_cst (TREE_TYPE (arg
), value
));
5432 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
5435 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
5443 unsigned int num_args
;
5445 num_args
= gfc_intrinsic_argument_list_length (expr
);
5446 args
= XALLOCAVEC (tree
, num_args
);
5448 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5449 if (expr
->ts
.type
!= BT_CHARACTER
)
5457 /* We do the same as in the non-character case, but the argument
5458 list is different because of the string length arguments. We
5459 also have to set the string length for the result. */
5466 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
5468 se
->string_length
= len
;
5470 type
= TREE_TYPE (tsource
);
5471 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
5472 fold_convert (type
, fsource
));
5476 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
5479 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
5481 tree args
[3], mask
, type
;
5483 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5484 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
5486 type
= TREE_TYPE (args
[0]);
5487 gcc_assert (TREE_TYPE (args
[1]) == type
);
5488 gcc_assert (TREE_TYPE (mask
) == type
);
5490 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
5491 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
5492 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5494 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
5499 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
5500 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
5503 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
5505 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
5508 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5509 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5511 type
= gfc_get_int_type (expr
->ts
.kind
);
5512 utype
= unsigned_type_for (type
);
5514 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
5515 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
5517 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
5518 build_int_cst (utype
, 0));
5522 /* Left-justified mask. */
5523 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
5525 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5526 fold_convert (utype
, res
));
5528 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
5529 smaller than type width. */
5530 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5531 build_int_cst (TREE_TYPE (arg
), 0));
5532 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
5533 build_int_cst (utype
, 0), res
);
5537 /* Right-justified mask. */
5538 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5539 fold_convert (utype
, arg
));
5540 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
5542 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
5543 strictly smaller than type width. */
5544 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5546 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
5547 cond
, allones
, res
);
5550 se
->expr
= fold_convert (type
, res
);
5554 /* FRACTION (s) is translated into:
5555 isfinite (s) ? frexp (s, &dummy_int) : NaN */
5557 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
5559 tree arg
, type
, tmp
, res
, frexp
, cond
;
5561 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5563 type
= gfc_typenode_for_spec (&expr
->ts
);
5564 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5565 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5567 cond
= build_call_expr_loc (input_location
,
5568 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5571 tmp
= gfc_create_var (integer_type_node
, NULL
);
5572 res
= build_call_expr_loc (input_location
, frexp
, 2,
5573 fold_convert (type
, arg
),
5574 gfc_build_addr_expr (NULL_TREE
, tmp
));
5575 res
= fold_convert (type
, res
);
5577 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
5578 cond
, res
, gfc_build_nan (type
, ""));
5582 /* NEAREST (s, dir) is translated into
5583 tmp = copysign (HUGE_VAL, dir);
5584 return nextafter (s, tmp);
5587 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
5589 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
5591 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
5592 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
5594 type
= gfc_typenode_for_spec (&expr
->ts
);
5595 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5597 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
5598 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
5599 fold_convert (type
, args
[1]));
5600 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
5601 fold_convert (type
, args
[0]), tmp
);
5602 se
->expr
= fold_convert (type
, se
->expr
);
5606 /* SPACING (s) is translated into
5616 e = MAX_EXPR (e, emin);
5617 res = scalbn (1., e);
5621 where prec is the precision of s, gfc_real_kinds[k].digits,
5622 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
5623 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
5626 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
5628 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
5629 tree cond
, nan
, tmp
, frexp
, scalbn
;
5633 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5634 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
5635 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
5636 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
5638 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5639 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5641 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5642 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5644 type
= gfc_typenode_for_spec (&expr
->ts
);
5645 e
= gfc_create_var (integer_type_node
, NULL
);
5646 res
= gfc_create_var (type
, NULL
);
5649 /* Build the block for s /= 0. */
5650 gfc_start_block (&block
);
5651 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5652 gfc_build_addr_expr (NULL_TREE
, e
));
5653 gfc_add_expr_to_block (&block
, tmp
);
5655 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
5657 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
5658 integer_type_node
, tmp
, emin
));
5660 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
5661 build_real_from_int_cst (type
, integer_one_node
), e
);
5662 gfc_add_modify (&block
, res
, tmp
);
5664 /* Finish by building the IF statement for value zero. */
5665 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5666 build_real_from_int_cst (type
, integer_zero_node
));
5667 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
5668 gfc_finish_block (&block
));
5670 /* And deal with infinities and NaNs. */
5671 cond
= build_call_expr_loc (input_location
,
5672 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5674 nan
= gfc_build_nan (type
, "");
5675 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
5677 gfc_add_expr_to_block (&se
->pre
, tmp
);
5682 /* RRSPACING (s) is translated into
5691 x = scalbn (x, precision - e);
5698 where precision is gfc_real_kinds[k].digits. */
5701 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
5703 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
5707 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5708 prec
= gfc_real_kinds
[k
].digits
;
5710 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5711 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5712 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
5714 type
= gfc_typenode_for_spec (&expr
->ts
);
5715 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5716 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5718 e
= gfc_create_var (integer_type_node
, NULL
);
5719 x
= gfc_create_var (type
, NULL
);
5720 gfc_add_modify (&se
->pre
, x
,
5721 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5724 gfc_start_block (&block
);
5725 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5726 gfc_build_addr_expr (NULL_TREE
, e
));
5727 gfc_add_expr_to_block (&block
, tmp
);
5729 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5730 build_int_cst (integer_type_node
, prec
), e
);
5731 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5732 gfc_add_modify (&block
, x
, tmp
);
5733 stmt
= gfc_finish_block (&block
);
5736 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5737 build_real_from_int_cst (type
, integer_zero_node
));
5738 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5740 /* And deal with infinities and NaNs. */
5741 cond
= build_call_expr_loc (input_location
,
5742 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5744 nan
= gfc_build_nan (type
, "");
5745 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
5747 gfc_add_expr_to_block (&se
->pre
, tmp
);
5748 se
->expr
= fold_convert (type
, x
);
5752 /* SCALE (s, i) is translated into scalbn (s, i). */
5754 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5756 tree args
[2], type
, scalbn
;
5758 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5760 type
= gfc_typenode_for_spec (&expr
->ts
);
5761 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5762 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5763 fold_convert (type
, args
[0]),
5764 fold_convert (integer_type_node
, args
[1]));
5765 se
->expr
= fold_convert (type
, se
->expr
);
5769 /* SET_EXPONENT (s, i) is translated into
5770 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
5772 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5774 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
5776 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5777 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5779 type
= gfc_typenode_for_spec (&expr
->ts
);
5780 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5781 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5783 tmp
= gfc_create_var (integer_type_node
, NULL
);
5784 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5785 fold_convert (type
, args
[0]),
5786 gfc_build_addr_expr (NULL_TREE
, tmp
));
5787 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5788 fold_convert (integer_type_node
, args
[1]));
5789 res
= fold_convert (type
, res
);
5791 /* Call to isfinite */
5792 cond
= build_call_expr_loc (input_location
,
5793 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5795 nan
= gfc_build_nan (type
, "");
5797 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5803 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5805 gfc_actual_arglist
*actual
;
5812 gfc_init_se (&argse
, NULL
);
5813 actual
= expr
->value
.function
.actual
;
5815 if (actual
->expr
->ts
.type
== BT_CLASS
)
5816 gfc_add_class_array_ref (actual
->expr
);
5818 argse
.want_pointer
= 1;
5819 argse
.data_not_needed
= 1;
5820 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5821 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5822 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5823 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5825 /* Build the call to size0. */
5826 fncall0
= build_call_expr_loc (input_location
,
5827 gfor_fndecl_size0
, 1, arg1
);
5829 actual
= actual
->next
;
5833 gfc_init_se (&argse
, NULL
);
5834 gfc_conv_expr_type (&argse
, actual
->expr
,
5835 gfc_array_index_type
);
5836 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5838 /* Unusually, for an intrinsic, size does not exclude
5839 an optional arg2, so we must test for it. */
5840 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5841 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5842 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5845 /* Build the call to size1. */
5846 fncall1
= build_call_expr_loc (input_location
,
5847 gfor_fndecl_size1
, 2,
5850 gfc_init_se (&argse
, NULL
);
5851 argse
.want_pointer
= 1;
5852 argse
.data_not_needed
= 1;
5853 gfc_conv_expr (&argse
, actual
->expr
);
5854 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5855 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5856 argse
.expr
, null_pointer_node
);
5857 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5858 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5859 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5863 se
->expr
= NULL_TREE
;
5864 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5865 gfc_array_index_type
,
5866 argse
.expr
, gfc_index_one_node
);
5869 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5871 argse
.expr
= gfc_index_zero_node
;
5872 se
->expr
= NULL_TREE
;
5877 if (se
->expr
== NULL_TREE
)
5879 tree ubound
, lbound
;
5881 arg1
= build_fold_indirect_ref_loc (input_location
,
5883 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5884 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5885 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5886 gfc_array_index_type
, ubound
, lbound
);
5887 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5888 gfc_array_index_type
,
5889 se
->expr
, gfc_index_one_node
);
5890 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5891 gfc_array_index_type
, se
->expr
,
5892 gfc_index_zero_node
);
5895 type
= gfc_typenode_for_spec (&expr
->ts
);
5896 se
->expr
= convert (type
, se
->expr
);
5900 /* Helper function to compute the size of a character variable,
5901 excluding the terminating null characters. The result has
5902 gfc_array_index_type type. */
5905 size_of_string_in_bytes (int kind
, tree string_length
)
5908 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5910 bytesize
= build_int_cst (gfc_array_index_type
,
5911 gfc_character_kinds
[i
].bit_size
/ 8);
5913 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5915 fold_convert (gfc_array_index_type
, string_length
));
5920 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5931 gfc_init_se (&argse
, NULL
);
5932 arg
= expr
->value
.function
.actual
->expr
;
5934 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
5935 gfc_conv_expr_descriptor (&argse
, arg
);
5937 gfc_conv_expr_reference (&argse
, arg
);
5939 if (arg
->ts
.type
== BT_ASSUMED
)
5941 /* This only works if an array descriptor has been passed; thus, extract
5942 the size from the descriptor. */
5943 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
5944 == TYPE_PRECISION (size_type_node
));
5945 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
5946 tmp
= DECL_LANG_SPECIFIC (tmp
)
5947 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
5948 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
5949 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
5950 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5951 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
5952 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
5953 build_int_cst (TREE_TYPE (tmp
),
5954 GFC_DTYPE_SIZE_SHIFT
));
5955 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
5957 else if (arg
->ts
.type
== BT_CLASS
)
5959 /* Conv_expr_descriptor returns a component_ref to _data component of the
5960 class object. The class object may be a non-pointer object, e.g.
5961 located on the stack, or a memory location pointed to, e.g. a
5962 parameter, i.e., an indirect_ref. */
5964 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
5965 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
5966 && GFC_DECL_CLASS (TREE_OPERAND (
5967 TREE_OPERAND (argse
.expr
, 0), 0)))
5968 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
5969 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
5970 else if (arg
->rank
> 0)
5971 /* The scalarizer added an additional temp. To get the class' vptr
5972 one has to look at the original backend_decl. */
5973 byte_size
= gfc_class_vtab_size_get (
5974 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
5976 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
5980 if (arg
->ts
.type
== BT_CHARACTER
)
5981 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5985 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5988 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5989 byte_size
= fold_convert (gfc_array_index_type
,
5990 size_in_bytes (byte_size
));
5995 se
->expr
= byte_size
;
5998 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5999 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
6001 if (arg
->rank
== -1)
6003 tree cond
, loop_var
, exit_label
;
6006 tmp
= fold_convert (gfc_array_index_type
,
6007 gfc_conv_descriptor_rank (argse
.expr
));
6008 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
6009 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
6010 exit_label
= gfc_build_label_decl (NULL_TREE
);
6017 source_bytes = source_bytes * array.dim[i].extent;
6021 gfc_start_block (&body
);
6022 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6024 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6025 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6026 cond
, tmp
, build_empty_stmt (input_location
));
6027 gfc_add_expr_to_block (&body
, tmp
);
6029 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6030 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6031 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6032 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6033 gfc_array_index_type
, tmp
, source_bytes
);
6034 gfc_add_modify (&body
, source_bytes
, tmp
);
6036 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6037 gfc_array_index_type
, loop_var
,
6038 gfc_index_one_node
);
6039 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6041 tmp
= gfc_finish_block (&body
);
6043 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6045 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6047 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6048 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6052 /* Obtain the size of the array in bytes. */
6053 for (n
= 0; n
< arg
->rank
; n
++)
6056 idx
= gfc_rank_cst
[n
];
6057 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6058 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6059 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6060 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6061 gfc_array_index_type
, tmp
, source_bytes
);
6062 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6065 se
->expr
= source_bytes
;
6068 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6073 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6077 tree type
, result_type
, tmp
;
6079 arg
= expr
->value
.function
.actual
->expr
;
6081 gfc_init_se (&argse
, NULL
);
6082 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6086 if (arg
->ts
.type
== BT_CLASS
)
6088 gfc_add_vptr_component (arg
);
6089 gfc_add_size_component (arg
);
6090 gfc_conv_expr (&argse
, arg
);
6091 tmp
= fold_convert (result_type
, argse
.expr
);
6095 gfc_conv_expr_reference (&argse
, arg
);
6096 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6101 argse
.want_pointer
= 0;
6102 gfc_conv_expr_descriptor (&argse
, arg
);
6103 if (arg
->ts
.type
== BT_CLASS
)
6106 tmp
= gfc_class_vtab_size_get (
6107 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6109 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6110 tmp
= fold_convert (result_type
, tmp
);
6113 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6116 /* Obtain the argument's word length. */
6117 if (arg
->ts
.type
== BT_CHARACTER
)
6118 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6120 tmp
= size_in_bytes (type
);
6121 tmp
= fold_convert (result_type
, tmp
);
6124 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6125 build_int_cst (result_type
, BITS_PER_UNIT
));
6126 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6130 /* Intrinsic string comparison functions. */
6133 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6137 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6140 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6141 expr
->value
.function
.actual
->expr
->ts
.kind
,
6143 se
->expr
= fold_build2_loc (input_location
, op
,
6144 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6145 build_int_cst (TREE_TYPE (se
->expr
), 0));
6148 /* Generate a call to the adjustl/adjustr library function. */
6150 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6158 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6161 type
= TREE_TYPE (args
[2]);
6162 var
= gfc_conv_string_tmp (se
, type
, len
);
6165 tmp
= build_call_expr_loc (input_location
,
6166 fndecl
, 3, args
[0], args
[1], args
[2]);
6167 gfc_add_expr_to_block (&se
->pre
, tmp
);
6169 se
->string_length
= len
;
6173 /* Generate code for the TRANSFER intrinsic:
6175 DEST = TRANSFER (SOURCE, MOLD)
6177 typeof<DEST> = typeof<MOLD>
6182 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6184 typeof<DEST> = typeof<MOLD>
6186 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6187 sizeof (DEST(0) * SIZE). */
6189 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6205 gfc_actual_arglist
*arg
;
6207 gfc_array_info
*info
;
6211 gfc_expr
*source_expr
, *mold_expr
;
6215 info
= &se
->ss
->info
->data
.array
;
6217 /* Convert SOURCE. The output from this stage is:-
6218 source_bytes = length of the source in bytes
6219 source = pointer to the source data. */
6220 arg
= expr
->value
.function
.actual
;
6221 source_expr
= arg
->expr
;
6223 /* Ensure double transfer through LOGICAL preserves all
6225 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6226 && arg
->expr
->value
.function
.esym
== NULL
6227 && arg
->expr
->value
.function
.isym
!= NULL
6228 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6229 && arg
->expr
->ts
.type
== BT_LOGICAL
6230 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6231 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6233 gfc_init_se (&argse
, NULL
);
6235 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6237 /* Obtain the pointer to source and the length of source in bytes. */
6238 if (arg
->expr
->rank
== 0)
6240 gfc_conv_expr_reference (&argse
, arg
->expr
);
6241 if (arg
->expr
->ts
.type
== BT_CLASS
)
6242 source
= gfc_class_data_get (argse
.expr
);
6244 source
= argse
.expr
;
6246 /* Obtain the source word length. */
6247 switch (arg
->expr
->ts
.type
)
6250 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6251 argse
.string_length
);
6254 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6257 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6259 tmp
= fold_convert (gfc_array_index_type
,
6260 size_in_bytes (source_type
));
6266 argse
.want_pointer
= 0;
6267 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6268 source
= gfc_conv_descriptor_data_get (argse
.expr
);
6269 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6271 /* Repack the source if not simply contiguous. */
6272 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
6274 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
6276 if (warn_array_temporaries
)
6277 gfc_warning (OPT_Warray_temporaries
,
6278 "Creating array temporary at %L", &expr
->where
);
6280 source
= build_call_expr_loc (input_location
,
6281 gfor_fndecl_in_pack
, 1, tmp
);
6282 source
= gfc_evaluate_now (source
, &argse
.pre
);
6284 /* Free the temporary. */
6285 gfc_start_block (&block
);
6286 tmp
= gfc_call_free (source
);
6287 gfc_add_expr_to_block (&block
, tmp
);
6288 stmt
= gfc_finish_block (&block
);
6290 /* Clean up if it was repacked. */
6291 gfc_init_block (&block
);
6292 tmp
= gfc_conv_array_data (argse
.expr
);
6293 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6295 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
6296 build_empty_stmt (input_location
));
6297 gfc_add_expr_to_block (&block
, tmp
);
6298 gfc_add_block_to_block (&block
, &se
->post
);
6299 gfc_init_block (&se
->post
);
6300 gfc_add_block_to_block (&se
->post
, &block
);
6303 /* Obtain the source word length. */
6304 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
6305 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6306 argse
.string_length
);
6308 tmp
= fold_convert (gfc_array_index_type
,
6309 size_in_bytes (source_type
));
6311 /* Obtain the size of the array in bytes. */
6312 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
6313 for (n
= 0; n
< arg
->expr
->rank
; n
++)
6316 idx
= gfc_rank_cst
[n
];
6317 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6318 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6319 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6320 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6321 gfc_array_index_type
, upper
, lower
);
6322 gfc_add_modify (&argse
.pre
, extent
, tmp
);
6323 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6324 gfc_array_index_type
, extent
,
6325 gfc_index_one_node
);
6326 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6327 gfc_array_index_type
, tmp
, source_bytes
);
6331 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6332 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6333 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6335 /* Now convert MOLD. The outputs are:
6336 mold_type = the TREE type of MOLD
6337 dest_word_len = destination word length in bytes. */
6339 mold_expr
= arg
->expr
;
6341 gfc_init_se (&argse
, NULL
);
6343 scalar_mold
= arg
->expr
->rank
== 0;
6345 if (arg
->expr
->rank
== 0)
6347 gfc_conv_expr_reference (&argse
, arg
->expr
);
6348 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6353 gfc_init_se (&argse
, NULL
);
6354 argse
.want_pointer
= 0;
6355 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6356 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6359 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6360 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6362 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
6364 /* If this TRANSFER is nested in another TRANSFER, use a type
6365 that preserves all bits. */
6366 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
6367 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
6370 /* Obtain the destination word length. */
6371 switch (arg
->expr
->ts
.type
)
6374 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
6375 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
6378 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6381 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
6384 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
6385 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
6387 /* Finally convert SIZE, if it is present. */
6389 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
6393 gfc_init_se (&argse
, NULL
);
6394 gfc_conv_expr_reference (&argse
, arg
->expr
);
6395 tmp
= convert (gfc_array_index_type
,
6396 build_fold_indirect_ref_loc (input_location
,
6398 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6399 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6404 /* Separate array and scalar results. */
6405 if (scalar_mold
&& tmp
== NULL_TREE
)
6406 goto scalar_transfer
;
6408 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6409 if (tmp
!= NULL_TREE
)
6410 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6411 tmp
, dest_word_len
);
6415 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
6416 gfc_add_modify (&se
->pre
, size_words
,
6417 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
6418 gfc_array_index_type
,
6419 size_bytes
, dest_word_len
));
6421 /* Evaluate the bounds of the result. If the loop range exists, we have
6422 to check if it is too large. If so, we modify loop->to be consistent
6423 with min(size, size(source)). Otherwise, size is made consistent with
6424 the loop range, so that the right number of bytes is transferred.*/
6425 n
= se
->loop
->order
[0];
6426 if (se
->loop
->to
[n
] != NULL_TREE
)
6428 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6429 se
->loop
->to
[n
], se
->loop
->from
[n
]);
6430 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6431 tmp
, gfc_index_one_node
);
6432 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6434 gfc_add_modify (&se
->pre
, size_words
, tmp
);
6435 gfc_add_modify (&se
->pre
, size_bytes
,
6436 fold_build2_loc (input_location
, MULT_EXPR
,
6437 gfc_array_index_type
,
6438 size_words
, dest_word_len
));
6439 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6440 size_words
, se
->loop
->from
[n
]);
6441 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6442 upper
, gfc_index_one_node
);
6446 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6447 size_words
, gfc_index_one_node
);
6448 se
->loop
->from
[n
] = gfc_index_zero_node
;
6451 se
->loop
->to
[n
] = upper
;
6453 /* Build a destination descriptor, using the pointer, source, as the
6455 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
6456 NULL_TREE
, false, true, false, &expr
->where
);
6458 /* Cast the pointer to the result. */
6459 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6460 tmp
= fold_convert (pvoid_type_node
, tmp
);
6462 /* Use memcpy to do the transfer. */
6464 = build_call_expr_loc (input_location
,
6465 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
6466 fold_convert (pvoid_type_node
, source
),
6467 fold_convert (size_type_node
,
6468 fold_build2_loc (input_location
,
6470 gfc_array_index_type
,
6473 gfc_add_expr_to_block (&se
->pre
, tmp
);
6475 se
->expr
= info
->descriptor
;
6476 if (expr
->ts
.type
== BT_CHARACTER
)
6477 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6481 /* Deal with scalar results. */
6483 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6484 dest_word_len
, source_bytes
);
6485 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6486 extent
, gfc_index_zero_node
);
6488 if (expr
->ts
.type
== BT_CHARACTER
)
6490 tree direct
, indirect
, free
;
6492 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
6493 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
6496 /* If source is longer than the destination, use a pointer to
6497 the source directly. */
6498 gfc_init_block (&block
);
6499 gfc_add_modify (&block
, tmpdecl
, ptr
);
6500 direct
= gfc_finish_block (&block
);
6502 /* Otherwise, allocate a string with the length of the destination
6503 and copy the source into it. */
6504 gfc_init_block (&block
);
6505 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
6506 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
6507 gfc_add_modify (&block
, tmpdecl
,
6508 fold_convert (TREE_TYPE (ptr
), tmp
));
6509 tmp
= build_call_expr_loc (input_location
,
6510 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6511 fold_convert (pvoid_type_node
, tmpdecl
),
6512 fold_convert (pvoid_type_node
, ptr
),
6513 fold_convert (size_type_node
, extent
));
6514 gfc_add_expr_to_block (&block
, tmp
);
6515 indirect
= gfc_finish_block (&block
);
6517 /* Wrap it up with the condition. */
6518 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
6519 dest_word_len
, source_bytes
);
6520 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
6521 gfc_add_expr_to_block (&se
->pre
, tmp
);
6523 /* Free the temporary string, if necessary. */
6524 free
= gfc_call_free (tmpdecl
);
6525 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6526 dest_word_len
, source_bytes
);
6527 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
6528 gfc_add_expr_to_block (&se
->post
, tmp
);
6531 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6535 tmpdecl
= gfc_create_var (mold_type
, "transfer");
6537 ptr
= convert (build_pointer_type (mold_type
), source
);
6539 /* For CLASS results, allocate the needed memory first. */
6540 if (mold_expr
->ts
.type
== BT_CLASS
)
6543 cdata
= gfc_class_data_get (tmpdecl
);
6544 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
6545 gfc_add_modify (&se
->pre
, cdata
, tmp
);
6548 /* Use memcpy to do the transfer. */
6549 if (mold_expr
->ts
.type
== BT_CLASS
)
6550 tmp
= gfc_class_data_get (tmpdecl
);
6552 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
6554 tmp
= build_call_expr_loc (input_location
,
6555 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6556 fold_convert (pvoid_type_node
, tmp
),
6557 fold_convert (pvoid_type_node
, ptr
),
6558 fold_convert (size_type_node
, extent
));
6559 gfc_add_expr_to_block (&se
->pre
, tmp
);
6561 /* For CLASS results, set the _vptr. */
6562 if (mold_expr
->ts
.type
== BT_CLASS
)
6566 vptr
= gfc_class_vptr_get (tmpdecl
);
6567 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
6569 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
6570 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
6578 /* Generate code for the ALLOCATED intrinsic.
6579 Generate inline code that directly check the address of the argument. */
6582 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
6584 gfc_actual_arglist
*arg1
;
6588 gfc_init_se (&arg1se
, NULL
);
6589 arg1
= expr
->value
.function
.actual
;
6591 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6593 /* Make sure that class array expressions have both a _data
6594 component reference and an array reference.... */
6595 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
6596 gfc_add_class_array_ref (arg1
->expr
);
6597 /* .... whilst scalars only need the _data component. */
6599 gfc_add_data_component (arg1
->expr
);
6602 if (arg1
->expr
->rank
== 0)
6604 /* Allocatable scalar. */
6605 arg1se
.want_pointer
= 1;
6606 gfc_conv_expr (&arg1se
, arg1
->expr
);
6611 /* Allocatable array. */
6612 arg1se
.descriptor_only
= 1;
6613 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6614 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6617 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
6618 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6619 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6623 /* Generate code for the ASSOCIATED intrinsic.
6624 If both POINTER and TARGET are arrays, generate a call to library function
6625 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
6626 In other cases, generate inline code that directly compare the address of
6627 POINTER with the address of TARGET. */
6630 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
6632 gfc_actual_arglist
*arg1
;
6633 gfc_actual_arglist
*arg2
;
6638 tree nonzero_charlen
;
6639 tree nonzero_arraylen
;
6643 gfc_init_se (&arg1se
, NULL
);
6644 gfc_init_se (&arg2se
, NULL
);
6645 arg1
= expr
->value
.function
.actual
;
6648 /* Check whether the expression is a scalar or not; we cannot use
6649 arg1->expr->rank as it can be nonzero for proc pointers. */
6650 ss
= gfc_walk_expr (arg1
->expr
);
6651 scalar
= ss
== gfc_ss_terminator
;
6653 gfc_free_ss_chain (ss
);
6657 /* No optional target. */
6660 /* A pointer to a scalar. */
6661 arg1se
.want_pointer
= 1;
6662 gfc_conv_expr (&arg1se
, arg1
->expr
);
6663 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6664 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6665 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6667 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6669 tmp2
= gfc_class_data_get (arg1se
.expr
);
6670 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6671 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6678 /* A pointer to an array. */
6679 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6680 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6682 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6683 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6684 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
6685 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
6690 /* An optional target. */
6691 if (arg2
->expr
->ts
.type
== BT_CLASS
)
6692 gfc_add_data_component (arg2
->expr
);
6694 nonzero_charlen
= NULL_TREE
;
6695 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
6696 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
6698 arg1
->expr
->ts
.u
.cl
->backend_decl
,
6702 /* A pointer to a scalar. */
6703 arg1se
.want_pointer
= 1;
6704 gfc_conv_expr (&arg1se
, arg1
->expr
);
6705 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6706 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6707 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6709 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6710 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
6712 arg2se
.want_pointer
= 1;
6713 gfc_conv_expr (&arg2se
, arg2
->expr
);
6714 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6715 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
6716 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
6718 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6719 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6720 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6721 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6722 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6723 arg1se
.expr
, arg2se
.expr
);
6724 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6725 arg1se
.expr
, null_pointer_node
);
6726 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6727 boolean_type_node
, tmp
, tmp2
);
6731 /* An array pointer of zero length is not associated if target is
6733 arg1se
.descriptor_only
= 1;
6734 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
6735 if (arg1
->expr
->rank
== -1)
6737 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
6738 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6739 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
6742 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
6743 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
6744 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
6745 boolean_type_node
, tmp
,
6746 build_int_cst (TREE_TYPE (tmp
), 0));
6748 /* A pointer to an array, call library function _gfor_associated. */
6749 arg1se
.want_pointer
= 1;
6750 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6752 arg2se
.want_pointer
= 1;
6753 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
6754 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6755 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6756 se
->expr
= build_call_expr_loc (input_location
,
6757 gfor_fndecl_associated
, 2,
6758 arg1se
.expr
, arg2se
.expr
);
6759 se
->expr
= convert (boolean_type_node
, se
->expr
);
6760 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6761 boolean_type_node
, se
->expr
,
6765 /* If target is present zero character length pointers cannot
6767 if (nonzero_charlen
!= NULL_TREE
)
6768 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6770 se
->expr
, nonzero_charlen
);
6773 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6777 /* Generate code for the SAME_TYPE_AS intrinsic.
6778 Generate inline code that directly checks the vindices. */
6781 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
6786 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
6788 gfc_init_se (&se1
, NULL
);
6789 gfc_init_se (&se2
, NULL
);
6791 a
= expr
->value
.function
.actual
->expr
;
6792 b
= expr
->value
.function
.actual
->next
->expr
;
6794 if (UNLIMITED_POLY (a
))
6796 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
6797 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6798 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6801 if (UNLIMITED_POLY (b
))
6803 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
6804 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6805 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6808 if (a
->ts
.type
== BT_CLASS
)
6810 gfc_add_vptr_component (a
);
6811 gfc_add_hash_component (a
);
6813 else if (a
->ts
.type
== BT_DERIVED
)
6814 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6815 a
->ts
.u
.derived
->hash_value
);
6817 if (b
->ts
.type
== BT_CLASS
)
6819 gfc_add_vptr_component (b
);
6820 gfc_add_hash_component (b
);
6822 else if (b
->ts
.type
== BT_DERIVED
)
6823 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6824 b
->ts
.u
.derived
->hash_value
);
6826 gfc_conv_expr (&se1
, a
);
6827 gfc_conv_expr (&se2
, b
);
6829 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6830 boolean_type_node
, se1
.expr
,
6831 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
6834 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6835 boolean_type_node
, conda
, tmp
);
6838 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6839 boolean_type_node
, condb
, tmp
);
6841 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6845 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6848 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6852 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6853 se
->expr
= build_call_expr_loc (input_location
,
6854 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6855 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6859 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6862 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6866 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6868 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6869 type
= gfc_get_int_type (4);
6870 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6872 /* Convert it to the required type. */
6873 type
= gfc_typenode_for_spec (&expr
->ts
);
6874 se
->expr
= build_call_expr_loc (input_location
,
6875 gfor_fndecl_si_kind
, 1, arg
);
6876 se
->expr
= fold_convert (type
, se
->expr
);
6880 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6883 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6885 gfc_actual_arglist
*actual
;
6888 vec
<tree
, va_gc
> *args
= NULL
;
6890 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6892 gfc_init_se (&argse
, se
);
6894 /* Pass a NULL pointer for an absent arg. */
6895 if (actual
->expr
== NULL
)
6896 argse
.expr
= null_pointer_node
;
6902 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6904 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6905 ts
.type
= BT_INTEGER
;
6906 ts
.kind
= gfc_c_int_kind
;
6907 gfc_convert_type (actual
->expr
, &ts
, 2);
6909 gfc_conv_expr_reference (&argse
, actual
->expr
);
6912 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6913 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6914 vec_safe_push (args
, argse
.expr
);
6917 /* Convert it to the required type. */
6918 type
= gfc_typenode_for_spec (&expr
->ts
);
6919 se
->expr
= build_call_expr_loc_vec (input_location
,
6920 gfor_fndecl_sr_kind
, args
);
6921 se
->expr
= fold_convert (type
, se
->expr
);
6925 /* Generate code for TRIM (A) intrinsic function. */
6928 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6938 unsigned int num_args
;
6940 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6941 args
= XALLOCAVEC (tree
, num_args
);
6943 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6944 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6945 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6947 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6948 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6951 if (expr
->ts
.kind
== 1)
6952 function
= gfor_fndecl_string_trim
;
6953 else if (expr
->ts
.kind
== 4)
6954 function
= gfor_fndecl_string_trim_char4
;
6958 fndecl
= build_addr (function
);
6959 tmp
= build_call_array_loc (input_location
,
6960 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6962 gfc_add_expr_to_block (&se
->pre
, tmp
);
6964 /* Free the temporary afterwards, if necessary. */
6965 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6966 len
, build_int_cst (TREE_TYPE (len
), 0));
6967 tmp
= gfc_call_free (var
);
6968 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6969 gfc_add_expr_to_block (&se
->post
, tmp
);
6972 se
->string_length
= len
;
6976 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6979 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6981 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6982 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6984 stmtblock_t block
, body
;
6987 /* We store in charsize the size of a character. */
6988 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6989 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6991 /* Get the arguments. */
6992 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6993 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6995 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6996 ncopies_type
= TREE_TYPE (ncopies
);
6998 /* Check that NCOPIES is not negative. */
6999 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
7000 build_int_cst (ncopies_type
, 0));
7001 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7002 "Argument NCOPIES of REPEAT intrinsic is negative "
7003 "(its value is %ld)",
7004 fold_convert (long_integer_type_node
, ncopies
));
7006 /* If the source length is zero, any non negative value of NCOPIES
7007 is valid, and nothing happens. */
7008 n
= gfc_create_var (ncopies_type
, "ncopies");
7009 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7010 build_int_cst (size_type_node
, 0));
7011 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
7012 build_int_cst (ncopies_type
, 0), ncopies
);
7013 gfc_add_modify (&se
->pre
, n
, tmp
);
7016 /* Check that ncopies is not too large: ncopies should be less than
7017 (or equal to) MAX / slen, where MAX is the maximal integer of
7018 the gfc_charlen_type_node type. If slen == 0, we need a special
7019 case to avoid the division by zero. */
7020 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
7021 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
7022 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
7023 fold_convert (size_type_node
, max
), slen
);
7024 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
7025 ? size_type_node
: ncopies_type
;
7026 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7027 fold_convert (largest
, ncopies
),
7028 fold_convert (largest
, max
));
7029 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7030 build_int_cst (size_type_node
, 0));
7031 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
7032 boolean_false_node
, cond
);
7033 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7034 "Argument NCOPIES of REPEAT intrinsic is too large");
7036 /* Compute the destination length. */
7037 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7038 fold_convert (gfc_charlen_type_node
, slen
),
7039 fold_convert (gfc_charlen_type_node
, ncopies
));
7040 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
7041 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
7043 /* Generate the code to do the repeat operation:
7044 for (i = 0; i < ncopies; i++)
7045 memmove (dest + (i * slen * size), src, slen*size); */
7046 gfc_start_block (&block
);
7047 count
= gfc_create_var (ncopies_type
, "count");
7048 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
7049 exit_label
= gfc_build_label_decl (NULL_TREE
);
7051 /* Start the loop body. */
7052 gfc_start_block (&body
);
7054 /* Exit the loop if count >= ncopies. */
7055 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
7057 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7058 TREE_USED (exit_label
) = 1;
7059 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7060 build_empty_stmt (input_location
));
7061 gfc_add_expr_to_block (&body
, tmp
);
7063 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7064 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7065 fold_convert (gfc_charlen_type_node
, slen
),
7066 fold_convert (gfc_charlen_type_node
, count
));
7067 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7068 tmp
, fold_convert (gfc_charlen_type_node
, size
));
7069 tmp
= fold_build_pointer_plus_loc (input_location
,
7070 fold_convert (pvoid_type_node
, dest
), tmp
);
7071 tmp
= build_call_expr_loc (input_location
,
7072 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7074 fold_build2_loc (input_location
, MULT_EXPR
,
7075 size_type_node
, slen
,
7076 fold_convert (size_type_node
,
7078 gfc_add_expr_to_block (&body
, tmp
);
7080 /* Increment count. */
7081 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
7082 count
, build_int_cst (TREE_TYPE (count
), 1));
7083 gfc_add_modify (&body
, count
, tmp
);
7085 /* Build the loop. */
7086 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7087 gfc_add_expr_to_block (&block
, tmp
);
7089 /* Add the exit label. */
7090 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7091 gfc_add_expr_to_block (&block
, tmp
);
7093 /* Finish the block. */
7094 tmp
= gfc_finish_block (&block
);
7095 gfc_add_expr_to_block (&se
->pre
, tmp
);
7097 /* Set the result value. */
7099 se
->string_length
= dlen
;
7103 /* Generate code for the IARGC intrinsic. */
7106 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
7112 /* Call the library function. This always returns an INTEGER(4). */
7113 fndecl
= gfor_fndecl_iargc
;
7114 tmp
= build_call_expr_loc (input_location
,
7117 /* Convert it to the required type. */
7118 type
= gfc_typenode_for_spec (&expr
->ts
);
7119 tmp
= fold_convert (type
, tmp
);
7125 /* The loc intrinsic returns the address of its argument as
7126 gfc_index_integer_kind integer. */
7129 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7134 gcc_assert (!se
->ss
);
7136 arg_expr
= expr
->value
.function
.actual
->expr
;
7137 if (arg_expr
->rank
== 0)
7139 if (arg_expr
->ts
.type
== BT_CLASS
)
7140 gfc_add_component_ref (arg_expr
, "_data");
7141 gfc_conv_expr_reference (se
, arg_expr
);
7144 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7145 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7147 /* Create a temporary variable for loc return value. Without this,
7148 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7149 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7150 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7151 se
->expr
= temp_var
;
7155 /* The following routine generates code for the intrinsic
7156 functions from the ISO_C_BINDING module:
7162 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7164 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7166 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7168 if (arg
->expr
->rank
== 0)
7169 gfc_conv_expr_reference (se
, arg
->expr
);
7170 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
7171 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7174 gfc_conv_expr_descriptor (se
, arg
->expr
);
7175 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7178 /* TODO -- the following two lines shouldn't be necessary, but if
7179 they're removed, a bug is exposed later in the code path.
7180 This workaround was thus introduced, but will have to be
7181 removed; please see PR 35150 for details about the issue. */
7182 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7183 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7185 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7186 gfc_conv_expr_reference (se
, arg
->expr
);
7187 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7192 /* Build the addr_expr for the first argument. The argument is
7193 already an *address* so we don't need to set want_pointer in
7195 gfc_init_se (&arg1se
, NULL
);
7196 gfc_conv_expr (&arg1se
, arg
->expr
);
7197 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7198 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7200 /* See if we were given two arguments. */
7201 if (arg
->next
->expr
== NULL
)
7202 /* Only given one arg so generate a null and do a
7203 not-equal comparison against the first arg. */
7204 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7206 fold_convert (TREE_TYPE (arg1se
.expr
),
7207 null_pointer_node
));
7213 /* Given two arguments so build the arg2se from second arg. */
7214 gfc_init_se (&arg2se
, NULL
);
7215 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
7216 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7217 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7219 /* Generate test to compare that the two args are equal. */
7220 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7221 arg1se
.expr
, arg2se
.expr
);
7222 /* Generate test to ensure that the first arg is not null. */
7223 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
7225 arg1se
.expr
, null_pointer_node
);
7227 /* Finally, the generated test must check that both arg1 is not
7228 NULL and that it is equal to the second arg. */
7229 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7231 not_null_expr
, eq_expr
);
7239 /* The following routine generates code for the intrinsic
7240 subroutines from the ISO_C_BINDING module:
7242 * C_F_PROCPOINTER. */
7245 conv_isocbinding_subroutine (gfc_code
*code
)
7252 tree desc
, dim
, tmp
, stride
, offset
;
7253 stmtblock_t body
, block
;
7255 gfc_actual_arglist
*arg
= code
->ext
.actual
;
7257 gfc_init_se (&se
, NULL
);
7258 gfc_init_se (&cptrse
, NULL
);
7259 gfc_conv_expr (&cptrse
, arg
->expr
);
7260 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
7261 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
7263 gfc_init_se (&fptrse
, NULL
);
7264 if (arg
->next
->expr
->rank
== 0)
7266 fptrse
.want_pointer
= 1;
7267 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
7268 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
7269 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
7270 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7271 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
7272 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
7274 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7275 TREE_TYPE (fptrse
.expr
),
7277 fold_convert (TREE_TYPE (fptrse
.expr
),
7279 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
7280 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7281 return gfc_finish_block (&se
.pre
);
7284 gfc_start_block (&block
);
7286 /* Get the descriptor of the Fortran pointer. */
7287 fptrse
.descriptor_only
= 1;
7288 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
7289 gfc_add_block_to_block (&block
, &fptrse
.pre
);
7292 /* Set data value, dtype, and offset. */
7293 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
7294 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
7295 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7296 gfc_get_dtype (TREE_TYPE (desc
)));
7298 /* Start scalarization of the bounds, using the shape argument. */
7300 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
7301 gcc_assert (shape_ss
!= gfc_ss_terminator
);
7302 gfc_init_se (&shapese
, NULL
);
7304 gfc_init_loopinfo (&loop
);
7305 gfc_add_ss_to_loop (&loop
, shape_ss
);
7306 gfc_conv_ss_startstride (&loop
);
7307 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
7308 gfc_mark_ss_chain_used (shape_ss
, 1);
7310 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
7311 shapese
.ss
= shape_ss
;
7313 stride
= gfc_create_var (gfc_array_index_type
, "stride");
7314 offset
= gfc_create_var (gfc_array_index_type
, "offset");
7315 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
7316 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7319 gfc_start_scalarized_body (&loop
, &body
);
7321 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7322 loop
.loopvar
[0], loop
.from
[0]);
7324 /* Set bounds and stride. */
7325 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
7326 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
7328 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
7329 gfc_add_block_to_block (&body
, &shapese
.pre
);
7330 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
7331 gfc_add_block_to_block (&body
, &shapese
.post
);
7333 /* Calculate offset. */
7334 gfc_add_modify (&body
, offset
,
7335 fold_build2_loc (input_location
, PLUS_EXPR
,
7336 gfc_array_index_type
, offset
, stride
));
7337 /* Update stride. */
7338 gfc_add_modify (&body
, stride
,
7339 fold_build2_loc (input_location
, MULT_EXPR
,
7340 gfc_array_index_type
, stride
,
7341 fold_convert (gfc_array_index_type
,
7343 /* Finish scalarization loop. */
7344 gfc_trans_scalarizing_loops (&loop
, &body
);
7345 gfc_add_block_to_block (&block
, &loop
.pre
);
7346 gfc_add_block_to_block (&block
, &loop
.post
);
7347 gfc_add_block_to_block (&block
, &fptrse
.post
);
7348 gfc_cleanup_loop (&loop
);
7350 gfc_add_modify (&block
, offset
,
7351 fold_build1_loc (input_location
, NEGATE_EXPR
,
7352 gfc_array_index_type
, offset
));
7353 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
7355 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
7356 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7357 return gfc_finish_block (&se
.pre
);
7361 /* Save and restore floating-point state. */
7364 gfc_save_fp_state (stmtblock_t
*block
)
7366 tree type
, fpstate
, tmp
;
7368 type
= build_array_type (char_type_node
,
7369 build_range_type (size_type_node
, size_zero_node
,
7370 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
7371 fpstate
= gfc_create_var (type
, "fpstate");
7372 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
7374 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
7376 gfc_add_expr_to_block (block
, tmp
);
7383 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
7387 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
7389 gfc_add_expr_to_block (block
, tmp
);
7393 /* Generate code for arguments of IEEE functions. */
7396 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
7399 gfc_actual_arglist
*actual
;
7404 actual
= expr
->value
.function
.actual
;
7405 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
7407 gcc_assert (actual
);
7410 gfc_init_se (&argse
, se
);
7411 gfc_conv_expr_val (&argse
, e
);
7413 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7414 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7415 argarray
[arg
] = argse
.expr
;
7420 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
7421 and IEEE_UNORDERED, which translate directly to GCC type-generic
7425 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
7426 enum built_in_function code
, int nargs
)
7429 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
7431 conv_ieee_function_args (se
, expr
, args
, nargs
);
7432 se
->expr
= build_call_expr_loc_array (input_location
,
7433 builtin_decl_explicit (code
),
7435 STRIP_TYPE_NOPS (se
->expr
);
7436 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7440 /* Generate code for IEEE_IS_NORMAL intrinsic:
7441 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
7444 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
7446 tree arg
, isnormal
, iszero
;
7448 /* Convert arg, evaluate it only once. */
7449 conv_ieee_function_args (se
, expr
, &arg
, 1);
7450 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7452 isnormal
= build_call_expr_loc (input_location
,
7453 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
7455 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
7456 build_real_from_int_cst (TREE_TYPE (arg
),
7457 integer_zero_node
));
7458 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7459 boolean_type_node
, isnormal
, iszero
);
7460 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7464 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
7465 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
7468 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
7470 tree arg
, signbit
, isnan
;
7472 /* Convert arg, evaluate it only once. */
7473 conv_ieee_function_args (se
, expr
, &arg
, 1);
7474 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7476 isnan
= build_call_expr_loc (input_location
,
7477 builtin_decl_explicit (BUILT_IN_ISNAN
),
7479 STRIP_TYPE_NOPS (isnan
);
7481 signbit
= build_call_expr_loc (input_location
,
7482 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
7484 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7485 signbit
, integer_zero_node
);
7487 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7488 boolean_type_node
, signbit
,
7489 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
7490 TREE_TYPE(isnan
), isnan
));
7492 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7496 /* Generate code for IEEE_LOGB and IEEE_RINT. */
7499 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
7500 enum built_in_function code
)
7502 tree arg
, decl
, call
, fpstate
;
7505 conv_ieee_function_args (se
, expr
, &arg
, 1);
7506 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
7507 decl
= builtin_decl_for_precision (code
, argprec
);
7509 /* Save floating-point state. */
7510 fpstate
= gfc_save_fp_state (&se
->pre
);
7512 /* Make the function call. */
7513 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
7514 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
7516 /* Restore floating-point state. */
7517 gfc_restore_fp_state (&se
->post
, fpstate
);
7521 /* Generate code for IEEE_REM. */
7524 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
7526 tree args
[2], decl
, call
, fpstate
;
7529 conv_ieee_function_args (se
, expr
, args
, 2);
7531 /* If arguments have unequal size, convert them to the larger. */
7532 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
7533 > TYPE_PRECISION (TREE_TYPE (args
[1])))
7534 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7535 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
7536 > TYPE_PRECISION (TREE_TYPE (args
[0])))
7537 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
7539 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7540 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
7542 /* Save floating-point state. */
7543 fpstate
= gfc_save_fp_state (&se
->pre
);
7545 /* Make the function call. */
7546 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7547 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7549 /* Restore floating-point state. */
7550 gfc_restore_fp_state (&se
->post
, fpstate
);
7554 /* Generate code for IEEE_NEXT_AFTER. */
7557 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
7559 tree args
[2], decl
, call
, fpstate
;
7562 conv_ieee_function_args (se
, expr
, args
, 2);
7564 /* Result has the characteristics of first argument. */
7565 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7566 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7567 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
7569 /* Save floating-point state. */
7570 fpstate
= gfc_save_fp_state (&se
->pre
);
7572 /* Make the function call. */
7573 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7574 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7576 /* Restore floating-point state. */
7577 gfc_restore_fp_state (&se
->post
, fpstate
);
7581 /* Generate code for IEEE_SCALB. */
7584 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
7586 tree args
[2], decl
, call
, huge
, type
;
7589 conv_ieee_function_args (se
, expr
, args
, 2);
7591 /* Result has the characteristics of first argument. */
7592 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7593 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
7595 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
7597 /* We need to fold the integer into the range of a C int. */
7598 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
7599 type
= TREE_TYPE (args
[1]);
7601 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
7602 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
7604 huge
= fold_convert (type
, huge
);
7605 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
7607 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
7608 fold_build1_loc (input_location
, NEGATE_EXPR
,
7612 args
[1] = fold_convert (integer_type_node
, args
[1]);
7614 /* Make the function call. */
7615 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7616 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7620 /* Generate code for IEEE_COPY_SIGN. */
7623 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
7625 tree args
[2], decl
, sign
;
7628 conv_ieee_function_args (se
, expr
, args
, 2);
7630 /* Get the sign of the second argument. */
7631 sign
= build_call_expr_loc (input_location
,
7632 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
7634 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7635 sign
, integer_zero_node
);
7637 /* Create a value of one, with the right sign. */
7638 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
7640 fold_build1_loc (input_location
, NEGATE_EXPR
,
7644 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
7646 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7647 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
7649 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7653 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
7657 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
7659 const char *name
= expr
->value
.function
.name
;
7661 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
7663 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
7664 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
7665 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
7666 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
7667 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
7668 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
7669 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
7670 conv_intrinsic_ieee_is_normal (se
, expr
);
7671 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
7672 conv_intrinsic_ieee_is_negative (se
, expr
);
7673 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
7674 conv_intrinsic_ieee_copy_sign (se
, expr
);
7675 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
7676 conv_intrinsic_ieee_scalb (se
, expr
);
7677 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
7678 conv_intrinsic_ieee_next_after (se
, expr
);
7679 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
7680 conv_intrinsic_ieee_rem (se
, expr
);
7681 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
7682 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
7683 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
7684 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
7686 /* It is not among the functions we translate directly. We return
7687 false, so a library function call is emitted. */
7696 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
7699 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
7701 tree arg
, res
, restype
;
7703 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7704 arg
= fold_convert (size_type_node
, arg
);
7705 res
= build_call_expr_loc (input_location
,
7706 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
7707 restype
= gfc_typenode_for_spec (&expr
->ts
);
7708 se
->expr
= fold_convert (restype
, res
);
7712 /* Generate code for an intrinsic function. Some map directly to library
7713 calls, others get special handling. In some cases the name of the function
7714 used depends on the type specifiers. */
7717 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
7723 name
= &expr
->value
.function
.name
[2];
7727 lib
= gfc_is_intrinsic_libcall (expr
);
7731 se
->ignore_optional
= 1;
7733 switch (expr
->value
.function
.isym
->id
)
7735 case GFC_ISYM_EOSHIFT
:
7737 case GFC_ISYM_RESHAPE
:
7738 /* For all of those the first argument specifies the type and the
7739 third is optional. */
7740 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
7744 gfc_conv_intrinsic_funcall (se
, expr
);
7752 switch (expr
->value
.function
.isym
->id
)
7757 case GFC_ISYM_REPEAT
:
7758 gfc_conv_intrinsic_repeat (se
, expr
);
7762 gfc_conv_intrinsic_trim (se
, expr
);
7765 case GFC_ISYM_SC_KIND
:
7766 gfc_conv_intrinsic_sc_kind (se
, expr
);
7769 case GFC_ISYM_SI_KIND
:
7770 gfc_conv_intrinsic_si_kind (se
, expr
);
7773 case GFC_ISYM_SR_KIND
:
7774 gfc_conv_intrinsic_sr_kind (se
, expr
);
7777 case GFC_ISYM_EXPONENT
:
7778 gfc_conv_intrinsic_exponent (se
, expr
);
7782 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7784 fndecl
= gfor_fndecl_string_scan
;
7786 fndecl
= gfor_fndecl_string_scan_char4
;
7790 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7793 case GFC_ISYM_VERIFY
:
7794 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7796 fndecl
= gfor_fndecl_string_verify
;
7798 fndecl
= gfor_fndecl_string_verify_char4
;
7802 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7805 case GFC_ISYM_ALLOCATED
:
7806 gfc_conv_allocated (se
, expr
);
7809 case GFC_ISYM_ASSOCIATED
:
7810 gfc_conv_associated(se
, expr
);
7813 case GFC_ISYM_SAME_TYPE_AS
:
7814 gfc_conv_same_type_as (se
, expr
);
7818 gfc_conv_intrinsic_abs (se
, expr
);
7821 case GFC_ISYM_ADJUSTL
:
7822 if (expr
->ts
.kind
== 1)
7823 fndecl
= gfor_fndecl_adjustl
;
7824 else if (expr
->ts
.kind
== 4)
7825 fndecl
= gfor_fndecl_adjustl_char4
;
7829 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7832 case GFC_ISYM_ADJUSTR
:
7833 if (expr
->ts
.kind
== 1)
7834 fndecl
= gfor_fndecl_adjustr
;
7835 else if (expr
->ts
.kind
== 4)
7836 fndecl
= gfor_fndecl_adjustr_char4
;
7840 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7843 case GFC_ISYM_AIMAG
:
7844 gfc_conv_intrinsic_imagpart (se
, expr
);
7848 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
7852 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
7855 case GFC_ISYM_ANINT
:
7856 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
7860 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7864 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
7867 case GFC_ISYM_BTEST
:
7868 gfc_conv_intrinsic_btest (se
, expr
);
7872 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
7876 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
7880 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
7884 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
7887 case GFC_ISYM_C_ASSOCIATED
:
7888 case GFC_ISYM_C_FUNLOC
:
7889 case GFC_ISYM_C_LOC
:
7890 conv_isocbinding_function (se
, expr
);
7893 case GFC_ISYM_ACHAR
:
7895 gfc_conv_intrinsic_char (se
, expr
);
7898 case GFC_ISYM_CONVERSION
:
7900 case GFC_ISYM_LOGICAL
:
7902 gfc_conv_intrinsic_conversion (se
, expr
);
7905 /* Integer conversions are handled separately to make sure we get the
7906 correct rounding mode. */
7911 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
7915 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
7918 case GFC_ISYM_CEILING
:
7919 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
7922 case GFC_ISYM_FLOOR
:
7923 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
7927 gfc_conv_intrinsic_mod (se
, expr
, 0);
7930 case GFC_ISYM_MODULO
:
7931 gfc_conv_intrinsic_mod (se
, expr
, 1);
7934 case GFC_ISYM_CAF_GET
:
7935 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
);
7938 case GFC_ISYM_CMPLX
:
7939 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
7942 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
7943 gfc_conv_intrinsic_iargc (se
, expr
);
7946 case GFC_ISYM_COMPLEX
:
7947 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
7950 case GFC_ISYM_CONJG
:
7951 gfc_conv_intrinsic_conjg (se
, expr
);
7954 case GFC_ISYM_COUNT
:
7955 gfc_conv_intrinsic_count (se
, expr
);
7958 case GFC_ISYM_CTIME
:
7959 gfc_conv_intrinsic_ctime (se
, expr
);
7963 gfc_conv_intrinsic_dim (se
, expr
);
7966 case GFC_ISYM_DOT_PRODUCT
:
7967 gfc_conv_intrinsic_dot_product (se
, expr
);
7970 case GFC_ISYM_DPROD
:
7971 gfc_conv_intrinsic_dprod (se
, expr
);
7974 case GFC_ISYM_DSHIFTL
:
7975 gfc_conv_intrinsic_dshift (se
, expr
, true);
7978 case GFC_ISYM_DSHIFTR
:
7979 gfc_conv_intrinsic_dshift (se
, expr
, false);
7982 case GFC_ISYM_FDATE
:
7983 gfc_conv_intrinsic_fdate (se
, expr
);
7986 case GFC_ISYM_FRACTION
:
7987 gfc_conv_intrinsic_fraction (se
, expr
);
7991 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
7995 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7999 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
8002 case GFC_ISYM_IBCLR
:
8003 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
8006 case GFC_ISYM_IBITS
:
8007 gfc_conv_intrinsic_ibits (se
, expr
);
8010 case GFC_ISYM_IBSET
:
8011 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
8014 case GFC_ISYM_IACHAR
:
8015 case GFC_ISYM_ICHAR
:
8016 /* We assume ASCII character sequence. */
8017 gfc_conv_intrinsic_ichar (se
, expr
);
8020 case GFC_ISYM_IARGC
:
8021 gfc_conv_intrinsic_iargc (se
, expr
);
8025 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8028 case GFC_ISYM_INDEX
:
8029 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8031 fndecl
= gfor_fndecl_string_index
;
8033 fndecl
= gfor_fndecl_string_index_char4
;
8037 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8041 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8044 case GFC_ISYM_IPARITY
:
8045 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
8048 case GFC_ISYM_IS_IOSTAT_END
:
8049 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
8052 case GFC_ISYM_IS_IOSTAT_EOR
:
8053 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
8056 case GFC_ISYM_ISNAN
:
8057 gfc_conv_intrinsic_isnan (se
, expr
);
8060 case GFC_ISYM_LSHIFT
:
8061 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8064 case GFC_ISYM_RSHIFT
:
8065 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8068 case GFC_ISYM_SHIFTA
:
8069 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8072 case GFC_ISYM_SHIFTL
:
8073 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8076 case GFC_ISYM_SHIFTR
:
8077 gfc_conv_intrinsic_shift (se
, expr
, true, false);
8080 case GFC_ISYM_ISHFT
:
8081 gfc_conv_intrinsic_ishft (se
, expr
);
8084 case GFC_ISYM_ISHFTC
:
8085 gfc_conv_intrinsic_ishftc (se
, expr
);
8088 case GFC_ISYM_LEADZ
:
8089 gfc_conv_intrinsic_leadz (se
, expr
);
8092 case GFC_ISYM_TRAILZ
:
8093 gfc_conv_intrinsic_trailz (se
, expr
);
8096 case GFC_ISYM_POPCNT
:
8097 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
8100 case GFC_ISYM_POPPAR
:
8101 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
8104 case GFC_ISYM_LBOUND
:
8105 gfc_conv_intrinsic_bound (se
, expr
, 0);
8108 case GFC_ISYM_LCOBOUND
:
8109 conv_intrinsic_cobound (se
, expr
);
8112 case GFC_ISYM_TRANSPOSE
:
8113 /* The scalarizer has already been set up for reversed dimension access
8114 order ; now we just get the argument value normally. */
8115 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
8119 gfc_conv_intrinsic_len (se
, expr
);
8122 case GFC_ISYM_LEN_TRIM
:
8123 gfc_conv_intrinsic_len_trim (se
, expr
);
8127 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
8131 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
8135 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
8139 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
8142 case GFC_ISYM_MALLOC
:
8143 gfc_conv_intrinsic_malloc (se
, expr
);
8146 case GFC_ISYM_MASKL
:
8147 gfc_conv_intrinsic_mask (se
, expr
, 1);
8150 case GFC_ISYM_MASKR
:
8151 gfc_conv_intrinsic_mask (se
, expr
, 0);
8155 if (expr
->ts
.type
== BT_CHARACTER
)
8156 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
8158 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
8161 case GFC_ISYM_MAXLOC
:
8162 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8165 case GFC_ISYM_MAXVAL
:
8166 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
8169 case GFC_ISYM_MERGE
:
8170 gfc_conv_intrinsic_merge (se
, expr
);
8173 case GFC_ISYM_MERGE_BITS
:
8174 gfc_conv_intrinsic_merge_bits (se
, expr
);
8178 if (expr
->ts
.type
== BT_CHARACTER
)
8179 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
8181 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
8184 case GFC_ISYM_MINLOC
:
8185 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8188 case GFC_ISYM_MINVAL
:
8189 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
8192 case GFC_ISYM_NEAREST
:
8193 gfc_conv_intrinsic_nearest (se
, expr
);
8196 case GFC_ISYM_NORM2
:
8197 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
8201 gfc_conv_intrinsic_not (se
, expr
);
8205 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8208 case GFC_ISYM_PARITY
:
8209 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
8212 case GFC_ISYM_PRESENT
:
8213 gfc_conv_intrinsic_present (se
, expr
);
8216 case GFC_ISYM_PRODUCT
:
8217 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
8221 gfc_conv_intrinsic_rank (se
, expr
);
8224 case GFC_ISYM_RRSPACING
:
8225 gfc_conv_intrinsic_rrspacing (se
, expr
);
8228 case GFC_ISYM_SET_EXPONENT
:
8229 gfc_conv_intrinsic_set_exponent (se
, expr
);
8232 case GFC_ISYM_SCALE
:
8233 gfc_conv_intrinsic_scale (se
, expr
);
8237 gfc_conv_intrinsic_sign (se
, expr
);
8241 gfc_conv_intrinsic_size (se
, expr
);
8244 case GFC_ISYM_SIZEOF
:
8245 case GFC_ISYM_C_SIZEOF
:
8246 gfc_conv_intrinsic_sizeof (se
, expr
);
8249 case GFC_ISYM_STORAGE_SIZE
:
8250 gfc_conv_intrinsic_storage_size (se
, expr
);
8253 case GFC_ISYM_SPACING
:
8254 gfc_conv_intrinsic_spacing (se
, expr
);
8257 case GFC_ISYM_STRIDE
:
8258 conv_intrinsic_stride (se
, expr
);
8262 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
8265 case GFC_ISYM_TRANSFER
:
8266 if (se
->ss
&& se
->ss
->info
->useflags
)
8267 /* Access the previously obtained result. */
8268 gfc_conv_tmp_array_ref (se
);
8270 gfc_conv_intrinsic_transfer (se
, expr
);
8273 case GFC_ISYM_TTYNAM
:
8274 gfc_conv_intrinsic_ttynam (se
, expr
);
8277 case GFC_ISYM_UBOUND
:
8278 gfc_conv_intrinsic_bound (se
, expr
, 1);
8281 case GFC_ISYM_UCOBOUND
:
8282 conv_intrinsic_cobound (se
, expr
);
8286 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8290 gfc_conv_intrinsic_loc (se
, expr
);
8293 case GFC_ISYM_THIS_IMAGE
:
8294 /* For num_images() == 1, handle as LCOBOUND. */
8295 if (expr
->value
.function
.actual
->expr
8296 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
8297 conv_intrinsic_cobound (se
, expr
);
8299 trans_this_image (se
, expr
);
8302 case GFC_ISYM_IMAGE_INDEX
:
8303 trans_image_index (se
, expr
);
8306 case GFC_ISYM_NUM_IMAGES
:
8307 trans_num_images (se
, expr
);
8310 case GFC_ISYM_ACCESS
:
8311 case GFC_ISYM_CHDIR
:
8312 case GFC_ISYM_CHMOD
:
8313 case GFC_ISYM_DTIME
:
8314 case GFC_ISYM_ETIME
:
8315 case GFC_ISYM_EXTENDS_TYPE_OF
:
8317 case GFC_ISYM_FGETC
:
8320 case GFC_ISYM_FPUTC
:
8321 case GFC_ISYM_FSTAT
:
8322 case GFC_ISYM_FTELL
:
8323 case GFC_ISYM_GETCWD
:
8324 case GFC_ISYM_GETGID
:
8325 case GFC_ISYM_GETPID
:
8326 case GFC_ISYM_GETUID
:
8327 case GFC_ISYM_HOSTNM
:
8329 case GFC_ISYM_IERRNO
:
8330 case GFC_ISYM_IRAND
:
8331 case GFC_ISYM_ISATTY
:
8334 case GFC_ISYM_LSTAT
:
8335 case GFC_ISYM_MATMUL
:
8336 case GFC_ISYM_MCLOCK
:
8337 case GFC_ISYM_MCLOCK8
:
8339 case GFC_ISYM_RENAME
:
8340 case GFC_ISYM_SECOND
:
8341 case GFC_ISYM_SECNDS
:
8342 case GFC_ISYM_SIGNAL
:
8344 case GFC_ISYM_SYMLNK
:
8345 case GFC_ISYM_SYSTEM
:
8347 case GFC_ISYM_TIME8
:
8348 case GFC_ISYM_UMASK
:
8349 case GFC_ISYM_UNLINK
:
8351 gfc_conv_intrinsic_funcall (se
, expr
);
8354 case GFC_ISYM_EOSHIFT
:
8356 case GFC_ISYM_RESHAPE
:
8357 /* For those, expr->rank should always be >0 and thus the if above the
8358 switch should have matched. */
8363 gfc_conv_intrinsic_lib_function (se
, expr
);
8370 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
8372 gfc_ss
*arg_ss
, *tmp_ss
;
8373 gfc_actual_arglist
*arg
;
8375 arg
= expr
->value
.function
.actual
;
8377 gcc_assert (arg
->expr
);
8379 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
8380 gcc_assert (arg_ss
!= gfc_ss_terminator
);
8382 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
8384 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
8385 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
8387 gcc_assert (tmp_ss
->dimen
== 2);
8389 /* We just invert dimensions. */
8390 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
8393 /* Stop when tmp_ss points to the last valid element of the chain... */
8394 if (tmp_ss
->next
== gfc_ss_terminator
)
8398 /* ... so that we can attach the rest of the chain to it. */
8405 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
8406 This has the side effect of reversing the nested list, so there is no
8407 need to call gfc_reverse_ss on it (the given list is assumed not to be
8411 nest_loop_dimension (gfc_ss
*ss
, int dim
)
8414 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
8415 gfc_loopinfo
*new_loop
;
8417 gcc_assert (ss
!= gfc_ss_terminator
);
8419 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
8421 new_ss
= gfc_get_ss ();
8422 new_ss
->next
= prev_ss
;
8423 new_ss
->parent
= ss
;
8424 new_ss
->info
= ss
->info
;
8425 new_ss
->info
->refcount
++;
8428 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
8429 && ss
->info
->type
!= GFC_SS_REFERENCE
);
8432 new_ss
->dim
[0] = ss
->dim
[dim
];
8434 gcc_assert (dim
< ss
->dimen
);
8436 ss_dim
= --ss
->dimen
;
8437 for (i
= dim
; i
< ss_dim
; i
++)
8438 ss
->dim
[i
] = ss
->dim
[i
+ 1];
8440 ss
->dim
[ss_dim
] = 0;
8446 ss
->nested_ss
->parent
= new_ss
;
8447 new_ss
->nested_ss
= ss
->nested_ss
;
8449 ss
->nested_ss
= new_ss
;
8452 new_loop
= gfc_get_loopinfo ();
8453 gfc_init_loopinfo (new_loop
);
8455 gcc_assert (prev_ss
!= NULL
);
8456 gcc_assert (prev_ss
!= gfc_ss_terminator
);
8457 gfc_add_ss_to_loop (new_loop
, prev_ss
);
8458 return new_ss
->parent
;
8462 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
8463 is to be inlined. */
8466 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
8468 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
8469 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
8471 bool scalar_mask
= false;
8473 /* The rank of the result will be determined later. */
8474 arg1
= expr
->value
.function
.actual
;
8477 gcc_assert (arg3
!= NULL
);
8479 if (expr
->rank
== 0)
8482 tmp_ss
= gfc_ss_terminator
;
8488 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
8489 if (mask_ss
== tmp_ss
)
8495 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
8496 gcc_assert (array_ss
!= tmp_ss
);
8498 /* Odd thing: If the mask is scalar, it is used by the frontend after
8499 the array (to make an if around the nested loop). Thus it shall
8500 be after array_ss once the gfc_ss list is reversed. */
8502 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
8506 /* "Hide" the dimension on which we will sum in the first arg's scalarization
8508 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
8509 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
8517 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
8520 switch (expr
->value
.function
.isym
->id
)
8522 case GFC_ISYM_PRODUCT
:
8524 return walk_inline_intrinsic_arith (ss
, expr
);
8526 case GFC_ISYM_TRANSPOSE
:
8527 return walk_inline_intrinsic_transpose (ss
, expr
);
8536 /* This generates code to execute before entering the scalarization loop.
8537 Currently does nothing. */
8540 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
8542 switch (ss
->info
->expr
->value
.function
.isym
->id
)
8544 case GFC_ISYM_UBOUND
:
8545 case GFC_ISYM_LBOUND
:
8546 case GFC_ISYM_UCOBOUND
:
8547 case GFC_ISYM_LCOBOUND
:
8548 case GFC_ISYM_THIS_IMAGE
:
8557 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
8558 are expanded into code inside the scalarization loop. */
8561 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
8563 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
8564 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
8566 /* The two argument version returns a scalar. */
8567 if (expr
->value
.function
.actual
->next
->expr
)
8570 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
8574 /* Walk an intrinsic array libcall. */
8577 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
8579 gcc_assert (expr
->rank
> 0);
8580 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8584 /* Return whether the function call expression EXPR will be expanded
8585 inline by gfc_conv_intrinsic_function. */
8588 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
8590 gfc_actual_arglist
*args
;
8592 if (!expr
->value
.function
.isym
)
8595 switch (expr
->value
.function
.isym
->id
)
8597 case GFC_ISYM_PRODUCT
:
8599 /* Disable inline expansion if code size matters. */
8603 args
= expr
->value
.function
.actual
;
8604 /* We need to be able to subset the SUM argument at compile-time. */
8605 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
8610 case GFC_ISYM_TRANSPOSE
:
8619 /* Returns nonzero if the specified intrinsic function call maps directly to
8620 an external library call. Should only be used for functions that return
8624 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
8626 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
8627 gcc_assert (expr
->rank
> 0);
8629 if (gfc_inline_intrinsic_function_p (expr
))
8632 switch (expr
->value
.function
.isym
->id
)
8636 case GFC_ISYM_COUNT
:
8640 case GFC_ISYM_IPARITY
:
8641 case GFC_ISYM_MATMUL
:
8642 case GFC_ISYM_MAXLOC
:
8643 case GFC_ISYM_MAXVAL
:
8644 case GFC_ISYM_MINLOC
:
8645 case GFC_ISYM_MINVAL
:
8646 case GFC_ISYM_NORM2
:
8647 case GFC_ISYM_PARITY
:
8648 case GFC_ISYM_PRODUCT
:
8650 case GFC_ISYM_SHAPE
:
8651 case GFC_ISYM_SPREAD
:
8653 /* Ignore absent optional parameters. */
8656 case GFC_ISYM_RESHAPE
:
8657 case GFC_ISYM_CSHIFT
:
8658 case GFC_ISYM_EOSHIFT
:
8660 case GFC_ISYM_UNPACK
:
8661 /* Pass absent optional parameters. */
8669 /* Walk an intrinsic function. */
8671 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
8672 gfc_intrinsic_sym
* isym
)
8676 if (isym
->elemental
)
8677 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8678 NULL
, GFC_SS_SCALAR
);
8680 if (expr
->rank
== 0)
8683 if (gfc_inline_intrinsic_function_p (expr
))
8684 return walk_inline_intrinsic_function (ss
, expr
);
8686 if (gfc_is_intrinsic_libcall (expr
))
8687 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8689 /* Special cases. */
8692 case GFC_ISYM_LBOUND
:
8693 case GFC_ISYM_LCOBOUND
:
8694 case GFC_ISYM_UBOUND
:
8695 case GFC_ISYM_UCOBOUND
:
8696 case GFC_ISYM_THIS_IMAGE
:
8697 return gfc_walk_intrinsic_bound (ss
, expr
);
8699 case GFC_ISYM_TRANSFER
:
8700 case GFC_ISYM_CAF_GET
:
8701 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8704 /* This probably meant someone forgot to add an intrinsic to the above
8705 list(s) when they implemented it, or something's gone horribly
8713 conv_co_collective (gfc_code
*code
)
8716 stmtblock_t block
, post_block
;
8717 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
8718 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
8720 gfc_start_block (&block
);
8721 gfc_init_block (&post_block
);
8723 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
8725 opr_expr
= code
->ext
.actual
->next
->expr
;
8726 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
8727 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8728 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
8733 image_idx_expr
= code
->ext
.actual
->next
->expr
;
8734 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8735 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8741 gfc_init_se (&argse
, NULL
);
8742 gfc_conv_expr (&argse
, stat_expr
);
8743 gfc_add_block_to_block (&block
, &argse
.pre
);
8744 gfc_add_block_to_block (&post_block
, &argse
.post
);
8746 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8747 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
8749 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8752 stat
= null_pointer_node
;
8754 /* Early exit for GFC_FCOARRAY_SINGLE. */
8755 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8757 if (stat
!= NULL_TREE
)
8758 gfc_add_modify (&block
, stat
,
8759 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
8760 return gfc_finish_block (&block
);
8763 /* Handle the array. */
8764 gfc_init_se (&argse
, NULL
);
8765 if (code
->ext
.actual
->expr
->rank
== 0)
8767 symbol_attribute attr
;
8768 gfc_clear_attr (&attr
);
8769 gfc_init_se (&argse
, NULL
);
8770 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8771 gfc_add_block_to_block (&block
, &argse
.pre
);
8772 gfc_add_block_to_block (&post_block
, &argse
.post
);
8773 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
8774 array
= gfc_build_addr_expr (NULL_TREE
, array
);
8778 argse
.want_pointer
= 1;
8779 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
8782 gfc_add_block_to_block (&block
, &argse
.pre
);
8783 gfc_add_block_to_block (&post_block
, &argse
.post
);
8785 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
8786 strlen
= argse
.string_length
;
8788 strlen
= integer_zero_node
;
8793 gfc_init_se (&argse
, NULL
);
8794 gfc_conv_expr (&argse
, image_idx_expr
);
8795 gfc_add_block_to_block (&block
, &argse
.pre
);
8796 gfc_add_block_to_block (&post_block
, &argse
.post
);
8797 image_index
= fold_convert (integer_type_node
, argse
.expr
);
8800 image_index
= integer_zero_node
;
8805 gfc_init_se (&argse
, NULL
);
8806 gfc_conv_expr (&argse
, errmsg_expr
);
8807 gfc_add_block_to_block (&block
, &argse
.pre
);
8808 gfc_add_block_to_block (&post_block
, &argse
.post
);
8809 errmsg
= argse
.expr
;
8810 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
8814 errmsg
= null_pointer_node
;
8815 errmsg_len
= integer_zero_node
;
8818 /* Generate the function call. */
8819 switch (code
->resolved_isym
->id
)
8821 case GFC_ISYM_CO_BROADCAST
:
8822 fndecl
= gfor_fndecl_co_broadcast
;
8824 case GFC_ISYM_CO_MAX
:
8825 fndecl
= gfor_fndecl_co_max
;
8827 case GFC_ISYM_CO_MIN
:
8828 fndecl
= gfor_fndecl_co_min
;
8830 case GFC_ISYM_CO_REDUCE
:
8831 fndecl
= gfor_fndecl_co_reduce
;
8833 case GFC_ISYM_CO_SUM
:
8834 fndecl
= gfor_fndecl_co_sum
;
8840 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
8841 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
8842 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
8843 image_index
, stat
, errmsg
, errmsg_len
);
8844 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
8845 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
8846 stat
, errmsg
, strlen
, errmsg_len
);
8849 tree opr
, opr_flags
;
8851 // FIXME: Handle TS29113's bind(C) strings with descriptor.
8853 if (gfc_is_proc_ptr_comp (opr_expr
))
8855 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
8856 opr_flag_int
= sym
->attr
.dimension
8857 || (sym
->ts
.type
== BT_CHARACTER
8858 && !sym
->attr
.is_bind_c
)
8859 ? GFC_CAF_BYREF
: 0;
8860 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8861 && !sym
->attr
.is_bind_c
8862 ? GFC_CAF_HIDDENLEN
: 0;
8863 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
8867 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
8868 ? GFC_CAF_BYREF
: 0;
8869 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8870 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
8871 ? GFC_CAF_HIDDENLEN
: 0;
8872 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
8873 ? GFC_CAF_ARG_VALUE
: 0;
8875 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
8876 gfc_conv_expr (&argse
, opr_expr
);
8878 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
8879 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
8882 gfc_add_expr_to_block (&block
, fndecl
);
8883 gfc_add_block_to_block (&block
, &post_block
);
8885 return gfc_finish_block (&block
);
8890 conv_intrinsic_atomic_op (gfc_code
*code
)
8893 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
8894 stmtblock_t block
, post_block
;
8895 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
8896 gfc_expr
*stat_expr
;
8897 built_in_function fn
;
8899 if (atom_expr
->expr_type
== EXPR_FUNCTION
8900 && atom_expr
->value
.function
.isym
8901 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8902 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8904 gfc_start_block (&block
);
8905 gfc_init_block (&post_block
);
8907 gfc_init_se (&argse
, NULL
);
8908 argse
.want_pointer
= 1;
8909 gfc_conv_expr (&argse
, atom_expr
);
8910 gfc_add_block_to_block (&block
, &argse
.pre
);
8911 gfc_add_block_to_block (&post_block
, &argse
.post
);
8914 gfc_init_se (&argse
, NULL
);
8915 if (flag_coarray
== GFC_FCOARRAY_LIB
8916 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8917 argse
.want_pointer
= 1;
8918 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
8919 gfc_add_block_to_block (&block
, &argse
.pre
);
8920 gfc_add_block_to_block (&post_block
, &argse
.post
);
8923 switch (code
->resolved_isym
->id
)
8925 case GFC_ISYM_ATOMIC_ADD
:
8926 case GFC_ISYM_ATOMIC_AND
:
8927 case GFC_ISYM_ATOMIC_DEF
:
8928 case GFC_ISYM_ATOMIC_OR
:
8929 case GFC_ISYM_ATOMIC_XOR
:
8930 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8931 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8932 old
= null_pointer_node
;
8935 gfc_init_se (&argse
, NULL
);
8936 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8937 argse
.want_pointer
= 1;
8938 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
8939 gfc_add_block_to_block (&block
, &argse
.pre
);
8940 gfc_add_block_to_block (&post_block
, &argse
.post
);
8942 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8946 if (stat_expr
!= NULL
)
8948 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
8949 gfc_init_se (&argse
, NULL
);
8950 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8951 argse
.want_pointer
= 1;
8952 gfc_conv_expr_val (&argse
, stat_expr
);
8953 gfc_add_block_to_block (&block
, &argse
.pre
);
8954 gfc_add_block_to_block (&post_block
, &argse
.post
);
8957 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
8958 stat
= null_pointer_node
;
8960 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8962 tree image_index
, caf_decl
, offset
, token
;
8965 switch (code
->resolved_isym
->id
)
8967 case GFC_ISYM_ATOMIC_ADD
:
8968 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8969 op
= (int) GFC_CAF_ATOMIC_ADD
;
8971 case GFC_ISYM_ATOMIC_AND
:
8972 case GFC_ISYM_ATOMIC_FETCH_AND
:
8973 op
= (int) GFC_CAF_ATOMIC_AND
;
8975 case GFC_ISYM_ATOMIC_OR
:
8976 case GFC_ISYM_ATOMIC_FETCH_OR
:
8977 op
= (int) GFC_CAF_ATOMIC_OR
;
8979 case GFC_ISYM_ATOMIC_XOR
:
8980 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8981 op
= (int) GFC_CAF_ATOMIC_XOR
;
8983 case GFC_ISYM_ATOMIC_DEF
:
8984 op
= 0; /* Unused. */
8990 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
8991 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8992 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8994 if (gfc_is_coindexed (atom_expr
))
8995 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
8997 image_index
= integer_zero_node
;
8999 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9001 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9002 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
9003 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9006 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9008 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
9009 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
9010 token
, offset
, image_index
, value
, stat
,
9011 build_int_cst (integer_type_node
,
9012 (int) atom_expr
->ts
.type
),
9013 build_int_cst (integer_type_node
,
9014 (int) atom_expr
->ts
.kind
));
9016 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
9017 build_int_cst (integer_type_node
, op
),
9018 token
, offset
, image_index
, value
, old
, stat
,
9019 build_int_cst (integer_type_node
,
9020 (int) atom_expr
->ts
.type
),
9021 build_int_cst (integer_type_node
,
9022 (int) atom_expr
->ts
.kind
));
9024 gfc_add_expr_to_block (&block
, tmp
);
9025 gfc_add_block_to_block (&block
, &post_block
);
9026 return gfc_finish_block (&block
);
9030 switch (code
->resolved_isym
->id
)
9032 case GFC_ISYM_ATOMIC_ADD
:
9033 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9034 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
9036 case GFC_ISYM_ATOMIC_AND
:
9037 case GFC_ISYM_ATOMIC_FETCH_AND
:
9038 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
9040 case GFC_ISYM_ATOMIC_DEF
:
9041 fn
= BUILT_IN_ATOMIC_STORE_N
;
9043 case GFC_ISYM_ATOMIC_OR
:
9044 case GFC_ISYM_ATOMIC_FETCH_OR
:
9045 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
9047 case GFC_ISYM_ATOMIC_XOR
:
9048 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9049 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
9055 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9056 fn
= (built_in_function
) ((int) fn
9057 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9059 tmp
= builtin_decl_explicit (fn
);
9060 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
9061 tmp
= builtin_decl_explicit (fn
);
9063 switch (code
->resolved_isym
->id
)
9065 case GFC_ISYM_ATOMIC_ADD
:
9066 case GFC_ISYM_ATOMIC_AND
:
9067 case GFC_ISYM_ATOMIC_DEF
:
9068 case GFC_ISYM_ATOMIC_OR
:
9069 case GFC_ISYM_ATOMIC_XOR
:
9070 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9071 fold_convert (itype
, value
),
9072 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9073 gfc_add_expr_to_block (&block
, tmp
);
9076 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9077 fold_convert (itype
, value
),
9078 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9079 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
9083 if (stat
!= NULL_TREE
)
9084 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9085 gfc_add_block_to_block (&block
, &post_block
);
9086 return gfc_finish_block (&block
);
9091 conv_intrinsic_atomic_ref (gfc_code
*code
)
9094 tree tmp
, atom
, value
, stat
= NULL_TREE
;
9095 stmtblock_t block
, post_block
;
9096 built_in_function fn
;
9097 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
9099 if (atom_expr
->expr_type
== EXPR_FUNCTION
9100 && atom_expr
->value
.function
.isym
9101 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9102 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9104 gfc_start_block (&block
);
9105 gfc_init_block (&post_block
);
9106 gfc_init_se (&argse
, NULL
);
9107 argse
.want_pointer
= 1;
9108 gfc_conv_expr (&argse
, atom_expr
);
9109 gfc_add_block_to_block (&block
, &argse
.pre
);
9110 gfc_add_block_to_block (&post_block
, &argse
.post
);
9113 gfc_init_se (&argse
, NULL
);
9114 if (flag_coarray
== GFC_FCOARRAY_LIB
9115 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9116 argse
.want_pointer
= 1;
9117 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9118 gfc_add_block_to_block (&block
, &argse
.pre
);
9119 gfc_add_block_to_block (&post_block
, &argse
.post
);
9123 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
9125 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9127 gfc_init_se (&argse
, NULL
);
9128 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9129 argse
.want_pointer
= 1;
9130 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9131 gfc_add_block_to_block (&block
, &argse
.pre
);
9132 gfc_add_block_to_block (&post_block
, &argse
.post
);
9135 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9136 stat
= null_pointer_node
;
9138 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9140 tree image_index
, caf_decl
, offset
, token
;
9141 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
9143 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9144 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9145 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9147 if (gfc_is_coindexed (atom_expr
))
9148 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9150 image_index
= integer_zero_node
;
9152 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9154 /* Different type, need type conversion. */
9155 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9157 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9159 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
9162 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
9163 token
, offset
, image_index
, value
, stat
,
9164 build_int_cst (integer_type_node
,
9165 (int) atom_expr
->ts
.type
),
9166 build_int_cst (integer_type_node
,
9167 (int) atom_expr
->ts
.kind
));
9168 gfc_add_expr_to_block (&block
, tmp
);
9169 if (vardecl
!= NULL_TREE
)
9170 gfc_add_modify (&block
, orig_value
,
9171 fold_convert (TREE_TYPE (orig_value
), vardecl
));
9172 gfc_add_block_to_block (&block
, &post_block
);
9173 return gfc_finish_block (&block
);
9176 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9177 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
9178 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9180 tmp
= builtin_decl_explicit (fn
);
9181 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
9182 build_int_cst (integer_type_node
,
9184 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
9186 if (stat
!= NULL_TREE
)
9187 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9188 gfc_add_block_to_block (&block
, &post_block
);
9189 return gfc_finish_block (&block
);
9194 conv_intrinsic_atomic_cas (gfc_code
*code
)
9197 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
9198 stmtblock_t block
, post_block
;
9199 built_in_function fn
;
9200 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9202 if (atom_expr
->expr_type
== EXPR_FUNCTION
9203 && atom_expr
->value
.function
.isym
9204 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9205 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9207 gfc_init_block (&block
);
9208 gfc_init_block (&post_block
);
9209 gfc_init_se (&argse
, NULL
);
9210 argse
.want_pointer
= 1;
9211 gfc_conv_expr (&argse
, atom_expr
);
9214 gfc_init_se (&argse
, NULL
);
9215 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9216 argse
.want_pointer
= 1;
9217 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9218 gfc_add_block_to_block (&block
, &argse
.pre
);
9219 gfc_add_block_to_block (&post_block
, &argse
.post
);
9222 gfc_init_se (&argse
, NULL
);
9223 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9224 argse
.want_pointer
= 1;
9225 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9226 gfc_add_block_to_block (&block
, &argse
.pre
);
9227 gfc_add_block_to_block (&post_block
, &argse
.post
);
9230 gfc_init_se (&argse
, NULL
);
9231 if (flag_coarray
== GFC_FCOARRAY_LIB
9232 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
9233 == atom_expr
->ts
.kind
)
9234 argse
.want_pointer
= 1;
9235 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
9236 gfc_add_block_to_block (&block
, &argse
.pre
);
9237 gfc_add_block_to_block (&post_block
, &argse
.post
);
9238 new_val
= argse
.expr
;
9241 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
9243 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
9245 gfc_init_se (&argse
, NULL
);
9246 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9247 argse
.want_pointer
= 1;
9248 gfc_conv_expr_val (&argse
,
9249 code
->ext
.actual
->next
->next
->next
->next
->expr
);
9250 gfc_add_block_to_block (&block
, &argse
.pre
);
9251 gfc_add_block_to_block (&post_block
, &argse
.post
);
9254 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9255 stat
= null_pointer_node
;
9257 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9259 tree image_index
, caf_decl
, offset
, token
;
9261 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9262 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9263 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9265 if (gfc_is_coindexed (atom_expr
))
9266 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9268 image_index
= integer_zero_node
;
9270 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
9272 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
9273 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
9274 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9277 /* Convert a constant to a pointer. */
9278 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
9280 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
9281 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
9282 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9285 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9287 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
9288 token
, offset
, image_index
, old
, comp
, new_val
,
9289 stat
, build_int_cst (integer_type_node
,
9290 (int) atom_expr
->ts
.type
),
9291 build_int_cst (integer_type_node
,
9292 (int) atom_expr
->ts
.kind
));
9293 gfc_add_expr_to_block (&block
, tmp
);
9294 gfc_add_block_to_block (&block
, &post_block
);
9295 return gfc_finish_block (&block
);
9298 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9299 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
9300 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9302 tmp
= builtin_decl_explicit (fn
);
9304 gfc_add_modify (&block
, old
, comp
);
9305 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
9306 gfc_build_addr_expr (NULL
, old
),
9307 fold_convert (TREE_TYPE (old
), new_val
),
9309 build_int_cst (NULL
, MEMMODEL_RELAXED
),
9310 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9311 gfc_add_expr_to_block (&block
, tmp
);
9313 if (stat
!= NULL_TREE
)
9314 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9315 gfc_add_block_to_block (&block
, &post_block
);
9316 return gfc_finish_block (&block
);
9320 conv_intrinsic_event_query (gfc_code
*code
)
9323 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
9324 tree count
= NULL_TREE
, count2
= NULL_TREE
;
9326 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
9328 if (code
->ext
.actual
->next
->next
->expr
)
9330 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9332 gfc_init_se (&argse
, NULL
);
9333 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9336 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9337 stat
= null_pointer_node
;
9339 if (code
->ext
.actual
->next
->expr
)
9341 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
9342 gfc_init_se (&argse
, NULL
);
9343 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
9347 gfc_start_block (&se
.pre
);
9348 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9350 tree tmp
, token
, image_index
;
9351 tree index
= size_zero_node
;
9353 if (event_expr
->expr_type
== EXPR_FUNCTION
9354 && event_expr
->value
.function
.isym
9355 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9356 event_expr
= event_expr
->value
.function
.actual
->expr
;
9358 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
9360 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9361 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
9362 != INTMOD_ISO_FORTRAN_ENV
9363 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
9364 != ISOFORTRAN_EVENT_TYPE
)
9366 gfc_error ("Sorry, the event component of derived type at %L is not "
9367 "yet supported", &event_expr
->where
);
9371 if (gfc_is_coindexed (event_expr
))
9373 gfc_error ("The event variable at %L shall not be coindexed ",
9374 &event_expr
->where
);
9378 image_index
= integer_zero_node
;
9380 gfc_get_caf_token_offset (&token
, NULL
, caf_decl
, NULL_TREE
, event_expr
);
9382 /* For arrays, obtain the array index. */
9383 if (gfc_expr_attr (event_expr
).dimension
)
9385 tree desc
, tmp
, extent
, lbound
, ubound
;
9386 gfc_array_ref
*ar
, ar2
;
9389 /* TODO: Extend this, once DT components are supported. */
9390 ar
= &event_expr
->ref
->u
.ar
;
9392 memset (ar
, '\0', sizeof (*ar
));
9396 gfc_init_se (&argse
, NULL
);
9397 argse
.descriptor_only
= 1;
9398 gfc_conv_expr_descriptor (&argse
, event_expr
);
9399 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
9403 extent
= integer_one_node
;
9404 for (i
= 0; i
< ar
->dimen
; i
++)
9406 gfc_init_se (&argse
, NULL
);
9407 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
9408 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
9409 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
9410 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9411 integer_type_node
, argse
.expr
,
9412 fold_convert(integer_type_node
, lbound
));
9413 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9414 integer_type_node
, extent
, tmp
);
9415 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
9416 integer_type_node
, index
, tmp
);
9417 if (i
< ar
->dimen
- 1)
9419 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
9420 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
9421 tmp
= fold_convert (integer_type_node
, tmp
);
9422 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
9423 integer_type_node
, extent
, tmp
);
9428 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
9431 count
= gfc_create_var (integer_type_node
, "count");
9434 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
9437 stat
= gfc_create_var (integer_type_node
, "stat");
9440 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
9441 token
, index
, image_index
, count
9442 ? gfc_build_addr_expr (NULL
, count
) : count
,
9443 stat
!= null_pointer_node
9444 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
9445 gfc_add_expr_to_block (&se
.pre
, tmp
);
9447 if (count2
!= NULL_TREE
)
9448 gfc_add_modify (&se
.pre
, count2
,
9449 fold_convert (TREE_TYPE (count2
), count
));
9451 if (stat2
!= NULL_TREE
)
9452 gfc_add_modify (&se
.pre
, stat2
,
9453 fold_convert (TREE_TYPE (stat2
), stat
));
9455 return gfc_finish_block (&se
.pre
);
9458 gfc_init_se (&argse
, NULL
);
9459 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
9460 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
9462 if (stat
!= NULL_TREE
)
9463 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9465 return gfc_finish_block (&se
.pre
);
9469 conv_intrinsic_move_alloc (gfc_code
*code
)
9472 gfc_expr
*from_expr
, *to_expr
;
9473 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
9474 gfc_se from_se
, to_se
;
9478 gfc_start_block (&block
);
9480 from_expr
= code
->ext
.actual
->expr
;
9481 to_expr
= code
->ext
.actual
->next
->expr
;
9483 gfc_init_se (&from_se
, NULL
);
9484 gfc_init_se (&to_se
, NULL
);
9486 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
9487 || to_expr
->ts
.type
== BT_CLASS
);
9488 coarray
= gfc_get_corank (from_expr
) != 0;
9490 if (from_expr
->rank
== 0 && !coarray
)
9492 if (from_expr
->ts
.type
!= BT_CLASS
)
9493 from_expr2
= from_expr
;
9496 from_expr2
= gfc_copy_expr (from_expr
);
9497 gfc_add_data_component (from_expr2
);
9500 if (to_expr
->ts
.type
!= BT_CLASS
)
9504 to_expr2
= gfc_copy_expr (to_expr
);
9505 gfc_add_data_component (to_expr2
);
9508 from_se
.want_pointer
= 1;
9509 to_se
.want_pointer
= 1;
9510 gfc_conv_expr (&from_se
, from_expr2
);
9511 gfc_conv_expr (&to_se
, to_expr2
);
9512 gfc_add_block_to_block (&block
, &from_se
.pre
);
9513 gfc_add_block_to_block (&block
, &to_se
.pre
);
9515 /* Deallocate "to". */
9516 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
9517 to_expr
, to_expr
->ts
);
9518 gfc_add_expr_to_block (&block
, tmp
);
9520 /* Assign (_data) pointers. */
9521 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9522 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
9524 /* Set "from" to NULL. */
9525 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9526 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
9528 gfc_add_block_to_block (&block
, &from_se
.post
);
9529 gfc_add_block_to_block (&block
, &to_se
.post
);
9532 if (to_expr
->ts
.type
== BT_CLASS
)
9536 gfc_free_expr (to_expr2
);
9537 gfc_init_se (&to_se
, NULL
);
9538 to_se
.want_pointer
= 1;
9539 gfc_add_vptr_component (to_expr
);
9540 gfc_conv_expr (&to_se
, to_expr
);
9542 if (from_expr
->ts
.type
== BT_CLASS
)
9544 if (UNLIMITED_POLY (from_expr
))
9548 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9552 gfc_free_expr (from_expr2
);
9553 gfc_init_se (&from_se
, NULL
);
9554 from_se
.want_pointer
= 1;
9555 gfc_add_vptr_component (from_expr
);
9556 gfc_conv_expr (&from_se
, from_expr
);
9557 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9558 fold_convert (TREE_TYPE (to_se
.expr
),
9561 /* Reset _vptr component to declared type. */
9563 /* Unlimited polymorphic. */
9564 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9565 fold_convert (TREE_TYPE (from_se
.expr
),
9566 null_pointer_node
));
9569 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9570 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9571 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9576 vtab
= gfc_find_vtab (&from_expr
->ts
);
9578 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9579 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9580 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9584 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
9586 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
9587 fold_convert (TREE_TYPE (to_se
.string_length
),
9588 from_se
.string_length
));
9589 if (from_expr
->ts
.deferred
)
9590 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
9591 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
9594 return gfc_finish_block (&block
);
9597 /* Update _vptr component. */
9598 if (to_expr
->ts
.type
== BT_CLASS
)
9602 to_se
.want_pointer
= 1;
9603 to_expr2
= gfc_copy_expr (to_expr
);
9604 gfc_add_vptr_component (to_expr2
);
9605 gfc_conv_expr (&to_se
, to_expr2
);
9607 if (from_expr
->ts
.type
== BT_CLASS
)
9609 if (UNLIMITED_POLY (from_expr
))
9613 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9617 from_se
.want_pointer
= 1;
9618 from_expr2
= gfc_copy_expr (from_expr
);
9619 gfc_add_vptr_component (from_expr2
);
9620 gfc_conv_expr (&from_se
, from_expr2
);
9621 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9622 fold_convert (TREE_TYPE (to_se
.expr
),
9625 /* Reset _vptr component to declared type. */
9627 /* Unlimited polymorphic. */
9628 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9629 fold_convert (TREE_TYPE (from_se
.expr
),
9630 null_pointer_node
));
9633 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9634 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9635 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9640 vtab
= gfc_find_vtab (&from_expr
->ts
);
9642 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9643 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9644 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9647 gfc_free_expr (to_expr2
);
9648 gfc_init_se (&to_se
, NULL
);
9650 if (from_expr
->ts
.type
== BT_CLASS
)
9652 gfc_free_expr (from_expr2
);
9653 gfc_init_se (&from_se
, NULL
);
9658 /* Deallocate "to". */
9659 if (from_expr
->rank
== 0)
9661 to_se
.want_coarray
= 1;
9662 from_se
.want_coarray
= 1;
9664 gfc_conv_expr_descriptor (&to_se
, to_expr
);
9665 gfc_conv_expr_descriptor (&from_se
, from_expr
);
9667 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
9668 is an image control "statement", cf. IR F08/0040 in 12-006A. */
9669 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9673 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
9674 NULL_TREE
, NULL_TREE
, true, to_expr
,
9676 gfc_add_expr_to_block (&block
, tmp
);
9678 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9679 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9680 boolean_type_node
, tmp
,
9681 fold_convert (TREE_TYPE (tmp
),
9682 null_pointer_node
));
9683 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
9684 3, null_pointer_node
, null_pointer_node
,
9685 build_int_cst (integer_type_node
, 0));
9687 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
9688 tmp
, build_empty_stmt (input_location
));
9689 gfc_add_expr_to_block (&block
, tmp
);
9693 if (to_expr
->ts
.type
== BT_DERIVED
9694 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
9696 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
9697 to_se
.expr
, to_expr
->rank
);
9698 gfc_add_expr_to_block (&block
, tmp
);
9701 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9702 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9703 NULL_TREE
, true, to_expr
, false);
9704 gfc_add_expr_to_block (&block
, tmp
);
9707 /* Move the pointer and update the array descriptor data. */
9708 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
9710 /* Set "from" to NULL. */
9711 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
9712 gfc_add_modify_loc (input_location
, &block
, tmp
,
9713 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
9716 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
9718 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
9719 fold_convert (TREE_TYPE (to_se
.string_length
),
9720 from_se
.string_length
));
9721 if (from_expr
->ts
.deferred
)
9722 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
9723 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
9726 return gfc_finish_block (&block
);
9731 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
9735 gcc_assert (code
->resolved_isym
);
9737 switch (code
->resolved_isym
->id
)
9739 case GFC_ISYM_MOVE_ALLOC
:
9740 res
= conv_intrinsic_move_alloc (code
);
9743 case GFC_ISYM_ATOMIC_CAS
:
9744 res
= conv_intrinsic_atomic_cas (code
);
9747 case GFC_ISYM_ATOMIC_ADD
:
9748 case GFC_ISYM_ATOMIC_AND
:
9749 case GFC_ISYM_ATOMIC_DEF
:
9750 case GFC_ISYM_ATOMIC_OR
:
9751 case GFC_ISYM_ATOMIC_XOR
:
9752 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9753 case GFC_ISYM_ATOMIC_FETCH_AND
:
9754 case GFC_ISYM_ATOMIC_FETCH_OR
:
9755 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9756 res
= conv_intrinsic_atomic_op (code
);
9759 case GFC_ISYM_ATOMIC_REF
:
9760 res
= conv_intrinsic_atomic_ref (code
);
9763 case GFC_ISYM_EVENT_QUERY
:
9764 res
= conv_intrinsic_event_query (code
);
9767 case GFC_ISYM_C_F_POINTER
:
9768 case GFC_ISYM_C_F_PROCPOINTER
:
9769 res
= conv_isocbinding_subroutine (code
);
9772 case GFC_ISYM_CAF_SEND
:
9773 res
= conv_caf_send (code
);
9776 case GFC_ISYM_CO_BROADCAST
:
9777 case GFC_ISYM_CO_MIN
:
9778 case GFC_ISYM_CO_MAX
:
9779 case GFC_ISYM_CO_REDUCE
:
9780 case GFC_ISYM_CO_SUM
:
9781 res
= conv_co_collective (code
);
9785 res
= conv_intrinsic_free (code
);
9788 case GFC_ISYM_SYSTEM_CLOCK
:
9789 res
= conv_intrinsic_system_clock (code
);
9800 #include "gt-fortran-trans-intrinsic.h"