1 /* Intrinsic translation
2 Copyright (C) 2002-2016 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
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
, *tmp_stat
;
1105 tree caf_decl
, token
, offset
, image_index
, tmp
;
1106 tree res_var
, dst_var
, type
, kind
, vec
, stat
;
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
;
1125 tmp_stat
= gfc_find_stat_co(expr
);
1130 gfc_init_se(&stat_se
, NULL
);
1131 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1132 stat
= stat_se
.expr
;
1133 gfc_add_block_to_block (&se
->pre
, &stat_se
.pre
);
1134 gfc_add_block_to_block (&se
->post
, &stat_se
.post
);
1137 stat
= null_pointer_node
;
1139 gfc_init_se (&argse
, NULL
);
1140 if (array_expr
->rank
== 0)
1142 symbol_attribute attr
;
1144 gfc_clear_attr (&attr
);
1145 gfc_conv_expr (&argse
, array_expr
);
1147 if (lhs
== NULL_TREE
)
1149 gfc_clear_attr (&attr
);
1150 if (array_expr
->ts
.type
== BT_CHARACTER
)
1151 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1152 argse
.string_length
);
1154 res_var
= gfc_create_var (type
, "caf_res");
1155 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1156 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1158 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1159 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1163 /* If has_vector, pass descriptor for whole array and the
1164 vector bounds separately. */
1165 gfc_array_ref
*ar
, ar2
;
1166 bool has_vector
= false;
1168 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1171 ar
= gfc_find_array_ref (expr
);
1173 memset (ar
, '\0', sizeof (*ar
));
1177 gfc_conv_expr_descriptor (&argse
, array_expr
);
1178 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1179 has the wrong type if component references are done. */
1180 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1181 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1186 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1190 if (lhs
== NULL_TREE
)
1192 /* Create temporary. */
1193 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1194 if (se
->loop
->to
[n
] == NULL_TREE
)
1197 gfc_conv_descriptor_lbound_get (argse
.expr
, gfc_rank_cst
[n
]);
1199 gfc_conv_descriptor_ubound_get (argse
.expr
, gfc_rank_cst
[n
]);
1201 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1202 NULL_TREE
, false, true, false,
1203 &array_expr
->where
);
1204 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1205 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1207 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1210 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1211 if (lhs_kind
== NULL_TREE
)
1214 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1215 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1217 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1218 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1219 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1220 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1221 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, argse
.expr
, array_expr
);
1223 /* No overlap possible as we have generated a temporary. */
1224 if (lhs
== NULL_TREE
)
1225 may_require_tmp
= boolean_false_node
;
1227 /* It guarantees memory consistency within the same segment */
1228 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1229 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1230 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1231 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1232 ASM_VOLATILE_P (tmp
) = 1;
1233 gfc_add_expr_to_block (&se
->pre
, tmp
);
1235 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 10,
1236 token
, offset
, image_index
, argse
.expr
, vec
,
1237 dst_var
, kind
, lhs_kind
, may_require_tmp
, stat
);
1238 gfc_add_expr_to_block (&se
->pre
, tmp
);
1241 gfc_advance_se_ss_chain (se
);
1244 if (array_expr
->ts
.type
== BT_CHARACTER
)
1245 se
->string_length
= argse
.string_length
;
1249 /* Send data to a remove coarray. */
1252 conv_caf_send (gfc_code
*code
) {
1253 gfc_expr
*lhs_expr
, *rhs_expr
, *tmp_stat
;
1254 gfc_se lhs_se
, rhs_se
;
1256 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1257 tree may_require_tmp
, stat
;
1258 tree lhs_type
= NULL_TREE
;
1259 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1261 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1263 lhs_expr
= code
->ext
.actual
->expr
;
1264 rhs_expr
= code
->ext
.actual
->next
->expr
;
1265 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1266 ? boolean_false_node
: boolean_true_node
;
1267 gfc_init_block (&block
);
1269 stat
= null_pointer_node
;
1272 gfc_init_se (&lhs_se
, NULL
);
1273 if (lhs_expr
->rank
== 0)
1275 symbol_attribute attr
;
1276 gfc_clear_attr (&attr
);
1277 gfc_conv_expr (&lhs_se
, lhs_expr
);
1278 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1279 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1280 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1284 /* If has_vector, pass descriptor for whole array and the
1285 vector bounds separately. */
1286 gfc_array_ref
*ar
, ar2
;
1287 bool has_vector
= false;
1289 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1292 ar
= gfc_find_array_ref (lhs_expr
);
1294 memset (ar
, '\0', sizeof (*ar
));
1298 lhs_se
.want_pointer
= 1;
1299 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1300 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1301 has the wrong type if component references are done. */
1302 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1303 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1304 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1305 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1310 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1315 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1316 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1318 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1319 temporary and a loop. */
1320 if (!gfc_is_coindexed (lhs_expr
))
1322 gcc_assert (gfc_is_coindexed (rhs_expr
));
1323 gfc_init_se (&rhs_se
, NULL
);
1324 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1326 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1327 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1328 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1329 return gfc_finish_block (&block
);
1332 /* Obtain token, offset and image index for the LHS. */
1334 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1335 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1336 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1337 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1338 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, lhs_se
.expr
, lhs_expr
);
1341 gfc_init_se (&rhs_se
, NULL
);
1342 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1343 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1344 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1345 if (rhs_expr
->rank
== 0)
1347 symbol_attribute attr
;
1348 gfc_clear_attr (&attr
);
1349 gfc_conv_expr (&rhs_se
, rhs_expr
);
1350 if (!gfc_is_coindexed (rhs_expr
) && rhs_expr
->ts
.type
!= BT_CHARACTER
)
1351 rhs_se
.expr
= fold_convert (lhs_type
, rhs_se
.expr
);
1352 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
1353 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
1357 /* If has_vector, pass descriptor for whole array and the
1358 vector bounds separately. */
1359 gfc_array_ref
*ar
, ar2
;
1360 bool has_vector
= false;
1363 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
1366 ar
= gfc_find_array_ref (rhs_expr
);
1368 memset (ar
, '\0', sizeof (*ar
));
1372 rhs_se
.want_pointer
= 1;
1373 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
1374 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1375 has the wrong type if component references are done. */
1376 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
1377 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
1378 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1379 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1384 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
1389 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1391 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
1393 tmp_stat
= gfc_find_stat_co(lhs_expr
);
1398 gfc_init_se (&stat_se
, NULL
);
1399 gfc_conv_expr_reference (&stat_se
, tmp_stat
);
1400 stat
= stat_se
.expr
;
1401 gfc_add_block_to_block (&block
, &stat_se
.pre
);
1402 gfc_add_block_to_block (&block
, &stat_se
.post
);
1405 stat
= null_pointer_node
;
1407 if (!gfc_is_coindexed (rhs_expr
))
1408 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 10, token
,
1409 offset
, image_index
, lhs_se
.expr
, vec
,
1410 rhs_se
.expr
, lhs_kind
, rhs_kind
, may_require_tmp
,
1414 tree rhs_token
, rhs_offset
, rhs_image_index
;
1416 /* It guarantees memory consistency within the same segment */
1417 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1418 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1419 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1420 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1421 ASM_VOLATILE_P (tmp
) = 1;
1422 gfc_add_expr_to_block (&block
, tmp
);
1424 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
1425 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1426 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1427 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
1428 gfc_get_caf_token_offset (&rhs_token
, &rhs_offset
, caf_decl
, rhs_se
.expr
,
1430 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
, 13,
1431 token
, offset
, image_index
, lhs_se
.expr
, vec
,
1432 rhs_token
, rhs_offset
, rhs_image_index
,
1433 rhs_se
.expr
, rhs_vec
, lhs_kind
, rhs_kind
,
1436 gfc_add_expr_to_block (&block
, tmp
);
1437 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1438 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1440 /* It guarantees memory consistency within the same segment */
1441 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1442 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1443 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1444 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1445 ASM_VOLATILE_P (tmp
) = 1;
1446 gfc_add_expr_to_block (&block
, tmp
);
1448 return gfc_finish_block (&block
);
1453 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
1456 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
1457 lbound
, ubound
, extent
, ml
;
1460 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
1462 if (expr
->value
.function
.actual
->expr
1463 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
1464 distance
= expr
->value
.function
.actual
->expr
;
1466 /* The case -fcoarray=single is handled elsewhere. */
1467 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
1469 /* Argument-free version: THIS_IMAGE(). */
1470 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
1474 gfc_init_se (&argse
, NULL
);
1475 gfc_conv_expr_val (&argse
, distance
);
1476 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1477 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1478 tmp
= fold_convert (integer_type_node
, argse
.expr
);
1481 tmp
= integer_zero_node
;
1482 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1484 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1489 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1491 type
= gfc_get_int_type (gfc_default_integer_kind
);
1492 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1493 rank
= expr
->value
.function
.actual
->expr
->rank
;
1495 /* Obtain the descriptor of the COARRAY. */
1496 gfc_init_se (&argse
, NULL
);
1497 argse
.want_coarray
= 1;
1498 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1499 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1500 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1505 /* Create an implicit second parameter from the loop variable. */
1506 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
1507 gcc_assert (corank
> 0);
1508 gcc_assert (se
->loop
->dimen
== 1);
1509 gcc_assert (se
->ss
->info
->expr
== expr
);
1511 dim_arg
= se
->loop
->loopvar
[0];
1512 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
1513 gfc_array_index_type
, dim_arg
,
1514 build_int_cst (TREE_TYPE (dim_arg
), 1));
1515 gfc_advance_se_ss_chain (se
);
1519 /* Use the passed DIM= argument. */
1520 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
1521 gfc_init_se (&argse
, NULL
);
1522 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
1523 gfc_array_index_type
);
1524 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1525 dim_arg
= argse
.expr
;
1527 if (INTEGER_CST_P (dim_arg
))
1529 if (wi::ltu_p (dim_arg
, 1)
1530 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
1531 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1532 "dimension index", expr
->value
.function
.isym
->name
,
1535 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1537 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1538 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1540 build_int_cst (TREE_TYPE (dim_arg
), 1));
1541 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1542 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1544 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1545 boolean_type_node
, cond
, tmp
);
1546 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1551 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1552 one always has a dim_arg argument.
1554 m = this_image() - 1
1557 sub(1) = m + lcobound(corank)
1561 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1564 extent = gfc_extent(i)
1572 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1573 : m + lcobound(corank)
1576 /* this_image () - 1. */
1577 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1579 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
1580 fold_convert (type
, tmp
), build_int_cst (type
, 1));
1583 /* sub(1) = m + lcobound(corank). */
1584 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1585 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1587 lbound
= fold_convert (type
, lbound
);
1588 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1594 m
= gfc_create_var (type
, NULL
);
1595 ml
= gfc_create_var (type
, NULL
);
1596 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1597 min_var
= gfc_create_var (integer_type_node
, NULL
);
1599 /* m = this_image () - 1. */
1600 gfc_add_modify (&se
->pre
, m
, tmp
);
1602 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1603 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1604 fold_convert (integer_type_node
, dim_arg
),
1605 build_int_cst (integer_type_node
, rank
- 1));
1606 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1607 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1609 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1612 tmp
= build_int_cst (integer_type_node
, rank
);
1613 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1615 exit_label
= gfc_build_label_decl (NULL_TREE
);
1616 TREE_USED (exit_label
) = 1;
1619 gfc_init_block (&loop
);
1622 gfc_add_modify (&loop
, ml
, m
);
1625 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1626 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1627 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1628 extent
= fold_convert (type
, extent
);
1631 gfc_add_modify (&loop
, m
,
1632 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1635 /* Exit condition: if (i >= min_var) goto exit_label. */
1636 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1638 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1639 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1640 build_empty_stmt (input_location
));
1641 gfc_add_expr_to_block (&loop
, tmp
);
1643 /* Increment loop variable: i++. */
1644 gfc_add_modify (&loop
, loop_var
,
1645 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1647 build_int_cst (integer_type_node
, 1)));
1649 /* Making the loop... actually loop! */
1650 tmp
= gfc_finish_block (&loop
);
1651 tmp
= build1_v (LOOP_EXPR
, tmp
);
1652 gfc_add_expr_to_block (&se
->pre
, tmp
);
1654 /* The exit label. */
1655 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1656 gfc_add_expr_to_block (&se
->pre
, tmp
);
1658 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1659 : m + lcobound(corank) */
1661 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1662 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1664 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1665 fold_build2_loc (input_location
, PLUS_EXPR
,
1666 gfc_array_index_type
, dim_arg
,
1667 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1668 lbound
= fold_convert (type
, lbound
);
1670 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1671 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1673 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1675 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1676 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1682 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1684 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1686 gfc_se argse
, subse
;
1687 int rank
, corank
, codim
;
1689 type
= gfc_get_int_type (gfc_default_integer_kind
);
1690 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1691 rank
= expr
->value
.function
.actual
->expr
->rank
;
1693 /* Obtain the descriptor of the COARRAY. */
1694 gfc_init_se (&argse
, NULL
);
1695 argse
.want_coarray
= 1;
1696 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1697 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1698 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1701 /* Obtain a handle to the SUB argument. */
1702 gfc_init_se (&subse
, NULL
);
1703 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1704 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1705 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1706 subdesc
= build_fold_indirect_ref_loc (input_location
,
1707 gfc_conv_descriptor_data_get (subse
.expr
));
1709 /* Fortran 2008 does not require that the values remain in the cobounds,
1710 thus we need explicitly check this - and return 0 if they are exceeded. */
1712 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1713 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1714 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1715 fold_convert (gfc_array_index_type
, tmp
),
1718 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1720 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1721 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1722 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1723 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1724 fold_convert (gfc_array_index_type
, tmp
),
1726 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1727 boolean_type_node
, invalid_bound
, cond
);
1728 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1729 fold_convert (gfc_array_index_type
, tmp
),
1731 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1732 boolean_type_node
, invalid_bound
, cond
);
1735 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
1737 /* See Fortran 2008, C.10 for the following algorithm. */
1739 /* coindex = sub(corank) - lcobound(n). */
1740 coindex
= fold_convert (gfc_array_index_type
,
1741 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1743 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1744 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1745 fold_convert (gfc_array_index_type
, coindex
),
1748 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1750 tree extent
, ubound
;
1752 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1753 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1754 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1755 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1757 /* coindex *= extent. */
1758 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1759 gfc_array_index_type
, coindex
, extent
);
1761 /* coindex += sub(codim). */
1762 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1763 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1764 gfc_array_index_type
, coindex
,
1765 fold_convert (gfc_array_index_type
, tmp
));
1767 /* coindex -= lbound(codim). */
1768 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1769 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1770 gfc_array_index_type
, coindex
, lbound
);
1773 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1774 fold_convert(type
, coindex
),
1775 build_int_cst (type
, 1));
1777 /* Return 0 if "coindex" exceeds num_images(). */
1779 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
1780 num_images
= build_int_cst (type
, 1);
1783 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1785 build_int_cst (integer_type_node
, -1));
1786 num_images
= fold_convert (type
, tmp
);
1789 tmp
= gfc_create_var (type
, NULL
);
1790 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1792 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1794 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1796 fold_convert (boolean_type_node
, invalid_bound
));
1797 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1798 build_int_cst (type
, 0), tmp
);
1803 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
1805 tree tmp
, distance
, failed
;
1808 if (expr
->value
.function
.actual
->expr
)
1810 gfc_init_se (&argse
, NULL
);
1811 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
1812 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1813 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1814 distance
= fold_convert (integer_type_node
, argse
.expr
);
1817 distance
= integer_zero_node
;
1819 if (expr
->value
.function
.actual
->next
->expr
)
1821 gfc_init_se (&argse
, NULL
);
1822 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
1823 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1824 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1825 failed
= fold_convert (integer_type_node
, argse
.expr
);
1828 failed
= build_int_cst (integer_type_node
, -1);
1830 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1832 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
1837 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1841 gfc_init_se (&argse
, NULL
);
1842 argse
.data_not_needed
= 1;
1843 argse
.descriptor_only
= 1;
1845 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1846 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1847 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1849 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1853 /* Evaluate a single upper or lower bound. */
1854 /* TODO: bound intrinsic generates way too much unnecessary code. */
1857 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1859 gfc_actual_arglist
*arg
;
1860 gfc_actual_arglist
*arg2
;
1865 tree cond
, cond1
, cond3
, cond4
, size
;
1869 gfc_array_spec
* as
;
1870 bool assumed_rank_lb_one
;
1872 arg
= expr
->value
.function
.actual
;
1877 /* Create an implicit second parameter from the loop variable. */
1878 gcc_assert (!arg2
->expr
);
1879 gcc_assert (se
->loop
->dimen
== 1);
1880 gcc_assert (se
->ss
->info
->expr
== expr
);
1881 gfc_advance_se_ss_chain (se
);
1882 bound
= se
->loop
->loopvar
[0];
1883 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1884 gfc_array_index_type
, bound
,
1889 /* use the passed argument. */
1890 gcc_assert (arg2
->expr
);
1891 gfc_init_se (&argse
, NULL
);
1892 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1893 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1895 /* Convert from one based to zero based. */
1896 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1897 gfc_array_index_type
, bound
,
1898 gfc_index_one_node
);
1901 /* TODO: don't re-evaluate the descriptor on each iteration. */
1902 /* Get a descriptor for the first parameter. */
1903 gfc_init_se (&argse
, NULL
);
1904 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1905 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1906 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1910 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1912 if (INTEGER_CST_P (bound
))
1914 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1915 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
1916 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
1917 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1918 "dimension index", upper
? "UBOUND" : "LBOUND",
1922 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1924 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1926 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1927 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1928 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1929 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1930 tmp
= gfc_conv_descriptor_rank (desc
);
1932 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1933 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1934 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1935 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1936 boolean_type_node
, cond
, tmp
);
1937 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1942 /* Take care of the lbound shift for assumed-rank arrays, which are
1943 nonallocatable and nonpointers. Those has a lbound of 1. */
1944 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1945 && ((arg
->expr
->ts
.type
!= BT_CLASS
1946 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1947 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1948 || (arg
->expr
->ts
.type
== BT_CLASS
1949 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1950 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1952 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1953 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1955 /* 13.14.53: Result value for LBOUND
1957 Case (i): For an array section or for an array expression other than a
1958 whole array or array structure component, LBOUND(ARRAY, DIM)
1959 has the value 1. For a whole array or array structure
1960 component, LBOUND(ARRAY, DIM) has the value:
1961 (a) equal to the lower bound for subscript DIM of ARRAY if
1962 dimension DIM of ARRAY does not have extent zero
1963 or if ARRAY is an assumed-size array of rank DIM,
1966 13.14.113: Result value for UBOUND
1968 Case (i): For an array section or for an array expression other than a
1969 whole array or array structure component, UBOUND(ARRAY, DIM)
1970 has the value equal to the number of elements in the given
1971 dimension; otherwise, it has a value equal to the upper bound
1972 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1973 not have size zero and has value zero if dimension DIM has
1976 if (!upper
&& assumed_rank_lb_one
)
1977 se
->expr
= gfc_index_one_node
;
1980 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1982 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1984 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1985 stride
, gfc_index_zero_node
);
1986 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1987 boolean_type_node
, cond3
, cond1
);
1988 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1989 stride
, gfc_index_zero_node
);
1994 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1995 boolean_type_node
, cond3
, cond4
);
1996 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1997 gfc_index_one_node
, lbound
);
1998 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1999 boolean_type_node
, cond4
, cond5
);
2001 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2002 boolean_type_node
, cond
, cond5
);
2004 if (assumed_rank_lb_one
)
2006 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2007 gfc_array_index_type
, ubound
, lbound
);
2008 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2009 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2014 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2015 gfc_array_index_type
, cond
,
2016 tmp
, gfc_index_zero_node
);
2020 if (as
->type
== AS_ASSUMED_SIZE
)
2021 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2022 bound
, build_int_cst (TREE_TYPE (bound
),
2023 arg
->expr
->rank
- 1));
2025 cond
= boolean_false_node
;
2027 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2028 boolean_type_node
, cond3
, cond4
);
2029 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2030 boolean_type_node
, cond
, cond1
);
2032 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2033 gfc_array_index_type
, cond
,
2034 lbound
, gfc_index_one_node
);
2041 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2042 gfc_array_index_type
, ubound
, lbound
);
2043 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2044 gfc_array_index_type
, size
,
2045 gfc_index_one_node
);
2046 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2047 gfc_array_index_type
, se
->expr
,
2048 gfc_index_zero_node
);
2051 se
->expr
= gfc_index_one_node
;
2054 type
= gfc_typenode_for_spec (&expr
->ts
);
2055 se
->expr
= convert (type
, se
->expr
);
2060 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2062 gfc_actual_arglist
*arg
;
2063 gfc_actual_arglist
*arg2
;
2065 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2069 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2070 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2071 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2073 arg
= expr
->value
.function
.actual
;
2076 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2077 corank
= gfc_get_corank (arg
->expr
);
2079 gfc_init_se (&argse
, NULL
);
2080 argse
.want_coarray
= 1;
2082 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2083 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2084 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2089 /* Create an implicit second parameter from the loop variable. */
2090 gcc_assert (!arg2
->expr
);
2091 gcc_assert (corank
> 0);
2092 gcc_assert (se
->loop
->dimen
== 1);
2093 gcc_assert (se
->ss
->info
->expr
== expr
);
2095 bound
= se
->loop
->loopvar
[0];
2096 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2097 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2098 gfc_advance_se_ss_chain (se
);
2102 /* use the passed argument. */
2103 gcc_assert (arg2
->expr
);
2104 gfc_init_se (&argse
, NULL
);
2105 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2106 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2109 if (INTEGER_CST_P (bound
))
2111 if (wi::ltu_p (bound
, 1)
2112 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2113 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2114 "dimension index", expr
->value
.function
.isym
->name
,
2117 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2119 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2120 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2121 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2122 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2123 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2125 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2126 boolean_type_node
, cond
, tmp
);
2127 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2132 /* Subtract 1 to get to zero based and add dimensions. */
2133 switch (arg
->expr
->rank
)
2136 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2137 gfc_array_index_type
, bound
,
2138 gfc_index_one_node
);
2142 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2143 gfc_array_index_type
, bound
,
2144 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2148 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2150 /* Handle UCOBOUND with special handling of the last codimension. */
2151 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2153 /* Last codimension: For -fcoarray=single just return
2154 the lcobound - otherwise add
2155 ceiling (real (num_images ()) / real (size)) - 1
2156 = (num_images () + size - 1) / size - 1
2157 = (num_images - 1) / size(),
2158 where size is the product of the extent of all but the last
2161 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2165 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2166 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2167 2, integer_zero_node
,
2168 build_int_cst (integer_type_node
, -1));
2169 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2170 gfc_array_index_type
,
2171 fold_convert (gfc_array_index_type
, tmp
),
2172 build_int_cst (gfc_array_index_type
, 1));
2173 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2174 gfc_array_index_type
, tmp
,
2175 fold_convert (gfc_array_index_type
, cosize
));
2176 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2177 gfc_array_index_type
, resbound
, tmp
);
2179 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2181 /* ubound = lbound + num_images() - 1. */
2182 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2183 2, integer_zero_node
,
2184 build_int_cst (integer_type_node
, -1));
2185 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2186 gfc_array_index_type
,
2187 fold_convert (gfc_array_index_type
, tmp
),
2188 build_int_cst (gfc_array_index_type
, 1));
2189 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2190 gfc_array_index_type
, resbound
, tmp
);
2195 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2197 build_int_cst (TREE_TYPE (bound
),
2198 arg
->expr
->rank
+ corank
- 1));
2200 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2201 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2202 gfc_array_index_type
, cond
,
2203 resbound
, resbound2
);
2206 se
->expr
= resbound
;
2209 se
->expr
= resbound
;
2211 type
= gfc_typenode_for_spec (&expr
->ts
);
2212 se
->expr
= convert (type
, se
->expr
);
2217 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2219 gfc_actual_arglist
*array_arg
;
2220 gfc_actual_arglist
*dim_arg
;
2224 array_arg
= expr
->value
.function
.actual
;
2225 dim_arg
= array_arg
->next
;
2227 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2229 gfc_init_se (&argse
, NULL
);
2230 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2231 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2232 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2235 gcc_assert (dim_arg
->expr
);
2236 gfc_init_se (&argse
, NULL
);
2237 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2238 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2239 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2240 argse
.expr
, gfc_index_one_node
);
2241 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2246 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2250 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2252 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
2256 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
2261 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
2262 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
2271 /* Create a complex value from one or two real components. */
2274 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
2280 unsigned int num_args
;
2282 num_args
= gfc_intrinsic_argument_list_length (expr
);
2283 args
= XALLOCAVEC (tree
, num_args
);
2285 type
= gfc_typenode_for_spec (&expr
->ts
);
2286 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2287 real
= convert (TREE_TYPE (type
), args
[0]);
2289 imag
= convert (TREE_TYPE (type
), args
[1]);
2290 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
2292 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2293 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
2294 imag
= convert (TREE_TYPE (type
), imag
);
2297 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
2299 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
2303 /* Remainder function MOD(A, P) = A - INT(A / P) * P
2304 MODULO(A, P) = A - FLOOR (A / P) * P
2306 The obvious algorithms above are numerically instable for large
2307 arguments, hence these intrinsics are instead implemented via calls
2308 to the fmod family of functions. It is the responsibility of the
2309 user to ensure that the second argument is non-zero. */
2312 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
2322 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2324 switch (expr
->ts
.type
)
2327 /* Integer case is easy, we've got a builtin op. */
2328 type
= TREE_TYPE (args
[0]);
2331 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
2334 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
2340 /* Check if we have a builtin fmod. */
2341 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
2343 /* The builtin should always be available. */
2344 gcc_assert (fmod
!= NULL_TREE
);
2346 tmp
= build_addr (fmod
);
2347 se
->expr
= build_call_array_loc (input_location
,
2348 TREE_TYPE (TREE_TYPE (fmod
)),
2353 type
= TREE_TYPE (args
[0]);
2355 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2356 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
2359 modulo = arg - floor (arg/arg2) * arg2
2361 In order to calculate the result accurately, we use the fmod
2362 function as follows.
2364 res = fmod (arg, arg2);
2367 if ((arg < 0) xor (arg2 < 0))
2371 res = copysign (0., arg2);
2373 => As two nested ternary exprs:
2375 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2376 : copysign (0., arg2);
2380 zero
= gfc_build_const (type
, integer_zero_node
);
2381 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2382 if (!flag_signed_zeros
)
2384 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2386 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2388 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2389 boolean_type_node
, test
, test2
);
2390 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2392 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2393 boolean_type_node
, test
, test2
);
2394 test
= gfc_evaluate_now (test
, &se
->pre
);
2395 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2396 fold_build2_loc (input_location
,
2398 type
, tmp
, args
[1]),
2403 tree expr1
, copysign
, cscall
;
2404 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
2406 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2408 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2410 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2411 boolean_type_node
, test
, test2
);
2412 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
2413 fold_build2_loc (input_location
,
2415 type
, tmp
, args
[1]),
2417 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2419 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
2421 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2431 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2432 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2433 where the right shifts are logical (i.e. 0's are shifted in).
2434 Because SHIFT_EXPR's want shifts strictly smaller than the integral
2435 type width, we have to special-case both S == 0 and S == BITSIZE(J):
2437 DSHIFTL(I,J,BITSIZE) = J
2439 DSHIFTR(I,J,BITSIZE) = I. */
2442 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
2444 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
2445 tree args
[3], cond
, tmp
;
2448 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2450 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
2451 type
= TREE_TYPE (args
[0]);
2452 bitsize
= TYPE_PRECISION (type
);
2453 utype
= unsigned_type_for (type
);
2454 stype
= TREE_TYPE (args
[2]);
2456 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
2457 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
2458 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
2460 /* The generic case. */
2461 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
2462 build_int_cst (stype
, bitsize
), shift
);
2463 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
2464 arg1
, dshiftl
? shift
: tmp
);
2466 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
2467 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
2468 right
= fold_convert (type
, right
);
2470 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
2472 /* Special cases. */
2473 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2474 build_int_cst (stype
, 0));
2475 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2476 dshiftl
? arg1
: arg2
, res
);
2478 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2479 build_int_cst (stype
, bitsize
));
2480 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2481 dshiftl
? arg2
: arg1
, res
);
2487 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
2490 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
2498 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2499 type
= TREE_TYPE (args
[0]);
2501 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
2502 val
= gfc_evaluate_now (val
, &se
->pre
);
2504 zero
= gfc_build_const (type
, integer_zero_node
);
2505 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
2506 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
2510 /* SIGN(A, B) is absolute value of A times sign of B.
2511 The real value versions use library functions to ensure the correct
2512 handling of negative zero. Integer case implemented as:
2513 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
2517 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
2523 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2524 if (expr
->ts
.type
== BT_REAL
)
2528 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
2529 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
2531 /* We explicitly have to ignore the minus sign. We do so by using
2532 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
2534 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
2537 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
2538 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2540 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2541 TREE_TYPE (args
[0]), cond
,
2542 build_call_expr_loc (input_location
, abs
, 1,
2544 build_call_expr_loc (input_location
, tmp
, 2,
2548 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
2553 /* Having excluded floating point types, we know we are now dealing
2554 with signed integer types. */
2555 type
= TREE_TYPE (args
[0]);
2557 /* Args[0] is used multiple times below. */
2558 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2560 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2561 the signs of A and B are the same, and of all ones if they differ. */
2562 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2563 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2564 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2565 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2567 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2568 is all ones (i.e. -1). */
2569 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2570 fold_build2_loc (input_location
, PLUS_EXPR
,
2571 type
, args
[0], tmp
), tmp
);
2575 /* Test for the presence of an optional argument. */
2578 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2582 arg
= expr
->value
.function
.actual
->expr
;
2583 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2584 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2585 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2589 /* Calculate the double precision product of two single precision values. */
2592 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2597 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2599 /* Convert the args to double precision before multiplying. */
2600 type
= gfc_typenode_for_spec (&expr
->ts
);
2601 args
[0] = convert (type
, args
[0]);
2602 args
[1] = convert (type
, args
[1]);
2603 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2608 /* Return a length one character string containing an ascii character. */
2611 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2616 unsigned int num_args
;
2618 num_args
= gfc_intrinsic_argument_list_length (expr
);
2619 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2621 type
= gfc_get_char_type (expr
->ts
.kind
);
2622 var
= gfc_create_var (type
, "char");
2624 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2625 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2626 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2627 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2632 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2640 unsigned int num_args
;
2642 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2643 args
= XALLOCAVEC (tree
, num_args
);
2645 var
= gfc_create_var (pchar_type_node
, "pstr");
2646 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2648 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2649 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2650 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2652 fndecl
= build_addr (gfor_fndecl_ctime
);
2653 tmp
= build_call_array_loc (input_location
,
2654 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2655 fndecl
, num_args
, args
);
2656 gfc_add_expr_to_block (&se
->pre
, tmp
);
2658 /* Free the temporary afterwards, if necessary. */
2659 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2660 len
, build_int_cst (TREE_TYPE (len
), 0));
2661 tmp
= gfc_call_free (var
);
2662 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2663 gfc_add_expr_to_block (&se
->post
, tmp
);
2666 se
->string_length
= len
;
2671 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2679 unsigned int num_args
;
2681 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2682 args
= XALLOCAVEC (tree
, num_args
);
2684 var
= gfc_create_var (pchar_type_node
, "pstr");
2685 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2687 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2688 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2689 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2691 fndecl
= build_addr (gfor_fndecl_fdate
);
2692 tmp
= build_call_array_loc (input_location
,
2693 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2694 fndecl
, num_args
, args
);
2695 gfc_add_expr_to_block (&se
->pre
, tmp
);
2697 /* Free the temporary afterwards, if necessary. */
2698 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2699 len
, build_int_cst (TREE_TYPE (len
), 0));
2700 tmp
= gfc_call_free (var
);
2701 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2702 gfc_add_expr_to_block (&se
->post
, tmp
);
2705 se
->string_length
= len
;
2709 /* Generate a direct call to free() for the FREE subroutine. */
2712 conv_intrinsic_free (gfc_code
*code
)
2718 gfc_init_se (&argse
, NULL
);
2719 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
2720 arg
= fold_convert (ptr_type_node
, argse
.expr
);
2722 gfc_init_block (&block
);
2723 call
= build_call_expr_loc (input_location
,
2724 builtin_decl_explicit (BUILT_IN_FREE
), 1, arg
);
2725 gfc_add_expr_to_block (&block
, call
);
2726 return gfc_finish_block (&block
);
2730 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
2734 conv_intrinsic_system_clock (gfc_code
*code
)
2737 gfc_se count_se
, count_rate_se
, count_max_se
;
2738 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
2742 gfc_expr
*count
= code
->ext
.actual
->expr
;
2743 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
2744 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
2746 /* Evaluate our arguments. */
2749 gfc_init_se (&count_se
, NULL
);
2750 gfc_conv_expr (&count_se
, count
);
2755 gfc_init_se (&count_rate_se
, NULL
);
2756 gfc_conv_expr (&count_rate_se
, count_rate
);
2761 gfc_init_se (&count_max_se
, NULL
);
2762 gfc_conv_expr (&count_max_se
, count_max
);
2765 /* Find the smallest kind found of the arguments. */
2767 least
= (count
&& count
->ts
.kind
< least
) ? count
->ts
.kind
: least
;
2768 least
= (count_rate
&& count_rate
->ts
.kind
< least
) ? count_rate
->ts
.kind
2770 least
= (count_max
&& count_max
->ts
.kind
< least
) ? count_max
->ts
.kind
2773 /* Prepare temporary variables. */
2778 arg1
= gfc_create_var (gfc_get_int_type (8), "count");
2779 else if (least
== 4)
2780 arg1
= gfc_create_var (gfc_get_int_type (4), "count");
2781 else if (count
->ts
.kind
== 1)
2782 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[0].pedantic_min_int
,
2785 arg1
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[1].pedantic_min_int
,
2792 arg2
= gfc_create_var (gfc_get_int_type (8), "count_rate");
2793 else if (least
== 4)
2794 arg2
= gfc_create_var (gfc_get_int_type (4), "count_rate");
2796 arg2
= integer_zero_node
;
2802 arg3
= gfc_create_var (gfc_get_int_type (8), "count_max");
2803 else if (least
== 4)
2804 arg3
= gfc_create_var (gfc_get_int_type (4), "count_max");
2806 arg3
= integer_zero_node
;
2809 /* Make the function call. */
2810 gfc_init_block (&block
);
2816 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2817 : null_pointer_node
;
2818 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2819 : null_pointer_node
;
2820 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2821 : null_pointer_node
;
2826 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2827 : null_pointer_node
;
2828 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2829 : null_pointer_node
;
2830 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2831 : null_pointer_node
;
2838 tmp
= build_call_expr_loc (input_location
,
2839 gfor_fndecl_system_clock4
, 3,
2840 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2841 : null_pointer_node
,
2842 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2843 : null_pointer_node
,
2844 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2845 : null_pointer_node
);
2846 gfc_add_expr_to_block (&block
, tmp
);
2848 /* Handle kind>=8, 10, or 16 arguments */
2851 tmp
= build_call_expr_loc (input_location
,
2852 gfor_fndecl_system_clock8
, 3,
2853 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2854 : null_pointer_node
,
2855 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2856 : null_pointer_node
,
2857 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2858 : null_pointer_node
);
2859 gfc_add_expr_to_block (&block
, tmp
);
2863 /* And store values back if needed. */
2864 if (arg1
&& arg1
!= count_se
.expr
)
2865 gfc_add_modify (&block
, count_se
.expr
,
2866 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
2867 if (arg2
&& arg2
!= count_rate_se
.expr
)
2868 gfc_add_modify (&block
, count_rate_se
.expr
,
2869 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
2870 if (arg3
&& arg3
!= count_max_se
.expr
)
2871 gfc_add_modify (&block
, count_max_se
.expr
,
2872 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
2874 return gfc_finish_block (&block
);
2878 /* Return a character string containing the tty name. */
2881 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2889 unsigned int num_args
;
2891 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2892 args
= XALLOCAVEC (tree
, num_args
);
2894 var
= gfc_create_var (pchar_type_node
, "pstr");
2895 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2897 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2898 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2899 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2901 fndecl
= build_addr (gfor_fndecl_ttynam
);
2902 tmp
= build_call_array_loc (input_location
,
2903 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2904 fndecl
, num_args
, args
);
2905 gfc_add_expr_to_block (&se
->pre
, tmp
);
2907 /* Free the temporary afterwards, if necessary. */
2908 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2909 len
, build_int_cst (TREE_TYPE (len
), 0));
2910 tmp
= gfc_call_free (var
);
2911 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2912 gfc_add_expr_to_block (&se
->post
, tmp
);
2915 se
->string_length
= len
;
2919 /* Get the minimum/maximum value of all the parameters.
2920 minmax (a1, a2, a3, ...)
2923 if (a2 .op. mvar || isnan (mvar))
2925 if (a3 .op. mvar || isnan (mvar))
2932 /* TODO: Mismatching types can occur when specific names are used.
2933 These should be handled during resolution. */
2935 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2943 gfc_actual_arglist
*argexpr
;
2944 unsigned int i
, nargs
;
2946 nargs
= gfc_intrinsic_argument_list_length (expr
);
2947 args
= XALLOCAVEC (tree
, nargs
);
2949 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2950 type
= gfc_typenode_for_spec (&expr
->ts
);
2952 argexpr
= expr
->value
.function
.actual
;
2953 if (TREE_TYPE (args
[0]) != type
)
2954 args
[0] = convert (type
, args
[0]);
2955 /* Only evaluate the argument once. */
2956 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2957 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2959 mvar
= gfc_create_var (type
, "M");
2960 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2961 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2967 /* Handle absent optional arguments by ignoring the comparison. */
2968 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2969 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2970 && TREE_CODE (val
) == INDIRECT_REF
)
2971 cond
= fold_build2_loc (input_location
,
2972 NE_EXPR
, boolean_type_node
,
2973 TREE_OPERAND (val
, 0),
2974 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2979 /* Only evaluate the argument once. */
2980 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2981 val
= gfc_evaluate_now (val
, &se
->pre
);
2984 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2986 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2987 convert (type
, val
), mvar
);
2989 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2990 __builtin_isnan might be made dependent on that module being loaded,
2991 to help performance of programs that don't rely on IEEE semantics. */
2992 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2994 isnan
= build_call_expr_loc (input_location
,
2995 builtin_decl_explicit (BUILT_IN_ISNAN
),
2997 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2998 boolean_type_node
, tmp
,
2999 fold_convert (boolean_type_node
, isnan
));
3001 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
3002 build_empty_stmt (input_location
));
3004 if (cond
!= NULL_TREE
)
3005 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
3006 build_empty_stmt (input_location
));
3008 gfc_add_expr_to_block (&se
->pre
, tmp
);
3009 argexpr
= argexpr
->next
;
3015 /* Generate library calls for MIN and MAX intrinsics for character
3018 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
3021 tree var
, len
, fndecl
, tmp
, cond
, function
;
3024 nargs
= gfc_intrinsic_argument_list_length (expr
);
3025 args
= XALLOCAVEC (tree
, nargs
+ 4);
3026 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
3028 /* Create the result variables. */
3029 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3030 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3031 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3032 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3033 args
[2] = build_int_cst (integer_type_node
, op
);
3034 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3036 if (expr
->ts
.kind
== 1)
3037 function
= gfor_fndecl_string_minmax
;
3038 else if (expr
->ts
.kind
== 4)
3039 function
= gfor_fndecl_string_minmax_char4
;
3043 /* Make the function call. */
3044 fndecl
= build_addr (function
);
3045 tmp
= build_call_array_loc (input_location
,
3046 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3048 gfc_add_expr_to_block (&se
->pre
, tmp
);
3050 /* Free the temporary afterwards, if necessary. */
3051 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3052 len
, build_int_cst (TREE_TYPE (len
), 0));
3053 tmp
= gfc_call_free (var
);
3054 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3055 gfc_add_expr_to_block (&se
->post
, tmp
);
3058 se
->string_length
= len
;
3062 /* Create a symbol node for this intrinsic. The symbol from the frontend
3063 has the generic name. */
3066 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3070 /* TODO: Add symbols for intrinsic function to the global namespace. */
3071 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3072 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3075 sym
->attr
.external
= 1;
3076 sym
->attr
.function
= 1;
3077 sym
->attr
.always_explicit
= 1;
3078 sym
->attr
.proc
= PROC_INTRINSIC
;
3079 sym
->attr
.flavor
= FL_PROCEDURE
;
3083 sym
->attr
.dimension
= 1;
3084 sym
->as
= gfc_get_array_spec ();
3085 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3086 sym
->as
->rank
= expr
->rank
;
3089 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3090 ignore_optional
? expr
->value
.function
.actual
3096 /* Generate a call to an external intrinsic function. */
3098 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3101 vec
<tree
, va_gc
> *append_args
;
3103 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3106 gcc_assert (expr
->rank
> 0);
3108 gcc_assert (expr
->rank
== 0);
3110 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3112 /* Calls to libgfortran_matmul need to be appended special arguments,
3113 to be able to call the BLAS ?gemm functions if required and possible. */
3115 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3116 && sym
->ts
.type
!= BT_LOGICAL
)
3118 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3120 if (flag_external_blas
3121 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3122 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3126 if (sym
->ts
.type
== BT_REAL
)
3128 if (sym
->ts
.kind
== 4)
3129 gemm_fndecl
= gfor_fndecl_sgemm
;
3131 gemm_fndecl
= gfor_fndecl_dgemm
;
3135 if (sym
->ts
.kind
== 4)
3136 gemm_fndecl
= gfor_fndecl_cgemm
;
3138 gemm_fndecl
= gfor_fndecl_zgemm
;
3141 vec_alloc (append_args
, 3);
3142 append_args
->quick_push (build_int_cst (cint
, 1));
3143 append_args
->quick_push (build_int_cst (cint
,
3144 flag_blas_matmul_limit
));
3145 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3150 vec_alloc (append_args
, 3);
3151 append_args
->quick_push (build_int_cst (cint
, 0));
3152 append_args
->quick_push (build_int_cst (cint
, 0));
3153 append_args
->quick_push (null_pointer_node
);
3157 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3159 gfc_free_symbol (sym
);
3162 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3182 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3191 gfc_actual_arglist
*actual
;
3198 gfc_conv_intrinsic_funcall (se
, expr
);
3202 actual
= expr
->value
.function
.actual
;
3203 type
= gfc_typenode_for_spec (&expr
->ts
);
3204 /* Initialize the result. */
3205 resvar
= gfc_create_var (type
, "test");
3207 tmp
= convert (type
, boolean_true_node
);
3209 tmp
= convert (type
, boolean_false_node
);
3210 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3212 /* Walk the arguments. */
3213 arrayss
= gfc_walk_expr (actual
->expr
);
3214 gcc_assert (arrayss
!= gfc_ss_terminator
);
3216 /* Initialize the scalarizer. */
3217 gfc_init_loopinfo (&loop
);
3218 exit_label
= gfc_build_label_decl (NULL_TREE
);
3219 TREE_USED (exit_label
) = 1;
3220 gfc_add_ss_to_loop (&loop
, arrayss
);
3222 /* Initialize the loop. */
3223 gfc_conv_ss_startstride (&loop
);
3224 gfc_conv_loop_setup (&loop
, &expr
->where
);
3226 gfc_mark_ss_chain_used (arrayss
, 1);
3227 /* Generate the loop body. */
3228 gfc_start_scalarized_body (&loop
, &body
);
3230 /* If the condition matches then set the return value. */
3231 gfc_start_block (&block
);
3233 tmp
= convert (type
, boolean_false_node
);
3235 tmp
= convert (type
, boolean_true_node
);
3236 gfc_add_modify (&block
, resvar
, tmp
);
3238 /* And break out of the loop. */
3239 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3240 gfc_add_expr_to_block (&block
, tmp
);
3242 found
= gfc_finish_block (&block
);
3244 /* Check this element. */
3245 gfc_init_se (&arrayse
, NULL
);
3246 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3247 arrayse
.ss
= arrayss
;
3248 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3250 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3251 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3252 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3253 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3254 gfc_add_expr_to_block (&body
, tmp
);
3255 gfc_add_block_to_block (&body
, &arrayse
.post
);
3257 gfc_trans_scalarizing_loops (&loop
, &body
);
3259 /* Add the exit label. */
3260 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3261 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3263 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3264 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3265 gfc_cleanup_loop (&loop
);
3270 /* COUNT(A) = Number of true elements in A. */
3272 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
3279 gfc_actual_arglist
*actual
;
3285 gfc_conv_intrinsic_funcall (se
, expr
);
3289 actual
= expr
->value
.function
.actual
;
3291 type
= gfc_typenode_for_spec (&expr
->ts
);
3292 /* Initialize the result. */
3293 resvar
= gfc_create_var (type
, "count");
3294 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
3296 /* Walk the arguments. */
3297 arrayss
= gfc_walk_expr (actual
->expr
);
3298 gcc_assert (arrayss
!= gfc_ss_terminator
);
3300 /* Initialize the scalarizer. */
3301 gfc_init_loopinfo (&loop
);
3302 gfc_add_ss_to_loop (&loop
, arrayss
);
3304 /* Initialize the loop. */
3305 gfc_conv_ss_startstride (&loop
);
3306 gfc_conv_loop_setup (&loop
, &expr
->where
);
3308 gfc_mark_ss_chain_used (arrayss
, 1);
3309 /* Generate the loop body. */
3310 gfc_start_scalarized_body (&loop
, &body
);
3312 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
3313 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
3314 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
3316 gfc_init_se (&arrayse
, NULL
);
3317 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3318 arrayse
.ss
= arrayss
;
3319 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3320 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
3321 build_empty_stmt (input_location
));
3323 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3324 gfc_add_expr_to_block (&body
, tmp
);
3325 gfc_add_block_to_block (&body
, &arrayse
.post
);
3327 gfc_trans_scalarizing_loops (&loop
, &body
);
3329 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3330 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3331 gfc_cleanup_loop (&loop
);
3337 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
3338 struct and return the corresponding loopinfo. */
3340 static gfc_loopinfo
*
3341 enter_nested_loop (gfc_se
*se
)
3343 se
->ss
= se
->ss
->nested_ss
;
3344 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
3346 return se
->ss
->loop
;
3350 /* Inline implementation of the sum and product intrinsics. */
3352 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
3356 tree scale
= NULL_TREE
;
3361 gfc_loopinfo loop
, *ploop
;
3362 gfc_actual_arglist
*arg_array
, *arg_mask
;
3363 gfc_ss
*arrayss
= NULL
;
3364 gfc_ss
*maskss
= NULL
;
3368 gfc_expr
*arrayexpr
;
3373 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
3379 type
= gfc_typenode_for_spec (&expr
->ts
);
3380 /* Initialize the result. */
3381 resvar
= gfc_create_var (type
, "val");
3386 scale
= gfc_create_var (type
, "scale");
3387 gfc_add_modify (&se
->pre
, scale
,
3388 gfc_build_const (type
, integer_one_node
));
3389 tmp
= gfc_build_const (type
, integer_zero_node
);
3391 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
3392 tmp
= gfc_build_const (type
, integer_zero_node
);
3393 else if (op
== NE_EXPR
)
3395 tmp
= convert (type
, boolean_false_node
);
3396 else if (op
== BIT_AND_EXPR
)
3397 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
3398 type
, integer_one_node
));
3400 tmp
= gfc_build_const (type
, integer_one_node
);
3402 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3404 arg_array
= expr
->value
.function
.actual
;
3406 arrayexpr
= arg_array
->expr
;
3408 if (op
== NE_EXPR
|| norm2
)
3409 /* PARITY and NORM2. */
3413 arg_mask
= arg_array
->next
->next
;
3414 gcc_assert (arg_mask
!= NULL
);
3415 maskexpr
= arg_mask
->expr
;
3418 if (expr
->rank
== 0)
3420 /* Walk the arguments. */
3421 arrayss
= gfc_walk_expr (arrayexpr
);
3422 gcc_assert (arrayss
!= gfc_ss_terminator
);
3424 if (maskexpr
&& maskexpr
->rank
> 0)
3426 maskss
= gfc_walk_expr (maskexpr
);
3427 gcc_assert (maskss
!= gfc_ss_terminator
);
3432 /* Initialize the scalarizer. */
3433 gfc_init_loopinfo (&loop
);
3434 gfc_add_ss_to_loop (&loop
, arrayss
);
3435 if (maskexpr
&& maskexpr
->rank
> 0)
3436 gfc_add_ss_to_loop (&loop
, maskss
);
3438 /* Initialize the loop. */
3439 gfc_conv_ss_startstride (&loop
);
3440 gfc_conv_loop_setup (&loop
, &expr
->where
);
3442 gfc_mark_ss_chain_used (arrayss
, 1);
3443 if (maskexpr
&& maskexpr
->rank
> 0)
3444 gfc_mark_ss_chain_used (maskss
, 1);
3449 /* All the work has been done in the parent loops. */
3450 ploop
= enter_nested_loop (se
);
3454 /* Generate the loop body. */
3455 gfc_start_scalarized_body (ploop
, &body
);
3457 /* If we have a mask, only add this element if the mask is set. */
3458 if (maskexpr
&& maskexpr
->rank
> 0)
3460 gfc_init_se (&maskse
, parent_se
);
3461 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
3462 if (expr
->rank
== 0)
3464 gfc_conv_expr_val (&maskse
, maskexpr
);
3465 gfc_add_block_to_block (&body
, &maskse
.pre
);
3467 gfc_start_block (&block
);
3470 gfc_init_block (&block
);
3472 /* Do the actual summation/product. */
3473 gfc_init_se (&arrayse
, parent_se
);
3474 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
3475 if (expr
->rank
== 0)
3476 arrayse
.ss
= arrayss
;
3477 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3478 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3482 /* if (x (i) != 0.0)
3488 result = 1.0 + result * val * val;
3494 result += val * val;
3497 tree res1
, res2
, cond
, absX
, val
;
3498 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
3500 gfc_init_block (&ifblock1
);
3502 absX
= gfc_create_var (type
, "absX");
3503 gfc_add_modify (&ifblock1
, absX
,
3504 fold_build1_loc (input_location
, ABS_EXPR
, type
,
3506 val
= gfc_create_var (type
, "val");
3507 gfc_add_expr_to_block (&ifblock1
, val
);
3509 gfc_init_block (&ifblock2
);
3510 gfc_add_modify (&ifblock2
, val
,
3511 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
3513 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3514 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
3515 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
3516 gfc_build_const (type
, integer_one_node
));
3517 gfc_add_modify (&ifblock2
, resvar
, res1
);
3518 gfc_add_modify (&ifblock2
, scale
, absX
);
3519 res1
= gfc_finish_block (&ifblock2
);
3521 gfc_init_block (&ifblock3
);
3522 gfc_add_modify (&ifblock3
, val
,
3523 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
3525 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3526 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
3527 gfc_add_modify (&ifblock3
, resvar
, res2
);
3528 res2
= gfc_finish_block (&ifblock3
);
3530 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3532 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
3533 gfc_add_expr_to_block (&ifblock1
, tmp
);
3534 tmp
= gfc_finish_block (&ifblock1
);
3536 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3538 gfc_build_const (type
, integer_zero_node
));
3540 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3541 gfc_add_expr_to_block (&block
, tmp
);
3545 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
3546 gfc_add_modify (&block
, resvar
, tmp
);
3549 gfc_add_block_to_block (&block
, &arrayse
.post
);
3551 if (maskexpr
&& maskexpr
->rank
> 0)
3553 /* We enclose the above in if (mask) {...} . */
3555 tmp
= gfc_finish_block (&block
);
3556 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3557 build_empty_stmt (input_location
));
3560 tmp
= gfc_finish_block (&block
);
3561 gfc_add_expr_to_block (&body
, tmp
);
3563 gfc_trans_scalarizing_loops (ploop
, &body
);
3565 /* For a scalar mask, enclose the loop in an if statement. */
3566 if (maskexpr
&& maskexpr
->rank
== 0)
3568 gfc_init_block (&block
);
3569 gfc_add_block_to_block (&block
, &ploop
->pre
);
3570 gfc_add_block_to_block (&block
, &ploop
->post
);
3571 tmp
= gfc_finish_block (&block
);
3575 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
3576 build_empty_stmt (input_location
));
3577 gfc_advance_se_ss_chain (se
);
3581 gcc_assert (expr
->rank
== 0);
3582 gfc_init_se (&maskse
, NULL
);
3583 gfc_conv_expr_val (&maskse
, maskexpr
);
3584 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3585 build_empty_stmt (input_location
));
3588 gfc_add_expr_to_block (&block
, tmp
);
3589 gfc_add_block_to_block (&se
->pre
, &block
);
3590 gcc_assert (se
->post
.head
== NULL
);
3594 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
3595 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
3598 if (expr
->rank
== 0)
3599 gfc_cleanup_loop (ploop
);
3603 /* result = scale * sqrt(result). */
3605 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
3606 resvar
= build_call_expr_loc (input_location
,
3608 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
3615 /* Inline implementation of the dot_product intrinsic. This function
3616 is based on gfc_conv_intrinsic_arith (the previous function). */
3618 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
3626 gfc_actual_arglist
*actual
;
3627 gfc_ss
*arrayss1
, *arrayss2
;
3628 gfc_se arrayse1
, arrayse2
;
3629 gfc_expr
*arrayexpr1
, *arrayexpr2
;
3631 type
= gfc_typenode_for_spec (&expr
->ts
);
3633 /* Initialize the result. */
3634 resvar
= gfc_create_var (type
, "val");
3635 if (expr
->ts
.type
== BT_LOGICAL
)
3636 tmp
= build_int_cst (type
, 0);
3638 tmp
= gfc_build_const (type
, integer_zero_node
);
3640 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3642 /* Walk argument #1. */
3643 actual
= expr
->value
.function
.actual
;
3644 arrayexpr1
= actual
->expr
;
3645 arrayss1
= gfc_walk_expr (arrayexpr1
);
3646 gcc_assert (arrayss1
!= gfc_ss_terminator
);
3648 /* Walk argument #2. */
3649 actual
= actual
->next
;
3650 arrayexpr2
= actual
->expr
;
3651 arrayss2
= gfc_walk_expr (arrayexpr2
);
3652 gcc_assert (arrayss2
!= gfc_ss_terminator
);
3654 /* Initialize the scalarizer. */
3655 gfc_init_loopinfo (&loop
);
3656 gfc_add_ss_to_loop (&loop
, arrayss1
);
3657 gfc_add_ss_to_loop (&loop
, arrayss2
);
3659 /* Initialize the loop. */
3660 gfc_conv_ss_startstride (&loop
);
3661 gfc_conv_loop_setup (&loop
, &expr
->where
);
3663 gfc_mark_ss_chain_used (arrayss1
, 1);
3664 gfc_mark_ss_chain_used (arrayss2
, 1);
3666 /* Generate the loop body. */
3667 gfc_start_scalarized_body (&loop
, &body
);
3668 gfc_init_block (&block
);
3670 /* Make the tree expression for [conjg(]array1[)]. */
3671 gfc_init_se (&arrayse1
, NULL
);
3672 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
3673 arrayse1
.ss
= arrayss1
;
3674 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
3675 if (expr
->ts
.type
== BT_COMPLEX
)
3676 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
3678 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
3680 /* Make the tree expression for array2. */
3681 gfc_init_se (&arrayse2
, NULL
);
3682 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
3683 arrayse2
.ss
= arrayss2
;
3684 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
3685 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
3687 /* Do the actual product and sum. */
3688 if (expr
->ts
.type
== BT_LOGICAL
)
3690 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
3691 arrayse1
.expr
, arrayse2
.expr
);
3692 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
3696 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
3698 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
3700 gfc_add_modify (&block
, resvar
, tmp
);
3702 /* Finish up the loop block and the loop. */
3703 tmp
= gfc_finish_block (&block
);
3704 gfc_add_expr_to_block (&body
, tmp
);
3706 gfc_trans_scalarizing_loops (&loop
, &body
);
3707 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3708 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3709 gfc_cleanup_loop (&loop
);
3715 /* Emit code for minloc or maxloc intrinsic. There are many different cases
3716 we need to handle. For performance reasons we sometimes create two
3717 loops instead of one, where the second one is much simpler.
3718 Examples for minloc intrinsic:
3719 1) Result is an array, a call is generated
3720 2) Array mask is used and NaNs need to be supported:
3726 if (pos == 0) pos = S + (1 - from);
3727 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3734 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3738 3) NaNs need to be supported, but it is known at compile time or cheaply
3739 at runtime whether array is nonempty or not:
3744 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3747 if (from <= to) pos = 1;
3751 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3755 4) NaNs aren't supported, array mask is used:
3756 limit = infinities_supported ? Infinity : huge (limit);
3760 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3766 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3770 5) Same without array mask:
3771 limit = infinities_supported ? Infinity : huge (limit);
3772 pos = (from <= to) ? 1 : 0;
3775 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3778 For 3) and 5), if mask is scalar, this all goes into a conditional,
3779 setting pos = 0; in the else branch. */
3782 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3786 stmtblock_t ifblock
;
3787 stmtblock_t elseblock
;
3798 gfc_actual_arglist
*actual
;
3803 gfc_expr
*arrayexpr
;
3810 gfc_conv_intrinsic_funcall (se
, expr
);
3814 /* Initialize the result. */
3815 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3816 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3817 type
= gfc_typenode_for_spec (&expr
->ts
);
3819 /* Walk the arguments. */
3820 actual
= expr
->value
.function
.actual
;
3821 arrayexpr
= actual
->expr
;
3822 arrayss
= gfc_walk_expr (arrayexpr
);
3823 gcc_assert (arrayss
!= gfc_ss_terminator
);
3825 actual
= actual
->next
->next
;
3826 gcc_assert (actual
);
3827 maskexpr
= actual
->expr
;
3829 if (maskexpr
&& maskexpr
->rank
!= 0)
3831 maskss
= gfc_walk_expr (maskexpr
);
3832 gcc_assert (maskss
!= gfc_ss_terminator
);
3837 if (gfc_array_size (arrayexpr
, &asize
))
3839 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3841 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3842 boolean_type_node
, nonempty
,
3843 gfc_index_zero_node
);
3848 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3849 switch (arrayexpr
->ts
.type
)
3852 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3856 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3857 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3858 arrayexpr
->ts
.kind
);
3865 /* We start with the most negative possible value for MAXLOC, and the most
3866 positive possible value for MINLOC. The most negative possible value is
3867 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3868 possible value is HUGE in both cases. */
3870 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3871 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
3872 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3873 build_int_cst (TREE_TYPE (tmp
), 1));
3875 gfc_add_modify (&se
->pre
, limit
, tmp
);
3877 /* Initialize the scalarizer. */
3878 gfc_init_loopinfo (&loop
);
3879 gfc_add_ss_to_loop (&loop
, arrayss
);
3881 gfc_add_ss_to_loop (&loop
, maskss
);
3883 /* Initialize the loop. */
3884 gfc_conv_ss_startstride (&loop
);
3886 /* The code generated can have more than one loop in sequence (see the
3887 comment at the function header). This doesn't work well with the
3888 scalarizer, which changes arrays' offset when the scalarization loops
3889 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3890 are currently inlined in the scalar case only (for which loop is of rank
3891 one). As there is no dependency to care about in that case, there is no
3892 temporary, so that we can use the scalarizer temporary code to handle
3893 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3894 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3896 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3897 should eventually go away. We could either create two loops properly,
3898 or find another way to save/restore the array offsets between the two
3899 loops (without conflicting with temporary management), or use a single
3900 loop minmaxloc implementation. See PR 31067. */
3901 loop
.temp_dim
= loop
.dimen
;
3902 gfc_conv_loop_setup (&loop
, &expr
->where
);
3904 gcc_assert (loop
.dimen
== 1);
3905 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3906 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3907 loop
.from
[0], loop
.to
[0]);
3911 /* Initialize the position to zero, following Fortran 2003. We are free
3912 to do this because Fortran 95 allows the result of an entirely false
3913 mask to be processor dependent. If we know at compile time the array
3914 is non-empty and no MASK is used, we can initialize to 1 to simplify
3916 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3917 gfc_add_modify (&loop
.pre
, pos
,
3918 fold_build3_loc (input_location
, COND_EXPR
,
3919 gfc_array_index_type
,
3920 nonempty
, gfc_index_one_node
,
3921 gfc_index_zero_node
));
3924 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3925 lab1
= gfc_build_label_decl (NULL_TREE
);
3926 TREE_USED (lab1
) = 1;
3927 lab2
= gfc_build_label_decl (NULL_TREE
);
3928 TREE_USED (lab2
) = 1;
3931 /* An offset must be added to the loop
3932 counter to obtain the required position. */
3933 gcc_assert (loop
.from
[0]);
3935 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3936 gfc_index_one_node
, loop
.from
[0]);
3937 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3939 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3941 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3942 /* Generate the loop body. */
3943 gfc_start_scalarized_body (&loop
, &body
);
3945 /* If we have a mask, only check this element if the mask is set. */
3948 gfc_init_se (&maskse
, NULL
);
3949 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3951 gfc_conv_expr_val (&maskse
, maskexpr
);
3952 gfc_add_block_to_block (&body
, &maskse
.pre
);
3954 gfc_start_block (&block
);
3957 gfc_init_block (&block
);
3959 /* Compare with the current limit. */
3960 gfc_init_se (&arrayse
, NULL
);
3961 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3962 arrayse
.ss
= arrayss
;
3963 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3964 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3966 /* We do the following if this is a more extreme value. */
3967 gfc_start_block (&ifblock
);
3969 /* Assign the value to the limit... */
3970 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3972 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3974 stmtblock_t ifblock2
;
3977 gfc_start_block (&ifblock2
);
3978 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3979 loop
.loopvar
[0], offset
);
3980 gfc_add_modify (&ifblock2
, pos
, tmp
);
3981 ifbody2
= gfc_finish_block (&ifblock2
);
3982 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3983 gfc_index_zero_node
);
3984 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3985 build_empty_stmt (input_location
));
3986 gfc_add_expr_to_block (&block
, tmp
);
3989 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3990 loop
.loopvar
[0], offset
);
3991 gfc_add_modify (&ifblock
, pos
, tmp
);
3994 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3996 ifbody
= gfc_finish_block (&ifblock
);
3998 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
4001 cond
= fold_build2_loc (input_location
,
4002 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4003 boolean_type_node
, arrayse
.expr
, limit
);
4005 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4006 arrayse
.expr
, limit
);
4008 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
4009 build_empty_stmt (input_location
));
4011 gfc_add_expr_to_block (&block
, ifbody
);
4015 /* We enclose the above in if (mask) {...}. */
4016 tmp
= gfc_finish_block (&block
);
4018 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4019 build_empty_stmt (input_location
));
4022 tmp
= gfc_finish_block (&block
);
4023 gfc_add_expr_to_block (&body
, tmp
);
4027 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4029 if (HONOR_NANS (DECL_MODE (limit
)))
4031 if (nonempty
!= NULL
)
4033 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
4034 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
4035 build_empty_stmt (input_location
));
4036 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
4040 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
4041 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
4043 /* If we have a mask, only check this element if the mask is set. */
4046 gfc_init_se (&maskse
, NULL
);
4047 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4049 gfc_conv_expr_val (&maskse
, maskexpr
);
4050 gfc_add_block_to_block (&body
, &maskse
.pre
);
4052 gfc_start_block (&block
);
4055 gfc_init_block (&block
);
4057 /* Compare with the current limit. */
4058 gfc_init_se (&arrayse
, NULL
);
4059 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4060 arrayse
.ss
= arrayss
;
4061 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4062 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4064 /* We do the following if this is a more extreme value. */
4065 gfc_start_block (&ifblock
);
4067 /* Assign the value to the limit... */
4068 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4070 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4071 loop
.loopvar
[0], offset
);
4072 gfc_add_modify (&ifblock
, pos
, tmp
);
4074 ifbody
= gfc_finish_block (&ifblock
);
4076 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4077 arrayse
.expr
, limit
);
4079 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4080 build_empty_stmt (input_location
));
4081 gfc_add_expr_to_block (&block
, tmp
);
4085 /* We enclose the above in if (mask) {...}. */
4086 tmp
= gfc_finish_block (&block
);
4088 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4089 build_empty_stmt (input_location
));
4092 tmp
= gfc_finish_block (&block
);
4093 gfc_add_expr_to_block (&body
, tmp
);
4094 /* Avoid initializing loopvar[0] again, it should be left where
4095 it finished by the first loop. */
4096 loop
.from
[0] = loop
.loopvar
[0];
4099 gfc_trans_scalarizing_loops (&loop
, &body
);
4102 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4104 /* For a scalar mask, enclose the loop in an if statement. */
4105 if (maskexpr
&& maskss
== NULL
)
4107 gfc_init_se (&maskse
, NULL
);
4108 gfc_conv_expr_val (&maskse
, maskexpr
);
4109 gfc_init_block (&block
);
4110 gfc_add_block_to_block (&block
, &loop
.pre
);
4111 gfc_add_block_to_block (&block
, &loop
.post
);
4112 tmp
= gfc_finish_block (&block
);
4114 /* For the else part of the scalar mask, just initialize
4115 the pos variable the same way as above. */
4117 gfc_init_block (&elseblock
);
4118 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4119 elsetmp
= gfc_finish_block (&elseblock
);
4121 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4122 gfc_add_expr_to_block (&block
, tmp
);
4123 gfc_add_block_to_block (&se
->pre
, &block
);
4127 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4128 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4130 gfc_cleanup_loop (&loop
);
4132 se
->expr
= convert (type
, pos
);
4135 /* Emit code for minval or maxval intrinsic. There are many different cases
4136 we need to handle. For performance reasons we sometimes create two
4137 loops instead of one, where the second one is much simpler.
4138 Examples for minval intrinsic:
4139 1) Result is an array, a call is generated
4140 2) Array mask is used and NaNs need to be supported, rank 1:
4145 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4148 limit = nonempty ? NaN : huge (limit);
4150 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4151 3) NaNs need to be supported, but it is known at compile time or cheaply
4152 at runtime whether array is nonempty or not, rank 1:
4155 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4156 limit = (from <= to) ? NaN : huge (limit);
4158 while (S <= to) { limit = min (a[S], limit); S++; }
4159 4) Array mask is used and NaNs need to be supported, rank > 1:
4168 if (fast) limit = min (a[S1][S2], limit);
4171 if (a[S1][S2] <= limit) {
4182 limit = nonempty ? NaN : huge (limit);
4183 5) NaNs need to be supported, but it is known at compile time or cheaply
4184 at runtime whether array is nonempty or not, rank > 1:
4191 if (fast) limit = min (a[S1][S2], limit);
4193 if (a[S1][S2] <= limit) {
4203 limit = (nonempty_array) ? NaN : huge (limit);
4204 6) NaNs aren't supported, but infinities are. Array mask is used:
4209 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4212 limit = nonempty ? limit : huge (limit);
4213 7) Same without array mask:
4216 while (S <= to) { limit = min (a[S], limit); S++; }
4217 limit = (from <= to) ? limit : huge (limit);
4218 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4219 limit = huge (limit);
4221 while (S <= to) { limit = min (a[S], limit); S++); }
4223 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4224 with array mask instead).
4225 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4226 setting limit = huge (limit); in the else branch. */
4229 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4239 tree huge_cst
= NULL
, nan_cst
= NULL
;
4241 stmtblock_t block
, block2
;
4243 gfc_actual_arglist
*actual
;
4248 gfc_expr
*arrayexpr
;
4254 gfc_conv_intrinsic_funcall (se
, expr
);
4258 type
= gfc_typenode_for_spec (&expr
->ts
);
4259 /* Initialize the result. */
4260 limit
= gfc_create_var (type
, "limit");
4261 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
4262 switch (expr
->ts
.type
)
4265 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
4267 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4269 REAL_VALUE_TYPE real
;
4271 tmp
= build_real (type
, real
);
4275 if (HONOR_NANS (DECL_MODE (limit
)))
4276 nan_cst
= gfc_build_nan (type
, "");
4280 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
4287 /* We start with the most negative possible value for MAXVAL, and the most
4288 positive possible value for MINVAL. The most negative possible value is
4289 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4290 possible value is HUGE in both cases. */
4293 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4295 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
4296 TREE_TYPE (huge_cst
), huge_cst
);
4299 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
4300 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
4301 tmp
, build_int_cst (type
, 1));
4303 gfc_add_modify (&se
->pre
, limit
, tmp
);
4305 /* Walk the arguments. */
4306 actual
= expr
->value
.function
.actual
;
4307 arrayexpr
= actual
->expr
;
4308 arrayss
= gfc_walk_expr (arrayexpr
);
4309 gcc_assert (arrayss
!= gfc_ss_terminator
);
4311 actual
= actual
->next
->next
;
4312 gcc_assert (actual
);
4313 maskexpr
= actual
->expr
;
4315 if (maskexpr
&& maskexpr
->rank
!= 0)
4317 maskss
= gfc_walk_expr (maskexpr
);
4318 gcc_assert (maskss
!= gfc_ss_terminator
);
4323 if (gfc_array_size (arrayexpr
, &asize
))
4325 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4327 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4328 boolean_type_node
, nonempty
,
4329 gfc_index_zero_node
);
4334 /* Initialize the scalarizer. */
4335 gfc_init_loopinfo (&loop
);
4336 gfc_add_ss_to_loop (&loop
, arrayss
);
4338 gfc_add_ss_to_loop (&loop
, maskss
);
4340 /* Initialize the loop. */
4341 gfc_conv_ss_startstride (&loop
);
4343 /* The code generated can have more than one loop in sequence (see the
4344 comment at the function header). This doesn't work well with the
4345 scalarizer, which changes arrays' offset when the scalarization loops
4346 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
4347 are currently inlined in the scalar case only. As there is no dependency
4348 to care about in that case, there is no temporary, so that we can use the
4349 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
4350 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
4351 gfc_trans_scalarized_loop_boundary even later to restore offset.
4352 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
4353 should eventually go away. We could either create two loops properly,
4354 or find another way to save/restore the array offsets between the two
4355 loops (without conflicting with temporary management), or use a single
4356 loop minmaxval implementation. See PR 31067. */
4357 loop
.temp_dim
= loop
.dimen
;
4358 gfc_conv_loop_setup (&loop
, &expr
->where
);
4360 if (nonempty
== NULL
&& maskss
== NULL
4361 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
4362 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4363 loop
.from
[0], loop
.to
[0]);
4364 nonempty_var
= NULL
;
4365 if (nonempty
== NULL
4366 && (HONOR_INFINITIES (DECL_MODE (limit
))
4367 || HONOR_NANS (DECL_MODE (limit
))))
4369 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
4370 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
4371 nonempty
= nonempty_var
;
4375 if (HONOR_NANS (DECL_MODE (limit
)))
4377 if (loop
.dimen
== 1)
4379 lab
= gfc_build_label_decl (NULL_TREE
);
4380 TREE_USED (lab
) = 1;
4384 fast
= gfc_create_var (boolean_type_node
, "fast");
4385 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
4389 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
4391 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
4392 /* Generate the loop body. */
4393 gfc_start_scalarized_body (&loop
, &body
);
4395 /* If we have a mask, only add this element if the mask is set. */
4398 gfc_init_se (&maskse
, NULL
);
4399 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4401 gfc_conv_expr_val (&maskse
, maskexpr
);
4402 gfc_add_block_to_block (&body
, &maskse
.pre
);
4404 gfc_start_block (&block
);
4407 gfc_init_block (&block
);
4409 /* Compare with the current limit. */
4410 gfc_init_se (&arrayse
, NULL
);
4411 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4412 arrayse
.ss
= arrayss
;
4413 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4414 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4416 gfc_init_block (&block2
);
4419 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
4421 if (HONOR_NANS (DECL_MODE (limit
)))
4423 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4424 boolean_type_node
, arrayse
.expr
, limit
);
4426 ifbody
= build1_v (GOTO_EXPR
, lab
);
4429 stmtblock_t ifblock
;
4431 gfc_init_block (&ifblock
);
4432 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4433 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
4434 ifbody
= gfc_finish_block (&ifblock
);
4436 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4437 build_empty_stmt (input_location
));
4438 gfc_add_expr_to_block (&block2
, tmp
);
4442 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4444 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4446 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4447 arrayse
.expr
, limit
);
4448 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4449 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4450 build_empty_stmt (input_location
));
4451 gfc_add_expr_to_block (&block2
, tmp
);
4455 tmp
= fold_build2_loc (input_location
,
4456 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4457 type
, arrayse
.expr
, limit
);
4458 gfc_add_modify (&block2
, limit
, tmp
);
4464 tree elsebody
= gfc_finish_block (&block2
);
4466 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4468 if (HONOR_NANS (DECL_MODE (limit
))
4469 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4471 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4472 arrayse
.expr
, limit
);
4473 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4474 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
4475 build_empty_stmt (input_location
));
4479 tmp
= fold_build2_loc (input_location
,
4480 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4481 type
, arrayse
.expr
, limit
);
4482 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4484 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
4485 gfc_add_expr_to_block (&block
, tmp
);
4488 gfc_add_block_to_block (&block
, &block2
);
4490 gfc_add_block_to_block (&block
, &arrayse
.post
);
4492 tmp
= gfc_finish_block (&block
);
4494 /* We enclose the above in if (mask) {...}. */
4495 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4496 build_empty_stmt (input_location
));
4497 gfc_add_expr_to_block (&body
, tmp
);
4501 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4503 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4505 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
4506 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
4508 /* If we have a mask, only add this element if the mask is set. */
4511 gfc_init_se (&maskse
, NULL
);
4512 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4514 gfc_conv_expr_val (&maskse
, maskexpr
);
4515 gfc_add_block_to_block (&body
, &maskse
.pre
);
4517 gfc_start_block (&block
);
4520 gfc_init_block (&block
);
4522 /* Compare with the current limit. */
4523 gfc_init_se (&arrayse
, NULL
);
4524 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4525 arrayse
.ss
= arrayss
;
4526 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4527 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4529 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4531 if (HONOR_NANS (DECL_MODE (limit
))
4532 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4534 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4535 arrayse
.expr
, limit
);
4536 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4537 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4538 build_empty_stmt (input_location
));
4539 gfc_add_expr_to_block (&block
, tmp
);
4543 tmp
= fold_build2_loc (input_location
,
4544 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4545 type
, arrayse
.expr
, limit
);
4546 gfc_add_modify (&block
, limit
, tmp
);
4549 gfc_add_block_to_block (&block
, &arrayse
.post
);
4551 tmp
= gfc_finish_block (&block
);
4553 /* We enclose the above in if (mask) {...}. */
4554 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4555 build_empty_stmt (input_location
));
4556 gfc_add_expr_to_block (&body
, tmp
);
4557 /* Avoid initializing loopvar[0] again, it should be left where
4558 it finished by the first loop. */
4559 loop
.from
[0] = loop
.loopvar
[0];
4561 gfc_trans_scalarizing_loops (&loop
, &body
);
4565 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4567 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4568 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
4570 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4572 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
4574 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
4576 gfc_add_modify (&loop
.pre
, limit
, tmp
);
4579 /* For a scalar mask, enclose the loop in an if statement. */
4580 if (maskexpr
&& maskss
== NULL
)
4584 gfc_init_se (&maskse
, NULL
);
4585 gfc_conv_expr_val (&maskse
, maskexpr
);
4586 gfc_init_block (&block
);
4587 gfc_add_block_to_block (&block
, &loop
.pre
);
4588 gfc_add_block_to_block (&block
, &loop
.post
);
4589 tmp
= gfc_finish_block (&block
);
4591 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4592 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
4594 else_stmt
= build_empty_stmt (input_location
);
4595 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
4596 gfc_add_expr_to_block (&block
, tmp
);
4597 gfc_add_block_to_block (&se
->pre
, &block
);
4601 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4602 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4605 gfc_cleanup_loop (&loop
);
4610 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
4612 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
4618 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4619 type
= TREE_TYPE (args
[0]);
4621 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4622 build_int_cst (type
, 1), args
[1]);
4623 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
4624 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
4625 build_int_cst (type
, 0));
4626 type
= gfc_typenode_for_spec (&expr
->ts
);
4627 se
->expr
= convert (type
, tmp
);
4631 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
4633 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4637 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4639 /* Convert both arguments to the unsigned type of the same size. */
4640 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
4641 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
4643 /* If they have unequal type size, convert to the larger one. */
4644 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
4645 > TYPE_PRECISION (TREE_TYPE (args
[1])))
4646 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
4647 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
4648 > TYPE_PRECISION (TREE_TYPE (args
[0])))
4649 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
4651 /* Now, we compare them. */
4652 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4657 /* Generate code to perform the specified operation. */
4659 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4663 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4664 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
4670 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
4674 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4675 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4676 TREE_TYPE (arg
), arg
);
4679 /* Set or clear a single bit. */
4681 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
4688 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4689 type
= TREE_TYPE (args
[0]);
4691 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4692 build_int_cst (type
, 1), args
[1]);
4698 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
4700 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
4703 /* Extract a sequence of bits.
4704 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
4706 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
4713 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4714 type
= TREE_TYPE (args
[0]);
4716 mask
= build_int_cst (type
, -1);
4717 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
4718 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
4720 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
4722 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4726 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4729 tree args
[2], type
, num_bits
, cond
;
4731 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4733 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4734 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4735 type
= TREE_TYPE (args
[0]);
4738 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4740 gcc_assert (right_shift
);
4742 se
->expr
= fold_build2_loc (input_location
,
4743 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4744 TREE_TYPE (args
[0]), args
[0], args
[1]);
4747 se
->expr
= fold_convert (type
, se
->expr
);
4749 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4750 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4752 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4753 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4756 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4757 build_int_cst (type
, 0), se
->expr
);
4760 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4762 : ((shift >= 0) ? i << shift : i >> -shift)
4763 where all shifts are logical shifts. */
4765 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4777 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4779 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4780 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4782 type
= TREE_TYPE (args
[0]);
4783 utype
= unsigned_type_for (type
);
4785 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4788 /* Left shift if positive. */
4789 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4791 /* Right shift if negative.
4792 We convert to an unsigned type because we want a logical shift.
4793 The standard doesn't define the case of shifting negative
4794 numbers, and we try to be compatible with other compilers, most
4795 notably g77, here. */
4796 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4797 utype
, convert (utype
, args
[0]), width
));
4799 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4800 build_int_cst (TREE_TYPE (args
[1]), 0));
4801 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4803 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4804 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4806 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4807 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4809 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4810 build_int_cst (type
, 0), tmp
);
4814 /* Circular shift. AKA rotate or barrel shift. */
4817 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4825 unsigned int num_args
;
4827 num_args
= gfc_intrinsic_argument_list_length (expr
);
4828 args
= XALLOCAVEC (tree
, num_args
);
4830 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4834 /* Use a library function for the 3 parameter version. */
4835 tree int4type
= gfc_get_int_type (4);
4837 type
= TREE_TYPE (args
[0]);
4838 /* We convert the first argument to at least 4 bytes, and
4839 convert back afterwards. This removes the need for library
4840 functions for all argument sizes, and function will be
4841 aligned to at least 32 bits, so there's no loss. */
4842 if (expr
->ts
.kind
< 4)
4843 args
[0] = convert (int4type
, args
[0]);
4845 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4846 need loads of library functions. They cannot have values >
4847 BIT_SIZE (I) so the conversion is safe. */
4848 args
[1] = convert (int4type
, args
[1]);
4849 args
[2] = convert (int4type
, args
[2]);
4851 switch (expr
->ts
.kind
)
4856 tmp
= gfor_fndecl_math_ishftc4
;
4859 tmp
= gfor_fndecl_math_ishftc8
;
4862 tmp
= gfor_fndecl_math_ishftc16
;
4867 se
->expr
= build_call_expr_loc (input_location
,
4868 tmp
, 3, args
[0], args
[1], args
[2]);
4869 /* Convert the result back to the original type, if we extended
4870 the first argument's width above. */
4871 if (expr
->ts
.kind
< 4)
4872 se
->expr
= convert (type
, se
->expr
);
4876 type
= TREE_TYPE (args
[0]);
4878 /* Evaluate arguments only once. */
4879 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4880 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4882 /* Rotate left if positive. */
4883 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4885 /* Rotate right if negative. */
4886 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4888 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4890 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4891 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4893 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4895 /* Do nothing if shift == 0. */
4896 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4898 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4903 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4904 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4906 The conditional expression is necessary because the result of LEADZ(0)
4907 is defined, but the result of __builtin_clz(0) is undefined for most
4910 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4911 difference in bit size between the argument of LEADZ and the C int. */
4914 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4926 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4927 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4929 /* Which variant of __builtin_clz* should we call? */
4930 if (argsize
<= INT_TYPE_SIZE
)
4932 arg_type
= unsigned_type_node
;
4933 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4935 else if (argsize
<= LONG_TYPE_SIZE
)
4937 arg_type
= long_unsigned_type_node
;
4938 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4940 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4942 arg_type
= long_long_unsigned_type_node
;
4943 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4947 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4948 arg_type
= gfc_build_uint_type (argsize
);
4952 /* Convert the actual argument twice: first, to the unsigned type of the
4953 same size; then, to the proper argument type for the built-in
4954 function. But the return type is of the default INTEGER kind. */
4955 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4956 arg
= fold_convert (arg_type
, arg
);
4957 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4958 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4960 /* Compute LEADZ for the case i .ne. 0. */
4963 s
= TYPE_PRECISION (arg_type
) - argsize
;
4964 tmp
= fold_convert (result_type
,
4965 build_call_expr_loc (input_location
, func
,
4967 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4968 tmp
, build_int_cst (result_type
, s
));
4972 /* We end up here if the argument type is larger than 'long long'.
4973 We generate this code:
4975 if (x & (ULL_MAX << ULL_SIZE) != 0)
4976 return clzll ((unsigned long long) (x >> ULLSIZE));
4978 return ULL_SIZE + clzll ((unsigned long long) x);
4979 where ULL_MAX is the largest value that a ULL_MAX can hold
4980 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4981 is the bit-size of the long long type (64 in this example). */
4982 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4984 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4985 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4986 long_long_unsigned_type_node
,
4987 build_int_cst (long_long_unsigned_type_node
,
4990 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4991 fold_convert (arg_type
, ullmax
), ullsize
);
4992 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4994 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4995 cond
, build_int_cst (arg_type
, 0));
4997 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4999 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5000 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5001 tmp1
= fold_convert (result_type
,
5002 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5004 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5005 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
5006 tmp2
= fold_convert (result_type
,
5007 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5008 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5011 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5015 /* Build BIT_SIZE. */
5016 bit_size
= build_int_cst (result_type
, argsize
);
5018 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5019 arg
, build_int_cst (arg_type
, 0));
5020 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5025 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5027 The conditional expression is necessary because the result of TRAILZ(0)
5028 is defined, but the result of __builtin_ctz(0) is undefined for most
5032 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
5043 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5044 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5046 /* Which variant of __builtin_ctz* should we call? */
5047 if (argsize
<= INT_TYPE_SIZE
)
5049 arg_type
= unsigned_type_node
;
5050 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5052 else if (argsize
<= LONG_TYPE_SIZE
)
5054 arg_type
= long_unsigned_type_node
;
5055 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5057 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5059 arg_type
= long_long_unsigned_type_node
;
5060 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5064 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5065 arg_type
= gfc_build_uint_type (argsize
);
5069 /* Convert the actual argument twice: first, to the unsigned type of the
5070 same size; then, to the proper argument type for the built-in
5071 function. But the return type is of the default INTEGER kind. */
5072 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5073 arg
= fold_convert (arg_type
, arg
);
5074 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5075 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5077 /* Compute TRAILZ for the case i .ne. 0. */
5079 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5083 /* We end up here if the argument type is larger than 'long long'.
5084 We generate this code:
5086 if ((x & ULL_MAX) == 0)
5087 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5089 return ctzll ((unsigned long long) x);
5091 where ULL_MAX is the largest value that a ULL_MAX can hold
5092 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5093 is the bit-size of the long long type (64 in this example). */
5094 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5096 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5097 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5098 long_long_unsigned_type_node
,
5099 build_int_cst (long_long_unsigned_type_node
, 0));
5101 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5102 fold_convert (arg_type
, ullmax
));
5103 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
5104 build_int_cst (arg_type
, 0));
5106 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5108 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5109 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5110 tmp1
= fold_convert (result_type
,
5111 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5112 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5115 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5116 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5117 tmp2
= fold_convert (result_type
,
5118 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5120 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5124 /* Build BIT_SIZE. */
5125 bit_size
= build_int_cst (result_type
, argsize
);
5127 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5128 arg
, build_int_cst (arg_type
, 0));
5129 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5133 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5134 for types larger than "long long", we call the long long built-in for
5135 the lower and higher bits and combine the result. */
5138 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5146 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5147 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5148 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5150 /* Which variant of the builtin should we call? */
5151 if (argsize
<= INT_TYPE_SIZE
)
5153 arg_type
= unsigned_type_node
;
5154 func
= builtin_decl_explicit (parity
5156 : BUILT_IN_POPCOUNT
);
5158 else if (argsize
<= LONG_TYPE_SIZE
)
5160 arg_type
= long_unsigned_type_node
;
5161 func
= builtin_decl_explicit (parity
5163 : BUILT_IN_POPCOUNTL
);
5165 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5167 arg_type
= long_long_unsigned_type_node
;
5168 func
= builtin_decl_explicit (parity
5170 : BUILT_IN_POPCOUNTLL
);
5174 /* Our argument type is larger than 'long long', which mean none
5175 of the POPCOUNT builtins covers it. We thus call the 'long long'
5176 variant multiple times, and add the results. */
5177 tree utype
, arg2
, call1
, call2
;
5179 /* For now, we only cover the case where argsize is twice as large
5181 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5183 func
= builtin_decl_explicit (parity
5185 : BUILT_IN_POPCOUNTLL
);
5187 /* Convert it to an integer, and store into a variable. */
5188 utype
= gfc_build_uint_type (argsize
);
5189 arg
= fold_convert (utype
, arg
);
5190 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5192 /* Call the builtin twice. */
5193 call1
= build_call_expr_loc (input_location
, func
, 1,
5194 fold_convert (long_long_unsigned_type_node
,
5197 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5198 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5199 call2
= build_call_expr_loc (input_location
, func
, 1,
5200 fold_convert (long_long_unsigned_type_node
,
5203 /* Combine the results. */
5205 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5208 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5214 /* Convert the actual argument twice: first, to the unsigned type of the
5215 same size; then, to the proper argument type for the built-in
5217 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5218 arg
= fold_convert (arg_type
, arg
);
5220 se
->expr
= fold_convert (result_type
,
5221 build_call_expr_loc (input_location
, func
, 1, arg
));
5225 /* Process an intrinsic with unspecified argument-types that has an optional
5226 argument (which could be of type character), e.g. EOSHIFT. For those, we
5227 need to append the string length of the optional argument if it is not
5228 present and the type is really character.
5229 primary specifies the position (starting at 1) of the non-optional argument
5230 specifying the type and optional gives the position of the optional
5231 argument in the arglist. */
5234 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5235 unsigned primary
, unsigned optional
)
5237 gfc_actual_arglist
* prim_arg
;
5238 gfc_actual_arglist
* opt_arg
;
5240 gfc_actual_arglist
* arg
;
5242 vec
<tree
, va_gc
> *append_args
;
5244 /* Find the two arguments given as position. */
5248 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5252 if (cur_pos
== primary
)
5254 if (cur_pos
== optional
)
5257 if (cur_pos
>= primary
&& cur_pos
>= optional
)
5260 gcc_assert (prim_arg
);
5261 gcc_assert (prim_arg
->expr
);
5262 gcc_assert (opt_arg
);
5264 /* If we do have type CHARACTER and the optional argument is really absent,
5265 append a dummy 0 as string length. */
5267 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
5271 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
5272 vec_alloc (append_args
, 1);
5273 append_args
->quick_push (dummy
);
5276 /* Build the call itself. */
5277 gcc_assert (!se
->ignore_optional
);
5278 sym
= gfc_get_symbol_for_expr (expr
, false);
5279 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5281 gfc_free_symbol (sym
);
5285 /* The length of a character string. */
5287 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
5296 gcc_assert (!se
->ss
);
5298 arg
= expr
->value
.function
.actual
->expr
;
5300 type
= gfc_typenode_for_spec (&expr
->ts
);
5301 switch (arg
->expr_type
)
5304 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
5308 /* Obtain the string length from the function used by
5309 trans-array.c(gfc_trans_array_constructor). */
5311 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
5315 if (arg
->ref
== NULL
5316 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
5318 /* This doesn't catch all cases.
5319 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
5320 and the surrounding thread. */
5321 sym
= arg
->symtree
->n
.sym
;
5322 decl
= gfc_get_symbol_decl (sym
);
5323 if (decl
== current_function_decl
&& sym
->attr
.function
5324 && (sym
->result
== sym
))
5325 decl
= gfc_get_fake_result_decl (sym
, 0);
5327 len
= sym
->ts
.u
.cl
->backend_decl
;
5332 /* Otherwise fall through. */
5335 /* Anybody stupid enough to do this deserves inefficient code. */
5336 gfc_init_se (&argse
, se
);
5338 gfc_conv_expr (&argse
, arg
);
5340 gfc_conv_expr_descriptor (&argse
, arg
);
5341 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5342 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5343 len
= argse
.string_length
;
5346 se
->expr
= convert (type
, len
);
5349 /* The length of a character string not including trailing blanks. */
5351 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
5353 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5354 tree args
[2], type
, fndecl
;
5356 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5357 type
= gfc_typenode_for_spec (&expr
->ts
);
5360 fndecl
= gfor_fndecl_string_len_trim
;
5362 fndecl
= gfor_fndecl_string_len_trim_char4
;
5366 se
->expr
= build_call_expr_loc (input_location
,
5367 fndecl
, 2, args
[0], args
[1]);
5368 se
->expr
= convert (type
, se
->expr
);
5372 /* Returns the starting position of a substring within a string. */
5375 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
5378 tree logical4_type_node
= gfc_get_logical_type (4);
5382 unsigned int num_args
;
5384 args
= XALLOCAVEC (tree
, 5);
5386 /* Get number of arguments; characters count double due to the
5387 string length argument. Kind= is not passed to the library
5388 and thus ignored. */
5389 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
5394 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5395 type
= gfc_typenode_for_spec (&expr
->ts
);
5398 args
[4] = build_int_cst (logical4_type_node
, 0);
5400 args
[4] = convert (logical4_type_node
, args
[4]);
5402 fndecl
= build_addr (function
);
5403 se
->expr
= build_call_array_loc (input_location
,
5404 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
5406 se
->expr
= convert (type
, se
->expr
);
5410 /* The ascii value for a single character. */
5412 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
5414 tree args
[3], type
, pchartype
;
5417 nargs
= gfc_intrinsic_argument_list_length (expr
);
5418 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
5419 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
5420 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
5421 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
5422 type
= gfc_typenode_for_spec (&expr
->ts
);
5424 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5426 se
->expr
= convert (type
, se
->expr
);
5430 /* Intrinsic ISNAN calls __builtin_isnan. */
5433 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
5437 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5438 se
->expr
= build_call_expr_loc (input_location
,
5439 builtin_decl_explicit (BUILT_IN_ISNAN
),
5441 STRIP_TYPE_NOPS (se
->expr
);
5442 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5446 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
5447 their argument against a constant integer value. */
5450 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
5454 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5455 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
5456 gfc_typenode_for_spec (&expr
->ts
),
5457 arg
, build_int_cst (TREE_TYPE (arg
), value
));
5462 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
5465 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
5473 unsigned int num_args
;
5475 num_args
= gfc_intrinsic_argument_list_length (expr
);
5476 args
= XALLOCAVEC (tree
, num_args
);
5478 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5479 if (expr
->ts
.type
!= BT_CHARACTER
)
5487 /* We do the same as in the non-character case, but the argument
5488 list is different because of the string length arguments. We
5489 also have to set the string length for the result. */
5496 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
5498 se
->string_length
= len
;
5500 type
= TREE_TYPE (tsource
);
5501 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
5502 fold_convert (type
, fsource
));
5506 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
5509 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
5511 tree args
[3], mask
, type
;
5513 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5514 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
5516 type
= TREE_TYPE (args
[0]);
5517 gcc_assert (TREE_TYPE (args
[1]) == type
);
5518 gcc_assert (TREE_TYPE (mask
) == type
);
5520 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
5521 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
5522 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5524 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
5529 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
5530 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
5533 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
5535 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
5538 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5539 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5541 type
= gfc_get_int_type (expr
->ts
.kind
);
5542 utype
= unsigned_type_for (type
);
5544 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
5545 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
5547 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
5548 build_int_cst (utype
, 0));
5552 /* Left-justified mask. */
5553 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
5555 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5556 fold_convert (utype
, res
));
5558 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
5559 smaller than type width. */
5560 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5561 build_int_cst (TREE_TYPE (arg
), 0));
5562 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
5563 build_int_cst (utype
, 0), res
);
5567 /* Right-justified mask. */
5568 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5569 fold_convert (utype
, arg
));
5570 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
5572 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
5573 strictly smaller than type width. */
5574 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5576 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
5577 cond
, allones
, res
);
5580 se
->expr
= fold_convert (type
, res
);
5584 /* FRACTION (s) is translated into:
5585 isfinite (s) ? frexp (s, &dummy_int) : NaN */
5587 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
5589 tree arg
, type
, tmp
, res
, frexp
, cond
;
5591 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5593 type
= gfc_typenode_for_spec (&expr
->ts
);
5594 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5595 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5597 cond
= build_call_expr_loc (input_location
,
5598 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5601 tmp
= gfc_create_var (integer_type_node
, NULL
);
5602 res
= build_call_expr_loc (input_location
, frexp
, 2,
5603 fold_convert (type
, arg
),
5604 gfc_build_addr_expr (NULL_TREE
, tmp
));
5605 res
= fold_convert (type
, res
);
5607 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
5608 cond
, res
, gfc_build_nan (type
, ""));
5612 /* NEAREST (s, dir) is translated into
5613 tmp = copysign (HUGE_VAL, dir);
5614 return nextafter (s, tmp);
5617 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
5619 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
5621 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
5622 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
5624 type
= gfc_typenode_for_spec (&expr
->ts
);
5625 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5627 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
5628 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
5629 fold_convert (type
, args
[1]));
5630 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
5631 fold_convert (type
, args
[0]), tmp
);
5632 se
->expr
= fold_convert (type
, se
->expr
);
5636 /* SPACING (s) is translated into
5646 e = MAX_EXPR (e, emin);
5647 res = scalbn (1., e);
5651 where prec is the precision of s, gfc_real_kinds[k].digits,
5652 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
5653 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
5656 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
5658 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
5659 tree cond
, nan
, tmp
, frexp
, scalbn
;
5663 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5664 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
5665 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
5666 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
5668 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5669 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5671 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5672 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5674 type
= gfc_typenode_for_spec (&expr
->ts
);
5675 e
= gfc_create_var (integer_type_node
, NULL
);
5676 res
= gfc_create_var (type
, NULL
);
5679 /* Build the block for s /= 0. */
5680 gfc_start_block (&block
);
5681 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5682 gfc_build_addr_expr (NULL_TREE
, e
));
5683 gfc_add_expr_to_block (&block
, tmp
);
5685 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
5687 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
5688 integer_type_node
, tmp
, emin
));
5690 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
5691 build_real_from_int_cst (type
, integer_one_node
), e
);
5692 gfc_add_modify (&block
, res
, tmp
);
5694 /* Finish by building the IF statement for value zero. */
5695 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5696 build_real_from_int_cst (type
, integer_zero_node
));
5697 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
5698 gfc_finish_block (&block
));
5700 /* And deal with infinities and NaNs. */
5701 cond
= build_call_expr_loc (input_location
,
5702 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5704 nan
= gfc_build_nan (type
, "");
5705 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
5707 gfc_add_expr_to_block (&se
->pre
, tmp
);
5712 /* RRSPACING (s) is translated into
5721 x = scalbn (x, precision - e);
5728 where precision is gfc_real_kinds[k].digits. */
5731 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
5733 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
5737 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5738 prec
= gfc_real_kinds
[k
].digits
;
5740 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5741 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5742 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
5744 type
= gfc_typenode_for_spec (&expr
->ts
);
5745 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5746 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5748 e
= gfc_create_var (integer_type_node
, NULL
);
5749 x
= gfc_create_var (type
, NULL
);
5750 gfc_add_modify (&se
->pre
, x
,
5751 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5754 gfc_start_block (&block
);
5755 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5756 gfc_build_addr_expr (NULL_TREE
, e
));
5757 gfc_add_expr_to_block (&block
, tmp
);
5759 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5760 build_int_cst (integer_type_node
, prec
), e
);
5761 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5762 gfc_add_modify (&block
, x
, tmp
);
5763 stmt
= gfc_finish_block (&block
);
5766 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5767 build_real_from_int_cst (type
, integer_zero_node
));
5768 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5770 /* And deal with infinities and NaNs. */
5771 cond
= build_call_expr_loc (input_location
,
5772 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5774 nan
= gfc_build_nan (type
, "");
5775 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
5777 gfc_add_expr_to_block (&se
->pre
, tmp
);
5778 se
->expr
= fold_convert (type
, x
);
5782 /* SCALE (s, i) is translated into scalbn (s, i). */
5784 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5786 tree args
[2], type
, scalbn
;
5788 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5790 type
= gfc_typenode_for_spec (&expr
->ts
);
5791 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5792 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5793 fold_convert (type
, args
[0]),
5794 fold_convert (integer_type_node
, args
[1]));
5795 se
->expr
= fold_convert (type
, se
->expr
);
5799 /* SET_EXPONENT (s, i) is translated into
5800 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
5802 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5804 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
5806 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5807 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5809 type
= gfc_typenode_for_spec (&expr
->ts
);
5810 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5811 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5813 tmp
= gfc_create_var (integer_type_node
, NULL
);
5814 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5815 fold_convert (type
, args
[0]),
5816 gfc_build_addr_expr (NULL_TREE
, tmp
));
5817 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5818 fold_convert (integer_type_node
, args
[1]));
5819 res
= fold_convert (type
, res
);
5821 /* Call to isfinite */
5822 cond
= build_call_expr_loc (input_location
,
5823 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5825 nan
= gfc_build_nan (type
, "");
5827 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5833 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5835 gfc_actual_arglist
*actual
;
5842 gfc_init_se (&argse
, NULL
);
5843 actual
= expr
->value
.function
.actual
;
5845 if (actual
->expr
->ts
.type
== BT_CLASS
)
5846 gfc_add_class_array_ref (actual
->expr
);
5848 argse
.want_pointer
= 1;
5849 argse
.data_not_needed
= 1;
5850 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5851 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5852 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5853 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5855 /* Build the call to size0. */
5856 fncall0
= build_call_expr_loc (input_location
,
5857 gfor_fndecl_size0
, 1, arg1
);
5859 actual
= actual
->next
;
5863 gfc_init_se (&argse
, NULL
);
5864 gfc_conv_expr_type (&argse
, actual
->expr
,
5865 gfc_array_index_type
);
5866 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5868 /* Unusually, for an intrinsic, size does not exclude
5869 an optional arg2, so we must test for it. */
5870 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5871 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5872 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5875 /* Build the call to size1. */
5876 fncall1
= build_call_expr_loc (input_location
,
5877 gfor_fndecl_size1
, 2,
5880 gfc_init_se (&argse
, NULL
);
5881 argse
.want_pointer
= 1;
5882 argse
.data_not_needed
= 1;
5883 gfc_conv_expr (&argse
, actual
->expr
);
5884 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5885 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5886 argse
.expr
, null_pointer_node
);
5887 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5888 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5889 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5893 se
->expr
= NULL_TREE
;
5894 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5895 gfc_array_index_type
,
5896 argse
.expr
, gfc_index_one_node
);
5899 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5901 argse
.expr
= gfc_index_zero_node
;
5902 se
->expr
= NULL_TREE
;
5907 if (se
->expr
== NULL_TREE
)
5909 tree ubound
, lbound
;
5911 arg1
= build_fold_indirect_ref_loc (input_location
,
5913 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5914 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5915 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5916 gfc_array_index_type
, ubound
, lbound
);
5917 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5918 gfc_array_index_type
,
5919 se
->expr
, gfc_index_one_node
);
5920 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5921 gfc_array_index_type
, se
->expr
,
5922 gfc_index_zero_node
);
5925 type
= gfc_typenode_for_spec (&expr
->ts
);
5926 se
->expr
= convert (type
, se
->expr
);
5930 /* Helper function to compute the size of a character variable,
5931 excluding the terminating null characters. The result has
5932 gfc_array_index_type type. */
5935 size_of_string_in_bytes (int kind
, tree string_length
)
5938 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5940 bytesize
= build_int_cst (gfc_array_index_type
,
5941 gfc_character_kinds
[i
].bit_size
/ 8);
5943 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5945 fold_convert (gfc_array_index_type
, string_length
));
5950 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5961 gfc_init_se (&argse
, NULL
);
5962 arg
= expr
->value
.function
.actual
->expr
;
5964 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
5965 gfc_conv_expr_descriptor (&argse
, arg
);
5967 gfc_conv_expr_reference (&argse
, arg
);
5969 if (arg
->ts
.type
== BT_ASSUMED
)
5971 /* This only works if an array descriptor has been passed; thus, extract
5972 the size from the descriptor. */
5973 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
5974 == TYPE_PRECISION (size_type_node
));
5975 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
5976 tmp
= DECL_LANG_SPECIFIC (tmp
)
5977 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
5978 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
5979 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
5980 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5981 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
5982 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
5983 build_int_cst (TREE_TYPE (tmp
),
5984 GFC_DTYPE_SIZE_SHIFT
));
5985 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
5987 else if (arg
->ts
.type
== BT_CLASS
)
5989 /* Conv_expr_descriptor returns a component_ref to _data component of the
5990 class object. The class object may be a non-pointer object, e.g.
5991 located on the stack, or a memory location pointed to, e.g. a
5992 parameter, i.e., an indirect_ref. */
5994 || (arg
->rank
> 0 && !VAR_P (argse
.expr
)
5995 && ((INDIRECT_REF_P (TREE_OPERAND (argse
.expr
, 0))
5996 && GFC_DECL_CLASS (TREE_OPERAND (
5997 TREE_OPERAND (argse
.expr
, 0), 0)))
5998 || GFC_DECL_CLASS (TREE_OPERAND (argse
.expr
, 0)))))
5999 byte_size
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6000 else if (arg
->rank
> 0)
6001 /* The scalarizer added an additional temp. To get the class' vptr
6002 one has to look at the original backend_decl. */
6003 byte_size
= gfc_class_vtab_size_get (
6004 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6006 byte_size
= gfc_class_vtab_size_get (argse
.expr
);
6010 if (arg
->ts
.type
== BT_CHARACTER
)
6011 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6015 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6018 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6019 byte_size
= fold_convert (gfc_array_index_type
,
6020 size_in_bytes (byte_size
));
6025 se
->expr
= byte_size
;
6028 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
6029 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
6031 if (arg
->rank
== -1)
6033 tree cond
, loop_var
, exit_label
;
6036 tmp
= fold_convert (gfc_array_index_type
,
6037 gfc_conv_descriptor_rank (argse
.expr
));
6038 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
6039 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
6040 exit_label
= gfc_build_label_decl (NULL_TREE
);
6047 source_bytes = source_bytes * array.dim[i].extent;
6051 gfc_start_block (&body
);
6052 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
6054 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6055 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6056 cond
, tmp
, build_empty_stmt (input_location
));
6057 gfc_add_expr_to_block (&body
, tmp
);
6059 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
6060 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
6061 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6062 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6063 gfc_array_index_type
, tmp
, source_bytes
);
6064 gfc_add_modify (&body
, source_bytes
, tmp
);
6066 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6067 gfc_array_index_type
, loop_var
,
6068 gfc_index_one_node
);
6069 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
6071 tmp
= gfc_finish_block (&body
);
6073 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6075 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6077 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6078 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6082 /* Obtain the size of the array in bytes. */
6083 for (n
= 0; n
< arg
->rank
; n
++)
6086 idx
= gfc_rank_cst
[n
];
6087 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6088 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6089 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6090 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6091 gfc_array_index_type
, tmp
, source_bytes
);
6092 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6095 se
->expr
= source_bytes
;
6098 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6103 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6107 tree type
, result_type
, tmp
;
6109 arg
= expr
->value
.function
.actual
->expr
;
6111 gfc_init_se (&argse
, NULL
);
6112 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6116 if (arg
->ts
.type
== BT_CLASS
)
6118 gfc_add_vptr_component (arg
);
6119 gfc_add_size_component (arg
);
6120 gfc_conv_expr (&argse
, arg
);
6121 tmp
= fold_convert (result_type
, argse
.expr
);
6125 gfc_conv_expr_reference (&argse
, arg
);
6126 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6131 argse
.want_pointer
= 0;
6132 gfc_conv_expr_descriptor (&argse
, arg
);
6133 if (arg
->ts
.type
== BT_CLASS
)
6136 tmp
= gfc_class_vtab_size_get (
6137 GFC_DECL_SAVED_DESCRIPTOR (arg
->symtree
->n
.sym
->backend_decl
));
6139 tmp
= gfc_class_vtab_size_get (TREE_OPERAND (argse
.expr
, 0));
6140 tmp
= fold_convert (result_type
, tmp
);
6143 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6146 /* Obtain the argument's word length. */
6147 if (arg
->ts
.type
== BT_CHARACTER
)
6148 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6150 tmp
= size_in_bytes (type
);
6151 tmp
= fold_convert (result_type
, tmp
);
6154 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6155 build_int_cst (result_type
, BITS_PER_UNIT
));
6156 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6160 /* Intrinsic string comparison functions. */
6163 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6167 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6170 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6171 expr
->value
.function
.actual
->expr
->ts
.kind
,
6173 se
->expr
= fold_build2_loc (input_location
, op
,
6174 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6175 build_int_cst (TREE_TYPE (se
->expr
), 0));
6178 /* Generate a call to the adjustl/adjustr library function. */
6180 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6188 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6191 type
= TREE_TYPE (args
[2]);
6192 var
= gfc_conv_string_tmp (se
, type
, len
);
6195 tmp
= build_call_expr_loc (input_location
,
6196 fndecl
, 3, args
[0], args
[1], args
[2]);
6197 gfc_add_expr_to_block (&se
->pre
, tmp
);
6199 se
->string_length
= len
;
6203 /* Generate code for the TRANSFER intrinsic:
6205 DEST = TRANSFER (SOURCE, MOLD)
6207 typeof<DEST> = typeof<MOLD>
6212 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6214 typeof<DEST> = typeof<MOLD>
6216 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6217 sizeof (DEST(0) * SIZE). */
6219 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6235 gfc_actual_arglist
*arg
;
6237 gfc_array_info
*info
;
6241 gfc_expr
*source_expr
, *mold_expr
;
6245 info
= &se
->ss
->info
->data
.array
;
6247 /* Convert SOURCE. The output from this stage is:-
6248 source_bytes = length of the source in bytes
6249 source = pointer to the source data. */
6250 arg
= expr
->value
.function
.actual
;
6251 source_expr
= arg
->expr
;
6253 /* Ensure double transfer through LOGICAL preserves all
6255 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6256 && arg
->expr
->value
.function
.esym
== NULL
6257 && arg
->expr
->value
.function
.isym
!= NULL
6258 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6259 && arg
->expr
->ts
.type
== BT_LOGICAL
6260 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6261 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6263 gfc_init_se (&argse
, NULL
);
6265 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6267 /* Obtain the pointer to source and the length of source in bytes. */
6268 if (arg
->expr
->rank
== 0)
6270 gfc_conv_expr_reference (&argse
, arg
->expr
);
6271 if (arg
->expr
->ts
.type
== BT_CLASS
)
6272 source
= gfc_class_data_get (argse
.expr
);
6274 source
= argse
.expr
;
6276 /* Obtain the source word length. */
6277 switch (arg
->expr
->ts
.type
)
6280 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6281 argse
.string_length
);
6284 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6287 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6289 tmp
= fold_convert (gfc_array_index_type
,
6290 size_in_bytes (source_type
));
6296 argse
.want_pointer
= 0;
6297 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6298 source
= gfc_conv_descriptor_data_get (argse
.expr
);
6299 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6301 /* Repack the source if not simply contiguous. */
6302 if (!gfc_is_simply_contiguous (arg
->expr
, false, true))
6304 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
6306 if (warn_array_temporaries
)
6307 gfc_warning (OPT_Warray_temporaries
,
6308 "Creating array temporary at %L", &expr
->where
);
6310 source
= build_call_expr_loc (input_location
,
6311 gfor_fndecl_in_pack
, 1, tmp
);
6312 source
= gfc_evaluate_now (source
, &argse
.pre
);
6314 /* Free the temporary. */
6315 gfc_start_block (&block
);
6316 tmp
= gfc_call_free (source
);
6317 gfc_add_expr_to_block (&block
, tmp
);
6318 stmt
= gfc_finish_block (&block
);
6320 /* Clean up if it was repacked. */
6321 gfc_init_block (&block
);
6322 tmp
= gfc_conv_array_data (argse
.expr
);
6323 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6325 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
6326 build_empty_stmt (input_location
));
6327 gfc_add_expr_to_block (&block
, tmp
);
6328 gfc_add_block_to_block (&block
, &se
->post
);
6329 gfc_init_block (&se
->post
);
6330 gfc_add_block_to_block (&se
->post
, &block
);
6333 /* Obtain the source word length. */
6334 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
6335 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6336 argse
.string_length
);
6338 tmp
= fold_convert (gfc_array_index_type
,
6339 size_in_bytes (source_type
));
6341 /* Obtain the size of the array in bytes. */
6342 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
6343 for (n
= 0; n
< arg
->expr
->rank
; n
++)
6346 idx
= gfc_rank_cst
[n
];
6347 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6348 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6349 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6350 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6351 gfc_array_index_type
, upper
, lower
);
6352 gfc_add_modify (&argse
.pre
, extent
, tmp
);
6353 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6354 gfc_array_index_type
, extent
,
6355 gfc_index_one_node
);
6356 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6357 gfc_array_index_type
, tmp
, source_bytes
);
6361 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6362 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6363 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6365 /* Now convert MOLD. The outputs are:
6366 mold_type = the TREE type of MOLD
6367 dest_word_len = destination word length in bytes. */
6369 mold_expr
= arg
->expr
;
6371 gfc_init_se (&argse
, NULL
);
6373 scalar_mold
= arg
->expr
->rank
== 0;
6375 if (arg
->expr
->rank
== 0)
6377 gfc_conv_expr_reference (&argse
, arg
->expr
);
6378 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6383 gfc_init_se (&argse
, NULL
);
6384 argse
.want_pointer
= 0;
6385 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6386 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6389 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6390 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6392 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
6394 /* If this TRANSFER is nested in another TRANSFER, use a type
6395 that preserves all bits. */
6396 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
6397 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
6400 /* Obtain the destination word length. */
6401 switch (arg
->expr
->ts
.type
)
6404 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
6405 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
6408 tmp
= gfc_class_vtab_size_get (argse
.expr
);
6411 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
6414 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
6415 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
6417 /* Finally convert SIZE, if it is present. */
6419 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
6423 gfc_init_se (&argse
, NULL
);
6424 gfc_conv_expr_reference (&argse
, arg
->expr
);
6425 tmp
= convert (gfc_array_index_type
,
6426 build_fold_indirect_ref_loc (input_location
,
6428 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6429 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6434 /* Separate array and scalar results. */
6435 if (scalar_mold
&& tmp
== NULL_TREE
)
6436 goto scalar_transfer
;
6438 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6439 if (tmp
!= NULL_TREE
)
6440 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6441 tmp
, dest_word_len
);
6445 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
6446 gfc_add_modify (&se
->pre
, size_words
,
6447 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
6448 gfc_array_index_type
,
6449 size_bytes
, dest_word_len
));
6451 /* Evaluate the bounds of the result. If the loop range exists, we have
6452 to check if it is too large. If so, we modify loop->to be consistent
6453 with min(size, size(source)). Otherwise, size is made consistent with
6454 the loop range, so that the right number of bytes is transferred.*/
6455 n
= se
->loop
->order
[0];
6456 if (se
->loop
->to
[n
] != NULL_TREE
)
6458 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6459 se
->loop
->to
[n
], se
->loop
->from
[n
]);
6460 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6461 tmp
, gfc_index_one_node
);
6462 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6464 gfc_add_modify (&se
->pre
, size_words
, tmp
);
6465 gfc_add_modify (&se
->pre
, size_bytes
,
6466 fold_build2_loc (input_location
, MULT_EXPR
,
6467 gfc_array_index_type
,
6468 size_words
, dest_word_len
));
6469 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6470 size_words
, se
->loop
->from
[n
]);
6471 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6472 upper
, gfc_index_one_node
);
6476 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6477 size_words
, gfc_index_one_node
);
6478 se
->loop
->from
[n
] = gfc_index_zero_node
;
6481 se
->loop
->to
[n
] = upper
;
6483 /* Build a destination descriptor, using the pointer, source, as the
6485 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
6486 NULL_TREE
, false, true, false, &expr
->where
);
6488 /* Cast the pointer to the result. */
6489 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6490 tmp
= fold_convert (pvoid_type_node
, tmp
);
6492 /* Use memcpy to do the transfer. */
6494 = build_call_expr_loc (input_location
,
6495 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
6496 fold_convert (pvoid_type_node
, source
),
6497 fold_convert (size_type_node
,
6498 fold_build2_loc (input_location
,
6500 gfc_array_index_type
,
6503 gfc_add_expr_to_block (&se
->pre
, tmp
);
6505 se
->expr
= info
->descriptor
;
6506 if (expr
->ts
.type
== BT_CHARACTER
)
6507 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6511 /* Deal with scalar results. */
6513 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6514 dest_word_len
, source_bytes
);
6515 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6516 extent
, gfc_index_zero_node
);
6518 if (expr
->ts
.type
== BT_CHARACTER
)
6520 tree direct
, indirect
, free
;
6522 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
6523 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
6526 /* If source is longer than the destination, use a pointer to
6527 the source directly. */
6528 gfc_init_block (&block
);
6529 gfc_add_modify (&block
, tmpdecl
, ptr
);
6530 direct
= gfc_finish_block (&block
);
6532 /* Otherwise, allocate a string with the length of the destination
6533 and copy the source into it. */
6534 gfc_init_block (&block
);
6535 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
6536 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
6537 gfc_add_modify (&block
, tmpdecl
,
6538 fold_convert (TREE_TYPE (ptr
), tmp
));
6539 tmp
= build_call_expr_loc (input_location
,
6540 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6541 fold_convert (pvoid_type_node
, tmpdecl
),
6542 fold_convert (pvoid_type_node
, ptr
),
6543 fold_convert (size_type_node
, extent
));
6544 gfc_add_expr_to_block (&block
, tmp
);
6545 indirect
= gfc_finish_block (&block
);
6547 /* Wrap it up with the condition. */
6548 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
6549 dest_word_len
, source_bytes
);
6550 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
6551 gfc_add_expr_to_block (&se
->pre
, tmp
);
6553 /* Free the temporary string, if necessary. */
6554 free
= gfc_call_free (tmpdecl
);
6555 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6556 dest_word_len
, source_bytes
);
6557 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
6558 gfc_add_expr_to_block (&se
->post
, tmp
);
6561 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6565 tmpdecl
= gfc_create_var (mold_type
, "transfer");
6567 ptr
= convert (build_pointer_type (mold_type
), source
);
6569 /* For CLASS results, allocate the needed memory first. */
6570 if (mold_expr
->ts
.type
== BT_CLASS
)
6573 cdata
= gfc_class_data_get (tmpdecl
);
6574 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
6575 gfc_add_modify (&se
->pre
, cdata
, tmp
);
6578 /* Use memcpy to do the transfer. */
6579 if (mold_expr
->ts
.type
== BT_CLASS
)
6580 tmp
= gfc_class_data_get (tmpdecl
);
6582 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
6584 tmp
= build_call_expr_loc (input_location
,
6585 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6586 fold_convert (pvoid_type_node
, tmp
),
6587 fold_convert (pvoid_type_node
, ptr
),
6588 fold_convert (size_type_node
, extent
));
6589 gfc_add_expr_to_block (&se
->pre
, tmp
);
6591 /* For CLASS results, set the _vptr. */
6592 if (mold_expr
->ts
.type
== BT_CLASS
)
6596 vptr
= gfc_class_vptr_get (tmpdecl
);
6597 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
6599 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
6600 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
6608 /* Generate code for the ALLOCATED intrinsic.
6609 Generate inline code that directly check the address of the argument. */
6612 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
6614 gfc_actual_arglist
*arg1
;
6618 gfc_init_se (&arg1se
, NULL
);
6619 arg1
= expr
->value
.function
.actual
;
6621 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6623 /* Make sure that class array expressions have both a _data
6624 component reference and an array reference.... */
6625 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
6626 gfc_add_class_array_ref (arg1
->expr
);
6627 /* .... whilst scalars only need the _data component. */
6629 gfc_add_data_component (arg1
->expr
);
6632 if (arg1
->expr
->rank
== 0)
6634 /* Allocatable scalar. */
6635 arg1se
.want_pointer
= 1;
6636 gfc_conv_expr (&arg1se
, arg1
->expr
);
6641 /* Allocatable array. */
6642 arg1se
.descriptor_only
= 1;
6643 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6644 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6647 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
6648 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6649 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6653 /* Generate code for the ASSOCIATED intrinsic.
6654 If both POINTER and TARGET are arrays, generate a call to library function
6655 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
6656 In other cases, generate inline code that directly compare the address of
6657 POINTER with the address of TARGET. */
6660 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
6662 gfc_actual_arglist
*arg1
;
6663 gfc_actual_arglist
*arg2
;
6668 tree nonzero_charlen
;
6669 tree nonzero_arraylen
;
6673 gfc_init_se (&arg1se
, NULL
);
6674 gfc_init_se (&arg2se
, NULL
);
6675 arg1
= expr
->value
.function
.actual
;
6678 /* Check whether the expression is a scalar or not; we cannot use
6679 arg1->expr->rank as it can be nonzero for proc pointers. */
6680 ss
= gfc_walk_expr (arg1
->expr
);
6681 scalar
= ss
== gfc_ss_terminator
;
6683 gfc_free_ss_chain (ss
);
6687 /* No optional target. */
6690 /* A pointer to a scalar. */
6691 arg1se
.want_pointer
= 1;
6692 gfc_conv_expr (&arg1se
, arg1
->expr
);
6693 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6694 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6695 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6697 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6699 tmp2
= gfc_class_data_get (arg1se
.expr
);
6700 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6701 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6708 /* A pointer to an array. */
6709 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6710 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6712 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6713 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6714 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
6715 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
6720 /* An optional target. */
6721 if (arg2
->expr
->ts
.type
== BT_CLASS
)
6722 gfc_add_data_component (arg2
->expr
);
6724 nonzero_charlen
= NULL_TREE
;
6725 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
6726 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
6728 arg1
->expr
->ts
.u
.cl
->backend_decl
,
6732 /* A pointer to a scalar. */
6733 arg1se
.want_pointer
= 1;
6734 gfc_conv_expr (&arg1se
, arg1
->expr
);
6735 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6736 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6737 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6739 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6740 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
6742 arg2se
.want_pointer
= 1;
6743 gfc_conv_expr (&arg2se
, arg2
->expr
);
6744 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6745 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
6746 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
6748 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6749 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6750 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6751 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6752 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6753 arg1se
.expr
, arg2se
.expr
);
6754 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6755 arg1se
.expr
, null_pointer_node
);
6756 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6757 boolean_type_node
, tmp
, tmp2
);
6761 /* An array pointer of zero length is not associated if target is
6763 arg1se
.descriptor_only
= 1;
6764 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
6765 if (arg1
->expr
->rank
== -1)
6767 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
6768 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6769 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
6772 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
6773 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
6774 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
6775 boolean_type_node
, tmp
,
6776 build_int_cst (TREE_TYPE (tmp
), 0));
6778 /* A pointer to an array, call library function _gfor_associated. */
6779 arg1se
.want_pointer
= 1;
6780 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6782 arg2se
.want_pointer
= 1;
6783 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
6784 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6785 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6786 se
->expr
= build_call_expr_loc (input_location
,
6787 gfor_fndecl_associated
, 2,
6788 arg1se
.expr
, arg2se
.expr
);
6789 se
->expr
= convert (boolean_type_node
, se
->expr
);
6790 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6791 boolean_type_node
, se
->expr
,
6795 /* If target is present zero character length pointers cannot
6797 if (nonzero_charlen
!= NULL_TREE
)
6798 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6800 se
->expr
, nonzero_charlen
);
6803 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6807 /* Generate code for the SAME_TYPE_AS intrinsic.
6808 Generate inline code that directly checks the vindices. */
6811 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
6816 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
6818 gfc_init_se (&se1
, NULL
);
6819 gfc_init_se (&se2
, NULL
);
6821 a
= expr
->value
.function
.actual
->expr
;
6822 b
= expr
->value
.function
.actual
->next
->expr
;
6824 if (UNLIMITED_POLY (a
))
6826 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
6827 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6828 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6831 if (UNLIMITED_POLY (b
))
6833 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
6834 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6835 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6838 if (a
->ts
.type
== BT_CLASS
)
6840 gfc_add_vptr_component (a
);
6841 gfc_add_hash_component (a
);
6843 else if (a
->ts
.type
== BT_DERIVED
)
6844 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6845 a
->ts
.u
.derived
->hash_value
);
6847 if (b
->ts
.type
== BT_CLASS
)
6849 gfc_add_vptr_component (b
);
6850 gfc_add_hash_component (b
);
6852 else if (b
->ts
.type
== BT_DERIVED
)
6853 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6854 b
->ts
.u
.derived
->hash_value
);
6856 gfc_conv_expr (&se1
, a
);
6857 gfc_conv_expr (&se2
, b
);
6859 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6860 boolean_type_node
, se1
.expr
,
6861 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
6864 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6865 boolean_type_node
, conda
, tmp
);
6868 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6869 boolean_type_node
, condb
, tmp
);
6871 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6875 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6878 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6882 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6883 se
->expr
= build_call_expr_loc (input_location
,
6884 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6885 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6889 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6892 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6896 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6898 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6899 type
= gfc_get_int_type (4);
6900 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6902 /* Convert it to the required type. */
6903 type
= gfc_typenode_for_spec (&expr
->ts
);
6904 se
->expr
= build_call_expr_loc (input_location
,
6905 gfor_fndecl_si_kind
, 1, arg
);
6906 se
->expr
= fold_convert (type
, se
->expr
);
6910 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6913 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6915 gfc_actual_arglist
*actual
;
6918 vec
<tree
, va_gc
> *args
= NULL
;
6920 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6922 gfc_init_se (&argse
, se
);
6924 /* Pass a NULL pointer for an absent arg. */
6925 if (actual
->expr
== NULL
)
6926 argse
.expr
= null_pointer_node
;
6932 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6934 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6935 ts
.type
= BT_INTEGER
;
6936 ts
.kind
= gfc_c_int_kind
;
6937 gfc_convert_type (actual
->expr
, &ts
, 2);
6939 gfc_conv_expr_reference (&argse
, actual
->expr
);
6942 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6943 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6944 vec_safe_push (args
, argse
.expr
);
6947 /* Convert it to the required type. */
6948 type
= gfc_typenode_for_spec (&expr
->ts
);
6949 se
->expr
= build_call_expr_loc_vec (input_location
,
6950 gfor_fndecl_sr_kind
, args
);
6951 se
->expr
= fold_convert (type
, se
->expr
);
6955 /* Generate code for TRIM (A) intrinsic function. */
6958 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6968 unsigned int num_args
;
6970 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6971 args
= XALLOCAVEC (tree
, num_args
);
6973 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6974 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6975 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6977 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6978 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6981 if (expr
->ts
.kind
== 1)
6982 function
= gfor_fndecl_string_trim
;
6983 else if (expr
->ts
.kind
== 4)
6984 function
= gfor_fndecl_string_trim_char4
;
6988 fndecl
= build_addr (function
);
6989 tmp
= build_call_array_loc (input_location
,
6990 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6992 gfc_add_expr_to_block (&se
->pre
, tmp
);
6994 /* Free the temporary afterwards, if necessary. */
6995 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6996 len
, build_int_cst (TREE_TYPE (len
), 0));
6997 tmp
= gfc_call_free (var
);
6998 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6999 gfc_add_expr_to_block (&se
->post
, tmp
);
7002 se
->string_length
= len
;
7006 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
7009 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
7011 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
7012 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
7014 stmtblock_t block
, body
;
7017 /* We store in charsize the size of a character. */
7018 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
7019 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
7021 /* Get the arguments. */
7022 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
7023 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
7025 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
7026 ncopies_type
= TREE_TYPE (ncopies
);
7028 /* Check that NCOPIES is not negative. */
7029 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
7030 build_int_cst (ncopies_type
, 0));
7031 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7032 "Argument NCOPIES of REPEAT intrinsic is negative "
7033 "(its value is %ld)",
7034 fold_convert (long_integer_type_node
, ncopies
));
7036 /* If the source length is zero, any non negative value of NCOPIES
7037 is valid, and nothing happens. */
7038 n
= gfc_create_var (ncopies_type
, "ncopies");
7039 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7040 build_int_cst (size_type_node
, 0));
7041 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
7042 build_int_cst (ncopies_type
, 0), ncopies
);
7043 gfc_add_modify (&se
->pre
, n
, tmp
);
7046 /* Check that ncopies is not too large: ncopies should be less than
7047 (or equal to) MAX / slen, where MAX is the maximal integer of
7048 the gfc_charlen_type_node type. If slen == 0, we need a special
7049 case to avoid the division by zero. */
7050 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
7051 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
7052 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
7053 fold_convert (size_type_node
, max
), slen
);
7054 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
7055 ? size_type_node
: ncopies_type
;
7056 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
7057 fold_convert (largest
, ncopies
),
7058 fold_convert (largest
, max
));
7059 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
7060 build_int_cst (size_type_node
, 0));
7061 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
7062 boolean_false_node
, cond
);
7063 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
7064 "Argument NCOPIES of REPEAT intrinsic is too large");
7066 /* Compute the destination length. */
7067 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7068 fold_convert (gfc_charlen_type_node
, slen
),
7069 fold_convert (gfc_charlen_type_node
, ncopies
));
7070 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
7071 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
7073 /* Generate the code to do the repeat operation:
7074 for (i = 0; i < ncopies; i++)
7075 memmove (dest + (i * slen * size), src, slen*size); */
7076 gfc_start_block (&block
);
7077 count
= gfc_create_var (ncopies_type
, "count");
7078 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
7079 exit_label
= gfc_build_label_decl (NULL_TREE
);
7081 /* Start the loop body. */
7082 gfc_start_block (&body
);
7084 /* Exit the loop if count >= ncopies. */
7085 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
7087 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7088 TREE_USED (exit_label
) = 1;
7089 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7090 build_empty_stmt (input_location
));
7091 gfc_add_expr_to_block (&body
, tmp
);
7093 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7094 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7095 fold_convert (gfc_charlen_type_node
, slen
),
7096 fold_convert (gfc_charlen_type_node
, count
));
7097 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7098 tmp
, fold_convert (gfc_charlen_type_node
, size
));
7099 tmp
= fold_build_pointer_plus_loc (input_location
,
7100 fold_convert (pvoid_type_node
, dest
), tmp
);
7101 tmp
= build_call_expr_loc (input_location
,
7102 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7104 fold_build2_loc (input_location
, MULT_EXPR
,
7105 size_type_node
, slen
,
7106 fold_convert (size_type_node
,
7108 gfc_add_expr_to_block (&body
, tmp
);
7110 /* Increment count. */
7111 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
7112 count
, build_int_cst (TREE_TYPE (count
), 1));
7113 gfc_add_modify (&body
, count
, tmp
);
7115 /* Build the loop. */
7116 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7117 gfc_add_expr_to_block (&block
, tmp
);
7119 /* Add the exit label. */
7120 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7121 gfc_add_expr_to_block (&block
, tmp
);
7123 /* Finish the block. */
7124 tmp
= gfc_finish_block (&block
);
7125 gfc_add_expr_to_block (&se
->pre
, tmp
);
7127 /* Set the result value. */
7129 se
->string_length
= dlen
;
7133 /* Generate code for the IARGC intrinsic. */
7136 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
7142 /* Call the library function. This always returns an INTEGER(4). */
7143 fndecl
= gfor_fndecl_iargc
;
7144 tmp
= build_call_expr_loc (input_location
,
7147 /* Convert it to the required type. */
7148 type
= gfc_typenode_for_spec (&expr
->ts
);
7149 tmp
= fold_convert (type
, tmp
);
7155 /* The loc intrinsic returns the address of its argument as
7156 gfc_index_integer_kind integer. */
7159 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7164 gcc_assert (!se
->ss
);
7166 arg_expr
= expr
->value
.function
.actual
->expr
;
7167 if (arg_expr
->rank
== 0)
7169 if (arg_expr
->ts
.type
== BT_CLASS
)
7170 gfc_add_data_component (arg_expr
);
7171 gfc_conv_expr_reference (se
, arg_expr
);
7174 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7175 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7177 /* Create a temporary variable for loc return value. Without this,
7178 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7179 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7180 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7181 se
->expr
= temp_var
;
7185 /* The following routine generates code for the intrinsic
7186 functions from the ISO_C_BINDING module:
7192 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7194 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7196 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7198 if (arg
->expr
->rank
== 0)
7199 gfc_conv_expr_reference (se
, arg
->expr
);
7200 else if (gfc_is_simply_contiguous (arg
->expr
, false, false))
7201 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7204 gfc_conv_expr_descriptor (se
, arg
->expr
);
7205 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7208 /* TODO -- the following two lines shouldn't be necessary, but if
7209 they're removed, a bug is exposed later in the code path.
7210 This workaround was thus introduced, but will have to be
7211 removed; please see PR 35150 for details about the issue. */
7212 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7213 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7215 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7216 gfc_conv_expr_reference (se
, arg
->expr
);
7217 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7222 /* Build the addr_expr for the first argument. The argument is
7223 already an *address* so we don't need to set want_pointer in
7225 gfc_init_se (&arg1se
, NULL
);
7226 gfc_conv_expr (&arg1se
, arg
->expr
);
7227 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7228 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7230 /* See if we were given two arguments. */
7231 if (arg
->next
->expr
== NULL
)
7232 /* Only given one arg so generate a null and do a
7233 not-equal comparison against the first arg. */
7234 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7236 fold_convert (TREE_TYPE (arg1se
.expr
),
7237 null_pointer_node
));
7243 /* Given two arguments so build the arg2se from second arg. */
7244 gfc_init_se (&arg2se
, NULL
);
7245 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
7246 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7247 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7249 /* Generate test to compare that the two args are equal. */
7250 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7251 arg1se
.expr
, arg2se
.expr
);
7252 /* Generate test to ensure that the first arg is not null. */
7253 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
7255 arg1se
.expr
, null_pointer_node
);
7257 /* Finally, the generated test must check that both arg1 is not
7258 NULL and that it is equal to the second arg. */
7259 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7261 not_null_expr
, eq_expr
);
7269 /* The following routine generates code for the intrinsic
7270 subroutines from the ISO_C_BINDING module:
7272 * C_F_PROCPOINTER. */
7275 conv_isocbinding_subroutine (gfc_code
*code
)
7282 tree desc
, dim
, tmp
, stride
, offset
;
7283 stmtblock_t body
, block
;
7285 gfc_actual_arglist
*arg
= code
->ext
.actual
;
7287 gfc_init_se (&se
, NULL
);
7288 gfc_init_se (&cptrse
, NULL
);
7289 gfc_conv_expr (&cptrse
, arg
->expr
);
7290 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
7291 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
7293 gfc_init_se (&fptrse
, NULL
);
7294 if (arg
->next
->expr
->rank
== 0)
7296 fptrse
.want_pointer
= 1;
7297 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
7298 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
7299 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
7300 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7301 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
7302 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
7304 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7305 TREE_TYPE (fptrse
.expr
),
7307 fold_convert (TREE_TYPE (fptrse
.expr
),
7309 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
7310 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7311 return gfc_finish_block (&se
.pre
);
7314 gfc_start_block (&block
);
7316 /* Get the descriptor of the Fortran pointer. */
7317 fptrse
.descriptor_only
= 1;
7318 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
7319 gfc_add_block_to_block (&block
, &fptrse
.pre
);
7322 /* Set data value, dtype, and offset. */
7323 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
7324 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
7325 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7326 gfc_get_dtype (TREE_TYPE (desc
)));
7328 /* Start scalarization of the bounds, using the shape argument. */
7330 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
7331 gcc_assert (shape_ss
!= gfc_ss_terminator
);
7332 gfc_init_se (&shapese
, NULL
);
7334 gfc_init_loopinfo (&loop
);
7335 gfc_add_ss_to_loop (&loop
, shape_ss
);
7336 gfc_conv_ss_startstride (&loop
);
7337 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
7338 gfc_mark_ss_chain_used (shape_ss
, 1);
7340 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
7341 shapese
.ss
= shape_ss
;
7343 stride
= gfc_create_var (gfc_array_index_type
, "stride");
7344 offset
= gfc_create_var (gfc_array_index_type
, "offset");
7345 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
7346 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7349 gfc_start_scalarized_body (&loop
, &body
);
7351 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7352 loop
.loopvar
[0], loop
.from
[0]);
7354 /* Set bounds and stride. */
7355 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
7356 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
7358 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
7359 gfc_add_block_to_block (&body
, &shapese
.pre
);
7360 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
7361 gfc_add_block_to_block (&body
, &shapese
.post
);
7363 /* Calculate offset. */
7364 gfc_add_modify (&body
, offset
,
7365 fold_build2_loc (input_location
, PLUS_EXPR
,
7366 gfc_array_index_type
, offset
, stride
));
7367 /* Update stride. */
7368 gfc_add_modify (&body
, stride
,
7369 fold_build2_loc (input_location
, MULT_EXPR
,
7370 gfc_array_index_type
, stride
,
7371 fold_convert (gfc_array_index_type
,
7373 /* Finish scalarization loop. */
7374 gfc_trans_scalarizing_loops (&loop
, &body
);
7375 gfc_add_block_to_block (&block
, &loop
.pre
);
7376 gfc_add_block_to_block (&block
, &loop
.post
);
7377 gfc_add_block_to_block (&block
, &fptrse
.post
);
7378 gfc_cleanup_loop (&loop
);
7380 gfc_add_modify (&block
, offset
,
7381 fold_build1_loc (input_location
, NEGATE_EXPR
,
7382 gfc_array_index_type
, offset
));
7383 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
7385 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
7386 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7387 return gfc_finish_block (&se
.pre
);
7391 /* Save and restore floating-point state. */
7394 gfc_save_fp_state (stmtblock_t
*block
)
7396 tree type
, fpstate
, tmp
;
7398 type
= build_array_type (char_type_node
,
7399 build_range_type (size_type_node
, size_zero_node
,
7400 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
7401 fpstate
= gfc_create_var (type
, "fpstate");
7402 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
7404 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
7406 gfc_add_expr_to_block (block
, tmp
);
7413 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
7417 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
7419 gfc_add_expr_to_block (block
, tmp
);
7423 /* Generate code for arguments of IEEE functions. */
7426 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
7429 gfc_actual_arglist
*actual
;
7434 actual
= expr
->value
.function
.actual
;
7435 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
7437 gcc_assert (actual
);
7440 gfc_init_se (&argse
, se
);
7441 gfc_conv_expr_val (&argse
, e
);
7443 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7444 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7445 argarray
[arg
] = argse
.expr
;
7450 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
7451 and IEEE_UNORDERED, which translate directly to GCC type-generic
7455 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
7456 enum built_in_function code
, int nargs
)
7459 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
7461 conv_ieee_function_args (se
, expr
, args
, nargs
);
7462 se
->expr
= build_call_expr_loc_array (input_location
,
7463 builtin_decl_explicit (code
),
7465 STRIP_TYPE_NOPS (se
->expr
);
7466 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7470 /* Generate code for IEEE_IS_NORMAL intrinsic:
7471 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
7474 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
7476 tree arg
, isnormal
, iszero
;
7478 /* Convert arg, evaluate it only once. */
7479 conv_ieee_function_args (se
, expr
, &arg
, 1);
7480 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7482 isnormal
= build_call_expr_loc (input_location
,
7483 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
7485 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
7486 build_real_from_int_cst (TREE_TYPE (arg
),
7487 integer_zero_node
));
7488 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7489 boolean_type_node
, isnormal
, iszero
);
7490 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7494 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
7495 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
7498 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
7500 tree arg
, signbit
, isnan
;
7502 /* Convert arg, evaluate it only once. */
7503 conv_ieee_function_args (se
, expr
, &arg
, 1);
7504 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7506 isnan
= build_call_expr_loc (input_location
,
7507 builtin_decl_explicit (BUILT_IN_ISNAN
),
7509 STRIP_TYPE_NOPS (isnan
);
7511 signbit
= build_call_expr_loc (input_location
,
7512 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
7514 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7515 signbit
, integer_zero_node
);
7517 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7518 boolean_type_node
, signbit
,
7519 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
7520 TREE_TYPE(isnan
), isnan
));
7522 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7526 /* Generate code for IEEE_LOGB and IEEE_RINT. */
7529 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
7530 enum built_in_function code
)
7532 tree arg
, decl
, call
, fpstate
;
7535 conv_ieee_function_args (se
, expr
, &arg
, 1);
7536 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
7537 decl
= builtin_decl_for_precision (code
, argprec
);
7539 /* Save floating-point state. */
7540 fpstate
= gfc_save_fp_state (&se
->pre
);
7542 /* Make the function call. */
7543 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
7544 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
7546 /* Restore floating-point state. */
7547 gfc_restore_fp_state (&se
->post
, fpstate
);
7551 /* Generate code for IEEE_REM. */
7554 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
7556 tree args
[2], decl
, call
, fpstate
;
7559 conv_ieee_function_args (se
, expr
, args
, 2);
7561 /* If arguments have unequal size, convert them to the larger. */
7562 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
7563 > TYPE_PRECISION (TREE_TYPE (args
[1])))
7564 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7565 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
7566 > TYPE_PRECISION (TREE_TYPE (args
[0])))
7567 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
7569 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7570 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
7572 /* Save floating-point state. */
7573 fpstate
= gfc_save_fp_state (&se
->pre
);
7575 /* Make the function call. */
7576 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7577 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7579 /* Restore floating-point state. */
7580 gfc_restore_fp_state (&se
->post
, fpstate
);
7584 /* Generate code for IEEE_NEXT_AFTER. */
7587 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
7589 tree args
[2], decl
, call
, fpstate
;
7592 conv_ieee_function_args (se
, expr
, args
, 2);
7594 /* Result has the characteristics of first argument. */
7595 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7596 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7597 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
7599 /* Save floating-point state. */
7600 fpstate
= gfc_save_fp_state (&se
->pre
);
7602 /* Make the function call. */
7603 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7604 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7606 /* Restore floating-point state. */
7607 gfc_restore_fp_state (&se
->post
, fpstate
);
7611 /* Generate code for IEEE_SCALB. */
7614 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
7616 tree args
[2], decl
, call
, huge
, type
;
7619 conv_ieee_function_args (se
, expr
, args
, 2);
7621 /* Result has the characteristics of first argument. */
7622 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7623 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
7625 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
7627 /* We need to fold the integer into the range of a C int. */
7628 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
7629 type
= TREE_TYPE (args
[1]);
7631 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
7632 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
7634 huge
= fold_convert (type
, huge
);
7635 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
7637 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
7638 fold_build1_loc (input_location
, NEGATE_EXPR
,
7642 args
[1] = fold_convert (integer_type_node
, args
[1]);
7644 /* Make the function call. */
7645 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7646 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7650 /* Generate code for IEEE_COPY_SIGN. */
7653 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
7655 tree args
[2], decl
, sign
;
7658 conv_ieee_function_args (se
, expr
, args
, 2);
7660 /* Get the sign of the second argument. */
7661 sign
= build_call_expr_loc (input_location
,
7662 builtin_decl_explicit (BUILT_IN_SIGNBIT
),
7664 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7665 sign
, integer_zero_node
);
7667 /* Create a value of one, with the right sign. */
7668 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
7670 fold_build1_loc (input_location
, NEGATE_EXPR
,
7674 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
7676 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7677 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
7679 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7683 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
7687 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
7689 const char *name
= expr
->value
.function
.name
;
7691 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
7693 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
7694 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
7695 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
7696 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
7697 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
7698 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
7699 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
7700 conv_intrinsic_ieee_is_normal (se
, expr
);
7701 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
7702 conv_intrinsic_ieee_is_negative (se
, expr
);
7703 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
7704 conv_intrinsic_ieee_copy_sign (se
, expr
);
7705 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
7706 conv_intrinsic_ieee_scalb (se
, expr
);
7707 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
7708 conv_intrinsic_ieee_next_after (se
, expr
);
7709 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
7710 conv_intrinsic_ieee_rem (se
, expr
);
7711 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
7712 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
7713 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
7714 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
7716 /* It is not among the functions we translate directly. We return
7717 false, so a library function call is emitted. */
7726 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
7729 gfc_conv_intrinsic_malloc (gfc_se
* se
, gfc_expr
* expr
)
7731 tree arg
, res
, restype
;
7733 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
7734 arg
= fold_convert (size_type_node
, arg
);
7735 res
= build_call_expr_loc (input_location
,
7736 builtin_decl_explicit (BUILT_IN_MALLOC
), 1, arg
);
7737 restype
= gfc_typenode_for_spec (&expr
->ts
);
7738 se
->expr
= fold_convert (restype
, res
);
7742 /* Generate code for an intrinsic function. Some map directly to library
7743 calls, others get special handling. In some cases the name of the function
7744 used depends on the type specifiers. */
7747 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
7753 name
= &expr
->value
.function
.name
[2];
7757 lib
= gfc_is_intrinsic_libcall (expr
);
7761 se
->ignore_optional
= 1;
7763 switch (expr
->value
.function
.isym
->id
)
7765 case GFC_ISYM_EOSHIFT
:
7767 case GFC_ISYM_RESHAPE
:
7768 /* For all of those the first argument specifies the type and the
7769 third is optional. */
7770 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
7774 gfc_conv_intrinsic_funcall (se
, expr
);
7782 switch (expr
->value
.function
.isym
->id
)
7787 case GFC_ISYM_REPEAT
:
7788 gfc_conv_intrinsic_repeat (se
, expr
);
7792 gfc_conv_intrinsic_trim (se
, expr
);
7795 case GFC_ISYM_SC_KIND
:
7796 gfc_conv_intrinsic_sc_kind (se
, expr
);
7799 case GFC_ISYM_SI_KIND
:
7800 gfc_conv_intrinsic_si_kind (se
, expr
);
7803 case GFC_ISYM_SR_KIND
:
7804 gfc_conv_intrinsic_sr_kind (se
, expr
);
7807 case GFC_ISYM_EXPONENT
:
7808 gfc_conv_intrinsic_exponent (se
, expr
);
7812 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7814 fndecl
= gfor_fndecl_string_scan
;
7816 fndecl
= gfor_fndecl_string_scan_char4
;
7820 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7823 case GFC_ISYM_VERIFY
:
7824 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7826 fndecl
= gfor_fndecl_string_verify
;
7828 fndecl
= gfor_fndecl_string_verify_char4
;
7832 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7835 case GFC_ISYM_ALLOCATED
:
7836 gfc_conv_allocated (se
, expr
);
7839 case GFC_ISYM_ASSOCIATED
:
7840 gfc_conv_associated(se
, expr
);
7843 case GFC_ISYM_SAME_TYPE_AS
:
7844 gfc_conv_same_type_as (se
, expr
);
7848 gfc_conv_intrinsic_abs (se
, expr
);
7851 case GFC_ISYM_ADJUSTL
:
7852 if (expr
->ts
.kind
== 1)
7853 fndecl
= gfor_fndecl_adjustl
;
7854 else if (expr
->ts
.kind
== 4)
7855 fndecl
= gfor_fndecl_adjustl_char4
;
7859 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7862 case GFC_ISYM_ADJUSTR
:
7863 if (expr
->ts
.kind
== 1)
7864 fndecl
= gfor_fndecl_adjustr
;
7865 else if (expr
->ts
.kind
== 4)
7866 fndecl
= gfor_fndecl_adjustr_char4
;
7870 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7873 case GFC_ISYM_AIMAG
:
7874 gfc_conv_intrinsic_imagpart (se
, expr
);
7878 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
7882 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
7885 case GFC_ISYM_ANINT
:
7886 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
7890 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7894 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
7897 case GFC_ISYM_BTEST
:
7898 gfc_conv_intrinsic_btest (se
, expr
);
7902 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
7906 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
7910 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
7914 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
7917 case GFC_ISYM_C_ASSOCIATED
:
7918 case GFC_ISYM_C_FUNLOC
:
7919 case GFC_ISYM_C_LOC
:
7920 conv_isocbinding_function (se
, expr
);
7923 case GFC_ISYM_ACHAR
:
7925 gfc_conv_intrinsic_char (se
, expr
);
7928 case GFC_ISYM_CONVERSION
:
7930 case GFC_ISYM_LOGICAL
:
7932 gfc_conv_intrinsic_conversion (se
, expr
);
7935 /* Integer conversions are handled separately to make sure we get the
7936 correct rounding mode. */
7941 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
7945 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
7948 case GFC_ISYM_CEILING
:
7949 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
7952 case GFC_ISYM_FLOOR
:
7953 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
7957 gfc_conv_intrinsic_mod (se
, expr
, 0);
7960 case GFC_ISYM_MODULO
:
7961 gfc_conv_intrinsic_mod (se
, expr
, 1);
7964 case GFC_ISYM_CAF_GET
:
7965 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
);
7968 case GFC_ISYM_CMPLX
:
7969 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
7972 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
7973 gfc_conv_intrinsic_iargc (se
, expr
);
7976 case GFC_ISYM_COMPLEX
:
7977 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
7980 case GFC_ISYM_CONJG
:
7981 gfc_conv_intrinsic_conjg (se
, expr
);
7984 case GFC_ISYM_COUNT
:
7985 gfc_conv_intrinsic_count (se
, expr
);
7988 case GFC_ISYM_CTIME
:
7989 gfc_conv_intrinsic_ctime (se
, expr
);
7993 gfc_conv_intrinsic_dim (se
, expr
);
7996 case GFC_ISYM_DOT_PRODUCT
:
7997 gfc_conv_intrinsic_dot_product (se
, expr
);
8000 case GFC_ISYM_DPROD
:
8001 gfc_conv_intrinsic_dprod (se
, expr
);
8004 case GFC_ISYM_DSHIFTL
:
8005 gfc_conv_intrinsic_dshift (se
, expr
, true);
8008 case GFC_ISYM_DSHIFTR
:
8009 gfc_conv_intrinsic_dshift (se
, expr
, false);
8012 case GFC_ISYM_FDATE
:
8013 gfc_conv_intrinsic_fdate (se
, expr
);
8016 case GFC_ISYM_FRACTION
:
8017 gfc_conv_intrinsic_fraction (se
, expr
);
8021 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
8025 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
8029 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
8032 case GFC_ISYM_IBCLR
:
8033 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
8036 case GFC_ISYM_IBITS
:
8037 gfc_conv_intrinsic_ibits (se
, expr
);
8040 case GFC_ISYM_IBSET
:
8041 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
8044 case GFC_ISYM_IACHAR
:
8045 case GFC_ISYM_ICHAR
:
8046 /* We assume ASCII character sequence. */
8047 gfc_conv_intrinsic_ichar (se
, expr
);
8050 case GFC_ISYM_IARGC
:
8051 gfc_conv_intrinsic_iargc (se
, expr
);
8055 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8058 case GFC_ISYM_INDEX
:
8059 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
8061 fndecl
= gfor_fndecl_string_index
;
8063 fndecl
= gfor_fndecl_string_index_char4
;
8067 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
8071 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8074 case GFC_ISYM_IPARITY
:
8075 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
8078 case GFC_ISYM_IS_IOSTAT_END
:
8079 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
8082 case GFC_ISYM_IS_IOSTAT_EOR
:
8083 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
8086 case GFC_ISYM_ISNAN
:
8087 gfc_conv_intrinsic_isnan (se
, expr
);
8090 case GFC_ISYM_LSHIFT
:
8091 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8094 case GFC_ISYM_RSHIFT
:
8095 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8098 case GFC_ISYM_SHIFTA
:
8099 gfc_conv_intrinsic_shift (se
, expr
, true, true);
8102 case GFC_ISYM_SHIFTL
:
8103 gfc_conv_intrinsic_shift (se
, expr
, false, false);
8106 case GFC_ISYM_SHIFTR
:
8107 gfc_conv_intrinsic_shift (se
, expr
, true, false);
8110 case GFC_ISYM_ISHFT
:
8111 gfc_conv_intrinsic_ishft (se
, expr
);
8114 case GFC_ISYM_ISHFTC
:
8115 gfc_conv_intrinsic_ishftc (se
, expr
);
8118 case GFC_ISYM_LEADZ
:
8119 gfc_conv_intrinsic_leadz (se
, expr
);
8122 case GFC_ISYM_TRAILZ
:
8123 gfc_conv_intrinsic_trailz (se
, expr
);
8126 case GFC_ISYM_POPCNT
:
8127 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
8130 case GFC_ISYM_POPPAR
:
8131 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
8134 case GFC_ISYM_LBOUND
:
8135 gfc_conv_intrinsic_bound (se
, expr
, 0);
8138 case GFC_ISYM_LCOBOUND
:
8139 conv_intrinsic_cobound (se
, expr
);
8142 case GFC_ISYM_TRANSPOSE
:
8143 /* The scalarizer has already been set up for reversed dimension access
8144 order ; now we just get the argument value normally. */
8145 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
8149 gfc_conv_intrinsic_len (se
, expr
);
8152 case GFC_ISYM_LEN_TRIM
:
8153 gfc_conv_intrinsic_len_trim (se
, expr
);
8157 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
8161 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
8165 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
8169 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
8172 case GFC_ISYM_MALLOC
:
8173 gfc_conv_intrinsic_malloc (se
, expr
);
8176 case GFC_ISYM_MASKL
:
8177 gfc_conv_intrinsic_mask (se
, expr
, 1);
8180 case GFC_ISYM_MASKR
:
8181 gfc_conv_intrinsic_mask (se
, expr
, 0);
8185 if (expr
->ts
.type
== BT_CHARACTER
)
8186 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
8188 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
8191 case GFC_ISYM_MAXLOC
:
8192 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8195 case GFC_ISYM_MAXVAL
:
8196 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
8199 case GFC_ISYM_MERGE
:
8200 gfc_conv_intrinsic_merge (se
, expr
);
8203 case GFC_ISYM_MERGE_BITS
:
8204 gfc_conv_intrinsic_merge_bits (se
, expr
);
8208 if (expr
->ts
.type
== BT_CHARACTER
)
8209 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
8211 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
8214 case GFC_ISYM_MINLOC
:
8215 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8218 case GFC_ISYM_MINVAL
:
8219 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
8222 case GFC_ISYM_NEAREST
:
8223 gfc_conv_intrinsic_nearest (se
, expr
);
8226 case GFC_ISYM_NORM2
:
8227 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
8231 gfc_conv_intrinsic_not (se
, expr
);
8235 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8238 case GFC_ISYM_PARITY
:
8239 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
8242 case GFC_ISYM_PRESENT
:
8243 gfc_conv_intrinsic_present (se
, expr
);
8246 case GFC_ISYM_PRODUCT
:
8247 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
8251 gfc_conv_intrinsic_rank (se
, expr
);
8254 case GFC_ISYM_RRSPACING
:
8255 gfc_conv_intrinsic_rrspacing (se
, expr
);
8258 case GFC_ISYM_SET_EXPONENT
:
8259 gfc_conv_intrinsic_set_exponent (se
, expr
);
8262 case GFC_ISYM_SCALE
:
8263 gfc_conv_intrinsic_scale (se
, expr
);
8267 gfc_conv_intrinsic_sign (se
, expr
);
8271 gfc_conv_intrinsic_size (se
, expr
);
8274 case GFC_ISYM_SIZEOF
:
8275 case GFC_ISYM_C_SIZEOF
:
8276 gfc_conv_intrinsic_sizeof (se
, expr
);
8279 case GFC_ISYM_STORAGE_SIZE
:
8280 gfc_conv_intrinsic_storage_size (se
, expr
);
8283 case GFC_ISYM_SPACING
:
8284 gfc_conv_intrinsic_spacing (se
, expr
);
8287 case GFC_ISYM_STRIDE
:
8288 conv_intrinsic_stride (se
, expr
);
8292 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
8295 case GFC_ISYM_TRANSFER
:
8296 if (se
->ss
&& se
->ss
->info
->useflags
)
8297 /* Access the previously obtained result. */
8298 gfc_conv_tmp_array_ref (se
);
8300 gfc_conv_intrinsic_transfer (se
, expr
);
8303 case GFC_ISYM_TTYNAM
:
8304 gfc_conv_intrinsic_ttynam (se
, expr
);
8307 case GFC_ISYM_UBOUND
:
8308 gfc_conv_intrinsic_bound (se
, expr
, 1);
8311 case GFC_ISYM_UCOBOUND
:
8312 conv_intrinsic_cobound (se
, expr
);
8316 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8320 gfc_conv_intrinsic_loc (se
, expr
);
8323 case GFC_ISYM_THIS_IMAGE
:
8324 /* For num_images() == 1, handle as LCOBOUND. */
8325 if (expr
->value
.function
.actual
->expr
8326 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
8327 conv_intrinsic_cobound (se
, expr
);
8329 trans_this_image (se
, expr
);
8332 case GFC_ISYM_IMAGE_INDEX
:
8333 trans_image_index (se
, expr
);
8336 case GFC_ISYM_NUM_IMAGES
:
8337 trans_num_images (se
, expr
);
8340 case GFC_ISYM_ACCESS
:
8341 case GFC_ISYM_CHDIR
:
8342 case GFC_ISYM_CHMOD
:
8343 case GFC_ISYM_DTIME
:
8344 case GFC_ISYM_ETIME
:
8345 case GFC_ISYM_EXTENDS_TYPE_OF
:
8347 case GFC_ISYM_FGETC
:
8350 case GFC_ISYM_FPUTC
:
8351 case GFC_ISYM_FSTAT
:
8352 case GFC_ISYM_FTELL
:
8353 case GFC_ISYM_GETCWD
:
8354 case GFC_ISYM_GETGID
:
8355 case GFC_ISYM_GETPID
:
8356 case GFC_ISYM_GETUID
:
8357 case GFC_ISYM_HOSTNM
:
8359 case GFC_ISYM_IERRNO
:
8360 case GFC_ISYM_IRAND
:
8361 case GFC_ISYM_ISATTY
:
8364 case GFC_ISYM_LSTAT
:
8365 case GFC_ISYM_MATMUL
:
8366 case GFC_ISYM_MCLOCK
:
8367 case GFC_ISYM_MCLOCK8
:
8369 case GFC_ISYM_RENAME
:
8370 case GFC_ISYM_SECOND
:
8371 case GFC_ISYM_SECNDS
:
8372 case GFC_ISYM_SIGNAL
:
8374 case GFC_ISYM_SYMLNK
:
8375 case GFC_ISYM_SYSTEM
:
8377 case GFC_ISYM_TIME8
:
8378 case GFC_ISYM_UMASK
:
8379 case GFC_ISYM_UNLINK
:
8381 gfc_conv_intrinsic_funcall (se
, expr
);
8384 case GFC_ISYM_EOSHIFT
:
8386 case GFC_ISYM_RESHAPE
:
8387 /* For those, expr->rank should always be >0 and thus the if above the
8388 switch should have matched. */
8393 gfc_conv_intrinsic_lib_function (se
, expr
);
8400 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
8402 gfc_ss
*arg_ss
, *tmp_ss
;
8403 gfc_actual_arglist
*arg
;
8405 arg
= expr
->value
.function
.actual
;
8407 gcc_assert (arg
->expr
);
8409 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
8410 gcc_assert (arg_ss
!= gfc_ss_terminator
);
8412 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
8414 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
8415 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
8417 gcc_assert (tmp_ss
->dimen
== 2);
8419 /* We just invert dimensions. */
8420 std::swap (tmp_ss
->dim
[0], tmp_ss
->dim
[1]);
8423 /* Stop when tmp_ss points to the last valid element of the chain... */
8424 if (tmp_ss
->next
== gfc_ss_terminator
)
8428 /* ... so that we can attach the rest of the chain to it. */
8435 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
8436 This has the side effect of reversing the nested list, so there is no
8437 need to call gfc_reverse_ss on it (the given list is assumed not to be
8441 nest_loop_dimension (gfc_ss
*ss
, int dim
)
8444 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
8445 gfc_loopinfo
*new_loop
;
8447 gcc_assert (ss
!= gfc_ss_terminator
);
8449 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
8451 new_ss
= gfc_get_ss ();
8452 new_ss
->next
= prev_ss
;
8453 new_ss
->parent
= ss
;
8454 new_ss
->info
= ss
->info
;
8455 new_ss
->info
->refcount
++;
8458 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
8459 && ss
->info
->type
!= GFC_SS_REFERENCE
);
8462 new_ss
->dim
[0] = ss
->dim
[dim
];
8464 gcc_assert (dim
< ss
->dimen
);
8466 ss_dim
= --ss
->dimen
;
8467 for (i
= dim
; i
< ss_dim
; i
++)
8468 ss
->dim
[i
] = ss
->dim
[i
+ 1];
8470 ss
->dim
[ss_dim
] = 0;
8476 ss
->nested_ss
->parent
= new_ss
;
8477 new_ss
->nested_ss
= ss
->nested_ss
;
8479 ss
->nested_ss
= new_ss
;
8482 new_loop
= gfc_get_loopinfo ();
8483 gfc_init_loopinfo (new_loop
);
8485 gcc_assert (prev_ss
!= NULL
);
8486 gcc_assert (prev_ss
!= gfc_ss_terminator
);
8487 gfc_add_ss_to_loop (new_loop
, prev_ss
);
8488 return new_ss
->parent
;
8492 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
8493 is to be inlined. */
8496 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
8498 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
8499 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
8501 bool scalar_mask
= false;
8503 /* The rank of the result will be determined later. */
8504 arg1
= expr
->value
.function
.actual
;
8507 gcc_assert (arg3
!= NULL
);
8509 if (expr
->rank
== 0)
8512 tmp_ss
= gfc_ss_terminator
;
8518 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
8519 if (mask_ss
== tmp_ss
)
8525 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
8526 gcc_assert (array_ss
!= tmp_ss
);
8528 /* Odd thing: If the mask is scalar, it is used by the frontend after
8529 the array (to make an if around the nested loop). Thus it shall
8530 be after array_ss once the gfc_ss list is reversed. */
8532 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
8536 /* "Hide" the dimension on which we will sum in the first arg's scalarization
8538 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
8539 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
8547 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
8550 switch (expr
->value
.function
.isym
->id
)
8552 case GFC_ISYM_PRODUCT
:
8554 return walk_inline_intrinsic_arith (ss
, expr
);
8556 case GFC_ISYM_TRANSPOSE
:
8557 return walk_inline_intrinsic_transpose (ss
, expr
);
8566 /* This generates code to execute before entering the scalarization loop.
8567 Currently does nothing. */
8570 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
8572 switch (ss
->info
->expr
->value
.function
.isym
->id
)
8574 case GFC_ISYM_UBOUND
:
8575 case GFC_ISYM_LBOUND
:
8576 case GFC_ISYM_UCOBOUND
:
8577 case GFC_ISYM_LCOBOUND
:
8578 case GFC_ISYM_THIS_IMAGE
:
8587 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
8588 are expanded into code inside the scalarization loop. */
8591 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
8593 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
8594 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
8596 /* The two argument version returns a scalar. */
8597 if (expr
->value
.function
.actual
->next
->expr
)
8600 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
8604 /* Walk an intrinsic array libcall. */
8607 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
8609 gcc_assert (expr
->rank
> 0);
8610 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8614 /* Return whether the function call expression EXPR will be expanded
8615 inline by gfc_conv_intrinsic_function. */
8618 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
8620 gfc_actual_arglist
*args
;
8622 if (!expr
->value
.function
.isym
)
8625 switch (expr
->value
.function
.isym
->id
)
8627 case GFC_ISYM_PRODUCT
:
8629 /* Disable inline expansion if code size matters. */
8633 args
= expr
->value
.function
.actual
;
8634 /* We need to be able to subset the SUM argument at compile-time. */
8635 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
8640 case GFC_ISYM_TRANSPOSE
:
8649 /* Returns nonzero if the specified intrinsic function call maps directly to
8650 an external library call. Should only be used for functions that return
8654 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
8656 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
8657 gcc_assert (expr
->rank
> 0);
8659 if (gfc_inline_intrinsic_function_p (expr
))
8662 switch (expr
->value
.function
.isym
->id
)
8666 case GFC_ISYM_COUNT
:
8670 case GFC_ISYM_IPARITY
:
8671 case GFC_ISYM_MATMUL
:
8672 case GFC_ISYM_MAXLOC
:
8673 case GFC_ISYM_MAXVAL
:
8674 case GFC_ISYM_MINLOC
:
8675 case GFC_ISYM_MINVAL
:
8676 case GFC_ISYM_NORM2
:
8677 case GFC_ISYM_PARITY
:
8678 case GFC_ISYM_PRODUCT
:
8680 case GFC_ISYM_SHAPE
:
8681 case GFC_ISYM_SPREAD
:
8683 /* Ignore absent optional parameters. */
8686 case GFC_ISYM_RESHAPE
:
8687 case GFC_ISYM_CSHIFT
:
8688 case GFC_ISYM_EOSHIFT
:
8690 case GFC_ISYM_UNPACK
:
8691 /* Pass absent optional parameters. */
8699 /* Walk an intrinsic function. */
8701 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
8702 gfc_intrinsic_sym
* isym
)
8706 if (isym
->elemental
)
8707 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8708 NULL
, GFC_SS_SCALAR
);
8710 if (expr
->rank
== 0)
8713 if (gfc_inline_intrinsic_function_p (expr
))
8714 return walk_inline_intrinsic_function (ss
, expr
);
8716 if (gfc_is_intrinsic_libcall (expr
))
8717 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8719 /* Special cases. */
8722 case GFC_ISYM_LBOUND
:
8723 case GFC_ISYM_LCOBOUND
:
8724 case GFC_ISYM_UBOUND
:
8725 case GFC_ISYM_UCOBOUND
:
8726 case GFC_ISYM_THIS_IMAGE
:
8727 return gfc_walk_intrinsic_bound (ss
, expr
);
8729 case GFC_ISYM_TRANSFER
:
8730 case GFC_ISYM_CAF_GET
:
8731 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8734 /* This probably meant someone forgot to add an intrinsic to the above
8735 list(s) when they implemented it, or something's gone horribly
8743 conv_co_collective (gfc_code
*code
)
8746 stmtblock_t block
, post_block
;
8747 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
8748 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
8750 gfc_start_block (&block
);
8751 gfc_init_block (&post_block
);
8753 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
8755 opr_expr
= code
->ext
.actual
->next
->expr
;
8756 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
8757 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8758 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
8763 image_idx_expr
= code
->ext
.actual
->next
->expr
;
8764 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8765 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8771 gfc_init_se (&argse
, NULL
);
8772 gfc_conv_expr (&argse
, stat_expr
);
8773 gfc_add_block_to_block (&block
, &argse
.pre
);
8774 gfc_add_block_to_block (&post_block
, &argse
.post
);
8776 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8777 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
8779 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8782 stat
= null_pointer_node
;
8784 /* Early exit for GFC_FCOARRAY_SINGLE. */
8785 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8787 if (stat
!= NULL_TREE
)
8788 gfc_add_modify (&block
, stat
,
8789 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
8790 return gfc_finish_block (&block
);
8793 /* Handle the array. */
8794 gfc_init_se (&argse
, NULL
);
8795 if (code
->ext
.actual
->expr
->rank
== 0)
8797 symbol_attribute attr
;
8798 gfc_clear_attr (&attr
);
8799 gfc_init_se (&argse
, NULL
);
8800 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8801 gfc_add_block_to_block (&block
, &argse
.pre
);
8802 gfc_add_block_to_block (&post_block
, &argse
.post
);
8803 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
8804 array
= gfc_build_addr_expr (NULL_TREE
, array
);
8808 argse
.want_pointer
= 1;
8809 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
8812 gfc_add_block_to_block (&block
, &argse
.pre
);
8813 gfc_add_block_to_block (&post_block
, &argse
.post
);
8815 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
8816 strlen
= argse
.string_length
;
8818 strlen
= integer_zero_node
;
8823 gfc_init_se (&argse
, NULL
);
8824 gfc_conv_expr (&argse
, image_idx_expr
);
8825 gfc_add_block_to_block (&block
, &argse
.pre
);
8826 gfc_add_block_to_block (&post_block
, &argse
.post
);
8827 image_index
= fold_convert (integer_type_node
, argse
.expr
);
8830 image_index
= integer_zero_node
;
8835 gfc_init_se (&argse
, NULL
);
8836 gfc_conv_expr (&argse
, errmsg_expr
);
8837 gfc_add_block_to_block (&block
, &argse
.pre
);
8838 gfc_add_block_to_block (&post_block
, &argse
.post
);
8839 errmsg
= argse
.expr
;
8840 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
8844 errmsg
= null_pointer_node
;
8845 errmsg_len
= integer_zero_node
;
8848 /* Generate the function call. */
8849 switch (code
->resolved_isym
->id
)
8851 case GFC_ISYM_CO_BROADCAST
:
8852 fndecl
= gfor_fndecl_co_broadcast
;
8854 case GFC_ISYM_CO_MAX
:
8855 fndecl
= gfor_fndecl_co_max
;
8857 case GFC_ISYM_CO_MIN
:
8858 fndecl
= gfor_fndecl_co_min
;
8860 case GFC_ISYM_CO_REDUCE
:
8861 fndecl
= gfor_fndecl_co_reduce
;
8863 case GFC_ISYM_CO_SUM
:
8864 fndecl
= gfor_fndecl_co_sum
;
8870 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
8871 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
8872 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
8873 image_index
, stat
, errmsg
, errmsg_len
);
8874 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
8875 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
8876 stat
, errmsg
, strlen
, errmsg_len
);
8879 tree opr
, opr_flags
;
8881 // FIXME: Handle TS29113's bind(C) strings with descriptor.
8883 if (gfc_is_proc_ptr_comp (opr_expr
))
8885 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
8886 opr_flag_int
= sym
->attr
.dimension
8887 || (sym
->ts
.type
== BT_CHARACTER
8888 && !sym
->attr
.is_bind_c
)
8889 ? GFC_CAF_BYREF
: 0;
8890 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8891 && !sym
->attr
.is_bind_c
8892 ? GFC_CAF_HIDDENLEN
: 0;
8893 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
8897 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
8898 ? GFC_CAF_BYREF
: 0;
8899 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8900 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
8901 ? GFC_CAF_HIDDENLEN
: 0;
8902 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
8903 ? GFC_CAF_ARG_VALUE
: 0;
8905 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
8906 gfc_conv_expr (&argse
, opr_expr
);
8908 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
8909 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
8912 gfc_add_expr_to_block (&block
, fndecl
);
8913 gfc_add_block_to_block (&block
, &post_block
);
8915 return gfc_finish_block (&block
);
8920 conv_intrinsic_atomic_op (gfc_code
*code
)
8923 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
8924 stmtblock_t block
, post_block
;
8925 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
8926 gfc_expr
*stat_expr
;
8927 built_in_function fn
;
8929 if (atom_expr
->expr_type
== EXPR_FUNCTION
8930 && atom_expr
->value
.function
.isym
8931 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8932 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8934 gfc_start_block (&block
);
8935 gfc_init_block (&post_block
);
8937 gfc_init_se (&argse
, NULL
);
8938 argse
.want_pointer
= 1;
8939 gfc_conv_expr (&argse
, atom_expr
);
8940 gfc_add_block_to_block (&block
, &argse
.pre
);
8941 gfc_add_block_to_block (&post_block
, &argse
.post
);
8944 gfc_init_se (&argse
, NULL
);
8945 if (flag_coarray
== GFC_FCOARRAY_LIB
8946 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8947 argse
.want_pointer
= 1;
8948 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
8949 gfc_add_block_to_block (&block
, &argse
.pre
);
8950 gfc_add_block_to_block (&post_block
, &argse
.post
);
8953 switch (code
->resolved_isym
->id
)
8955 case GFC_ISYM_ATOMIC_ADD
:
8956 case GFC_ISYM_ATOMIC_AND
:
8957 case GFC_ISYM_ATOMIC_DEF
:
8958 case GFC_ISYM_ATOMIC_OR
:
8959 case GFC_ISYM_ATOMIC_XOR
:
8960 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8961 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8962 old
= null_pointer_node
;
8965 gfc_init_se (&argse
, NULL
);
8966 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8967 argse
.want_pointer
= 1;
8968 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
8969 gfc_add_block_to_block (&block
, &argse
.pre
);
8970 gfc_add_block_to_block (&post_block
, &argse
.post
);
8972 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8976 if (stat_expr
!= NULL
)
8978 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
8979 gfc_init_se (&argse
, NULL
);
8980 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8981 argse
.want_pointer
= 1;
8982 gfc_conv_expr_val (&argse
, stat_expr
);
8983 gfc_add_block_to_block (&block
, &argse
.pre
);
8984 gfc_add_block_to_block (&post_block
, &argse
.post
);
8987 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
8988 stat
= null_pointer_node
;
8990 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8992 tree image_index
, caf_decl
, offset
, token
;
8995 switch (code
->resolved_isym
->id
)
8997 case GFC_ISYM_ATOMIC_ADD
:
8998 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8999 op
= (int) GFC_CAF_ATOMIC_ADD
;
9001 case GFC_ISYM_ATOMIC_AND
:
9002 case GFC_ISYM_ATOMIC_FETCH_AND
:
9003 op
= (int) GFC_CAF_ATOMIC_AND
;
9005 case GFC_ISYM_ATOMIC_OR
:
9006 case GFC_ISYM_ATOMIC_FETCH_OR
:
9007 op
= (int) GFC_CAF_ATOMIC_OR
;
9009 case GFC_ISYM_ATOMIC_XOR
:
9010 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9011 op
= (int) GFC_CAF_ATOMIC_XOR
;
9013 case GFC_ISYM_ATOMIC_DEF
:
9014 op
= 0; /* Unused. */
9020 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9021 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9022 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9024 if (gfc_is_coindexed (atom_expr
))
9025 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9027 image_index
= integer_zero_node
;
9029 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9031 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9032 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
9033 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9036 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9038 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
9039 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
9040 token
, offset
, image_index
, value
, stat
,
9041 build_int_cst (integer_type_node
,
9042 (int) atom_expr
->ts
.type
),
9043 build_int_cst (integer_type_node
,
9044 (int) atom_expr
->ts
.kind
));
9046 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
9047 build_int_cst (integer_type_node
, op
),
9048 token
, offset
, image_index
, value
, old
, stat
,
9049 build_int_cst (integer_type_node
,
9050 (int) atom_expr
->ts
.type
),
9051 build_int_cst (integer_type_node
,
9052 (int) atom_expr
->ts
.kind
));
9054 gfc_add_expr_to_block (&block
, tmp
);
9055 gfc_add_block_to_block (&block
, &post_block
);
9056 return gfc_finish_block (&block
);
9060 switch (code
->resolved_isym
->id
)
9062 case GFC_ISYM_ATOMIC_ADD
:
9063 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9064 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
9066 case GFC_ISYM_ATOMIC_AND
:
9067 case GFC_ISYM_ATOMIC_FETCH_AND
:
9068 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
9070 case GFC_ISYM_ATOMIC_DEF
:
9071 fn
= BUILT_IN_ATOMIC_STORE_N
;
9073 case GFC_ISYM_ATOMIC_OR
:
9074 case GFC_ISYM_ATOMIC_FETCH_OR
:
9075 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
9077 case GFC_ISYM_ATOMIC_XOR
:
9078 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9079 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
9085 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9086 fn
= (built_in_function
) ((int) fn
9087 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9089 tmp
= builtin_decl_explicit (fn
);
9090 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
9091 tmp
= builtin_decl_explicit (fn
);
9093 switch (code
->resolved_isym
->id
)
9095 case GFC_ISYM_ATOMIC_ADD
:
9096 case GFC_ISYM_ATOMIC_AND
:
9097 case GFC_ISYM_ATOMIC_DEF
:
9098 case GFC_ISYM_ATOMIC_OR
:
9099 case GFC_ISYM_ATOMIC_XOR
:
9100 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9101 fold_convert (itype
, value
),
9102 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9103 gfc_add_expr_to_block (&block
, tmp
);
9106 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
9107 fold_convert (itype
, value
),
9108 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9109 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
9113 if (stat
!= NULL_TREE
)
9114 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9115 gfc_add_block_to_block (&block
, &post_block
);
9116 return gfc_finish_block (&block
);
9121 conv_intrinsic_atomic_ref (gfc_code
*code
)
9124 tree tmp
, atom
, value
, stat
= NULL_TREE
;
9125 stmtblock_t block
, post_block
;
9126 built_in_function fn
;
9127 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
9129 if (atom_expr
->expr_type
== EXPR_FUNCTION
9130 && atom_expr
->value
.function
.isym
9131 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9132 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9134 gfc_start_block (&block
);
9135 gfc_init_block (&post_block
);
9136 gfc_init_se (&argse
, NULL
);
9137 argse
.want_pointer
= 1;
9138 gfc_conv_expr (&argse
, atom_expr
);
9139 gfc_add_block_to_block (&block
, &argse
.pre
);
9140 gfc_add_block_to_block (&post_block
, &argse
.post
);
9143 gfc_init_se (&argse
, NULL
);
9144 if (flag_coarray
== GFC_FCOARRAY_LIB
9145 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
9146 argse
.want_pointer
= 1;
9147 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
9148 gfc_add_block_to_block (&block
, &argse
.pre
);
9149 gfc_add_block_to_block (&post_block
, &argse
.post
);
9153 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
9155 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9157 gfc_init_se (&argse
, NULL
);
9158 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9159 argse
.want_pointer
= 1;
9160 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9161 gfc_add_block_to_block (&block
, &argse
.pre
);
9162 gfc_add_block_to_block (&post_block
, &argse
.post
);
9165 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9166 stat
= null_pointer_node
;
9168 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9170 tree image_index
, caf_decl
, offset
, token
;
9171 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
9173 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9174 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9175 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9177 if (gfc_is_coindexed (atom_expr
))
9178 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9180 image_index
= integer_zero_node
;
9182 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9184 /* Different type, need type conversion. */
9185 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9187 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9189 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
9192 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
9193 token
, offset
, image_index
, value
, stat
,
9194 build_int_cst (integer_type_node
,
9195 (int) atom_expr
->ts
.type
),
9196 build_int_cst (integer_type_node
,
9197 (int) atom_expr
->ts
.kind
));
9198 gfc_add_expr_to_block (&block
, tmp
);
9199 if (vardecl
!= NULL_TREE
)
9200 gfc_add_modify (&block
, orig_value
,
9201 fold_convert (TREE_TYPE (orig_value
), vardecl
));
9202 gfc_add_block_to_block (&block
, &post_block
);
9203 return gfc_finish_block (&block
);
9206 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9207 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
9208 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9210 tmp
= builtin_decl_explicit (fn
);
9211 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
9212 build_int_cst (integer_type_node
,
9214 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
9216 if (stat
!= NULL_TREE
)
9217 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9218 gfc_add_block_to_block (&block
, &post_block
);
9219 return gfc_finish_block (&block
);
9224 conv_intrinsic_atomic_cas (gfc_code
*code
)
9227 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
9228 stmtblock_t block
, post_block
;
9229 built_in_function fn
;
9230 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9232 if (atom_expr
->expr_type
== EXPR_FUNCTION
9233 && atom_expr
->value
.function
.isym
9234 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9235 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9237 gfc_init_block (&block
);
9238 gfc_init_block (&post_block
);
9239 gfc_init_se (&argse
, NULL
);
9240 argse
.want_pointer
= 1;
9241 gfc_conv_expr (&argse
, atom_expr
);
9244 gfc_init_se (&argse
, NULL
);
9245 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9246 argse
.want_pointer
= 1;
9247 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9248 gfc_add_block_to_block (&block
, &argse
.pre
);
9249 gfc_add_block_to_block (&post_block
, &argse
.post
);
9252 gfc_init_se (&argse
, NULL
);
9253 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9254 argse
.want_pointer
= 1;
9255 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9256 gfc_add_block_to_block (&block
, &argse
.pre
);
9257 gfc_add_block_to_block (&post_block
, &argse
.post
);
9260 gfc_init_se (&argse
, NULL
);
9261 if (flag_coarray
== GFC_FCOARRAY_LIB
9262 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
9263 == atom_expr
->ts
.kind
)
9264 argse
.want_pointer
= 1;
9265 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
9266 gfc_add_block_to_block (&block
, &argse
.pre
);
9267 gfc_add_block_to_block (&post_block
, &argse
.post
);
9268 new_val
= argse
.expr
;
9271 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
9273 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
9275 gfc_init_se (&argse
, NULL
);
9276 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9277 argse
.want_pointer
= 1;
9278 gfc_conv_expr_val (&argse
,
9279 code
->ext
.actual
->next
->next
->next
->next
->expr
);
9280 gfc_add_block_to_block (&block
, &argse
.pre
);
9281 gfc_add_block_to_block (&post_block
, &argse
.post
);
9284 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9285 stat
= null_pointer_node
;
9287 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9289 tree image_index
, caf_decl
, offset
, token
;
9291 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9292 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9293 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9295 if (gfc_is_coindexed (atom_expr
))
9296 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9298 image_index
= integer_zero_node
;
9300 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
9302 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
9303 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
9304 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9307 /* Convert a constant to a pointer. */
9308 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
9310 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
9311 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
9312 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9315 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9317 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
9318 token
, offset
, image_index
, old
, comp
, new_val
,
9319 stat
, build_int_cst (integer_type_node
,
9320 (int) atom_expr
->ts
.type
),
9321 build_int_cst (integer_type_node
,
9322 (int) atom_expr
->ts
.kind
));
9323 gfc_add_expr_to_block (&block
, tmp
);
9324 gfc_add_block_to_block (&block
, &post_block
);
9325 return gfc_finish_block (&block
);
9328 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9329 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
9330 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9332 tmp
= builtin_decl_explicit (fn
);
9334 gfc_add_modify (&block
, old
, comp
);
9335 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
9336 gfc_build_addr_expr (NULL
, old
),
9337 fold_convert (TREE_TYPE (old
), new_val
),
9339 build_int_cst (NULL
, MEMMODEL_RELAXED
),
9340 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9341 gfc_add_expr_to_block (&block
, tmp
);
9343 if (stat
!= NULL_TREE
)
9344 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9345 gfc_add_block_to_block (&block
, &post_block
);
9346 return gfc_finish_block (&block
);
9350 conv_intrinsic_event_query (gfc_code
*code
)
9353 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
9354 tree count
= NULL_TREE
, count2
= NULL_TREE
;
9356 gfc_expr
*event_expr
= code
->ext
.actual
->expr
;
9358 if (code
->ext
.actual
->next
->next
->expr
)
9360 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
9362 gfc_init_se (&argse
, NULL
);
9363 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9366 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9367 stat
= null_pointer_node
;
9369 if (code
->ext
.actual
->next
->expr
)
9371 gcc_assert (code
->ext
.actual
->next
->expr
->expr_type
== EXPR_VARIABLE
);
9372 gfc_init_se (&argse
, NULL
);
9373 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->expr
);
9377 gfc_start_block (&se
.pre
);
9378 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9380 tree tmp
, token
, image_index
;
9381 tree index
= size_zero_node
;
9383 if (event_expr
->expr_type
== EXPR_FUNCTION
9384 && event_expr
->value
.function
.isym
9385 && event_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9386 event_expr
= event_expr
->value
.function
.actual
->expr
;
9388 tree caf_decl
= gfc_get_tree_for_caf_expr (event_expr
);
9390 if (event_expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9391 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
9392 != INTMOD_ISO_FORTRAN_ENV
9393 || event_expr
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
9394 != ISOFORTRAN_EVENT_TYPE
)
9396 gfc_error ("Sorry, the event component of derived type at %L is not "
9397 "yet supported", &event_expr
->where
);
9401 if (gfc_is_coindexed (event_expr
))
9403 gfc_error ("The event variable at %L shall not be coindexed ",
9404 &event_expr
->where
);
9408 image_index
= integer_zero_node
;
9410 gfc_get_caf_token_offset (&token
, NULL
, caf_decl
, NULL_TREE
, event_expr
);
9412 /* For arrays, obtain the array index. */
9413 if (gfc_expr_attr (event_expr
).dimension
)
9415 tree desc
, tmp
, extent
, lbound
, ubound
;
9416 gfc_array_ref
*ar
, ar2
;
9419 /* TODO: Extend this, once DT components are supported. */
9420 ar
= &event_expr
->ref
->u
.ar
;
9422 memset (ar
, '\0', sizeof (*ar
));
9426 gfc_init_se (&argse
, NULL
);
9427 argse
.descriptor_only
= 1;
9428 gfc_conv_expr_descriptor (&argse
, event_expr
);
9429 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
9433 extent
= integer_one_node
;
9434 for (i
= 0; i
< ar
->dimen
; i
++)
9436 gfc_init_se (&argse
, NULL
);
9437 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
9438 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
9439 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
9440 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9441 integer_type_node
, argse
.expr
,
9442 fold_convert(integer_type_node
, lbound
));
9443 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9444 integer_type_node
, extent
, tmp
);
9445 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
9446 integer_type_node
, index
, tmp
);
9447 if (i
< ar
->dimen
- 1)
9449 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
9450 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
9451 tmp
= fold_convert (integer_type_node
, tmp
);
9452 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
9453 integer_type_node
, extent
, tmp
);
9458 if (count
!= null_pointer_node
&& TREE_TYPE (count
) != integer_type_node
)
9461 count
= gfc_create_var (integer_type_node
, "count");
9464 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
9467 stat
= gfc_create_var (integer_type_node
, "stat");
9470 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_query
, 5,
9471 token
, index
, image_index
, count
9472 ? gfc_build_addr_expr (NULL
, count
) : count
,
9473 stat
!= null_pointer_node
9474 ? gfc_build_addr_expr (NULL
, stat
) : stat
);
9475 gfc_add_expr_to_block (&se
.pre
, tmp
);
9477 if (count2
!= NULL_TREE
)
9478 gfc_add_modify (&se
.pre
, count2
,
9479 fold_convert (TREE_TYPE (count2
), count
));
9481 if (stat2
!= NULL_TREE
)
9482 gfc_add_modify (&se
.pre
, stat2
,
9483 fold_convert (TREE_TYPE (stat2
), stat
));
9485 return gfc_finish_block (&se
.pre
);
9488 gfc_init_se (&argse
, NULL
);
9489 gfc_conv_expr_val (&argse
, code
->ext
.actual
->expr
);
9490 gfc_add_modify (&se
.pre
, count
, fold_convert (TREE_TYPE (count
), argse
.expr
));
9492 if (stat
!= NULL_TREE
)
9493 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9495 return gfc_finish_block (&se
.pre
);
9499 conv_intrinsic_move_alloc (gfc_code
*code
)
9502 gfc_expr
*from_expr
, *to_expr
;
9503 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
9504 gfc_se from_se
, to_se
;
9508 gfc_start_block (&block
);
9510 from_expr
= code
->ext
.actual
->expr
;
9511 to_expr
= code
->ext
.actual
->next
->expr
;
9513 gfc_init_se (&from_se
, NULL
);
9514 gfc_init_se (&to_se
, NULL
);
9516 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
9517 || to_expr
->ts
.type
== BT_CLASS
);
9518 coarray
= gfc_get_corank (from_expr
) != 0;
9520 if (from_expr
->rank
== 0 && !coarray
)
9522 if (from_expr
->ts
.type
!= BT_CLASS
)
9523 from_expr2
= from_expr
;
9526 from_expr2
= gfc_copy_expr (from_expr
);
9527 gfc_add_data_component (from_expr2
);
9530 if (to_expr
->ts
.type
!= BT_CLASS
)
9534 to_expr2
= gfc_copy_expr (to_expr
);
9535 gfc_add_data_component (to_expr2
);
9538 from_se
.want_pointer
= 1;
9539 to_se
.want_pointer
= 1;
9540 gfc_conv_expr (&from_se
, from_expr2
);
9541 gfc_conv_expr (&to_se
, to_expr2
);
9542 gfc_add_block_to_block (&block
, &from_se
.pre
);
9543 gfc_add_block_to_block (&block
, &to_se
.pre
);
9545 /* Deallocate "to". */
9546 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
9547 to_expr
, to_expr
->ts
);
9548 gfc_add_expr_to_block (&block
, tmp
);
9550 /* Assign (_data) pointers. */
9551 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9552 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
9554 /* Set "from" to NULL. */
9555 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9556 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
9558 gfc_add_block_to_block (&block
, &from_se
.post
);
9559 gfc_add_block_to_block (&block
, &to_se
.post
);
9562 if (to_expr
->ts
.type
== BT_CLASS
)
9566 gfc_free_expr (to_expr2
);
9567 gfc_init_se (&to_se
, NULL
);
9568 to_se
.want_pointer
= 1;
9569 gfc_add_vptr_component (to_expr
);
9570 gfc_conv_expr (&to_se
, to_expr
);
9572 if (from_expr
->ts
.type
== BT_CLASS
)
9574 if (UNLIMITED_POLY (from_expr
))
9578 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9582 gfc_free_expr (from_expr2
);
9583 gfc_init_se (&from_se
, NULL
);
9584 from_se
.want_pointer
= 1;
9585 gfc_add_vptr_component (from_expr
);
9586 gfc_conv_expr (&from_se
, from_expr
);
9587 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9588 fold_convert (TREE_TYPE (to_se
.expr
),
9591 /* Reset _vptr component to declared type. */
9593 /* Unlimited polymorphic. */
9594 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9595 fold_convert (TREE_TYPE (from_se
.expr
),
9596 null_pointer_node
));
9599 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9600 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9601 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9606 vtab
= gfc_find_vtab (&from_expr
->ts
);
9608 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9609 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9610 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9614 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
9616 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
9617 fold_convert (TREE_TYPE (to_se
.string_length
),
9618 from_se
.string_length
));
9619 if (from_expr
->ts
.deferred
)
9620 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
9621 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
9624 return gfc_finish_block (&block
);
9627 /* Update _vptr component. */
9628 if (to_expr
->ts
.type
== BT_CLASS
)
9632 to_se
.want_pointer
= 1;
9633 to_expr2
= gfc_copy_expr (to_expr
);
9634 gfc_add_vptr_component (to_expr2
);
9635 gfc_conv_expr (&to_se
, to_expr2
);
9637 if (from_expr
->ts
.type
== BT_CLASS
)
9639 if (UNLIMITED_POLY (from_expr
))
9643 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9647 from_se
.want_pointer
= 1;
9648 from_expr2
= gfc_copy_expr (from_expr
);
9649 gfc_add_vptr_component (from_expr2
);
9650 gfc_conv_expr (&from_se
, from_expr2
);
9651 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9652 fold_convert (TREE_TYPE (to_se
.expr
),
9655 /* Reset _vptr component to declared type. */
9657 /* Unlimited polymorphic. */
9658 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9659 fold_convert (TREE_TYPE (from_se
.expr
),
9660 null_pointer_node
));
9663 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9664 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9665 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9670 vtab
= gfc_find_vtab (&from_expr
->ts
);
9672 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9673 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9674 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9677 gfc_free_expr (to_expr2
);
9678 gfc_init_se (&to_se
, NULL
);
9680 if (from_expr
->ts
.type
== BT_CLASS
)
9682 gfc_free_expr (from_expr2
);
9683 gfc_init_se (&from_se
, NULL
);
9688 /* Deallocate "to". */
9689 if (from_expr
->rank
== 0)
9691 to_se
.want_coarray
= 1;
9692 from_se
.want_coarray
= 1;
9694 gfc_conv_expr_descriptor (&to_se
, to_expr
);
9695 gfc_conv_expr_descriptor (&from_se
, from_expr
);
9697 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
9698 is an image control "statement", cf. IR F08/0040 in 12-006A. */
9699 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9703 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
9704 NULL_TREE
, NULL_TREE
, true, to_expr
,
9706 gfc_add_expr_to_block (&block
, tmp
);
9708 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9709 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9710 boolean_type_node
, tmp
,
9711 fold_convert (TREE_TYPE (tmp
),
9712 null_pointer_node
));
9713 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
9714 3, null_pointer_node
, null_pointer_node
,
9715 build_int_cst (integer_type_node
, 0));
9717 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
9718 tmp
, build_empty_stmt (input_location
));
9719 gfc_add_expr_to_block (&block
, tmp
);
9723 if (to_expr
->ts
.type
== BT_DERIVED
9724 && to_expr
->ts
.u
.derived
->attr
.alloc_comp
)
9726 tmp
= gfc_deallocate_alloc_comp (to_expr
->ts
.u
.derived
,
9727 to_se
.expr
, to_expr
->rank
);
9728 gfc_add_expr_to_block (&block
, tmp
);
9731 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9732 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9733 NULL_TREE
, true, to_expr
, false);
9734 gfc_add_expr_to_block (&block
, tmp
);
9737 /* Move the pointer and update the array descriptor data. */
9738 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
9740 /* Set "from" to NULL. */
9741 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
9742 gfc_add_modify_loc (input_location
, &block
, tmp
,
9743 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
9746 if (to_expr
->ts
.type
== BT_CHARACTER
&& to_expr
->ts
.deferred
)
9748 gfc_add_modify_loc (input_location
, &block
, to_se
.string_length
,
9749 fold_convert (TREE_TYPE (to_se
.string_length
),
9750 from_se
.string_length
));
9751 if (from_expr
->ts
.deferred
)
9752 gfc_add_modify_loc (input_location
, &block
, from_se
.string_length
,
9753 build_int_cst (TREE_TYPE (from_se
.string_length
), 0));
9756 return gfc_finish_block (&block
);
9761 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
9765 gcc_assert (code
->resolved_isym
);
9767 switch (code
->resolved_isym
->id
)
9769 case GFC_ISYM_MOVE_ALLOC
:
9770 res
= conv_intrinsic_move_alloc (code
);
9773 case GFC_ISYM_ATOMIC_CAS
:
9774 res
= conv_intrinsic_atomic_cas (code
);
9777 case GFC_ISYM_ATOMIC_ADD
:
9778 case GFC_ISYM_ATOMIC_AND
:
9779 case GFC_ISYM_ATOMIC_DEF
:
9780 case GFC_ISYM_ATOMIC_OR
:
9781 case GFC_ISYM_ATOMIC_XOR
:
9782 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9783 case GFC_ISYM_ATOMIC_FETCH_AND
:
9784 case GFC_ISYM_ATOMIC_FETCH_OR
:
9785 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9786 res
= conv_intrinsic_atomic_op (code
);
9789 case GFC_ISYM_ATOMIC_REF
:
9790 res
= conv_intrinsic_atomic_ref (code
);
9793 case GFC_ISYM_EVENT_QUERY
:
9794 res
= conv_intrinsic_event_query (code
);
9797 case GFC_ISYM_C_F_POINTER
:
9798 case GFC_ISYM_C_F_PROCPOINTER
:
9799 res
= conv_isocbinding_subroutine (code
);
9802 case GFC_ISYM_CAF_SEND
:
9803 res
= conv_caf_send (code
);
9806 case GFC_ISYM_CO_BROADCAST
:
9807 case GFC_ISYM_CO_MIN
:
9808 case GFC_ISYM_CO_MAX
:
9809 case GFC_ISYM_CO_REDUCE
:
9810 case GFC_ISYM_CO_SUM
:
9811 res
= conv_co_collective (code
);
9815 res
= conv_intrinsic_free (code
);
9818 case GFC_ISYM_SYSTEM_CLOCK
:
9819 res
= conv_intrinsic_system_clock (code
);
9830 #include "gt-fortran-trans-intrinsic.h"