1 /* Intrinsic translation
2 Copyright (C) 2002-2014 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. */
29 #include "stringpool.h"
30 #include "tree-nested.h"
31 #include "stor-layout.h"
33 #include "diagnostic-core.h" /* For internal_error. */
34 #include "toplev.h" /* For rest_of_decl_compilation. */
38 #include "intrinsic.h"
40 #include "trans-const.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
45 #include "tree-nested.h"
48 /* This maps Fortran intrinsic math functions to external library or GCC
50 typedef struct GTY(()) gfc_intrinsic_map_t
{
51 /* The explicit enum is required to work around inadequacies in the
52 garbage collection/gengtype parsing mechanism. */
55 /* Enum value from the "language-independent", aka C-centric, part
56 of gcc, or END_BUILTINS of no such value set. */
57 enum built_in_function float_built_in
;
58 enum built_in_function double_built_in
;
59 enum built_in_function long_double_built_in
;
60 enum built_in_function complex_float_built_in
;
61 enum built_in_function complex_double_built_in
;
62 enum built_in_function complex_long_double_built_in
;
64 /* True if the naming pattern is to prepend "c" for complex and
65 append "f" for kind=4. False if the naming pattern is to
66 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
69 /* True if a complex version of the function exists. */
70 bool complex_available
;
72 /* True if the function should be marked const. */
75 /* The base library name of this function. */
78 /* Cache decls created for the various operand types. */
90 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
91 defines complex variants of all of the entries in mathbuiltins.def
93 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
94 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
95 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
96 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
97 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
100 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
101 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
102 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
103 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
105 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
106 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
109 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
111 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
112 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
113 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
114 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
115 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
117 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
119 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
120 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
121 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
122 #include "mathbuiltins.def"
124 /* Functions in libgfortran. */
125 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
128 LIB_FUNCTION (NONE
, NULL
, false)
133 #undef DEFINE_MATH_BUILTIN
134 #undef DEFINE_MATH_BUILTIN_C
137 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
140 /* Find the correct variant of a given builtin from its argument. */
142 builtin_decl_for_precision (enum built_in_function base_built_in
,
145 enum built_in_function i
= END_BUILTINS
;
147 gfc_intrinsic_map_t
*m
;
148 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
151 if (precision
== TYPE_PRECISION (float_type_node
))
152 i
= m
->float_built_in
;
153 else if (precision
== TYPE_PRECISION (double_type_node
))
154 i
= m
->double_built_in
;
155 else if (precision
== TYPE_PRECISION (long_double_type_node
))
156 i
= m
->long_double_built_in
;
157 else if (precision
== TYPE_PRECISION (float128_type_node
))
159 /* Special treatment, because it is not exactly a built-in, but
160 a library function. */
161 return m
->real16_decl
;
164 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
169 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
172 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
174 if (gfc_real_kinds
[i
].c_float128
)
176 /* For __float128, the story is a bit different, because we return
177 a decl to a library function rather than a built-in. */
178 gfc_intrinsic_map_t
*m
;
179 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
182 return m
->real16_decl
;
185 return builtin_decl_for_precision (double_built_in
,
186 gfc_real_kinds
[i
].mode_precision
);
190 /* Evaluate the arguments to an intrinsic function. The value
191 of NARGS may be less than the actual number of arguments in EXPR
192 to allow optional "KIND" arguments that are not included in the
193 generated code to be ignored. */
196 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
197 tree
*argarray
, int nargs
)
199 gfc_actual_arglist
*actual
;
201 gfc_intrinsic_arg
*formal
;
205 formal
= expr
->value
.function
.isym
->formal
;
206 actual
= expr
->value
.function
.actual
;
208 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
209 actual
= actual
->next
,
210 formal
= formal
? formal
->next
: NULL
)
214 /* Skip omitted optional arguments. */
221 /* Evaluate the parameter. This will substitute scalarized
222 references automatically. */
223 gfc_init_se (&argse
, se
);
225 if (e
->ts
.type
== BT_CHARACTER
)
227 gfc_conv_expr (&argse
, e
);
228 gfc_conv_string_parameter (&argse
);
229 argarray
[curr_arg
++] = argse
.string_length
;
230 gcc_assert (curr_arg
< nargs
);
233 gfc_conv_expr_val (&argse
, e
);
235 /* If an optional argument is itself an optional dummy argument,
236 check its presence and substitute a null if absent. */
237 if (e
->expr_type
== EXPR_VARIABLE
238 && e
->symtree
->n
.sym
->attr
.optional
241 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
243 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
244 gfc_add_block_to_block (&se
->post
, &argse
.post
);
245 argarray
[curr_arg
] = argse
.expr
;
249 /* Count the number of actual arguments to the intrinsic function EXPR
250 including any "hidden" string length arguments. */
253 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
256 gfc_actual_arglist
*actual
;
258 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
263 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
273 /* Conversions between different types are output by the frontend as
274 intrinsic functions. We implement these directly with inline code. */
277 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
283 nargs
= gfc_intrinsic_argument_list_length (expr
);
284 args
= XALLOCAVEC (tree
, nargs
);
286 /* Evaluate all the arguments passed. Whilst we're only interested in the
287 first one here, there are other parts of the front-end that assume this
288 and will trigger an ICE if it's not the case. */
289 type
= gfc_typenode_for_spec (&expr
->ts
);
290 gcc_assert (expr
->value
.function
.actual
->expr
);
291 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
293 /* Conversion between character kinds involves a call to a library
295 if (expr
->ts
.type
== BT_CHARACTER
)
297 tree fndecl
, var
, addr
, tmp
;
299 if (expr
->ts
.kind
== 1
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
301 fndecl
= gfor_fndecl_convert_char4_to_char1
;
302 else if (expr
->ts
.kind
== 4
303 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
304 fndecl
= gfor_fndecl_convert_char1_to_char4
;
308 /* Create the variable storing the converted value. */
309 type
= gfc_get_pchar_type (expr
->ts
.kind
);
310 var
= gfc_create_var (type
, "str");
311 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
313 /* Call the library function that will perform the conversion. */
314 gcc_assert (nargs
>= 2);
315 tmp
= build_call_expr_loc (input_location
,
316 fndecl
, 3, addr
, args
[0], args
[1]);
317 gfc_add_expr_to_block (&se
->pre
, tmp
);
319 /* Free the temporary afterwards. */
320 tmp
= gfc_call_free (var
);
321 gfc_add_expr_to_block (&se
->post
, tmp
);
324 se
->string_length
= args
[0];
329 /* Conversion from complex to non-complex involves taking the real
330 component of the value. */
331 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
332 && expr
->ts
.type
!= BT_COMPLEX
)
336 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
337 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
341 se
->expr
= convert (type
, args
[0]);
344 /* This is needed because the gcc backend only implements
345 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
346 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
347 Similarly for CEILING. */
350 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
357 argtype
= TREE_TYPE (arg
);
358 arg
= gfc_evaluate_now (arg
, pblock
);
360 intval
= convert (type
, arg
);
361 intval
= gfc_evaluate_now (intval
, pblock
);
363 tmp
= convert (argtype
, intval
);
364 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
365 boolean_type_node
, tmp
, arg
);
367 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
368 intval
, build_int_cst (type
, 1));
369 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
374 /* Round to nearest integer, away from zero. */
377 build_round_expr (tree arg
, tree restype
)
381 int argprec
, resprec
;
383 argtype
= TREE_TYPE (arg
);
384 argprec
= TYPE_PRECISION (argtype
);
385 resprec
= TYPE_PRECISION (restype
);
387 /* Depending on the type of the result, choose the int intrinsic
388 (iround, available only as a builtin, therefore cannot use it for
389 __float128), long int intrinsic (lround family) or long long
390 intrinsic (llround). We might also need to convert the result
392 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
393 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
394 else if (resprec
<= LONG_TYPE_SIZE
)
395 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
396 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
397 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
401 return fold_convert (restype
, build_call_expr_loc (input_location
,
406 /* Convert a real to an integer using a specific rounding mode.
407 Ideally we would just build the corresponding GENERIC node,
408 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
411 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
412 enum rounding_mode op
)
417 return build_fixbound_expr (pblock
, arg
, type
, 0);
421 return build_fixbound_expr (pblock
, arg
, type
, 1);
425 return build_round_expr (arg
, type
);
429 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
438 /* Round a real value using the specified rounding mode.
439 We use a temporary integer of that same kind size as the result.
440 Values larger than those that can be represented by this kind are
441 unchanged, as they will not be accurate enough to represent the
443 huge = HUGE (KIND (a))
444 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
448 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
460 kind
= expr
->ts
.kind
;
461 nargs
= gfc_intrinsic_argument_list_length (expr
);
464 /* We have builtin functions for some cases. */
468 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
472 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
479 /* Evaluate the argument. */
480 gcc_assert (expr
->value
.function
.actual
->expr
);
481 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
483 /* Use a builtin function if one exists. */
484 if (decl
!= NULL_TREE
)
486 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
490 /* This code is probably redundant, but we'll keep it lying around just
492 type
= gfc_typenode_for_spec (&expr
->ts
);
493 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
495 /* Test if the value is too large to handle sensibly. */
496 gfc_set_model_kind (kind
);
498 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
499 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
500 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
501 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
504 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
505 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
506 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
508 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
510 itype
= gfc_get_int_type (kind
);
512 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
513 tmp
= convert (type
, tmp
);
514 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
520 /* Convert to an integer using the specified rounding mode. */
523 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
529 nargs
= gfc_intrinsic_argument_list_length (expr
);
530 args
= XALLOCAVEC (tree
, nargs
);
532 /* Evaluate the argument, we process all arguments even though we only
533 use the first one for code generation purposes. */
534 type
= gfc_typenode_for_spec (&expr
->ts
);
535 gcc_assert (expr
->value
.function
.actual
->expr
);
536 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
538 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
540 /* Conversion to a different integer kind. */
541 se
->expr
= convert (type
, args
[0]);
545 /* Conversion from complex to non-complex involves taking the real
546 component of the value. */
547 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
548 && expr
->ts
.type
!= BT_COMPLEX
)
552 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
553 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
557 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
562 /* Get the imaginary component of a value. */
565 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
569 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
570 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
571 TREE_TYPE (TREE_TYPE (arg
)), arg
);
575 /* Get the complex conjugate of a value. */
578 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
582 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
583 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
589 define_quad_builtin (const char *name
, tree type
, bool is_const
)
592 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
595 /* Mark the decl as external. */
596 DECL_EXTERNAL (fndecl
) = 1;
597 TREE_PUBLIC (fndecl
) = 1;
599 /* Mark it __attribute__((const)). */
600 TREE_READONLY (fndecl
) = is_const
;
602 rest_of_decl_compilation (fndecl
, 1, 0);
609 /* Initialize function decls for library functions. The external functions
610 are created as required. Builtin functions are added here. */
613 gfc_build_intrinsic_lib_fndecls (void)
615 gfc_intrinsic_map_t
*m
;
616 tree quad_decls
[END_BUILTINS
+ 1];
618 if (gfc_real16_is_float128
)
620 /* If we have soft-float types, we create the decls for their
621 C99-like library functions. For now, we only handle __float128
622 q-suffixed functions. */
624 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
625 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
627 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
629 type
= float128_type_node
;
630 complex_type
= complex_float128_type_node
;
631 /* type (*) (type) */
632 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
634 func_iround
= build_function_type_list (integer_type_node
,
636 /* long (*) (type) */
637 func_lround
= build_function_type_list (long_integer_type_node
,
639 /* long long (*) (type) */
640 func_llround
= build_function_type_list (long_long_integer_type_node
,
642 /* type (*) (type, type) */
643 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
644 /* type (*) (type, &int) */
646 = build_function_type_list (type
,
648 build_pointer_type (integer_type_node
),
650 /* type (*) (type, int) */
651 func_scalbn
= build_function_type_list (type
,
652 type
, integer_type_node
, NULL_TREE
);
653 /* type (*) (complex type) */
654 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
655 /* complex type (*) (complex type, complex type) */
657 = build_function_type_list (complex_type
,
658 complex_type
, complex_type
, NULL_TREE
);
660 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
661 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
662 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
664 /* Only these built-ins are actually needed here. These are used directly
665 from the code, when calling builtin_decl_for_precision() or
666 builtin_decl_for_float_type(). The others are all constructed by
667 gfc_get_intrinsic_lib_fndecl(). */
668 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
669 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
671 #include "mathbuiltins.def"
675 #undef DEFINE_MATH_BUILTIN
676 #undef DEFINE_MATH_BUILTIN_C
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 internal_error ("Intrinsic function %s(%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
, current_function_decl
);
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(s) intrinsic function is translated into
910 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
912 tree arg
, type
, res
, tmp
, frexp
;
914 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
915 expr
->value
.function
.actual
->expr
->ts
.kind
);
917 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
919 res
= gfc_create_var (integer_type_node
, NULL
);
920 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
921 gfc_build_addr_expr (NULL_TREE
, res
));
922 gfc_add_expr_to_block (&se
->pre
, tmp
);
924 type
= gfc_typenode_for_spec (&expr
->ts
);
925 se
->expr
= fold_convert (type
, res
);
929 /* Convert the coindex of a coarray into an image index; the result is
930 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2)+1)*extent(1)
931 + (idx(3)-lcobound(3)+1)*extent(2) + ... */
934 caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
937 tree lbound
, ubound
, extent
, tmp
, img_idx
;
941 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
942 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
944 gcc_assert (ref
!= NULL
);
946 img_idx
= integer_zero_node
;
947 extent
= integer_one_node
;
948 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
949 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
951 gfc_init_se (&se
, NULL
);
952 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
953 gfc_add_block_to_block (block
, &se
.pre
);
954 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
955 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
956 integer_type_node
, se
.expr
,
957 fold_convert(integer_type_node
, lbound
));
958 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
960 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
962 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
964 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
965 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
966 extent
= fold_convert (integer_type_node
, extent
);
970 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
972 gfc_init_se (&se
, NULL
);
973 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
974 gfc_add_block_to_block (block
, &se
.pre
);
975 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
976 lbound
= fold_convert (integer_type_node
, lbound
);
977 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
978 integer_type_node
, se
.expr
, lbound
);
979 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
981 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
983 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
985 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
986 ubound
= fold_convert (integer_type_node
, ubound
);
987 extent
= fold_build2_loc (input_location
, MINUS_EXPR
,
988 integer_type_node
, ubound
, lbound
);
989 extent
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
990 extent
, integer_one_node
);
993 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
994 img_idx
, integer_one_node
);
999 /* Fill in the following structure
1000 struct caf_vector_t {
1001 size_t nvec; // size of the vector
1008 ptrdiff_t lower_bound;
1009 ptrdiff_t upper_bound;
1016 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
1017 tree lower
, tree upper
, tree stride
,
1018 tree vector
, int kind
, tree nvec
)
1020 tree field
, type
, tmp
;
1022 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
1023 type
= TREE_TYPE (desc
);
1025 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1026 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1027 desc
, field
, NULL_TREE
);
1028 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
1031 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1032 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1033 desc
, field
, NULL_TREE
);
1034 type
= TREE_TYPE (desc
);
1036 /* Access the inner struct. */
1037 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
1038 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1039 desc
, field
, NULL_TREE
);
1040 type
= TREE_TYPE (desc
);
1042 if (vector
!= NULL_TREE
)
1044 /* Set dim.lower/upper/stride. */
1045 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1046 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1047 desc
, field
, NULL_TREE
);
1048 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
1049 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1050 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1051 desc
, field
, NULL_TREE
);
1052 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
1056 /* Set vector and kind. */
1057 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1058 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1059 desc
, field
, NULL_TREE
);
1060 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1062 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1063 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1064 desc
, field
, NULL_TREE
);
1065 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1067 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1068 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1069 desc
, field
, NULL_TREE
);
1070 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1076 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1079 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1080 tree lbound
, ubound
, tmp
;
1083 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1085 for (i
= 0; i
< ar
->dimen
; i
++)
1086 switch (ar
->dimen_type
[i
])
1091 gfc_init_se (&argse
, NULL
);
1092 gfc_conv_expr (&argse
, ar
->end
[i
]);
1093 gfc_add_block_to_block (block
, &argse
.pre
);
1094 upper
= gfc_evaluate_now (argse
.expr
, block
);
1097 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1100 gfc_init_se (&argse
, NULL
);
1101 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1102 gfc_add_block_to_block (block
, &argse
.pre
);
1103 stride
= gfc_evaluate_now (argse
.expr
, block
);
1106 stride
= gfc_index_one_node
;
1112 gfc_init_se (&argse
, NULL
);
1113 gfc_conv_expr (&argse
, ar
->start
[i
]);
1114 gfc_add_block_to_block (block
, &argse
.pre
);
1115 lower
= gfc_evaluate_now (argse
.expr
, block
);
1118 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1119 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1122 stride
= gfc_index_one_node
;
1125 nvec
= size_zero_node
;
1126 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1131 gfc_init_se (&argse
, NULL
);
1132 argse
.descriptor_only
= 1;
1133 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1134 gfc_add_block_to_block (block
, &argse
.pre
);
1135 vector
= argse
.expr
;
1136 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1137 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1138 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1139 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1140 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1141 TREE_TYPE (nvec
), nvec
, tmp
);
1142 lower
= gfc_index_zero_node
;
1143 upper
= gfc_index_zero_node
;
1144 stride
= gfc_index_zero_node
;
1145 vector
= gfc_conv_descriptor_data_get (vector
);
1146 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1147 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1152 return gfc_build_addr_expr (NULL_TREE
, var
);
1157 get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1162 /* Coarray token. */
1163 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1165 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1166 == GFC_ARRAY_ALLOCATABLE
1167 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1168 *token
= gfc_conv_descriptor_token (caf_decl
);
1170 else if (DECL_LANG_SPECIFIC (caf_decl
)
1171 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1172 *token
= GFC_DECL_TOKEN (caf_decl
);
1175 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1176 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1177 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1180 /* Offset between the coarray base address and the address wanted. */
1181 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1182 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1183 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1184 *offset
= build_int_cst (gfc_array_index_type
, 0);
1185 else if (DECL_LANG_SPECIFIC (caf_decl
)
1186 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1187 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1188 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1189 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1191 *offset
= build_int_cst (gfc_array_index_type
, 0);
1193 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1194 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1196 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1197 tmp
= gfc_conv_descriptor_data_get (tmp
);
1199 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1200 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1203 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1207 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1208 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1210 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1211 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1214 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1218 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1219 fold_convert (gfc_array_index_type
, *offset
),
1220 fold_convert (gfc_array_index_type
, tmp
));
1224 /* Get data from a remote coarray. */
1227 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
)
1229 gfc_expr
*array_expr
;
1231 tree caf_decl
, token
, offset
, image_index
, tmp
;
1232 tree res_var
, dst_var
, type
, kind
, vec
;
1234 gcc_assert (gfc_option
.coarray
== GFC_FCOARRAY_LIB
);
1236 if (se
->ss
&& se
->ss
->info
->useflags
)
1238 /* Access the previously obtained result. */
1239 gfc_conv_tmp_array_ref (se
);
1243 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1244 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1245 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1250 gfc_init_se (&argse
, NULL
);
1251 if (array_expr
->rank
== 0)
1253 symbol_attribute attr
;
1255 gfc_clear_attr (&attr
);
1256 gfc_conv_expr (&argse
, array_expr
);
1258 if (lhs
== NULL_TREE
)
1260 gfc_clear_attr (&attr
);
1261 if (array_expr
->ts
.type
== BT_CHARACTER
)
1262 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1263 argse
.string_length
);
1265 res_var
= gfc_create_var (type
, "caf_res");
1266 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1267 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1269 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1270 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1274 /* If has_vector, pass descriptor for whole array and the
1275 vector bounds separately. */
1276 gfc_array_ref
*ar
, ar2
;
1277 bool has_vector
= false;
1279 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1282 ar
= gfc_find_array_ref (expr
);
1284 memset (ar
, '\0', sizeof (*ar
));
1288 gfc_conv_expr_descriptor (&argse
, array_expr
);
1289 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1290 has the wrong type if component references are done. */
1291 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1292 gfc_get_dtype_rank_type (array_expr
->rank
, type
));
1295 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, ar
);
1299 if (lhs
== NULL_TREE
)
1301 /* Create temporary. */
1302 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1303 if (se
->loop
->to
[n
] == NULL_TREE
)
1306 gfc_conv_descriptor_lbound_get (argse
.expr
, gfc_rank_cst
[n
]);
1308 gfc_conv_descriptor_ubound_get (argse
.expr
, gfc_rank_cst
[n
]);
1310 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1311 NULL_TREE
, false, true, false,
1312 &array_expr
->where
);
1313 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1314 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1316 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1319 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1320 if (lhs_kind
== NULL_TREE
)
1323 vec
= null_pointer_node
;
1325 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1326 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1328 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1329 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1330 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1331 image_index
= caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1332 get_caf_token_offset (&token
, &offset
, caf_decl
, argse
.expr
, array_expr
);
1334 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 8,
1335 token
, offset
, image_index
, argse
.expr
, vec
,
1336 dst_var
, kind
, lhs_kind
);
1337 gfc_add_expr_to_block (&se
->pre
, tmp
);
1340 gfc_advance_se_ss_chain (se
);
1343 if (array_expr
->ts
.type
== BT_CHARACTER
)
1344 se
->string_length
= argse
.string_length
;
1348 /* Send data to a remove coarray. */
1351 conv_caf_send (gfc_code
*code
) {
1352 gfc_expr
*lhs_expr
, *rhs_expr
;
1353 gfc_se lhs_se
, rhs_se
;
1355 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1356 tree lhs_type
= NULL_TREE
;
1357 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1359 gcc_assert (gfc_option
.coarray
== GFC_FCOARRAY_LIB
);
1361 lhs_expr
= code
->ext
.actual
->expr
;
1362 rhs_expr
= code
->ext
.actual
->next
->expr
;
1363 gfc_init_block (&block
);
1366 gfc_init_se (&lhs_se
, NULL
);
1367 if (lhs_expr
->rank
== 0)
1369 symbol_attribute attr
;
1370 gfc_clear_attr (&attr
);
1371 gfc_conv_expr (&lhs_se
, lhs_expr
);
1372 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1373 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1374 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1378 /* If has_vector, pass descriptor for whole array and the
1379 vector bounds separately. */
1380 gfc_array_ref
*ar
, ar2
;
1381 bool has_vector
= false;
1383 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1386 ar
= gfc_find_array_ref (lhs_expr
);
1388 memset (ar
, '\0', sizeof (*ar
));
1392 lhs_se
.want_pointer
= 1;
1393 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1394 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1395 has the wrong type if component references are done. */
1396 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1397 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1398 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1399 gfc_get_dtype_rank_type (lhs_expr
->rank
, lhs_type
));
1402 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, ar
);
1407 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1408 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1410 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1411 temporary and a loop. */
1412 if (!gfc_is_coindexed (lhs_expr
))
1414 gcc_assert (gfc_is_coindexed (rhs_expr
));
1415 gfc_init_se (&rhs_se
, NULL
);
1416 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
);
1417 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1418 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1419 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1420 return gfc_finish_block (&block
);
1423 /* Obtain token, offset and image index for the LHS. */
1425 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1426 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1427 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1428 image_index
= caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1429 get_caf_token_offset (&token
, &offset
, caf_decl
, lhs_se
.expr
, lhs_expr
);
1432 gfc_init_se (&rhs_se
, NULL
);
1433 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1434 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1435 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1436 if (rhs_expr
->rank
== 0)
1438 symbol_attribute attr
;
1439 gfc_clear_attr (&attr
);
1440 gfc_conv_expr (&rhs_se
, rhs_expr
);
1441 if (!gfc_is_coindexed (rhs_expr
) && rhs_expr
->ts
.type
!= BT_CHARACTER
)
1442 rhs_se
.expr
= fold_convert (lhs_type
, rhs_se
.expr
);
1443 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
1444 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
1448 /* If has_vector, pass descriptor for whole array and the
1449 vector bounds separately. */
1450 gfc_array_ref
*ar
, ar2
;
1451 bool has_vector
= false;
1454 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
1457 ar
= gfc_find_array_ref (rhs_expr
);
1459 memset (ar
, '\0', sizeof (*ar
));
1463 rhs_se
.want_pointer
= 1;
1464 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
1465 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1466 has the wrong type if component references are done. */
1467 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
1468 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
1469 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1470 gfc_get_dtype_rank_type (rhs_expr
->rank
, tmp2
));
1473 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, ar
);
1478 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1480 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
1482 if (!gfc_is_coindexed (rhs_expr
))
1483 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 8, token
,
1484 offset
, image_index
, lhs_se
.expr
, vec
,
1485 rhs_se
.expr
, lhs_kind
, rhs_kind
);
1488 tree rhs_token
, rhs_offset
, rhs_image_index
;
1490 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
1491 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1492 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1493 rhs_image_index
= caf_get_image_index (&block
, rhs_expr
, caf_decl
);
1494 get_caf_token_offset (&rhs_token
, &rhs_offset
, caf_decl
, rhs_se
.expr
,
1496 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
, 12,
1497 token
, offset
, image_index
, lhs_se
.expr
, vec
,
1498 rhs_token
, rhs_offset
, rhs_image_index
,
1499 rhs_se
.expr
, rhs_vec
, lhs_kind
, rhs_kind
);
1501 gfc_add_expr_to_block (&block
, tmp
);
1502 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1503 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1504 return gfc_finish_block (&block
);
1509 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
1512 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
1513 lbound
, ubound
, extent
, ml
;
1516 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
1518 if (expr
->value
.function
.actual
->expr
1519 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
1520 distance
= expr
->value
.function
.actual
->expr
;
1522 /* The case -fcoarray=single is handled elsewhere. */
1523 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
1525 /* Argument-free version: THIS_IMAGE(). */
1526 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
1530 gfc_init_se (&argse
, NULL
);
1531 gfc_conv_expr_val (&argse
, distance
);
1532 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1533 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1534 tmp
= fold_convert (integer_type_node
, argse
.expr
);
1537 tmp
= integer_zero_node
;
1538 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1540 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1545 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1547 type
= gfc_get_int_type (gfc_default_integer_kind
);
1548 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1549 rank
= expr
->value
.function
.actual
->expr
->rank
;
1551 /* Obtain the descriptor of the COARRAY. */
1552 gfc_init_se (&argse
, NULL
);
1553 argse
.want_coarray
= 1;
1554 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1555 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1556 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1561 /* Create an implicit second parameter from the loop variable. */
1562 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
1563 gcc_assert (corank
> 0);
1564 gcc_assert (se
->loop
->dimen
== 1);
1565 gcc_assert (se
->ss
->info
->expr
== expr
);
1567 dim_arg
= se
->loop
->loopvar
[0];
1568 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
1569 gfc_array_index_type
, dim_arg
,
1570 build_int_cst (TREE_TYPE (dim_arg
), 1));
1571 gfc_advance_se_ss_chain (se
);
1575 /* Use the passed DIM= argument. */
1576 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
1577 gfc_init_se (&argse
, NULL
);
1578 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
1579 gfc_array_index_type
);
1580 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1581 dim_arg
= argse
.expr
;
1583 if (INTEGER_CST_P (dim_arg
))
1585 if (wi::ltu_p (dim_arg
, 1)
1586 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
1587 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1588 "dimension index", expr
->value
.function
.isym
->name
,
1591 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1593 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1594 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1596 build_int_cst (TREE_TYPE (dim_arg
), 1));
1597 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1598 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1600 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1601 boolean_type_node
, cond
, tmp
);
1602 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1607 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1608 one always has a dim_arg argument.
1610 m = this_image() - 1
1613 sub(1) = m + lcobound(corank)
1617 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1620 extent = gfc_extent(i)
1628 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1629 : m + lcobound(corank)
1632 /* this_image () - 1. */
1633 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1635 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
1636 fold_convert (type
, tmp
), build_int_cst (type
, 1));
1639 /* sub(1) = m + lcobound(corank). */
1640 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1641 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1643 lbound
= fold_convert (type
, lbound
);
1644 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1650 m
= gfc_create_var (type
, NULL
);
1651 ml
= gfc_create_var (type
, NULL
);
1652 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1653 min_var
= gfc_create_var (integer_type_node
, NULL
);
1655 /* m = this_image () - 1. */
1656 gfc_add_modify (&se
->pre
, m
, tmp
);
1658 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1659 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1660 fold_convert (integer_type_node
, dim_arg
),
1661 build_int_cst (integer_type_node
, rank
- 1));
1662 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1663 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1665 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1668 tmp
= build_int_cst (integer_type_node
, rank
);
1669 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1671 exit_label
= gfc_build_label_decl (NULL_TREE
);
1672 TREE_USED (exit_label
) = 1;
1675 gfc_init_block (&loop
);
1678 gfc_add_modify (&loop
, ml
, m
);
1681 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1682 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1683 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1684 extent
= fold_convert (type
, extent
);
1687 gfc_add_modify (&loop
, m
,
1688 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1691 /* Exit condition: if (i >= min_var) goto exit_label. */
1692 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1694 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1695 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1696 build_empty_stmt (input_location
));
1697 gfc_add_expr_to_block (&loop
, tmp
);
1699 /* Increment loop variable: i++. */
1700 gfc_add_modify (&loop
, loop_var
,
1701 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1703 build_int_cst (integer_type_node
, 1)));
1705 /* Making the loop... actually loop! */
1706 tmp
= gfc_finish_block (&loop
);
1707 tmp
= build1_v (LOOP_EXPR
, tmp
);
1708 gfc_add_expr_to_block (&se
->pre
, tmp
);
1710 /* The exit label. */
1711 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1712 gfc_add_expr_to_block (&se
->pre
, tmp
);
1714 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1715 : m + lcobound(corank) */
1717 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1718 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1720 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1721 fold_build2_loc (input_location
, PLUS_EXPR
,
1722 gfc_array_index_type
, dim_arg
,
1723 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1724 lbound
= fold_convert (type
, lbound
);
1726 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1727 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1729 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1731 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1732 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1738 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1740 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1742 gfc_se argse
, subse
;
1743 int rank
, corank
, codim
;
1745 type
= gfc_get_int_type (gfc_default_integer_kind
);
1746 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1747 rank
= expr
->value
.function
.actual
->expr
->rank
;
1749 /* Obtain the descriptor of the COARRAY. */
1750 gfc_init_se (&argse
, NULL
);
1751 argse
.want_coarray
= 1;
1752 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1753 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1754 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1757 /* Obtain a handle to the SUB argument. */
1758 gfc_init_se (&subse
, NULL
);
1759 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1760 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1761 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1762 subdesc
= build_fold_indirect_ref_loc (input_location
,
1763 gfc_conv_descriptor_data_get (subse
.expr
));
1765 /* Fortran 2008 does not require that the values remain in the cobounds,
1766 thus we need explicitly check this - and return 0 if they are exceeded. */
1768 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1769 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1770 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1771 fold_convert (gfc_array_index_type
, tmp
),
1774 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1776 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1777 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1778 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1779 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1780 fold_convert (gfc_array_index_type
, tmp
),
1782 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1783 boolean_type_node
, invalid_bound
, cond
);
1784 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1785 fold_convert (gfc_array_index_type
, tmp
),
1787 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1788 boolean_type_node
, invalid_bound
, cond
);
1791 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
1793 /* See Fortran 2008, C.10 for the following algorithm. */
1795 /* coindex = sub(corank) - lcobound(n). */
1796 coindex
= fold_convert (gfc_array_index_type
,
1797 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1799 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1800 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1801 fold_convert (gfc_array_index_type
, coindex
),
1804 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1806 tree extent
, ubound
;
1808 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1809 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1810 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1811 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1813 /* coindex *= extent. */
1814 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1815 gfc_array_index_type
, coindex
, extent
);
1817 /* coindex += sub(codim). */
1818 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1819 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1820 gfc_array_index_type
, coindex
,
1821 fold_convert (gfc_array_index_type
, tmp
));
1823 /* coindex -= lbound(codim). */
1824 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1825 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1826 gfc_array_index_type
, coindex
, lbound
);
1829 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1830 fold_convert(type
, coindex
),
1831 build_int_cst (type
, 1));
1833 /* Return 0 if "coindex" exceeds num_images(). */
1835 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1836 num_images
= build_int_cst (type
, 1);
1839 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1841 build_int_cst (integer_type_node
, -1));
1842 num_images
= fold_convert (type
, tmp
);
1845 tmp
= gfc_create_var (type
, NULL
);
1846 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1848 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1850 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1852 fold_convert (boolean_type_node
, invalid_bound
));
1853 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1854 build_int_cst (type
, 0), tmp
);
1859 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
1861 tree tmp
, distance
, failed
;
1864 if (expr
->value
.function
.actual
->expr
)
1866 gfc_init_se (&argse
, NULL
);
1867 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
1868 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1869 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1870 distance
= fold_convert (integer_type_node
, argse
.expr
);
1873 distance
= integer_zero_node
;
1875 if (expr
->value
.function
.actual
->next
->expr
)
1877 gfc_init_se (&argse
, NULL
);
1878 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
1879 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1880 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1881 failed
= fold_convert (integer_type_node
, argse
.expr
);
1884 failed
= build_int_cst (integer_type_node
, -1);
1886 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1888 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
1893 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1897 gfc_init_se (&argse
, NULL
);
1898 argse
.data_not_needed
= 1;
1899 argse
.descriptor_only
= 1;
1901 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1902 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1903 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1905 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1909 /* Evaluate a single upper or lower bound. */
1910 /* TODO: bound intrinsic generates way too much unnecessary code. */
1913 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1915 gfc_actual_arglist
*arg
;
1916 gfc_actual_arglist
*arg2
;
1921 tree cond
, cond1
, cond3
, cond4
, size
;
1925 gfc_array_spec
* as
;
1926 bool assumed_rank_lb_one
;
1928 arg
= expr
->value
.function
.actual
;
1933 /* Create an implicit second parameter from the loop variable. */
1934 gcc_assert (!arg2
->expr
);
1935 gcc_assert (se
->loop
->dimen
== 1);
1936 gcc_assert (se
->ss
->info
->expr
== expr
);
1937 gfc_advance_se_ss_chain (se
);
1938 bound
= se
->loop
->loopvar
[0];
1939 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1940 gfc_array_index_type
, bound
,
1945 /* use the passed argument. */
1946 gcc_assert (arg2
->expr
);
1947 gfc_init_se (&argse
, NULL
);
1948 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1949 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1951 /* Convert from one based to zero based. */
1952 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1953 gfc_array_index_type
, bound
,
1954 gfc_index_one_node
);
1957 /* TODO: don't re-evaluate the descriptor on each iteration. */
1958 /* Get a descriptor for the first parameter. */
1959 gfc_init_se (&argse
, NULL
);
1960 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1961 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1962 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1966 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1968 if (INTEGER_CST_P (bound
))
1970 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1971 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
1972 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
1973 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1974 "dimension index", upper
? "UBOUND" : "LBOUND",
1978 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1980 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1982 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1983 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1984 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1985 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1986 tmp
= gfc_conv_descriptor_rank (desc
);
1988 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1989 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1990 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1991 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1992 boolean_type_node
, cond
, tmp
);
1993 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1998 /* Take care of the lbound shift for assumed-rank arrays, which are
1999 nonallocatable and nonpointers. Those has a lbound of 1. */
2000 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
2001 && ((arg
->expr
->ts
.type
!= BT_CLASS
2002 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
2003 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
2004 || (arg
->expr
->ts
.type
== BT_CLASS
2005 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
2006 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
2008 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2009 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2011 /* 13.14.53: Result value for LBOUND
2013 Case (i): For an array section or for an array expression other than a
2014 whole array or array structure component, LBOUND(ARRAY, DIM)
2015 has the value 1. For a whole array or array structure
2016 component, LBOUND(ARRAY, DIM) has the value:
2017 (a) equal to the lower bound for subscript DIM of ARRAY if
2018 dimension DIM of ARRAY does not have extent zero
2019 or if ARRAY is an assumed-size array of rank DIM,
2022 13.14.113: Result value for UBOUND
2024 Case (i): For an array section or for an array expression other than a
2025 whole array or array structure component, UBOUND(ARRAY, DIM)
2026 has the value equal to the number of elements in the given
2027 dimension; otherwise, it has a value equal to the upper bound
2028 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2029 not have size zero and has value zero if dimension DIM has
2032 if (!upper
&& assumed_rank_lb_one
)
2033 se
->expr
= gfc_index_one_node
;
2036 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
2038 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2040 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
2041 stride
, gfc_index_zero_node
);
2042 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2043 boolean_type_node
, cond3
, cond1
);
2044 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2045 stride
, gfc_index_zero_node
);
2050 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2051 boolean_type_node
, cond3
, cond4
);
2052 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2053 gfc_index_one_node
, lbound
);
2054 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2055 boolean_type_node
, cond4
, cond5
);
2057 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2058 boolean_type_node
, cond
, cond5
);
2060 if (assumed_rank_lb_one
)
2062 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2063 gfc_array_index_type
, ubound
, lbound
);
2064 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2065 gfc_array_index_type
, tmp
, gfc_index_one_node
);
2070 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2071 gfc_array_index_type
, cond
,
2072 tmp
, gfc_index_zero_node
);
2076 if (as
->type
== AS_ASSUMED_SIZE
)
2077 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2078 bound
, build_int_cst (TREE_TYPE (bound
),
2079 arg
->expr
->rank
- 1));
2081 cond
= boolean_false_node
;
2083 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2084 boolean_type_node
, cond3
, cond4
);
2085 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2086 boolean_type_node
, cond
, cond1
);
2088 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2089 gfc_array_index_type
, cond
,
2090 lbound
, gfc_index_one_node
);
2097 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
2098 gfc_array_index_type
, ubound
, lbound
);
2099 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2100 gfc_array_index_type
, size
,
2101 gfc_index_one_node
);
2102 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2103 gfc_array_index_type
, se
->expr
,
2104 gfc_index_zero_node
);
2107 se
->expr
= gfc_index_one_node
;
2110 type
= gfc_typenode_for_spec (&expr
->ts
);
2111 se
->expr
= convert (type
, se
->expr
);
2116 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2118 gfc_actual_arglist
*arg
;
2119 gfc_actual_arglist
*arg2
;
2121 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2125 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2126 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2127 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2129 arg
= expr
->value
.function
.actual
;
2132 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2133 corank
= gfc_get_corank (arg
->expr
);
2135 gfc_init_se (&argse
, NULL
);
2136 argse
.want_coarray
= 1;
2138 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2139 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2140 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2145 /* Create an implicit second parameter from the loop variable. */
2146 gcc_assert (!arg2
->expr
);
2147 gcc_assert (corank
> 0);
2148 gcc_assert (se
->loop
->dimen
== 1);
2149 gcc_assert (se
->ss
->info
->expr
== expr
);
2151 bound
= se
->loop
->loopvar
[0];
2152 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2153 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2154 gfc_advance_se_ss_chain (se
);
2158 /* use the passed argument. */
2159 gcc_assert (arg2
->expr
);
2160 gfc_init_se (&argse
, NULL
);
2161 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2162 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2165 if (INTEGER_CST_P (bound
))
2167 if (wi::ltu_p (bound
, 1)
2168 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2169 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
2170 "dimension index", expr
->value
.function
.isym
->name
,
2173 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2175 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2176 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2177 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2178 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2179 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2181 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2182 boolean_type_node
, cond
, tmp
);
2183 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2188 /* Subtract 1 to get to zero based and add dimensions. */
2189 switch (arg
->expr
->rank
)
2192 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2193 gfc_array_index_type
, bound
,
2194 gfc_index_one_node
);
2198 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2199 gfc_array_index_type
, bound
,
2200 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2204 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2206 /* Handle UCOBOUND with special handling of the last codimension. */
2207 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2209 /* Last codimension: For -fcoarray=single just return
2210 the lcobound - otherwise add
2211 ceiling (real (num_images ()) / real (size)) - 1
2212 = (num_images () + size - 1) / size - 1
2213 = (num_images - 1) / size(),
2214 where size is the product of the extent of all but the last
2217 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2221 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2222 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2223 2, integer_zero_node
,
2224 build_int_cst (integer_type_node
, -1));
2225 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2226 gfc_array_index_type
,
2227 fold_convert (gfc_array_index_type
, tmp
),
2228 build_int_cst (gfc_array_index_type
, 1));
2229 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2230 gfc_array_index_type
, tmp
,
2231 fold_convert (gfc_array_index_type
, cosize
));
2232 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2233 gfc_array_index_type
, resbound
, tmp
);
2235 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
2237 /* ubound = lbound + num_images() - 1. */
2238 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2239 2, integer_zero_node
,
2240 build_int_cst (integer_type_node
, -1));
2241 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2242 gfc_array_index_type
,
2243 fold_convert (gfc_array_index_type
, tmp
),
2244 build_int_cst (gfc_array_index_type
, 1));
2245 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2246 gfc_array_index_type
, resbound
, tmp
);
2251 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2253 build_int_cst (TREE_TYPE (bound
),
2254 arg
->expr
->rank
+ corank
- 1));
2256 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2257 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2258 gfc_array_index_type
, cond
,
2259 resbound
, resbound2
);
2262 se
->expr
= resbound
;
2265 se
->expr
= resbound
;
2267 type
= gfc_typenode_for_spec (&expr
->ts
);
2268 se
->expr
= convert (type
, se
->expr
);
2273 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2275 gfc_actual_arglist
*array_arg
;
2276 gfc_actual_arglist
*dim_arg
;
2280 array_arg
= expr
->value
.function
.actual
;
2281 dim_arg
= array_arg
->next
;
2283 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2285 gfc_init_se (&argse
, NULL
);
2286 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2287 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2288 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2291 gcc_assert (dim_arg
->expr
);
2292 gfc_init_se (&argse
, NULL
);
2293 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2294 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2295 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2296 argse
.expr
, gfc_index_one_node
);
2297 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2302 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2306 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2308 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
2312 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
2317 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
2318 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
2327 /* Create a complex value from one or two real components. */
2330 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
2336 unsigned int num_args
;
2338 num_args
= gfc_intrinsic_argument_list_length (expr
);
2339 args
= XALLOCAVEC (tree
, num_args
);
2341 type
= gfc_typenode_for_spec (&expr
->ts
);
2342 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2343 real
= convert (TREE_TYPE (type
), args
[0]);
2345 imag
= convert (TREE_TYPE (type
), args
[1]);
2346 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
2348 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2349 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
2350 imag
= convert (TREE_TYPE (type
), imag
);
2353 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
2355 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
2359 /* Remainder function MOD(A, P) = A - INT(A / P) * P
2360 MODULO(A, P) = A - FLOOR (A / P) * P
2362 The obvious algorithms above are numerically instable for large
2363 arguments, hence these intrinsics are instead implemented via calls
2364 to the fmod family of functions. It is the responsibility of the
2365 user to ensure that the second argument is non-zero. */
2368 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
2378 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2380 switch (expr
->ts
.type
)
2383 /* Integer case is easy, we've got a builtin op. */
2384 type
= TREE_TYPE (args
[0]);
2387 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
2390 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
2396 /* Check if we have a builtin fmod. */
2397 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
2399 /* The builtin should always be available. */
2400 gcc_assert (fmod
!= NULL_TREE
);
2402 tmp
= build_addr (fmod
, current_function_decl
);
2403 se
->expr
= build_call_array_loc (input_location
,
2404 TREE_TYPE (TREE_TYPE (fmod
)),
2409 type
= TREE_TYPE (args
[0]);
2411 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2412 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
2415 modulo = arg - floor (arg/arg2) * arg2
2417 In order to calculate the result accurately, we use the fmod
2418 function as follows.
2420 res = fmod (arg, arg2);
2423 if ((arg < 0) xor (arg2 < 0))
2427 res = copysign (0., arg2);
2429 => As two nested ternary exprs:
2431 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2432 : copysign (0., arg2);
2436 zero
= gfc_build_const (type
, integer_zero_node
);
2437 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2438 if (!flag_signed_zeros
)
2440 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2442 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2444 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2445 boolean_type_node
, test
, test2
);
2446 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2448 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2449 boolean_type_node
, test
, test2
);
2450 test
= gfc_evaluate_now (test
, &se
->pre
);
2451 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2452 fold_build2_loc (input_location
,
2454 type
, tmp
, args
[1]),
2459 tree expr1
, copysign
, cscall
;
2460 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
2462 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2464 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2466 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2467 boolean_type_node
, test
, test2
);
2468 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
2469 fold_build2_loc (input_location
,
2471 type
, tmp
, args
[1]),
2473 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2475 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
2477 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2487 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2488 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2489 where the right shifts are logical (i.e. 0's are shifted in).
2490 Because SHIFT_EXPR's want shifts strictly smaller than the integral
2491 type width, we have to special-case both S == 0 and S == BITSIZE(J):
2493 DSHIFTL(I,J,BITSIZE) = J
2495 DSHIFTR(I,J,BITSIZE) = I. */
2498 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
2500 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
2501 tree args
[3], cond
, tmp
;
2504 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2506 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
2507 type
= TREE_TYPE (args
[0]);
2508 bitsize
= TYPE_PRECISION (type
);
2509 utype
= unsigned_type_for (type
);
2510 stype
= TREE_TYPE (args
[2]);
2512 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
2513 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
2514 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
2516 /* The generic case. */
2517 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
2518 build_int_cst (stype
, bitsize
), shift
);
2519 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
2520 arg1
, dshiftl
? shift
: tmp
);
2522 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
2523 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
2524 right
= fold_convert (type
, right
);
2526 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
2528 /* Special cases. */
2529 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2530 build_int_cst (stype
, 0));
2531 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2532 dshiftl
? arg1
: arg2
, res
);
2534 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2535 build_int_cst (stype
, bitsize
));
2536 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2537 dshiftl
? arg2
: arg1
, res
);
2543 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
2546 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
2554 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2555 type
= TREE_TYPE (args
[0]);
2557 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
2558 val
= gfc_evaluate_now (val
, &se
->pre
);
2560 zero
= gfc_build_const (type
, integer_zero_node
);
2561 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
2562 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
2566 /* SIGN(A, B) is absolute value of A times sign of B.
2567 The real value versions use library functions to ensure the correct
2568 handling of negative zero. Integer case implemented as:
2569 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
2573 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
2579 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2580 if (expr
->ts
.type
== BT_REAL
)
2584 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
2585 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
2587 /* We explicitly have to ignore the minus sign. We do so by using
2588 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
2589 if (!gfc_option
.flag_sign_zero
2590 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
2593 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
2594 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2596 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2597 TREE_TYPE (args
[0]), cond
,
2598 build_call_expr_loc (input_location
, abs
, 1,
2600 build_call_expr_loc (input_location
, tmp
, 2,
2604 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
2609 /* Having excluded floating point types, we know we are now dealing
2610 with signed integer types. */
2611 type
= TREE_TYPE (args
[0]);
2613 /* Args[0] is used multiple times below. */
2614 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2616 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2617 the signs of A and B are the same, and of all ones if they differ. */
2618 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2619 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2620 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2621 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2623 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2624 is all ones (i.e. -1). */
2625 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2626 fold_build2_loc (input_location
, PLUS_EXPR
,
2627 type
, args
[0], tmp
), tmp
);
2631 /* Test for the presence of an optional argument. */
2634 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2638 arg
= expr
->value
.function
.actual
->expr
;
2639 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2640 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2641 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2645 /* Calculate the double precision product of two single precision values. */
2648 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2653 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2655 /* Convert the args to double precision before multiplying. */
2656 type
= gfc_typenode_for_spec (&expr
->ts
);
2657 args
[0] = convert (type
, args
[0]);
2658 args
[1] = convert (type
, args
[1]);
2659 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2664 /* Return a length one character string containing an ascii character. */
2667 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2672 unsigned int num_args
;
2674 num_args
= gfc_intrinsic_argument_list_length (expr
);
2675 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2677 type
= gfc_get_char_type (expr
->ts
.kind
);
2678 var
= gfc_create_var (type
, "char");
2680 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2681 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2682 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2683 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2688 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2696 unsigned int num_args
;
2698 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2699 args
= XALLOCAVEC (tree
, num_args
);
2701 var
= gfc_create_var (pchar_type_node
, "pstr");
2702 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2704 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2705 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2706 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2708 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2709 tmp
= build_call_array_loc (input_location
,
2710 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2711 fndecl
, num_args
, args
);
2712 gfc_add_expr_to_block (&se
->pre
, tmp
);
2714 /* Free the temporary afterwards, if necessary. */
2715 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2716 len
, build_int_cst (TREE_TYPE (len
), 0));
2717 tmp
= gfc_call_free (var
);
2718 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2719 gfc_add_expr_to_block (&se
->post
, tmp
);
2722 se
->string_length
= len
;
2727 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2735 unsigned int num_args
;
2737 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2738 args
= XALLOCAVEC (tree
, num_args
);
2740 var
= gfc_create_var (pchar_type_node
, "pstr");
2741 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2743 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2744 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2745 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2747 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2748 tmp
= build_call_array_loc (input_location
,
2749 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2750 fndecl
, num_args
, args
);
2751 gfc_add_expr_to_block (&se
->pre
, tmp
);
2753 /* Free the temporary afterwards, if necessary. */
2754 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2755 len
, build_int_cst (TREE_TYPE (len
), 0));
2756 tmp
= gfc_call_free (var
);
2757 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2758 gfc_add_expr_to_block (&se
->post
, tmp
);
2761 se
->string_length
= len
;
2765 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
2769 conv_intrinsic_system_clock (gfc_code
*code
)
2772 gfc_se count_se
, count_rate_se
, count_max_se
;
2773 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
2777 gfc_expr
*count
= code
->ext
.actual
->expr
;
2778 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
2779 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
2781 /* The INTEGER(8) version has higher precision, it is used if both COUNT
2782 and COUNT_MAX can hold 64-bit values, or are absent. */
2783 if ((!count
|| count
->ts
.kind
>= 8)
2784 && (!count_max
|| count_max
->ts
.kind
>= 8))
2787 kind
= gfc_default_integer_kind
;
2788 type
= gfc_get_int_type (kind
);
2790 /* Evaluate our arguments. */
2793 gfc_init_se (&count_se
, NULL
);
2794 gfc_conv_expr (&count_se
, count
);
2799 gfc_init_se (&count_rate_se
, NULL
);
2800 gfc_conv_expr (&count_rate_se
, count_rate
);
2805 gfc_init_se (&count_max_se
, NULL
);
2806 gfc_conv_expr (&count_max_se
, count_max
);
2809 /* Prepare temporary variables if we need them. */
2810 if (count
&& count
->ts
.kind
!= kind
)
2811 arg1
= gfc_create_var (type
, "count");
2813 arg1
= count_se
.expr
;
2815 if (count_rate
&& (count_rate
->ts
.kind
!= kind
2816 || count_rate
->ts
.type
!= BT_INTEGER
))
2817 arg2
= gfc_create_var (type
, "count_rate");
2818 else if (count_rate
)
2819 arg2
= count_rate_se
.expr
;
2821 if (count_max
&& count_max
->ts
.kind
!= kind
)
2822 arg3
= gfc_create_var (type
, "count_max");
2824 arg3
= count_max_se
.expr
;
2826 /* Make the function call. */
2827 gfc_init_block (&block
);
2828 tmp
= build_call_expr_loc (input_location
,
2829 kind
== 4 ? gfor_fndecl_system_clock4
2830 : gfor_fndecl_system_clock8
,
2832 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2833 : null_pointer_node
,
2834 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2835 : null_pointer_node
,
2836 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2837 : null_pointer_node
);
2838 gfc_add_expr_to_block (&block
, tmp
);
2840 /* And store values back if needed. */
2841 if (arg1
&& arg1
!= count_se
.expr
)
2842 gfc_add_modify (&block
, count_se
.expr
,
2843 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
2844 if (arg2
&& arg2
!= count_rate_se
.expr
)
2845 gfc_add_modify (&block
, count_rate_se
.expr
,
2846 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
2847 if (arg3
&& arg3
!= count_max_se
.expr
)
2848 gfc_add_modify (&block
, count_max_se
.expr
,
2849 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
2851 return gfc_finish_block (&block
);
2855 /* Return a character string containing the tty name. */
2858 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2866 unsigned int num_args
;
2868 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2869 args
= XALLOCAVEC (tree
, num_args
);
2871 var
= gfc_create_var (pchar_type_node
, "pstr");
2872 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2874 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2875 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2876 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2878 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2879 tmp
= build_call_array_loc (input_location
,
2880 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2881 fndecl
, num_args
, args
);
2882 gfc_add_expr_to_block (&se
->pre
, tmp
);
2884 /* Free the temporary afterwards, if necessary. */
2885 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2886 len
, build_int_cst (TREE_TYPE (len
), 0));
2887 tmp
= gfc_call_free (var
);
2888 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2889 gfc_add_expr_to_block (&se
->post
, tmp
);
2892 se
->string_length
= len
;
2896 /* Get the minimum/maximum value of all the parameters.
2897 minmax (a1, a2, a3, ...)
2900 if (a2 .op. mvar || isnan (mvar))
2902 if (a3 .op. mvar || isnan (mvar))
2909 /* TODO: Mismatching types can occur when specific names are used.
2910 These should be handled during resolution. */
2912 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2920 gfc_actual_arglist
*argexpr
;
2921 unsigned int i
, nargs
;
2923 nargs
= gfc_intrinsic_argument_list_length (expr
);
2924 args
= XALLOCAVEC (tree
, nargs
);
2926 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2927 type
= gfc_typenode_for_spec (&expr
->ts
);
2929 argexpr
= expr
->value
.function
.actual
;
2930 if (TREE_TYPE (args
[0]) != type
)
2931 args
[0] = convert (type
, args
[0]);
2932 /* Only evaluate the argument once. */
2933 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2934 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2936 mvar
= gfc_create_var (type
, "M");
2937 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2938 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2944 /* Handle absent optional arguments by ignoring the comparison. */
2945 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2946 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2947 && TREE_CODE (val
) == INDIRECT_REF
)
2948 cond
= fold_build2_loc (input_location
,
2949 NE_EXPR
, boolean_type_node
,
2950 TREE_OPERAND (val
, 0),
2951 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2956 /* Only evaluate the argument once. */
2957 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2958 val
= gfc_evaluate_now (val
, &se
->pre
);
2961 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2963 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2964 convert (type
, val
), mvar
);
2966 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2967 __builtin_isnan might be made dependent on that module being loaded,
2968 to help performance of programs that don't rely on IEEE semantics. */
2969 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2971 isnan
= build_call_expr_loc (input_location
,
2972 builtin_decl_explicit (BUILT_IN_ISNAN
),
2974 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2975 boolean_type_node
, tmp
,
2976 fold_convert (boolean_type_node
, isnan
));
2978 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2979 build_empty_stmt (input_location
));
2981 if (cond
!= NULL_TREE
)
2982 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2983 build_empty_stmt (input_location
));
2985 gfc_add_expr_to_block (&se
->pre
, tmp
);
2986 argexpr
= argexpr
->next
;
2992 /* Generate library calls for MIN and MAX intrinsics for character
2995 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2998 tree var
, len
, fndecl
, tmp
, cond
, function
;
3001 nargs
= gfc_intrinsic_argument_list_length (expr
);
3002 args
= XALLOCAVEC (tree
, nargs
+ 4);
3003 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
3005 /* Create the result variables. */
3006 len
= gfc_create_var (gfc_charlen_type_node
, "len");
3007 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
3008 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
3009 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
3010 args
[2] = build_int_cst (integer_type_node
, op
);
3011 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
3013 if (expr
->ts
.kind
== 1)
3014 function
= gfor_fndecl_string_minmax
;
3015 else if (expr
->ts
.kind
== 4)
3016 function
= gfor_fndecl_string_minmax_char4
;
3020 /* Make the function call. */
3021 fndecl
= build_addr (function
, current_function_decl
);
3022 tmp
= build_call_array_loc (input_location
,
3023 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
3025 gfc_add_expr_to_block (&se
->pre
, tmp
);
3027 /* Free the temporary afterwards, if necessary. */
3028 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3029 len
, build_int_cst (TREE_TYPE (len
), 0));
3030 tmp
= gfc_call_free (var
);
3031 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3032 gfc_add_expr_to_block (&se
->post
, tmp
);
3035 se
->string_length
= len
;
3039 /* Create a symbol node for this intrinsic. The symbol from the frontend
3040 has the generic name. */
3043 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
3047 /* TODO: Add symbols for intrinsic function to the global namespace. */
3048 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
3049 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
3052 sym
->attr
.external
= 1;
3053 sym
->attr
.function
= 1;
3054 sym
->attr
.always_explicit
= 1;
3055 sym
->attr
.proc
= PROC_INTRINSIC
;
3056 sym
->attr
.flavor
= FL_PROCEDURE
;
3060 sym
->attr
.dimension
= 1;
3061 sym
->as
= gfc_get_array_spec ();
3062 sym
->as
->type
= AS_ASSUMED_SHAPE
;
3063 sym
->as
->rank
= expr
->rank
;
3066 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
3067 ignore_optional
? expr
->value
.function
.actual
3073 /* Generate a call to an external intrinsic function. */
3075 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
3078 vec
<tree
, va_gc
> *append_args
;
3080 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
3083 gcc_assert (expr
->rank
> 0);
3085 gcc_assert (expr
->rank
== 0);
3087 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
3089 /* Calls to libgfortran_matmul need to be appended special arguments,
3090 to be able to call the BLAS ?gemm functions if required and possible. */
3092 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
3093 && sym
->ts
.type
!= BT_LOGICAL
)
3095 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
3097 if (gfc_option
.flag_external_blas
3098 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
3099 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3103 if (sym
->ts
.type
== BT_REAL
)
3105 if (sym
->ts
.kind
== 4)
3106 gemm_fndecl
= gfor_fndecl_sgemm
;
3108 gemm_fndecl
= gfor_fndecl_dgemm
;
3112 if (sym
->ts
.kind
== 4)
3113 gemm_fndecl
= gfor_fndecl_cgemm
;
3115 gemm_fndecl
= gfor_fndecl_zgemm
;
3118 vec_alloc (append_args
, 3);
3119 append_args
->quick_push (build_int_cst (cint
, 1));
3120 append_args
->quick_push (build_int_cst (cint
,
3121 gfc_option
.blas_matmul_limit
));
3122 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3127 vec_alloc (append_args
, 3);
3128 append_args
->quick_push (build_int_cst (cint
, 0));
3129 append_args
->quick_push (build_int_cst (cint
, 0));
3130 append_args
->quick_push (null_pointer_node
);
3134 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3136 gfc_free_symbol (sym
);
3139 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3159 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3168 gfc_actual_arglist
*actual
;
3175 gfc_conv_intrinsic_funcall (se
, expr
);
3179 actual
= expr
->value
.function
.actual
;
3180 type
= gfc_typenode_for_spec (&expr
->ts
);
3181 /* Initialize the result. */
3182 resvar
= gfc_create_var (type
, "test");
3184 tmp
= convert (type
, boolean_true_node
);
3186 tmp
= convert (type
, boolean_false_node
);
3187 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3189 /* Walk the arguments. */
3190 arrayss
= gfc_walk_expr (actual
->expr
);
3191 gcc_assert (arrayss
!= gfc_ss_terminator
);
3193 /* Initialize the scalarizer. */
3194 gfc_init_loopinfo (&loop
);
3195 exit_label
= gfc_build_label_decl (NULL_TREE
);
3196 TREE_USED (exit_label
) = 1;
3197 gfc_add_ss_to_loop (&loop
, arrayss
);
3199 /* Initialize the loop. */
3200 gfc_conv_ss_startstride (&loop
);
3201 gfc_conv_loop_setup (&loop
, &expr
->where
);
3203 gfc_mark_ss_chain_used (arrayss
, 1);
3204 /* Generate the loop body. */
3205 gfc_start_scalarized_body (&loop
, &body
);
3207 /* If the condition matches then set the return value. */
3208 gfc_start_block (&block
);
3210 tmp
= convert (type
, boolean_false_node
);
3212 tmp
= convert (type
, boolean_true_node
);
3213 gfc_add_modify (&block
, resvar
, tmp
);
3215 /* And break out of the loop. */
3216 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3217 gfc_add_expr_to_block (&block
, tmp
);
3219 found
= gfc_finish_block (&block
);
3221 /* Check this element. */
3222 gfc_init_se (&arrayse
, NULL
);
3223 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3224 arrayse
.ss
= arrayss
;
3225 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3227 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3228 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3229 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3230 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3231 gfc_add_expr_to_block (&body
, tmp
);
3232 gfc_add_block_to_block (&body
, &arrayse
.post
);
3234 gfc_trans_scalarizing_loops (&loop
, &body
);
3236 /* Add the exit label. */
3237 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3238 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3240 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3241 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3242 gfc_cleanup_loop (&loop
);
3247 /* COUNT(A) = Number of true elements in A. */
3249 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
3256 gfc_actual_arglist
*actual
;
3262 gfc_conv_intrinsic_funcall (se
, expr
);
3266 actual
= expr
->value
.function
.actual
;
3268 type
= gfc_typenode_for_spec (&expr
->ts
);
3269 /* Initialize the result. */
3270 resvar
= gfc_create_var (type
, "count");
3271 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
3273 /* Walk the arguments. */
3274 arrayss
= gfc_walk_expr (actual
->expr
);
3275 gcc_assert (arrayss
!= gfc_ss_terminator
);
3277 /* Initialize the scalarizer. */
3278 gfc_init_loopinfo (&loop
);
3279 gfc_add_ss_to_loop (&loop
, arrayss
);
3281 /* Initialize the loop. */
3282 gfc_conv_ss_startstride (&loop
);
3283 gfc_conv_loop_setup (&loop
, &expr
->where
);
3285 gfc_mark_ss_chain_used (arrayss
, 1);
3286 /* Generate the loop body. */
3287 gfc_start_scalarized_body (&loop
, &body
);
3289 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
3290 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
3291 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
3293 gfc_init_se (&arrayse
, NULL
);
3294 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3295 arrayse
.ss
= arrayss
;
3296 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3297 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
3298 build_empty_stmt (input_location
));
3300 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3301 gfc_add_expr_to_block (&body
, tmp
);
3302 gfc_add_block_to_block (&body
, &arrayse
.post
);
3304 gfc_trans_scalarizing_loops (&loop
, &body
);
3306 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3307 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3308 gfc_cleanup_loop (&loop
);
3314 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
3315 struct and return the corresponding loopinfo. */
3317 static gfc_loopinfo
*
3318 enter_nested_loop (gfc_se
*se
)
3320 se
->ss
= se
->ss
->nested_ss
;
3321 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
3323 return se
->ss
->loop
;
3327 /* Inline implementation of the sum and product intrinsics. */
3329 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
3333 tree scale
= NULL_TREE
;
3338 gfc_loopinfo loop
, *ploop
;
3339 gfc_actual_arglist
*arg_array
, *arg_mask
;
3340 gfc_ss
*arrayss
= NULL
;
3341 gfc_ss
*maskss
= NULL
;
3345 gfc_expr
*arrayexpr
;
3350 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
3356 type
= gfc_typenode_for_spec (&expr
->ts
);
3357 /* Initialize the result. */
3358 resvar
= gfc_create_var (type
, "val");
3363 scale
= gfc_create_var (type
, "scale");
3364 gfc_add_modify (&se
->pre
, scale
,
3365 gfc_build_const (type
, integer_one_node
));
3366 tmp
= gfc_build_const (type
, integer_zero_node
);
3368 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
3369 tmp
= gfc_build_const (type
, integer_zero_node
);
3370 else if (op
== NE_EXPR
)
3372 tmp
= convert (type
, boolean_false_node
);
3373 else if (op
== BIT_AND_EXPR
)
3374 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
3375 type
, integer_one_node
));
3377 tmp
= gfc_build_const (type
, integer_one_node
);
3379 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3381 arg_array
= expr
->value
.function
.actual
;
3383 arrayexpr
= arg_array
->expr
;
3385 if (op
== NE_EXPR
|| norm2
)
3386 /* PARITY and NORM2. */
3390 arg_mask
= arg_array
->next
->next
;
3391 gcc_assert (arg_mask
!= NULL
);
3392 maskexpr
= arg_mask
->expr
;
3395 if (expr
->rank
== 0)
3397 /* Walk the arguments. */
3398 arrayss
= gfc_walk_expr (arrayexpr
);
3399 gcc_assert (arrayss
!= gfc_ss_terminator
);
3401 if (maskexpr
&& maskexpr
->rank
> 0)
3403 maskss
= gfc_walk_expr (maskexpr
);
3404 gcc_assert (maskss
!= gfc_ss_terminator
);
3409 /* Initialize the scalarizer. */
3410 gfc_init_loopinfo (&loop
);
3411 gfc_add_ss_to_loop (&loop
, arrayss
);
3412 if (maskexpr
&& maskexpr
->rank
> 0)
3413 gfc_add_ss_to_loop (&loop
, maskss
);
3415 /* Initialize the loop. */
3416 gfc_conv_ss_startstride (&loop
);
3417 gfc_conv_loop_setup (&loop
, &expr
->where
);
3419 gfc_mark_ss_chain_used (arrayss
, 1);
3420 if (maskexpr
&& maskexpr
->rank
> 0)
3421 gfc_mark_ss_chain_used (maskss
, 1);
3426 /* All the work has been done in the parent loops. */
3427 ploop
= enter_nested_loop (se
);
3431 /* Generate the loop body. */
3432 gfc_start_scalarized_body (ploop
, &body
);
3434 /* If we have a mask, only add this element if the mask is set. */
3435 if (maskexpr
&& maskexpr
->rank
> 0)
3437 gfc_init_se (&maskse
, parent_se
);
3438 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
3439 if (expr
->rank
== 0)
3441 gfc_conv_expr_val (&maskse
, maskexpr
);
3442 gfc_add_block_to_block (&body
, &maskse
.pre
);
3444 gfc_start_block (&block
);
3447 gfc_init_block (&block
);
3449 /* Do the actual summation/product. */
3450 gfc_init_se (&arrayse
, parent_se
);
3451 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
3452 if (expr
->rank
== 0)
3453 arrayse
.ss
= arrayss
;
3454 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3455 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3459 /* if (x (i) != 0.0)
3465 result = 1.0 + result * val * val;
3471 result += val * val;
3474 tree res1
, res2
, cond
, absX
, val
;
3475 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
3477 gfc_init_block (&ifblock1
);
3479 absX
= gfc_create_var (type
, "absX");
3480 gfc_add_modify (&ifblock1
, absX
,
3481 fold_build1_loc (input_location
, ABS_EXPR
, type
,
3483 val
= gfc_create_var (type
, "val");
3484 gfc_add_expr_to_block (&ifblock1
, val
);
3486 gfc_init_block (&ifblock2
);
3487 gfc_add_modify (&ifblock2
, val
,
3488 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
3490 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3491 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
3492 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
3493 gfc_build_const (type
, integer_one_node
));
3494 gfc_add_modify (&ifblock2
, resvar
, res1
);
3495 gfc_add_modify (&ifblock2
, scale
, absX
);
3496 res1
= gfc_finish_block (&ifblock2
);
3498 gfc_init_block (&ifblock3
);
3499 gfc_add_modify (&ifblock3
, val
,
3500 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
3502 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3503 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
3504 gfc_add_modify (&ifblock3
, resvar
, res2
);
3505 res2
= gfc_finish_block (&ifblock3
);
3507 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3509 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
3510 gfc_add_expr_to_block (&ifblock1
, tmp
);
3511 tmp
= gfc_finish_block (&ifblock1
);
3513 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3515 gfc_build_const (type
, integer_zero_node
));
3517 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3518 gfc_add_expr_to_block (&block
, tmp
);
3522 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
3523 gfc_add_modify (&block
, resvar
, tmp
);
3526 gfc_add_block_to_block (&block
, &arrayse
.post
);
3528 if (maskexpr
&& maskexpr
->rank
> 0)
3530 /* We enclose the above in if (mask) {...} . */
3532 tmp
= gfc_finish_block (&block
);
3533 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3534 build_empty_stmt (input_location
));
3537 tmp
= gfc_finish_block (&block
);
3538 gfc_add_expr_to_block (&body
, tmp
);
3540 gfc_trans_scalarizing_loops (ploop
, &body
);
3542 /* For a scalar mask, enclose the loop in an if statement. */
3543 if (maskexpr
&& maskexpr
->rank
== 0)
3545 gfc_init_block (&block
);
3546 gfc_add_block_to_block (&block
, &ploop
->pre
);
3547 gfc_add_block_to_block (&block
, &ploop
->post
);
3548 tmp
= gfc_finish_block (&block
);
3552 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
3553 build_empty_stmt (input_location
));
3554 gfc_advance_se_ss_chain (se
);
3558 gcc_assert (expr
->rank
== 0);
3559 gfc_init_se (&maskse
, NULL
);
3560 gfc_conv_expr_val (&maskse
, maskexpr
);
3561 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3562 build_empty_stmt (input_location
));
3565 gfc_add_expr_to_block (&block
, tmp
);
3566 gfc_add_block_to_block (&se
->pre
, &block
);
3567 gcc_assert (se
->post
.head
== NULL
);
3571 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
3572 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
3575 if (expr
->rank
== 0)
3576 gfc_cleanup_loop (ploop
);
3580 /* result = scale * sqrt(result). */
3582 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
3583 resvar
= build_call_expr_loc (input_location
,
3585 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
3592 /* Inline implementation of the dot_product intrinsic. This function
3593 is based on gfc_conv_intrinsic_arith (the previous function). */
3595 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
3603 gfc_actual_arglist
*actual
;
3604 gfc_ss
*arrayss1
, *arrayss2
;
3605 gfc_se arrayse1
, arrayse2
;
3606 gfc_expr
*arrayexpr1
, *arrayexpr2
;
3608 type
= gfc_typenode_for_spec (&expr
->ts
);
3610 /* Initialize the result. */
3611 resvar
= gfc_create_var (type
, "val");
3612 if (expr
->ts
.type
== BT_LOGICAL
)
3613 tmp
= build_int_cst (type
, 0);
3615 tmp
= gfc_build_const (type
, integer_zero_node
);
3617 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3619 /* Walk argument #1. */
3620 actual
= expr
->value
.function
.actual
;
3621 arrayexpr1
= actual
->expr
;
3622 arrayss1
= gfc_walk_expr (arrayexpr1
);
3623 gcc_assert (arrayss1
!= gfc_ss_terminator
);
3625 /* Walk argument #2. */
3626 actual
= actual
->next
;
3627 arrayexpr2
= actual
->expr
;
3628 arrayss2
= gfc_walk_expr (arrayexpr2
);
3629 gcc_assert (arrayss2
!= gfc_ss_terminator
);
3631 /* Initialize the scalarizer. */
3632 gfc_init_loopinfo (&loop
);
3633 gfc_add_ss_to_loop (&loop
, arrayss1
);
3634 gfc_add_ss_to_loop (&loop
, arrayss2
);
3636 /* Initialize the loop. */
3637 gfc_conv_ss_startstride (&loop
);
3638 gfc_conv_loop_setup (&loop
, &expr
->where
);
3640 gfc_mark_ss_chain_used (arrayss1
, 1);
3641 gfc_mark_ss_chain_used (arrayss2
, 1);
3643 /* Generate the loop body. */
3644 gfc_start_scalarized_body (&loop
, &body
);
3645 gfc_init_block (&block
);
3647 /* Make the tree expression for [conjg(]array1[)]. */
3648 gfc_init_se (&arrayse1
, NULL
);
3649 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
3650 arrayse1
.ss
= arrayss1
;
3651 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
3652 if (expr
->ts
.type
== BT_COMPLEX
)
3653 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
3655 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
3657 /* Make the tree expression for array2. */
3658 gfc_init_se (&arrayse2
, NULL
);
3659 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
3660 arrayse2
.ss
= arrayss2
;
3661 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
3662 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
3664 /* Do the actual product and sum. */
3665 if (expr
->ts
.type
== BT_LOGICAL
)
3667 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
3668 arrayse1
.expr
, arrayse2
.expr
);
3669 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
3673 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
3675 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
3677 gfc_add_modify (&block
, resvar
, tmp
);
3679 /* Finish up the loop block and the loop. */
3680 tmp
= gfc_finish_block (&block
);
3681 gfc_add_expr_to_block (&body
, tmp
);
3683 gfc_trans_scalarizing_loops (&loop
, &body
);
3684 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3685 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3686 gfc_cleanup_loop (&loop
);
3692 /* Emit code for minloc or maxloc intrinsic. There are many different cases
3693 we need to handle. For performance reasons we sometimes create two
3694 loops instead of one, where the second one is much simpler.
3695 Examples for minloc intrinsic:
3696 1) Result is an array, a call is generated
3697 2) Array mask is used and NaNs need to be supported:
3703 if (pos == 0) pos = S + (1 - from);
3704 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3711 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3715 3) NaNs need to be supported, but it is known at compile time or cheaply
3716 at runtime whether array is nonempty or not:
3721 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3724 if (from <= to) pos = 1;
3728 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3732 4) NaNs aren't supported, array mask is used:
3733 limit = infinities_supported ? Infinity : huge (limit);
3737 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3743 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3747 5) Same without array mask:
3748 limit = infinities_supported ? Infinity : huge (limit);
3749 pos = (from <= to) ? 1 : 0;
3752 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3755 For 3) and 5), if mask is scalar, this all goes into a conditional,
3756 setting pos = 0; in the else branch. */
3759 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3763 stmtblock_t ifblock
;
3764 stmtblock_t elseblock
;
3775 gfc_actual_arglist
*actual
;
3780 gfc_expr
*arrayexpr
;
3787 gfc_conv_intrinsic_funcall (se
, expr
);
3791 /* Initialize the result. */
3792 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3793 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3794 type
= gfc_typenode_for_spec (&expr
->ts
);
3796 /* Walk the arguments. */
3797 actual
= expr
->value
.function
.actual
;
3798 arrayexpr
= actual
->expr
;
3799 arrayss
= gfc_walk_expr (arrayexpr
);
3800 gcc_assert (arrayss
!= gfc_ss_terminator
);
3802 actual
= actual
->next
->next
;
3803 gcc_assert (actual
);
3804 maskexpr
= actual
->expr
;
3806 if (maskexpr
&& maskexpr
->rank
!= 0)
3808 maskss
= gfc_walk_expr (maskexpr
);
3809 gcc_assert (maskss
!= gfc_ss_terminator
);
3814 if (gfc_array_size (arrayexpr
, &asize
))
3816 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3818 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3819 boolean_type_node
, nonempty
,
3820 gfc_index_zero_node
);
3825 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3826 switch (arrayexpr
->ts
.type
)
3829 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3833 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3834 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3835 arrayexpr
->ts
.kind
);
3842 /* We start with the most negative possible value for MAXLOC, and the most
3843 positive possible value for MINLOC. The most negative possible value is
3844 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3845 possible value is HUGE in both cases. */
3847 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3848 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3849 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3850 build_int_cst (type
, 1));
3852 gfc_add_modify (&se
->pre
, limit
, tmp
);
3854 /* Initialize the scalarizer. */
3855 gfc_init_loopinfo (&loop
);
3856 gfc_add_ss_to_loop (&loop
, arrayss
);
3858 gfc_add_ss_to_loop (&loop
, maskss
);
3860 /* Initialize the loop. */
3861 gfc_conv_ss_startstride (&loop
);
3863 /* The code generated can have more than one loop in sequence (see the
3864 comment at the function header). This doesn't work well with the
3865 scalarizer, which changes arrays' offset when the scalarization loops
3866 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3867 are currently inlined in the scalar case only (for which loop is of rank
3868 one). As there is no dependency to care about in that case, there is no
3869 temporary, so that we can use the scalarizer temporary code to handle
3870 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3871 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3873 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3874 should eventually go away. We could either create two loops properly,
3875 or find another way to save/restore the array offsets between the two
3876 loops (without conflicting with temporary management), or use a single
3877 loop minmaxloc implementation. See PR 31067. */
3878 loop
.temp_dim
= loop
.dimen
;
3879 gfc_conv_loop_setup (&loop
, &expr
->where
);
3881 gcc_assert (loop
.dimen
== 1);
3882 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3883 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3884 loop
.from
[0], loop
.to
[0]);
3888 /* Initialize the position to zero, following Fortran 2003. We are free
3889 to do this because Fortran 95 allows the result of an entirely false
3890 mask to be processor dependent. If we know at compile time the array
3891 is non-empty and no MASK is used, we can initialize to 1 to simplify
3893 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3894 gfc_add_modify (&loop
.pre
, pos
,
3895 fold_build3_loc (input_location
, COND_EXPR
,
3896 gfc_array_index_type
,
3897 nonempty
, gfc_index_one_node
,
3898 gfc_index_zero_node
));
3901 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3902 lab1
= gfc_build_label_decl (NULL_TREE
);
3903 TREE_USED (lab1
) = 1;
3904 lab2
= gfc_build_label_decl (NULL_TREE
);
3905 TREE_USED (lab2
) = 1;
3908 /* An offset must be added to the loop
3909 counter to obtain the required position. */
3910 gcc_assert (loop
.from
[0]);
3912 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3913 gfc_index_one_node
, loop
.from
[0]);
3914 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3916 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3918 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3919 /* Generate the loop body. */
3920 gfc_start_scalarized_body (&loop
, &body
);
3922 /* If we have a mask, only check this element if the mask is set. */
3925 gfc_init_se (&maskse
, NULL
);
3926 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3928 gfc_conv_expr_val (&maskse
, maskexpr
);
3929 gfc_add_block_to_block (&body
, &maskse
.pre
);
3931 gfc_start_block (&block
);
3934 gfc_init_block (&block
);
3936 /* Compare with the current limit. */
3937 gfc_init_se (&arrayse
, NULL
);
3938 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3939 arrayse
.ss
= arrayss
;
3940 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3941 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3943 /* We do the following if this is a more extreme value. */
3944 gfc_start_block (&ifblock
);
3946 /* Assign the value to the limit... */
3947 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3949 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3951 stmtblock_t ifblock2
;
3954 gfc_start_block (&ifblock2
);
3955 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3956 loop
.loopvar
[0], offset
);
3957 gfc_add_modify (&ifblock2
, pos
, tmp
);
3958 ifbody2
= gfc_finish_block (&ifblock2
);
3959 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3960 gfc_index_zero_node
);
3961 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3962 build_empty_stmt (input_location
));
3963 gfc_add_expr_to_block (&block
, tmp
);
3966 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3967 loop
.loopvar
[0], offset
);
3968 gfc_add_modify (&ifblock
, pos
, tmp
);
3971 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3973 ifbody
= gfc_finish_block (&ifblock
);
3975 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3978 cond
= fold_build2_loc (input_location
,
3979 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3980 boolean_type_node
, arrayse
.expr
, limit
);
3982 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3983 arrayse
.expr
, limit
);
3985 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3986 build_empty_stmt (input_location
));
3988 gfc_add_expr_to_block (&block
, ifbody
);
3992 /* We enclose the above in if (mask) {...}. */
3993 tmp
= gfc_finish_block (&block
);
3995 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3996 build_empty_stmt (input_location
));
3999 tmp
= gfc_finish_block (&block
);
4000 gfc_add_expr_to_block (&body
, tmp
);
4004 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4006 if (HONOR_NANS (DECL_MODE (limit
)))
4008 if (nonempty
!= NULL
)
4010 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
4011 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
4012 build_empty_stmt (input_location
));
4013 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
4017 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
4018 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
4020 /* If we have a mask, only check this element if the mask is set. */
4023 gfc_init_se (&maskse
, NULL
);
4024 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4026 gfc_conv_expr_val (&maskse
, maskexpr
);
4027 gfc_add_block_to_block (&body
, &maskse
.pre
);
4029 gfc_start_block (&block
);
4032 gfc_init_block (&block
);
4034 /* Compare with the current limit. */
4035 gfc_init_se (&arrayse
, NULL
);
4036 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4037 arrayse
.ss
= arrayss
;
4038 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4039 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4041 /* We do the following if this is a more extreme value. */
4042 gfc_start_block (&ifblock
);
4044 /* Assign the value to the limit... */
4045 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4047 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
4048 loop
.loopvar
[0], offset
);
4049 gfc_add_modify (&ifblock
, pos
, tmp
);
4051 ifbody
= gfc_finish_block (&ifblock
);
4053 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4054 arrayse
.expr
, limit
);
4056 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
4057 build_empty_stmt (input_location
));
4058 gfc_add_expr_to_block (&block
, tmp
);
4062 /* We enclose the above in if (mask) {...}. */
4063 tmp
= gfc_finish_block (&block
);
4065 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4066 build_empty_stmt (input_location
));
4069 tmp
= gfc_finish_block (&block
);
4070 gfc_add_expr_to_block (&body
, tmp
);
4071 /* Avoid initializing loopvar[0] again, it should be left where
4072 it finished by the first loop. */
4073 loop
.from
[0] = loop
.loopvar
[0];
4076 gfc_trans_scalarizing_loops (&loop
, &body
);
4079 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
4081 /* For a scalar mask, enclose the loop in an if statement. */
4082 if (maskexpr
&& maskss
== NULL
)
4084 gfc_init_se (&maskse
, NULL
);
4085 gfc_conv_expr_val (&maskse
, maskexpr
);
4086 gfc_init_block (&block
);
4087 gfc_add_block_to_block (&block
, &loop
.pre
);
4088 gfc_add_block_to_block (&block
, &loop
.post
);
4089 tmp
= gfc_finish_block (&block
);
4091 /* For the else part of the scalar mask, just initialize
4092 the pos variable the same way as above. */
4094 gfc_init_block (&elseblock
);
4095 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
4096 elsetmp
= gfc_finish_block (&elseblock
);
4098 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
4099 gfc_add_expr_to_block (&block
, tmp
);
4100 gfc_add_block_to_block (&se
->pre
, &block
);
4104 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4105 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4107 gfc_cleanup_loop (&loop
);
4109 se
->expr
= convert (type
, pos
);
4112 /* Emit code for minval or maxval intrinsic. There are many different cases
4113 we need to handle. For performance reasons we sometimes create two
4114 loops instead of one, where the second one is much simpler.
4115 Examples for minval intrinsic:
4116 1) Result is an array, a call is generated
4117 2) Array mask is used and NaNs need to be supported, rank 1:
4122 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4125 limit = nonempty ? NaN : huge (limit);
4127 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4128 3) NaNs need to be supported, but it is known at compile time or cheaply
4129 at runtime whether array is nonempty or not, rank 1:
4132 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4133 limit = (from <= to) ? NaN : huge (limit);
4135 while (S <= to) { limit = min (a[S], limit); S++; }
4136 4) Array mask is used and NaNs need to be supported, rank > 1:
4145 if (fast) limit = min (a[S1][S2], limit);
4148 if (a[S1][S2] <= limit) {
4159 limit = nonempty ? NaN : huge (limit);
4160 5) NaNs need to be supported, but it is known at compile time or cheaply
4161 at runtime whether array is nonempty or not, rank > 1:
4168 if (fast) limit = min (a[S1][S2], limit);
4170 if (a[S1][S2] <= limit) {
4180 limit = (nonempty_array) ? NaN : huge (limit);
4181 6) NaNs aren't supported, but infinities are. Array mask is used:
4186 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4189 limit = nonempty ? limit : huge (limit);
4190 7) Same without array mask:
4193 while (S <= to) { limit = min (a[S], limit); S++; }
4194 limit = (from <= to) ? limit : huge (limit);
4195 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4196 limit = huge (limit);
4198 while (S <= to) { limit = min (a[S], limit); S++); }
4200 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4201 with array mask instead).
4202 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4203 setting limit = huge (limit); in the else branch. */
4206 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4216 tree huge_cst
= NULL
, nan_cst
= NULL
;
4218 stmtblock_t block
, block2
;
4220 gfc_actual_arglist
*actual
;
4225 gfc_expr
*arrayexpr
;
4231 gfc_conv_intrinsic_funcall (se
, expr
);
4235 type
= gfc_typenode_for_spec (&expr
->ts
);
4236 /* Initialize the result. */
4237 limit
= gfc_create_var (type
, "limit");
4238 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
4239 switch (expr
->ts
.type
)
4242 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
4244 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4246 REAL_VALUE_TYPE real
;
4248 tmp
= build_real (type
, real
);
4252 if (HONOR_NANS (DECL_MODE (limit
)))
4254 REAL_VALUE_TYPE real
;
4255 real_nan (&real
, "", 1, DECL_MODE (limit
));
4256 nan_cst
= build_real (type
, real
);
4261 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
4268 /* We start with the most negative possible value for MAXVAL, and the most
4269 positive possible value for MINVAL. The most negative possible value is
4270 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4271 possible value is HUGE in both cases. */
4274 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4276 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
4277 TREE_TYPE (huge_cst
), huge_cst
);
4280 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
4281 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
4282 tmp
, build_int_cst (type
, 1));
4284 gfc_add_modify (&se
->pre
, limit
, tmp
);
4286 /* Walk the arguments. */
4287 actual
= expr
->value
.function
.actual
;
4288 arrayexpr
= actual
->expr
;
4289 arrayss
= gfc_walk_expr (arrayexpr
);
4290 gcc_assert (arrayss
!= gfc_ss_terminator
);
4292 actual
= actual
->next
->next
;
4293 gcc_assert (actual
);
4294 maskexpr
= actual
->expr
;
4296 if (maskexpr
&& maskexpr
->rank
!= 0)
4298 maskss
= gfc_walk_expr (maskexpr
);
4299 gcc_assert (maskss
!= gfc_ss_terminator
);
4304 if (gfc_array_size (arrayexpr
, &asize
))
4306 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4308 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4309 boolean_type_node
, nonempty
,
4310 gfc_index_zero_node
);
4315 /* Initialize the scalarizer. */
4316 gfc_init_loopinfo (&loop
);
4317 gfc_add_ss_to_loop (&loop
, arrayss
);
4319 gfc_add_ss_to_loop (&loop
, maskss
);
4321 /* Initialize the loop. */
4322 gfc_conv_ss_startstride (&loop
);
4324 /* The code generated can have more than one loop in sequence (see the
4325 comment at the function header). This doesn't work well with the
4326 scalarizer, which changes arrays' offset when the scalarization loops
4327 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
4328 are currently inlined in the scalar case only. As there is no dependency
4329 to care about in that case, there is no temporary, so that we can use the
4330 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
4331 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
4332 gfc_trans_scalarized_loop_boundary even later to restore offset.
4333 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
4334 should eventually go away. We could either create two loops properly,
4335 or find another way to save/restore the array offsets between the two
4336 loops (without conflicting with temporary management), or use a single
4337 loop minmaxval implementation. See PR 31067. */
4338 loop
.temp_dim
= loop
.dimen
;
4339 gfc_conv_loop_setup (&loop
, &expr
->where
);
4341 if (nonempty
== NULL
&& maskss
== NULL
4342 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
4343 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4344 loop
.from
[0], loop
.to
[0]);
4345 nonempty_var
= NULL
;
4346 if (nonempty
== NULL
4347 && (HONOR_INFINITIES (DECL_MODE (limit
))
4348 || HONOR_NANS (DECL_MODE (limit
))))
4350 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
4351 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
4352 nonempty
= nonempty_var
;
4356 if (HONOR_NANS (DECL_MODE (limit
)))
4358 if (loop
.dimen
== 1)
4360 lab
= gfc_build_label_decl (NULL_TREE
);
4361 TREE_USED (lab
) = 1;
4365 fast
= gfc_create_var (boolean_type_node
, "fast");
4366 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
4370 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
4372 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
4373 /* Generate the loop body. */
4374 gfc_start_scalarized_body (&loop
, &body
);
4376 /* If we have a mask, only add this element if the mask is set. */
4379 gfc_init_se (&maskse
, NULL
);
4380 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4382 gfc_conv_expr_val (&maskse
, maskexpr
);
4383 gfc_add_block_to_block (&body
, &maskse
.pre
);
4385 gfc_start_block (&block
);
4388 gfc_init_block (&block
);
4390 /* Compare with the current limit. */
4391 gfc_init_se (&arrayse
, NULL
);
4392 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4393 arrayse
.ss
= arrayss
;
4394 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4395 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4397 gfc_init_block (&block2
);
4400 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
4402 if (HONOR_NANS (DECL_MODE (limit
)))
4404 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4405 boolean_type_node
, arrayse
.expr
, limit
);
4407 ifbody
= build1_v (GOTO_EXPR
, lab
);
4410 stmtblock_t ifblock
;
4412 gfc_init_block (&ifblock
);
4413 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4414 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
4415 ifbody
= gfc_finish_block (&ifblock
);
4417 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4418 build_empty_stmt (input_location
));
4419 gfc_add_expr_to_block (&block2
, tmp
);
4423 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4425 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4427 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4428 arrayse
.expr
, limit
);
4429 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4430 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4431 build_empty_stmt (input_location
));
4432 gfc_add_expr_to_block (&block2
, tmp
);
4436 tmp
= fold_build2_loc (input_location
,
4437 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4438 type
, arrayse
.expr
, limit
);
4439 gfc_add_modify (&block2
, limit
, tmp
);
4445 tree elsebody
= gfc_finish_block (&block2
);
4447 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4449 if (HONOR_NANS (DECL_MODE (limit
))
4450 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4452 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4453 arrayse
.expr
, limit
);
4454 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4455 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
4456 build_empty_stmt (input_location
));
4460 tmp
= fold_build2_loc (input_location
,
4461 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4462 type
, arrayse
.expr
, limit
);
4463 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4465 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
4466 gfc_add_expr_to_block (&block
, tmp
);
4469 gfc_add_block_to_block (&block
, &block2
);
4471 gfc_add_block_to_block (&block
, &arrayse
.post
);
4473 tmp
= gfc_finish_block (&block
);
4475 /* We enclose the above in if (mask) {...}. */
4476 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4477 build_empty_stmt (input_location
));
4478 gfc_add_expr_to_block (&body
, tmp
);
4482 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4484 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4486 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
4487 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
4489 /* If we have a mask, only add this element if the mask is set. */
4492 gfc_init_se (&maskse
, NULL
);
4493 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4495 gfc_conv_expr_val (&maskse
, maskexpr
);
4496 gfc_add_block_to_block (&body
, &maskse
.pre
);
4498 gfc_start_block (&block
);
4501 gfc_init_block (&block
);
4503 /* Compare with the current limit. */
4504 gfc_init_se (&arrayse
, NULL
);
4505 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4506 arrayse
.ss
= arrayss
;
4507 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4508 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4510 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4512 if (HONOR_NANS (DECL_MODE (limit
))
4513 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4515 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4516 arrayse
.expr
, limit
);
4517 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4518 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4519 build_empty_stmt (input_location
));
4520 gfc_add_expr_to_block (&block
, tmp
);
4524 tmp
= fold_build2_loc (input_location
,
4525 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4526 type
, arrayse
.expr
, limit
);
4527 gfc_add_modify (&block
, limit
, tmp
);
4530 gfc_add_block_to_block (&block
, &arrayse
.post
);
4532 tmp
= gfc_finish_block (&block
);
4534 /* We enclose the above in if (mask) {...}. */
4535 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4536 build_empty_stmt (input_location
));
4537 gfc_add_expr_to_block (&body
, tmp
);
4538 /* Avoid initializing loopvar[0] again, it should be left where
4539 it finished by the first loop. */
4540 loop
.from
[0] = loop
.loopvar
[0];
4542 gfc_trans_scalarizing_loops (&loop
, &body
);
4546 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4548 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4549 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
4551 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4553 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
4555 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
4557 gfc_add_modify (&loop
.pre
, limit
, tmp
);
4560 /* For a scalar mask, enclose the loop in an if statement. */
4561 if (maskexpr
&& maskss
== NULL
)
4565 gfc_init_se (&maskse
, NULL
);
4566 gfc_conv_expr_val (&maskse
, maskexpr
);
4567 gfc_init_block (&block
);
4568 gfc_add_block_to_block (&block
, &loop
.pre
);
4569 gfc_add_block_to_block (&block
, &loop
.post
);
4570 tmp
= gfc_finish_block (&block
);
4572 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4573 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
4575 else_stmt
= build_empty_stmt (input_location
);
4576 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
4577 gfc_add_expr_to_block (&block
, tmp
);
4578 gfc_add_block_to_block (&se
->pre
, &block
);
4582 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4583 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4586 gfc_cleanup_loop (&loop
);
4591 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
4593 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
4599 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4600 type
= TREE_TYPE (args
[0]);
4602 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4603 build_int_cst (type
, 1), args
[1]);
4604 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
4605 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
4606 build_int_cst (type
, 0));
4607 type
= gfc_typenode_for_spec (&expr
->ts
);
4608 se
->expr
= convert (type
, tmp
);
4612 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
4614 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4618 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4620 /* Convert both arguments to the unsigned type of the same size. */
4621 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
4622 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
4624 /* If they have unequal type size, convert to the larger one. */
4625 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
4626 > TYPE_PRECISION (TREE_TYPE (args
[1])))
4627 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
4628 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
4629 > TYPE_PRECISION (TREE_TYPE (args
[0])))
4630 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
4632 /* Now, we compare them. */
4633 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4638 /* Generate code to perform the specified operation. */
4640 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4644 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4645 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
4651 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
4655 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4656 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4657 TREE_TYPE (arg
), arg
);
4660 /* Set or clear a single bit. */
4662 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
4669 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4670 type
= TREE_TYPE (args
[0]);
4672 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4673 build_int_cst (type
, 1), args
[1]);
4679 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
4681 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
4684 /* Extract a sequence of bits.
4685 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
4687 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
4694 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4695 type
= TREE_TYPE (args
[0]);
4697 mask
= build_int_cst (type
, -1);
4698 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
4699 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
4701 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
4703 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4707 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4710 tree args
[2], type
, num_bits
, cond
;
4712 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4714 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4715 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4716 type
= TREE_TYPE (args
[0]);
4719 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4721 gcc_assert (right_shift
);
4723 se
->expr
= fold_build2_loc (input_location
,
4724 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4725 TREE_TYPE (args
[0]), args
[0], args
[1]);
4728 se
->expr
= fold_convert (type
, se
->expr
);
4730 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4731 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4733 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4734 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4737 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4738 build_int_cst (type
, 0), se
->expr
);
4741 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4743 : ((shift >= 0) ? i << shift : i >> -shift)
4744 where all shifts are logical shifts. */
4746 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4758 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4760 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4761 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4763 type
= TREE_TYPE (args
[0]);
4764 utype
= unsigned_type_for (type
);
4766 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4769 /* Left shift if positive. */
4770 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4772 /* Right shift if negative.
4773 We convert to an unsigned type because we want a logical shift.
4774 The standard doesn't define the case of shifting negative
4775 numbers, and we try to be compatible with other compilers, most
4776 notably g77, here. */
4777 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4778 utype
, convert (utype
, args
[0]), width
));
4780 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4781 build_int_cst (TREE_TYPE (args
[1]), 0));
4782 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4784 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4785 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4787 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4788 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4790 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4791 build_int_cst (type
, 0), tmp
);
4795 /* Circular shift. AKA rotate or barrel shift. */
4798 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4806 unsigned int num_args
;
4808 num_args
= gfc_intrinsic_argument_list_length (expr
);
4809 args
= XALLOCAVEC (tree
, num_args
);
4811 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4815 /* Use a library function for the 3 parameter version. */
4816 tree int4type
= gfc_get_int_type (4);
4818 type
= TREE_TYPE (args
[0]);
4819 /* We convert the first argument to at least 4 bytes, and
4820 convert back afterwards. This removes the need for library
4821 functions for all argument sizes, and function will be
4822 aligned to at least 32 bits, so there's no loss. */
4823 if (expr
->ts
.kind
< 4)
4824 args
[0] = convert (int4type
, args
[0]);
4826 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4827 need loads of library functions. They cannot have values >
4828 BIT_SIZE (I) so the conversion is safe. */
4829 args
[1] = convert (int4type
, args
[1]);
4830 args
[2] = convert (int4type
, args
[2]);
4832 switch (expr
->ts
.kind
)
4837 tmp
= gfor_fndecl_math_ishftc4
;
4840 tmp
= gfor_fndecl_math_ishftc8
;
4843 tmp
= gfor_fndecl_math_ishftc16
;
4848 se
->expr
= build_call_expr_loc (input_location
,
4849 tmp
, 3, args
[0], args
[1], args
[2]);
4850 /* Convert the result back to the original type, if we extended
4851 the first argument's width above. */
4852 if (expr
->ts
.kind
< 4)
4853 se
->expr
= convert (type
, se
->expr
);
4857 type
= TREE_TYPE (args
[0]);
4859 /* Evaluate arguments only once. */
4860 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4861 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4863 /* Rotate left if positive. */
4864 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4866 /* Rotate right if negative. */
4867 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4869 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4871 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4872 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4874 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4876 /* Do nothing if shift == 0. */
4877 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4879 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4884 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4885 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4887 The conditional expression is necessary because the result of LEADZ(0)
4888 is defined, but the result of __builtin_clz(0) is undefined for most
4891 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4892 difference in bit size between the argument of LEADZ and the C int. */
4895 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4907 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4908 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4910 /* Which variant of __builtin_clz* should we call? */
4911 if (argsize
<= INT_TYPE_SIZE
)
4913 arg_type
= unsigned_type_node
;
4914 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4916 else if (argsize
<= LONG_TYPE_SIZE
)
4918 arg_type
= long_unsigned_type_node
;
4919 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4921 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4923 arg_type
= long_long_unsigned_type_node
;
4924 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4928 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4929 arg_type
= gfc_build_uint_type (argsize
);
4933 /* Convert the actual argument twice: first, to the unsigned type of the
4934 same size; then, to the proper argument type for the built-in
4935 function. But the return type is of the default INTEGER kind. */
4936 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4937 arg
= fold_convert (arg_type
, arg
);
4938 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4939 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4941 /* Compute LEADZ for the case i .ne. 0. */
4944 s
= TYPE_PRECISION (arg_type
) - argsize
;
4945 tmp
= fold_convert (result_type
,
4946 build_call_expr_loc (input_location
, func
,
4948 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4949 tmp
, build_int_cst (result_type
, s
));
4953 /* We end up here if the argument type is larger than 'long long'.
4954 We generate this code:
4956 if (x & (ULL_MAX << ULL_SIZE) != 0)
4957 return clzll ((unsigned long long) (x >> ULLSIZE));
4959 return ULL_SIZE + clzll ((unsigned long long) x);
4960 where ULL_MAX is the largest value that a ULL_MAX can hold
4961 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4962 is the bit-size of the long long type (64 in this example). */
4963 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4965 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4966 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4967 long_long_unsigned_type_node
,
4968 build_int_cst (long_long_unsigned_type_node
,
4971 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4972 fold_convert (arg_type
, ullmax
), ullsize
);
4973 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4975 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4976 cond
, build_int_cst (arg_type
, 0));
4978 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4980 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4981 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4982 tmp1
= fold_convert (result_type
,
4983 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4985 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4986 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4987 tmp2
= fold_convert (result_type
,
4988 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4989 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4992 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4996 /* Build BIT_SIZE. */
4997 bit_size
= build_int_cst (result_type
, argsize
);
4999 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5000 arg
, build_int_cst (arg_type
, 0));
5001 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5006 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5008 The conditional expression is necessary because the result of TRAILZ(0)
5009 is defined, but the result of __builtin_ctz(0) is undefined for most
5013 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
5024 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5025 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5027 /* Which variant of __builtin_ctz* should we call? */
5028 if (argsize
<= INT_TYPE_SIZE
)
5030 arg_type
= unsigned_type_node
;
5031 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
5033 else if (argsize
<= LONG_TYPE_SIZE
)
5035 arg_type
= long_unsigned_type_node
;
5036 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
5038 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5040 arg_type
= long_long_unsigned_type_node
;
5041 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5045 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5046 arg_type
= gfc_build_uint_type (argsize
);
5050 /* Convert the actual argument twice: first, to the unsigned type of the
5051 same size; then, to the proper argument type for the built-in
5052 function. But the return type is of the default INTEGER kind. */
5053 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5054 arg
= fold_convert (arg_type
, arg
);
5055 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5056 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5058 /* Compute TRAILZ for the case i .ne. 0. */
5060 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
5064 /* We end up here if the argument type is larger than 'long long'.
5065 We generate this code:
5067 if ((x & ULL_MAX) == 0)
5068 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5070 return ctzll ((unsigned long long) x);
5072 where ULL_MAX is the largest value that a ULL_MAX can hold
5073 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5074 is the bit-size of the long long type (64 in this example). */
5075 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
5077 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
5078 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5079 long_long_unsigned_type_node
,
5080 build_int_cst (long_long_unsigned_type_node
, 0));
5082 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
5083 fold_convert (arg_type
, ullmax
));
5084 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
5085 build_int_cst (arg_type
, 0));
5087 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
5089 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
5090 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5091 tmp1
= fold_convert (result_type
,
5092 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
5093 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5096 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
5097 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
5098 tmp2
= fold_convert (result_type
,
5099 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
5101 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5105 /* Build BIT_SIZE. */
5106 bit_size
= build_int_cst (result_type
, argsize
);
5108 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5109 arg
, build_int_cst (arg_type
, 0));
5110 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5114 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5115 for types larger than "long long", we call the long long built-in for
5116 the lower and higher bits and combine the result. */
5119 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5127 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5128 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5129 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5131 /* Which variant of the builtin should we call? */
5132 if (argsize
<= INT_TYPE_SIZE
)
5134 arg_type
= unsigned_type_node
;
5135 func
= builtin_decl_explicit (parity
5137 : BUILT_IN_POPCOUNT
);
5139 else if (argsize
<= LONG_TYPE_SIZE
)
5141 arg_type
= long_unsigned_type_node
;
5142 func
= builtin_decl_explicit (parity
5144 : BUILT_IN_POPCOUNTL
);
5146 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5148 arg_type
= long_long_unsigned_type_node
;
5149 func
= builtin_decl_explicit (parity
5151 : BUILT_IN_POPCOUNTLL
);
5155 /* Our argument type is larger than 'long long', which mean none
5156 of the POPCOUNT builtins covers it. We thus call the 'long long'
5157 variant multiple times, and add the results. */
5158 tree utype
, arg2
, call1
, call2
;
5160 /* For now, we only cover the case where argsize is twice as large
5162 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5164 func
= builtin_decl_explicit (parity
5166 : BUILT_IN_POPCOUNTLL
);
5168 /* Convert it to an integer, and store into a variable. */
5169 utype
= gfc_build_uint_type (argsize
);
5170 arg
= fold_convert (utype
, arg
);
5171 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5173 /* Call the builtin twice. */
5174 call1
= build_call_expr_loc (input_location
, func
, 1,
5175 fold_convert (long_long_unsigned_type_node
,
5178 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5179 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5180 call2
= build_call_expr_loc (input_location
, func
, 1,
5181 fold_convert (long_long_unsigned_type_node
,
5184 /* Combine the results. */
5186 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5189 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5195 /* Convert the actual argument twice: first, to the unsigned type of the
5196 same size; then, to the proper argument type for the built-in
5198 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5199 arg
= fold_convert (arg_type
, arg
);
5201 se
->expr
= fold_convert (result_type
,
5202 build_call_expr_loc (input_location
, func
, 1, arg
));
5206 /* Process an intrinsic with unspecified argument-types that has an optional
5207 argument (which could be of type character), e.g. EOSHIFT. For those, we
5208 need to append the string length of the optional argument if it is not
5209 present and the type is really character.
5210 primary specifies the position (starting at 1) of the non-optional argument
5211 specifying the type and optional gives the position of the optional
5212 argument in the arglist. */
5215 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5216 unsigned primary
, unsigned optional
)
5218 gfc_actual_arglist
* prim_arg
;
5219 gfc_actual_arglist
* opt_arg
;
5221 gfc_actual_arglist
* arg
;
5223 vec
<tree
, va_gc
> *append_args
;
5225 /* Find the two arguments given as position. */
5229 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5233 if (cur_pos
== primary
)
5235 if (cur_pos
== optional
)
5238 if (cur_pos
>= primary
&& cur_pos
>= optional
)
5241 gcc_assert (prim_arg
);
5242 gcc_assert (prim_arg
->expr
);
5243 gcc_assert (opt_arg
);
5245 /* If we do have type CHARACTER and the optional argument is really absent,
5246 append a dummy 0 as string length. */
5248 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
5252 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
5253 vec_alloc (append_args
, 1);
5254 append_args
->quick_push (dummy
);
5257 /* Build the call itself. */
5258 gcc_assert (!se
->ignore_optional
);
5259 sym
= gfc_get_symbol_for_expr (expr
, false);
5260 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5262 gfc_free_symbol (sym
);
5266 /* The length of a character string. */
5268 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
5277 gcc_assert (!se
->ss
);
5279 arg
= expr
->value
.function
.actual
->expr
;
5281 type
= gfc_typenode_for_spec (&expr
->ts
);
5282 switch (arg
->expr_type
)
5285 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
5289 /* Obtain the string length from the function used by
5290 trans-array.c(gfc_trans_array_constructor). */
5292 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
5296 if (arg
->ref
== NULL
5297 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
5299 /* This doesn't catch all cases.
5300 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
5301 and the surrounding thread. */
5302 sym
= arg
->symtree
->n
.sym
;
5303 decl
= gfc_get_symbol_decl (sym
);
5304 if (decl
== current_function_decl
&& sym
->attr
.function
5305 && (sym
->result
== sym
))
5306 decl
= gfc_get_fake_result_decl (sym
, 0);
5308 len
= sym
->ts
.u
.cl
->backend_decl
;
5313 /* Otherwise fall through. */
5316 /* Anybody stupid enough to do this deserves inefficient code. */
5317 gfc_init_se (&argse
, se
);
5319 gfc_conv_expr (&argse
, arg
);
5321 gfc_conv_expr_descriptor (&argse
, arg
);
5322 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5323 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5324 len
= argse
.string_length
;
5327 se
->expr
= convert (type
, len
);
5330 /* The length of a character string not including trailing blanks. */
5332 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
5334 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5335 tree args
[2], type
, fndecl
;
5337 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5338 type
= gfc_typenode_for_spec (&expr
->ts
);
5341 fndecl
= gfor_fndecl_string_len_trim
;
5343 fndecl
= gfor_fndecl_string_len_trim_char4
;
5347 se
->expr
= build_call_expr_loc (input_location
,
5348 fndecl
, 2, args
[0], args
[1]);
5349 se
->expr
= convert (type
, se
->expr
);
5353 /* Returns the starting position of a substring within a string. */
5356 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
5359 tree logical4_type_node
= gfc_get_logical_type (4);
5363 unsigned int num_args
;
5365 args
= XALLOCAVEC (tree
, 5);
5367 /* Get number of arguments; characters count double due to the
5368 string length argument. Kind= is not passed to the library
5369 and thus ignored. */
5370 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
5375 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5376 type
= gfc_typenode_for_spec (&expr
->ts
);
5379 args
[4] = build_int_cst (logical4_type_node
, 0);
5381 args
[4] = convert (logical4_type_node
, args
[4]);
5383 fndecl
= build_addr (function
, current_function_decl
);
5384 se
->expr
= build_call_array_loc (input_location
,
5385 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
5387 se
->expr
= convert (type
, se
->expr
);
5391 /* The ascii value for a single character. */
5393 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
5395 tree args
[3], type
, pchartype
;
5398 nargs
= gfc_intrinsic_argument_list_length (expr
);
5399 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
5400 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
5401 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
5402 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
5403 type
= gfc_typenode_for_spec (&expr
->ts
);
5405 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5407 se
->expr
= convert (type
, se
->expr
);
5411 /* Intrinsic ISNAN calls __builtin_isnan. */
5414 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
5418 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5419 se
->expr
= build_call_expr_loc (input_location
,
5420 builtin_decl_explicit (BUILT_IN_ISNAN
),
5422 STRIP_TYPE_NOPS (se
->expr
);
5423 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5427 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
5428 their argument against a constant integer value. */
5431 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
5435 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5436 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
5437 gfc_typenode_for_spec (&expr
->ts
),
5438 arg
, build_int_cst (TREE_TYPE (arg
), value
));
5443 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
5446 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
5454 unsigned int num_args
;
5456 num_args
= gfc_intrinsic_argument_list_length (expr
);
5457 args
= XALLOCAVEC (tree
, num_args
);
5459 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5460 if (expr
->ts
.type
!= BT_CHARACTER
)
5468 /* We do the same as in the non-character case, but the argument
5469 list is different because of the string length arguments. We
5470 also have to set the string length for the result. */
5477 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
5479 se
->string_length
= len
;
5481 type
= TREE_TYPE (tsource
);
5482 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
5483 fold_convert (type
, fsource
));
5487 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
5490 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
5492 tree args
[3], mask
, type
;
5494 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5495 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
5497 type
= TREE_TYPE (args
[0]);
5498 gcc_assert (TREE_TYPE (args
[1]) == type
);
5499 gcc_assert (TREE_TYPE (mask
) == type
);
5501 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
5502 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
5503 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5505 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
5510 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
5511 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
5514 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
5516 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
5519 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5520 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5522 type
= gfc_get_int_type (expr
->ts
.kind
);
5523 utype
= unsigned_type_for (type
);
5525 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
5526 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
5528 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
5529 build_int_cst (utype
, 0));
5533 /* Left-justified mask. */
5534 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
5536 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5537 fold_convert (utype
, res
));
5539 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
5540 smaller than type width. */
5541 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5542 build_int_cst (TREE_TYPE (arg
), 0));
5543 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
5544 build_int_cst (utype
, 0), res
);
5548 /* Right-justified mask. */
5549 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5550 fold_convert (utype
, arg
));
5551 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
5553 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
5554 strictly smaller than type width. */
5555 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5557 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
5558 cond
, allones
, res
);
5561 se
->expr
= fold_convert (type
, res
);
5565 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
5567 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
5569 tree arg
, type
, tmp
, frexp
;
5571 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5573 type
= gfc_typenode_for_spec (&expr
->ts
);
5574 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5575 tmp
= gfc_create_var (integer_type_node
, NULL
);
5576 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
5577 fold_convert (type
, arg
),
5578 gfc_build_addr_expr (NULL_TREE
, tmp
));
5579 se
->expr
= fold_convert (type
, se
->expr
);
5583 /* NEAREST (s, dir) is translated into
5584 tmp = copysign (HUGE_VAL, dir);
5585 return nextafter (s, tmp);
5588 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
5590 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
5592 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
5593 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
5595 type
= gfc_typenode_for_spec (&expr
->ts
);
5596 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5598 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
5599 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
5600 fold_convert (type
, args
[1]));
5601 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
5602 fold_convert (type
, args
[0]), tmp
);
5603 se
->expr
= fold_convert (type
, se
->expr
);
5607 /* SPACING (s) is translated into
5615 e = MAX_EXPR (e, emin);
5616 res = scalbn (1., e);
5620 where prec is the precision of s, gfc_real_kinds[k].digits,
5621 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
5622 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
5625 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
5627 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
5628 tree cond
, tmp
, frexp
, scalbn
;
5632 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5633 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
5634 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
5635 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
5637 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5638 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5640 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5641 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5643 type
= gfc_typenode_for_spec (&expr
->ts
);
5644 e
= gfc_create_var (integer_type_node
, NULL
);
5645 res
= gfc_create_var (type
, NULL
);
5648 /* Build the block for s /= 0. */
5649 gfc_start_block (&block
);
5650 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5651 gfc_build_addr_expr (NULL_TREE
, e
));
5652 gfc_add_expr_to_block (&block
, tmp
);
5654 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
5656 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
5657 integer_type_node
, tmp
, emin
));
5659 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
5660 build_real_from_int_cst (type
, integer_one_node
), e
);
5661 gfc_add_modify (&block
, res
, tmp
);
5663 /* Finish by building the IF statement. */
5664 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5665 build_real_from_int_cst (type
, integer_zero_node
));
5666 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
5667 gfc_finish_block (&block
));
5669 gfc_add_expr_to_block (&se
->pre
, tmp
);
5674 /* RRSPACING (s) is translated into
5681 x = scalbn (x, precision - e);
5685 where precision is gfc_real_kinds[k].digits. */
5688 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
5690 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
5694 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5695 prec
= gfc_real_kinds
[k
].digits
;
5697 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5698 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5699 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
5701 type
= gfc_typenode_for_spec (&expr
->ts
);
5702 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5703 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5705 e
= gfc_create_var (integer_type_node
, NULL
);
5706 x
= gfc_create_var (type
, NULL
);
5707 gfc_add_modify (&se
->pre
, x
,
5708 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5711 gfc_start_block (&block
);
5712 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5713 gfc_build_addr_expr (NULL_TREE
, e
));
5714 gfc_add_expr_to_block (&block
, tmp
);
5716 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5717 build_int_cst (integer_type_node
, prec
), e
);
5718 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5719 gfc_add_modify (&block
, x
, tmp
);
5720 stmt
= gfc_finish_block (&block
);
5722 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5723 build_real_from_int_cst (type
, integer_zero_node
));
5724 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5725 gfc_add_expr_to_block (&se
->pre
, tmp
);
5727 se
->expr
= fold_convert (type
, x
);
5731 /* SCALE (s, i) is translated into scalbn (s, i). */
5733 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5735 tree args
[2], type
, scalbn
;
5737 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5739 type
= gfc_typenode_for_spec (&expr
->ts
);
5740 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5741 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5742 fold_convert (type
, args
[0]),
5743 fold_convert (integer_type_node
, args
[1]));
5744 se
->expr
= fold_convert (type
, se
->expr
);
5748 /* SET_EXPONENT (s, i) is translated into
5749 scalbn (frexp (s, &dummy_int), i). */
5751 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5753 tree args
[2], type
, tmp
, frexp
, scalbn
;
5755 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5756 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5758 type
= gfc_typenode_for_spec (&expr
->ts
);
5759 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5761 tmp
= gfc_create_var (integer_type_node
, NULL
);
5762 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5763 fold_convert (type
, args
[0]),
5764 gfc_build_addr_expr (NULL_TREE
, tmp
));
5765 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5766 fold_convert (integer_type_node
, args
[1]));
5767 se
->expr
= fold_convert (type
, se
->expr
);
5772 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5774 gfc_actual_arglist
*actual
;
5781 gfc_init_se (&argse
, NULL
);
5782 actual
= expr
->value
.function
.actual
;
5784 if (actual
->expr
->ts
.type
== BT_CLASS
)
5785 gfc_add_class_array_ref (actual
->expr
);
5787 argse
.want_pointer
= 1;
5788 argse
.data_not_needed
= 1;
5789 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5790 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5791 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5792 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5794 /* Build the call to size0. */
5795 fncall0
= build_call_expr_loc (input_location
,
5796 gfor_fndecl_size0
, 1, arg1
);
5798 actual
= actual
->next
;
5802 gfc_init_se (&argse
, NULL
);
5803 gfc_conv_expr_type (&argse
, actual
->expr
,
5804 gfc_array_index_type
);
5805 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5807 /* Unusually, for an intrinsic, size does not exclude
5808 an optional arg2, so we must test for it. */
5809 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5810 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5811 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5814 /* Build the call to size1. */
5815 fncall1
= build_call_expr_loc (input_location
,
5816 gfor_fndecl_size1
, 2,
5819 gfc_init_se (&argse
, NULL
);
5820 argse
.want_pointer
= 1;
5821 argse
.data_not_needed
= 1;
5822 gfc_conv_expr (&argse
, actual
->expr
);
5823 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5824 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5825 argse
.expr
, null_pointer_node
);
5826 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5827 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5828 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5832 se
->expr
= NULL_TREE
;
5833 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5834 gfc_array_index_type
,
5835 argse
.expr
, gfc_index_one_node
);
5838 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5840 argse
.expr
= gfc_index_zero_node
;
5841 se
->expr
= NULL_TREE
;
5846 if (se
->expr
== NULL_TREE
)
5848 tree ubound
, lbound
;
5850 arg1
= build_fold_indirect_ref_loc (input_location
,
5852 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5853 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5854 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5855 gfc_array_index_type
, ubound
, lbound
);
5856 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5857 gfc_array_index_type
,
5858 se
->expr
, gfc_index_one_node
);
5859 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5860 gfc_array_index_type
, se
->expr
,
5861 gfc_index_zero_node
);
5864 type
= gfc_typenode_for_spec (&expr
->ts
);
5865 se
->expr
= convert (type
, se
->expr
);
5869 /* Helper function to compute the size of a character variable,
5870 excluding the terminating null characters. The result has
5871 gfc_array_index_type type. */
5874 size_of_string_in_bytes (int kind
, tree string_length
)
5877 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5879 bytesize
= build_int_cst (gfc_array_index_type
,
5880 gfc_character_kinds
[i
].bit_size
/ 8);
5882 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5884 fold_convert (gfc_array_index_type
, string_length
));
5889 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5900 gfc_init_se (&argse
, NULL
);
5901 arg
= expr
->value
.function
.actual
->expr
;
5903 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
5904 gfc_conv_expr_descriptor (&argse
, arg
);
5906 gfc_conv_expr_reference (&argse
, arg
);
5908 if (arg
->ts
.type
== BT_ASSUMED
)
5910 /* This only works if an array descriptor has been passed; thus, extract
5911 the size from the descriptor. */
5912 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
5913 == TYPE_PRECISION (size_type_node
));
5914 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
5915 tmp
= DECL_LANG_SPECIFIC (tmp
)
5916 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
5917 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
5918 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
5919 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5920 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
5921 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
5922 build_int_cst (TREE_TYPE (tmp
),
5923 GFC_DTYPE_SIZE_SHIFT
));
5924 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
5926 else if (arg
->ts
.type
== BT_CLASS
)
5929 byte_size
= gfc_vtable_size_get (TREE_OPERAND (argse
.expr
, 0));
5931 byte_size
= gfc_vtable_size_get (argse
.expr
);
5935 if (arg
->ts
.type
== BT_CHARACTER
)
5936 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5940 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5943 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5944 byte_size
= fold_convert (gfc_array_index_type
,
5945 size_in_bytes (byte_size
));
5950 se
->expr
= byte_size
;
5953 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5954 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
5956 if (arg
->rank
== -1)
5958 tree cond
, loop_var
, exit_label
;
5961 tmp
= fold_convert (gfc_array_index_type
,
5962 gfc_conv_descriptor_rank (argse
.expr
));
5963 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
5964 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
5965 exit_label
= gfc_build_label_decl (NULL_TREE
);
5972 source_bytes = source_bytes * array.dim[i].extent;
5976 gfc_start_block (&body
);
5977 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5979 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5980 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5981 cond
, tmp
, build_empty_stmt (input_location
));
5982 gfc_add_expr_to_block (&body
, tmp
);
5984 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
5985 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
5986 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
5987 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5988 gfc_array_index_type
, tmp
, source_bytes
);
5989 gfc_add_modify (&body
, source_bytes
, tmp
);
5991 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5992 gfc_array_index_type
, loop_var
,
5993 gfc_index_one_node
);
5994 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
5996 tmp
= gfc_finish_block (&body
);
5998 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
6000 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6002 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6003 gfc_add_expr_to_block (&argse
.pre
, tmp
);
6007 /* Obtain the size of the array in bytes. */
6008 for (n
= 0; n
< arg
->rank
; n
++)
6011 idx
= gfc_rank_cst
[n
];
6012 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6013 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6014 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
6015 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6016 gfc_array_index_type
, tmp
, source_bytes
);
6017 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6020 se
->expr
= source_bytes
;
6023 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6028 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
6032 tree type
, result_type
, tmp
;
6034 arg
= expr
->value
.function
.actual
->expr
;
6036 gfc_init_se (&argse
, NULL
);
6037 result_type
= gfc_get_int_type (expr
->ts
.kind
);
6041 if (arg
->ts
.type
== BT_CLASS
)
6043 gfc_add_vptr_component (arg
);
6044 gfc_add_size_component (arg
);
6045 gfc_conv_expr (&argse
, arg
);
6046 tmp
= fold_convert (result_type
, argse
.expr
);
6050 gfc_conv_expr_reference (&argse
, arg
);
6051 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6056 argse
.want_pointer
= 0;
6057 gfc_conv_expr_descriptor (&argse
, arg
);
6058 if (arg
->ts
.type
== BT_CLASS
)
6060 tmp
= gfc_vtable_size_get (TREE_OPERAND (argse
.expr
, 0));
6061 tmp
= fold_convert (result_type
, tmp
);
6064 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6067 /* Obtain the argument's word length. */
6068 if (arg
->ts
.type
== BT_CHARACTER
)
6069 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6071 tmp
= size_in_bytes (type
);
6072 tmp
= fold_convert (result_type
, tmp
);
6075 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6076 build_int_cst (result_type
, BITS_PER_UNIT
));
6077 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6081 /* Intrinsic string comparison functions. */
6084 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6088 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6091 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6092 expr
->value
.function
.actual
->expr
->ts
.kind
,
6094 se
->expr
= fold_build2_loc (input_location
, op
,
6095 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6096 build_int_cst (TREE_TYPE (se
->expr
), 0));
6099 /* Generate a call to the adjustl/adjustr library function. */
6101 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6109 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6112 type
= TREE_TYPE (args
[2]);
6113 var
= gfc_conv_string_tmp (se
, type
, len
);
6116 tmp
= build_call_expr_loc (input_location
,
6117 fndecl
, 3, args
[0], args
[1], args
[2]);
6118 gfc_add_expr_to_block (&se
->pre
, tmp
);
6120 se
->string_length
= len
;
6124 /* Generate code for the TRANSFER intrinsic:
6126 DEST = TRANSFER (SOURCE, MOLD)
6128 typeof<DEST> = typeof<MOLD>
6133 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6135 typeof<DEST> = typeof<MOLD>
6137 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6138 sizeof (DEST(0) * SIZE). */
6140 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6156 gfc_actual_arglist
*arg
;
6158 gfc_array_info
*info
;
6162 gfc_expr
*source_expr
, *mold_expr
;
6166 info
= &se
->ss
->info
->data
.array
;
6168 /* Convert SOURCE. The output from this stage is:-
6169 source_bytes = length of the source in bytes
6170 source = pointer to the source data. */
6171 arg
= expr
->value
.function
.actual
;
6172 source_expr
= arg
->expr
;
6174 /* Ensure double transfer through LOGICAL preserves all
6176 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6177 && arg
->expr
->value
.function
.esym
== NULL
6178 && arg
->expr
->value
.function
.isym
!= NULL
6179 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6180 && arg
->expr
->ts
.type
== BT_LOGICAL
6181 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6182 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6184 gfc_init_se (&argse
, NULL
);
6186 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6188 /* Obtain the pointer to source and the length of source in bytes. */
6189 if (arg
->expr
->rank
== 0)
6191 gfc_conv_expr_reference (&argse
, arg
->expr
);
6192 if (arg
->expr
->ts
.type
== BT_CLASS
)
6193 source
= gfc_class_data_get (argse
.expr
);
6195 source
= argse
.expr
;
6197 /* Obtain the source word length. */
6198 switch (arg
->expr
->ts
.type
)
6201 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6202 argse
.string_length
);
6205 tmp
= gfc_vtable_size_get (argse
.expr
);
6208 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6210 tmp
= fold_convert (gfc_array_index_type
,
6211 size_in_bytes (source_type
));
6217 argse
.want_pointer
= 0;
6218 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6219 source
= gfc_conv_descriptor_data_get (argse
.expr
);
6220 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6222 /* Repack the source if not simply contiguous. */
6223 if (!gfc_is_simply_contiguous (arg
->expr
, false))
6225 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
6227 if (gfc_option
.warn_array_temp
)
6228 gfc_warning ("Creating array temporary at %L", &expr
->where
);
6230 source
= build_call_expr_loc (input_location
,
6231 gfor_fndecl_in_pack
, 1, tmp
);
6232 source
= gfc_evaluate_now (source
, &argse
.pre
);
6234 /* Free the temporary. */
6235 gfc_start_block (&block
);
6236 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
6237 gfc_add_expr_to_block (&block
, tmp
);
6238 stmt
= gfc_finish_block (&block
);
6240 /* Clean up if it was repacked. */
6241 gfc_init_block (&block
);
6242 tmp
= gfc_conv_array_data (argse
.expr
);
6243 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6245 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
6246 build_empty_stmt (input_location
));
6247 gfc_add_expr_to_block (&block
, tmp
);
6248 gfc_add_block_to_block (&block
, &se
->post
);
6249 gfc_init_block (&se
->post
);
6250 gfc_add_block_to_block (&se
->post
, &block
);
6253 /* Obtain the source word length. */
6254 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
6255 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6256 argse
.string_length
);
6258 tmp
= fold_convert (gfc_array_index_type
,
6259 size_in_bytes (source_type
));
6261 /* Obtain the size of the array in bytes. */
6262 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
6263 for (n
= 0; n
< arg
->expr
->rank
; n
++)
6266 idx
= gfc_rank_cst
[n
];
6267 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6268 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6269 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6270 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6271 gfc_array_index_type
, upper
, lower
);
6272 gfc_add_modify (&argse
.pre
, extent
, tmp
);
6273 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6274 gfc_array_index_type
, extent
,
6275 gfc_index_one_node
);
6276 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6277 gfc_array_index_type
, tmp
, source_bytes
);
6281 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6282 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6283 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6285 /* Now convert MOLD. The outputs are:
6286 mold_type = the TREE type of MOLD
6287 dest_word_len = destination word length in bytes. */
6289 mold_expr
= arg
->expr
;
6291 gfc_init_se (&argse
, NULL
);
6293 scalar_mold
= arg
->expr
->rank
== 0;
6295 if (arg
->expr
->rank
== 0)
6297 gfc_conv_expr_reference (&argse
, arg
->expr
);
6298 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6303 gfc_init_se (&argse
, NULL
);
6304 argse
.want_pointer
= 0;
6305 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6306 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6309 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6310 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6312 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
6314 /* If this TRANSFER is nested in another TRANSFER, use a type
6315 that preserves all bits. */
6316 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
6317 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
6320 /* Obtain the destination word length. */
6321 switch (arg
->expr
->ts
.type
)
6324 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
6325 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
6328 tmp
= gfc_vtable_size_get (argse
.expr
);
6331 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
6334 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
6335 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
6337 /* Finally convert SIZE, if it is present. */
6339 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
6343 gfc_init_se (&argse
, NULL
);
6344 gfc_conv_expr_reference (&argse
, arg
->expr
);
6345 tmp
= convert (gfc_array_index_type
,
6346 build_fold_indirect_ref_loc (input_location
,
6348 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6349 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6354 /* Separate array and scalar results. */
6355 if (scalar_mold
&& tmp
== NULL_TREE
)
6356 goto scalar_transfer
;
6358 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6359 if (tmp
!= NULL_TREE
)
6360 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6361 tmp
, dest_word_len
);
6365 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
6366 gfc_add_modify (&se
->pre
, size_words
,
6367 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
6368 gfc_array_index_type
,
6369 size_bytes
, dest_word_len
));
6371 /* Evaluate the bounds of the result. If the loop range exists, we have
6372 to check if it is too large. If so, we modify loop->to be consistent
6373 with min(size, size(source)). Otherwise, size is made consistent with
6374 the loop range, so that the right number of bytes is transferred.*/
6375 n
= se
->loop
->order
[0];
6376 if (se
->loop
->to
[n
] != NULL_TREE
)
6378 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6379 se
->loop
->to
[n
], se
->loop
->from
[n
]);
6380 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6381 tmp
, gfc_index_one_node
);
6382 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6384 gfc_add_modify (&se
->pre
, size_words
, tmp
);
6385 gfc_add_modify (&se
->pre
, size_bytes
,
6386 fold_build2_loc (input_location
, MULT_EXPR
,
6387 gfc_array_index_type
,
6388 size_words
, dest_word_len
));
6389 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6390 size_words
, se
->loop
->from
[n
]);
6391 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6392 upper
, gfc_index_one_node
);
6396 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6397 size_words
, gfc_index_one_node
);
6398 se
->loop
->from
[n
] = gfc_index_zero_node
;
6401 se
->loop
->to
[n
] = upper
;
6403 /* Build a destination descriptor, using the pointer, source, as the
6405 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
6406 NULL_TREE
, false, true, false, &expr
->where
);
6408 /* Cast the pointer to the result. */
6409 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6410 tmp
= fold_convert (pvoid_type_node
, tmp
);
6412 /* Use memcpy to do the transfer. */
6414 = build_call_expr_loc (input_location
,
6415 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
6416 fold_convert (pvoid_type_node
, source
),
6417 fold_convert (size_type_node
,
6418 fold_build2_loc (input_location
,
6420 gfc_array_index_type
,
6423 gfc_add_expr_to_block (&se
->pre
, tmp
);
6425 se
->expr
= info
->descriptor
;
6426 if (expr
->ts
.type
== BT_CHARACTER
)
6427 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6431 /* Deal with scalar results. */
6433 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6434 dest_word_len
, source_bytes
);
6435 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6436 extent
, gfc_index_zero_node
);
6438 if (expr
->ts
.type
== BT_CHARACTER
)
6440 tree direct
, indirect
, free
;
6442 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
6443 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
6446 /* If source is longer than the destination, use a pointer to
6447 the source directly. */
6448 gfc_init_block (&block
);
6449 gfc_add_modify (&block
, tmpdecl
, ptr
);
6450 direct
= gfc_finish_block (&block
);
6452 /* Otherwise, allocate a string with the length of the destination
6453 and copy the source into it. */
6454 gfc_init_block (&block
);
6455 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
6456 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
6457 gfc_add_modify (&block
, tmpdecl
,
6458 fold_convert (TREE_TYPE (ptr
), tmp
));
6459 tmp
= build_call_expr_loc (input_location
,
6460 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6461 fold_convert (pvoid_type_node
, tmpdecl
),
6462 fold_convert (pvoid_type_node
, ptr
),
6463 fold_convert (size_type_node
, extent
));
6464 gfc_add_expr_to_block (&block
, tmp
);
6465 indirect
= gfc_finish_block (&block
);
6467 /* Wrap it up with the condition. */
6468 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
6469 dest_word_len
, source_bytes
);
6470 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
6471 gfc_add_expr_to_block (&se
->pre
, tmp
);
6473 /* Free the temporary string, if necessary. */
6474 free
= gfc_call_free (tmpdecl
);
6475 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6476 dest_word_len
, source_bytes
);
6477 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
6478 gfc_add_expr_to_block (&se
->post
, tmp
);
6481 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6485 tmpdecl
= gfc_create_var (mold_type
, "transfer");
6487 ptr
= convert (build_pointer_type (mold_type
), source
);
6489 /* For CLASS results, allocate the needed memory first. */
6490 if (mold_expr
->ts
.type
== BT_CLASS
)
6493 cdata
= gfc_class_data_get (tmpdecl
);
6494 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
6495 gfc_add_modify (&se
->pre
, cdata
, tmp
);
6498 /* Use memcpy to do the transfer. */
6499 if (mold_expr
->ts
.type
== BT_CLASS
)
6500 tmp
= gfc_class_data_get (tmpdecl
);
6502 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
6504 tmp
= build_call_expr_loc (input_location
,
6505 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6506 fold_convert (pvoid_type_node
, tmp
),
6507 fold_convert (pvoid_type_node
, ptr
),
6508 fold_convert (size_type_node
, extent
));
6509 gfc_add_expr_to_block (&se
->pre
, tmp
);
6511 /* For CLASS results, set the _vptr. */
6512 if (mold_expr
->ts
.type
== BT_CLASS
)
6516 vptr
= gfc_class_vptr_get (tmpdecl
);
6517 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
6519 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
6520 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
6528 /* Generate code for the ALLOCATED intrinsic.
6529 Generate inline code that directly check the address of the argument. */
6532 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
6534 gfc_actual_arglist
*arg1
;
6538 gfc_init_se (&arg1se
, NULL
);
6539 arg1
= expr
->value
.function
.actual
;
6541 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6543 /* Make sure that class array expressions have both a _data
6544 component reference and an array reference.... */
6545 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
6546 gfc_add_class_array_ref (arg1
->expr
);
6547 /* .... whilst scalars only need the _data component. */
6549 gfc_add_data_component (arg1
->expr
);
6552 if (arg1
->expr
->rank
== 0)
6554 /* Allocatable scalar. */
6555 arg1se
.want_pointer
= 1;
6556 gfc_conv_expr (&arg1se
, arg1
->expr
);
6561 /* Allocatable array. */
6562 arg1se
.descriptor_only
= 1;
6563 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6564 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6567 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
6568 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6569 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6573 /* Generate code for the ASSOCIATED intrinsic.
6574 If both POINTER and TARGET are arrays, generate a call to library function
6575 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
6576 In other cases, generate inline code that directly compare the address of
6577 POINTER with the address of TARGET. */
6580 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
6582 gfc_actual_arglist
*arg1
;
6583 gfc_actual_arglist
*arg2
;
6588 tree nonzero_charlen
;
6589 tree nonzero_arraylen
;
6593 gfc_init_se (&arg1se
, NULL
);
6594 gfc_init_se (&arg2se
, NULL
);
6595 arg1
= expr
->value
.function
.actual
;
6598 /* Check whether the expression is a scalar or not; we cannot use
6599 arg1->expr->rank as it can be nonzero for proc pointers. */
6600 ss
= gfc_walk_expr (arg1
->expr
);
6601 scalar
= ss
== gfc_ss_terminator
;
6603 gfc_free_ss_chain (ss
);
6607 /* No optional target. */
6610 /* A pointer to a scalar. */
6611 arg1se
.want_pointer
= 1;
6612 gfc_conv_expr (&arg1se
, arg1
->expr
);
6613 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6614 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6615 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6617 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6618 tmp2
= gfc_class_data_get (arg1se
.expr
);
6624 /* A pointer to an array. */
6625 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6626 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6628 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6629 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6630 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
6631 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
6636 /* An optional target. */
6637 if (arg2
->expr
->ts
.type
== BT_CLASS
)
6638 gfc_add_data_component (arg2
->expr
);
6640 nonzero_charlen
= NULL_TREE
;
6641 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
6642 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
6644 arg1
->expr
->ts
.u
.cl
->backend_decl
,
6648 /* A pointer to a scalar. */
6649 arg1se
.want_pointer
= 1;
6650 gfc_conv_expr (&arg1se
, arg1
->expr
);
6651 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6652 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6653 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6655 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6656 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
6658 arg2se
.want_pointer
= 1;
6659 gfc_conv_expr (&arg2se
, arg2
->expr
);
6660 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6661 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
6662 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
6664 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6665 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6666 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6667 arg1se
.expr
, arg2se
.expr
);
6668 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6669 arg1se
.expr
, null_pointer_node
);
6670 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6671 boolean_type_node
, tmp
, tmp2
);
6675 /* An array pointer of zero length is not associated if target is
6677 arg1se
.descriptor_only
= 1;
6678 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
6679 if (arg1
->expr
->rank
== -1)
6681 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
6682 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6683 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
6686 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
6687 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
6688 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
6689 boolean_type_node
, tmp
,
6690 build_int_cst (TREE_TYPE (tmp
), 0));
6692 /* A pointer to an array, call library function _gfor_associated. */
6693 arg1se
.want_pointer
= 1;
6694 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6696 arg2se
.want_pointer
= 1;
6697 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
6698 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6699 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6700 se
->expr
= build_call_expr_loc (input_location
,
6701 gfor_fndecl_associated
, 2,
6702 arg1se
.expr
, arg2se
.expr
);
6703 se
->expr
= convert (boolean_type_node
, se
->expr
);
6704 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6705 boolean_type_node
, se
->expr
,
6709 /* If target is present zero character length pointers cannot
6711 if (nonzero_charlen
!= NULL_TREE
)
6712 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6714 se
->expr
, nonzero_charlen
);
6717 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6721 /* Generate code for the SAME_TYPE_AS intrinsic.
6722 Generate inline code that directly checks the vindices. */
6725 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
6730 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
6732 gfc_init_se (&se1
, NULL
);
6733 gfc_init_se (&se2
, NULL
);
6735 a
= expr
->value
.function
.actual
->expr
;
6736 b
= expr
->value
.function
.actual
->next
->expr
;
6738 if (UNLIMITED_POLY (a
))
6740 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
6741 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6742 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6745 if (UNLIMITED_POLY (b
))
6747 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
6748 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6749 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6752 if (a
->ts
.type
== BT_CLASS
)
6754 gfc_add_vptr_component (a
);
6755 gfc_add_hash_component (a
);
6757 else if (a
->ts
.type
== BT_DERIVED
)
6758 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6759 a
->ts
.u
.derived
->hash_value
);
6761 if (b
->ts
.type
== BT_CLASS
)
6763 gfc_add_vptr_component (b
);
6764 gfc_add_hash_component (b
);
6766 else if (b
->ts
.type
== BT_DERIVED
)
6767 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6768 b
->ts
.u
.derived
->hash_value
);
6770 gfc_conv_expr (&se1
, a
);
6771 gfc_conv_expr (&se2
, b
);
6773 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6774 boolean_type_node
, se1
.expr
,
6775 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
6778 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6779 boolean_type_node
, conda
, tmp
);
6782 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6783 boolean_type_node
, condb
, tmp
);
6785 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6789 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6792 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6796 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6797 se
->expr
= build_call_expr_loc (input_location
,
6798 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6799 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6803 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6806 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6810 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6812 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6813 type
= gfc_get_int_type (4);
6814 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6816 /* Convert it to the required type. */
6817 type
= gfc_typenode_for_spec (&expr
->ts
);
6818 se
->expr
= build_call_expr_loc (input_location
,
6819 gfor_fndecl_si_kind
, 1, arg
);
6820 se
->expr
= fold_convert (type
, se
->expr
);
6824 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6827 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6829 gfc_actual_arglist
*actual
;
6832 vec
<tree
, va_gc
> *args
= NULL
;
6834 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6836 gfc_init_se (&argse
, se
);
6838 /* Pass a NULL pointer for an absent arg. */
6839 if (actual
->expr
== NULL
)
6840 argse
.expr
= null_pointer_node
;
6846 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6848 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6849 ts
.type
= BT_INTEGER
;
6850 ts
.kind
= gfc_c_int_kind
;
6851 gfc_convert_type (actual
->expr
, &ts
, 2);
6853 gfc_conv_expr_reference (&argse
, actual
->expr
);
6856 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6857 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6858 vec_safe_push (args
, argse
.expr
);
6861 /* Convert it to the required type. */
6862 type
= gfc_typenode_for_spec (&expr
->ts
);
6863 se
->expr
= build_call_expr_loc_vec (input_location
,
6864 gfor_fndecl_sr_kind
, args
);
6865 se
->expr
= fold_convert (type
, se
->expr
);
6869 /* Generate code for TRIM (A) intrinsic function. */
6872 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6882 unsigned int num_args
;
6884 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6885 args
= XALLOCAVEC (tree
, num_args
);
6887 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6888 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6889 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6891 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6892 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6895 if (expr
->ts
.kind
== 1)
6896 function
= gfor_fndecl_string_trim
;
6897 else if (expr
->ts
.kind
== 4)
6898 function
= gfor_fndecl_string_trim_char4
;
6902 fndecl
= build_addr (function
, current_function_decl
);
6903 tmp
= build_call_array_loc (input_location
,
6904 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6906 gfc_add_expr_to_block (&se
->pre
, tmp
);
6908 /* Free the temporary afterwards, if necessary. */
6909 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6910 len
, build_int_cst (TREE_TYPE (len
), 0));
6911 tmp
= gfc_call_free (var
);
6912 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6913 gfc_add_expr_to_block (&se
->post
, tmp
);
6916 se
->string_length
= len
;
6920 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6923 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6925 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6926 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6928 stmtblock_t block
, body
;
6931 /* We store in charsize the size of a character. */
6932 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6933 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6935 /* Get the arguments. */
6936 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6937 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6939 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6940 ncopies_type
= TREE_TYPE (ncopies
);
6942 /* Check that NCOPIES is not negative. */
6943 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6944 build_int_cst (ncopies_type
, 0));
6945 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6946 "Argument NCOPIES of REPEAT intrinsic is negative "
6947 "(its value is %ld)",
6948 fold_convert (long_integer_type_node
, ncopies
));
6950 /* If the source length is zero, any non negative value of NCOPIES
6951 is valid, and nothing happens. */
6952 n
= gfc_create_var (ncopies_type
, "ncopies");
6953 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6954 build_int_cst (size_type_node
, 0));
6955 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6956 build_int_cst (ncopies_type
, 0), ncopies
);
6957 gfc_add_modify (&se
->pre
, n
, tmp
);
6960 /* Check that ncopies is not too large: ncopies should be less than
6961 (or equal to) MAX / slen, where MAX is the maximal integer of
6962 the gfc_charlen_type_node type. If slen == 0, we need a special
6963 case to avoid the division by zero. */
6964 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6965 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6966 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6967 fold_convert (size_type_node
, max
), slen
);
6968 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6969 ? size_type_node
: ncopies_type
;
6970 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6971 fold_convert (largest
, ncopies
),
6972 fold_convert (largest
, max
));
6973 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6974 build_int_cst (size_type_node
, 0));
6975 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6976 boolean_false_node
, cond
);
6977 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6978 "Argument NCOPIES of REPEAT intrinsic is too large");
6980 /* Compute the destination length. */
6981 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6982 fold_convert (gfc_charlen_type_node
, slen
),
6983 fold_convert (gfc_charlen_type_node
, ncopies
));
6984 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6985 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6987 /* Generate the code to do the repeat operation:
6988 for (i = 0; i < ncopies; i++)
6989 memmove (dest + (i * slen * size), src, slen*size); */
6990 gfc_start_block (&block
);
6991 count
= gfc_create_var (ncopies_type
, "count");
6992 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6993 exit_label
= gfc_build_label_decl (NULL_TREE
);
6995 /* Start the loop body. */
6996 gfc_start_block (&body
);
6998 /* Exit the loop if count >= ncopies. */
6999 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
7001 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7002 TREE_USED (exit_label
) = 1;
7003 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7004 build_empty_stmt (input_location
));
7005 gfc_add_expr_to_block (&body
, tmp
);
7007 /* Call memmove (dest + (i*slen*size), src, slen*size). */
7008 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7009 fold_convert (gfc_charlen_type_node
, slen
),
7010 fold_convert (gfc_charlen_type_node
, count
));
7011 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
7012 tmp
, fold_convert (gfc_charlen_type_node
, size
));
7013 tmp
= fold_build_pointer_plus_loc (input_location
,
7014 fold_convert (pvoid_type_node
, dest
), tmp
);
7015 tmp
= build_call_expr_loc (input_location
,
7016 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7018 fold_build2_loc (input_location
, MULT_EXPR
,
7019 size_type_node
, slen
,
7020 fold_convert (size_type_node
,
7022 gfc_add_expr_to_block (&body
, tmp
);
7024 /* Increment count. */
7025 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
7026 count
, build_int_cst (TREE_TYPE (count
), 1));
7027 gfc_add_modify (&body
, count
, tmp
);
7029 /* Build the loop. */
7030 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
7031 gfc_add_expr_to_block (&block
, tmp
);
7033 /* Add the exit label. */
7034 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7035 gfc_add_expr_to_block (&block
, tmp
);
7037 /* Finish the block. */
7038 tmp
= gfc_finish_block (&block
);
7039 gfc_add_expr_to_block (&se
->pre
, tmp
);
7041 /* Set the result value. */
7043 se
->string_length
= dlen
;
7047 /* Generate code for the IARGC intrinsic. */
7050 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
7056 /* Call the library function. This always returns an INTEGER(4). */
7057 fndecl
= gfor_fndecl_iargc
;
7058 tmp
= build_call_expr_loc (input_location
,
7061 /* Convert it to the required type. */
7062 type
= gfc_typenode_for_spec (&expr
->ts
);
7063 tmp
= fold_convert (type
, tmp
);
7069 /* The loc intrinsic returns the address of its argument as
7070 gfc_index_integer_kind integer. */
7073 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7078 gcc_assert (!se
->ss
);
7080 arg_expr
= expr
->value
.function
.actual
->expr
;
7081 if (arg_expr
->rank
== 0)
7082 gfc_conv_expr_reference (se
, arg_expr
);
7084 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7085 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7087 /* Create a temporary variable for loc return value. Without this,
7088 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7089 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7090 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7091 se
->expr
= temp_var
;
7095 /* The following routine generates code for the intrinsic
7096 functions from the ISO_C_BINDING module:
7102 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7104 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7106 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7108 if (arg
->expr
->rank
== 0)
7109 gfc_conv_expr_reference (se
, arg
->expr
);
7110 else if (gfc_is_simply_contiguous (arg
->expr
, false))
7111 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7114 gfc_conv_expr_descriptor (se
, arg
->expr
);
7115 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7118 /* TODO -- the following two lines shouldn't be necessary, but if
7119 they're removed, a bug is exposed later in the code path.
7120 This workaround was thus introduced, but will have to be
7121 removed; please see PR 35150 for details about the issue. */
7122 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7123 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7125 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7126 gfc_conv_expr_reference (se
, arg
->expr
);
7127 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7132 /* Build the addr_expr for the first argument. The argument is
7133 already an *address* so we don't need to set want_pointer in
7135 gfc_init_se (&arg1se
, NULL
);
7136 gfc_conv_expr (&arg1se
, arg
->expr
);
7137 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7138 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7140 /* See if we were given two arguments. */
7141 if (arg
->next
->expr
== NULL
)
7142 /* Only given one arg so generate a null and do a
7143 not-equal comparison against the first arg. */
7144 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7146 fold_convert (TREE_TYPE (arg1se
.expr
),
7147 null_pointer_node
));
7153 /* Given two arguments so build the arg2se from second arg. */
7154 gfc_init_se (&arg2se
, NULL
);
7155 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
7156 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7157 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7159 /* Generate test to compare that the two args are equal. */
7160 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7161 arg1se
.expr
, arg2se
.expr
);
7162 /* Generate test to ensure that the first arg is not null. */
7163 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
7165 arg1se
.expr
, null_pointer_node
);
7167 /* Finally, the generated test must check that both arg1 is not
7168 NULL and that it is equal to the second arg. */
7169 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7171 not_null_expr
, eq_expr
);
7179 /* The following routine generates code for the intrinsic
7180 subroutines from the ISO_C_BINDING module:
7182 * C_F_PROCPOINTER. */
7185 conv_isocbinding_subroutine (gfc_code
*code
)
7192 tree desc
, dim
, tmp
, stride
, offset
;
7193 stmtblock_t body
, block
;
7195 gfc_actual_arglist
*arg
= code
->ext
.actual
;
7197 gfc_init_se (&se
, NULL
);
7198 gfc_init_se (&cptrse
, NULL
);
7199 gfc_conv_expr (&cptrse
, arg
->expr
);
7200 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
7201 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
7203 gfc_init_se (&fptrse
, NULL
);
7204 if (arg
->next
->expr
->rank
== 0)
7206 fptrse
.want_pointer
= 1;
7207 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
7208 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
7209 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
7210 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7211 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
7212 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
7214 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7215 TREE_TYPE (fptrse
.expr
),
7217 fold_convert (TREE_TYPE (fptrse
.expr
),
7219 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
7220 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7221 return gfc_finish_block (&se
.pre
);
7224 gfc_start_block (&block
);
7226 /* Get the descriptor of the Fortran pointer. */
7227 fptrse
.descriptor_only
= 1;
7228 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
7229 gfc_add_block_to_block (&block
, &fptrse
.pre
);
7232 /* Set data value, dtype, and offset. */
7233 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
7234 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
7235 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7236 gfc_get_dtype (TREE_TYPE (desc
)));
7238 /* Start scalarization of the bounds, using the shape argument. */
7240 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
7241 gcc_assert (shape_ss
!= gfc_ss_terminator
);
7242 gfc_init_se (&shapese
, NULL
);
7244 gfc_init_loopinfo (&loop
);
7245 gfc_add_ss_to_loop (&loop
, shape_ss
);
7246 gfc_conv_ss_startstride (&loop
);
7247 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
7248 gfc_mark_ss_chain_used (shape_ss
, 1);
7250 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
7251 shapese
.ss
= shape_ss
;
7253 stride
= gfc_create_var (gfc_array_index_type
, "stride");
7254 offset
= gfc_create_var (gfc_array_index_type
, "offset");
7255 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
7256 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7259 gfc_start_scalarized_body (&loop
, &body
);
7261 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7262 loop
.loopvar
[0], loop
.from
[0]);
7264 /* Set bounds and stride. */
7265 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
7266 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
7268 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
7269 gfc_add_block_to_block (&body
, &shapese
.pre
);
7270 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
7271 gfc_add_block_to_block (&body
, &shapese
.post
);
7273 /* Calculate offset. */
7274 gfc_add_modify (&body
, offset
,
7275 fold_build2_loc (input_location
, PLUS_EXPR
,
7276 gfc_array_index_type
, offset
, stride
));
7277 /* Update stride. */
7278 gfc_add_modify (&body
, stride
,
7279 fold_build2_loc (input_location
, MULT_EXPR
,
7280 gfc_array_index_type
, stride
,
7281 fold_convert (gfc_array_index_type
,
7283 /* Finish scalarization loop. */
7284 gfc_trans_scalarizing_loops (&loop
, &body
);
7285 gfc_add_block_to_block (&block
, &loop
.pre
);
7286 gfc_add_block_to_block (&block
, &loop
.post
);
7287 gfc_add_block_to_block (&block
, &fptrse
.post
);
7288 gfc_cleanup_loop (&loop
);
7290 gfc_add_modify (&block
, offset
,
7291 fold_build1_loc (input_location
, NEGATE_EXPR
,
7292 gfc_array_index_type
, offset
));
7293 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
7295 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
7296 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7297 return gfc_finish_block (&se
.pre
);
7301 /* Generate code for an intrinsic function. Some map directly to library
7302 calls, others get special handling. In some cases the name of the function
7303 used depends on the type specifiers. */
7306 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
7312 name
= &expr
->value
.function
.name
[2];
7316 lib
= gfc_is_intrinsic_libcall (expr
);
7320 se
->ignore_optional
= 1;
7322 switch (expr
->value
.function
.isym
->id
)
7324 case GFC_ISYM_EOSHIFT
:
7326 case GFC_ISYM_RESHAPE
:
7327 /* For all of those the first argument specifies the type and the
7328 third is optional. */
7329 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
7333 gfc_conv_intrinsic_funcall (se
, expr
);
7341 switch (expr
->value
.function
.isym
->id
)
7346 case GFC_ISYM_REPEAT
:
7347 gfc_conv_intrinsic_repeat (se
, expr
);
7351 gfc_conv_intrinsic_trim (se
, expr
);
7354 case GFC_ISYM_SC_KIND
:
7355 gfc_conv_intrinsic_sc_kind (se
, expr
);
7358 case GFC_ISYM_SI_KIND
:
7359 gfc_conv_intrinsic_si_kind (se
, expr
);
7362 case GFC_ISYM_SR_KIND
:
7363 gfc_conv_intrinsic_sr_kind (se
, expr
);
7366 case GFC_ISYM_EXPONENT
:
7367 gfc_conv_intrinsic_exponent (se
, expr
);
7371 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7373 fndecl
= gfor_fndecl_string_scan
;
7375 fndecl
= gfor_fndecl_string_scan_char4
;
7379 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7382 case GFC_ISYM_VERIFY
:
7383 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7385 fndecl
= gfor_fndecl_string_verify
;
7387 fndecl
= gfor_fndecl_string_verify_char4
;
7391 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7394 case GFC_ISYM_ALLOCATED
:
7395 gfc_conv_allocated (se
, expr
);
7398 case GFC_ISYM_ASSOCIATED
:
7399 gfc_conv_associated(se
, expr
);
7402 case GFC_ISYM_SAME_TYPE_AS
:
7403 gfc_conv_same_type_as (se
, expr
);
7407 gfc_conv_intrinsic_abs (se
, expr
);
7410 case GFC_ISYM_ADJUSTL
:
7411 if (expr
->ts
.kind
== 1)
7412 fndecl
= gfor_fndecl_adjustl
;
7413 else if (expr
->ts
.kind
== 4)
7414 fndecl
= gfor_fndecl_adjustl_char4
;
7418 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7421 case GFC_ISYM_ADJUSTR
:
7422 if (expr
->ts
.kind
== 1)
7423 fndecl
= gfor_fndecl_adjustr
;
7424 else if (expr
->ts
.kind
== 4)
7425 fndecl
= gfor_fndecl_adjustr_char4
;
7429 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7432 case GFC_ISYM_AIMAG
:
7433 gfc_conv_intrinsic_imagpart (se
, expr
);
7437 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
7441 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
7444 case GFC_ISYM_ANINT
:
7445 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
7449 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7453 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
7456 case GFC_ISYM_BTEST
:
7457 gfc_conv_intrinsic_btest (se
, expr
);
7461 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
7465 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
7469 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
7473 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
7476 case GFC_ISYM_C_ASSOCIATED
:
7477 case GFC_ISYM_C_FUNLOC
:
7478 case GFC_ISYM_C_LOC
:
7479 conv_isocbinding_function (se
, expr
);
7482 case GFC_ISYM_ACHAR
:
7484 gfc_conv_intrinsic_char (se
, expr
);
7487 case GFC_ISYM_CONVERSION
:
7489 case GFC_ISYM_LOGICAL
:
7491 gfc_conv_intrinsic_conversion (se
, expr
);
7494 /* Integer conversions are handled separately to make sure we get the
7495 correct rounding mode. */
7500 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
7504 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
7507 case GFC_ISYM_CEILING
:
7508 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
7511 case GFC_ISYM_FLOOR
:
7512 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
7516 gfc_conv_intrinsic_mod (se
, expr
, 0);
7519 case GFC_ISYM_MODULO
:
7520 gfc_conv_intrinsic_mod (se
, expr
, 1);
7523 case GFC_ISYM_CAF_GET
:
7524 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
);
7527 case GFC_ISYM_CMPLX
:
7528 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
7531 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
7532 gfc_conv_intrinsic_iargc (se
, expr
);
7535 case GFC_ISYM_COMPLEX
:
7536 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
7539 case GFC_ISYM_CONJG
:
7540 gfc_conv_intrinsic_conjg (se
, expr
);
7543 case GFC_ISYM_COUNT
:
7544 gfc_conv_intrinsic_count (se
, expr
);
7547 case GFC_ISYM_CTIME
:
7548 gfc_conv_intrinsic_ctime (se
, expr
);
7552 gfc_conv_intrinsic_dim (se
, expr
);
7555 case GFC_ISYM_DOT_PRODUCT
:
7556 gfc_conv_intrinsic_dot_product (se
, expr
);
7559 case GFC_ISYM_DPROD
:
7560 gfc_conv_intrinsic_dprod (se
, expr
);
7563 case GFC_ISYM_DSHIFTL
:
7564 gfc_conv_intrinsic_dshift (se
, expr
, true);
7567 case GFC_ISYM_DSHIFTR
:
7568 gfc_conv_intrinsic_dshift (se
, expr
, false);
7571 case GFC_ISYM_FDATE
:
7572 gfc_conv_intrinsic_fdate (se
, expr
);
7575 case GFC_ISYM_FRACTION
:
7576 gfc_conv_intrinsic_fraction (se
, expr
);
7580 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
7584 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7588 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
7591 case GFC_ISYM_IBCLR
:
7592 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
7595 case GFC_ISYM_IBITS
:
7596 gfc_conv_intrinsic_ibits (se
, expr
);
7599 case GFC_ISYM_IBSET
:
7600 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
7603 case GFC_ISYM_IACHAR
:
7604 case GFC_ISYM_ICHAR
:
7605 /* We assume ASCII character sequence. */
7606 gfc_conv_intrinsic_ichar (se
, expr
);
7609 case GFC_ISYM_IARGC
:
7610 gfc_conv_intrinsic_iargc (se
, expr
);
7614 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
7617 case GFC_ISYM_INDEX
:
7618 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7620 fndecl
= gfor_fndecl_string_index
;
7622 fndecl
= gfor_fndecl_string_index_char4
;
7626 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7630 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
7633 case GFC_ISYM_IPARITY
:
7634 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
7637 case GFC_ISYM_IS_IOSTAT_END
:
7638 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
7641 case GFC_ISYM_IS_IOSTAT_EOR
:
7642 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
7645 case GFC_ISYM_ISNAN
:
7646 gfc_conv_intrinsic_isnan (se
, expr
);
7649 case GFC_ISYM_LSHIFT
:
7650 gfc_conv_intrinsic_shift (se
, expr
, false, false);
7653 case GFC_ISYM_RSHIFT
:
7654 gfc_conv_intrinsic_shift (se
, expr
, true, true);
7657 case GFC_ISYM_SHIFTA
:
7658 gfc_conv_intrinsic_shift (se
, expr
, true, true);
7661 case GFC_ISYM_SHIFTL
:
7662 gfc_conv_intrinsic_shift (se
, expr
, false, false);
7665 case GFC_ISYM_SHIFTR
:
7666 gfc_conv_intrinsic_shift (se
, expr
, true, false);
7669 case GFC_ISYM_ISHFT
:
7670 gfc_conv_intrinsic_ishft (se
, expr
);
7673 case GFC_ISYM_ISHFTC
:
7674 gfc_conv_intrinsic_ishftc (se
, expr
);
7677 case GFC_ISYM_LEADZ
:
7678 gfc_conv_intrinsic_leadz (se
, expr
);
7681 case GFC_ISYM_TRAILZ
:
7682 gfc_conv_intrinsic_trailz (se
, expr
);
7685 case GFC_ISYM_POPCNT
:
7686 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
7689 case GFC_ISYM_POPPAR
:
7690 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
7693 case GFC_ISYM_LBOUND
:
7694 gfc_conv_intrinsic_bound (se
, expr
, 0);
7697 case GFC_ISYM_LCOBOUND
:
7698 conv_intrinsic_cobound (se
, expr
);
7701 case GFC_ISYM_TRANSPOSE
:
7702 /* The scalarizer has already been set up for reversed dimension access
7703 order ; now we just get the argument value normally. */
7704 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
7708 gfc_conv_intrinsic_len (se
, expr
);
7711 case GFC_ISYM_LEN_TRIM
:
7712 gfc_conv_intrinsic_len_trim (se
, expr
);
7716 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
7720 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
7724 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
7728 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
7731 case GFC_ISYM_MASKL
:
7732 gfc_conv_intrinsic_mask (se
, expr
, 1);
7735 case GFC_ISYM_MASKR
:
7736 gfc_conv_intrinsic_mask (se
, expr
, 0);
7740 if (expr
->ts
.type
== BT_CHARACTER
)
7741 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
7743 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
7746 case GFC_ISYM_MAXLOC
:
7747 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
7750 case GFC_ISYM_MAXVAL
:
7751 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
7754 case GFC_ISYM_MERGE
:
7755 gfc_conv_intrinsic_merge (se
, expr
);
7758 case GFC_ISYM_MERGE_BITS
:
7759 gfc_conv_intrinsic_merge_bits (se
, expr
);
7763 if (expr
->ts
.type
== BT_CHARACTER
)
7764 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
7766 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
7769 case GFC_ISYM_MINLOC
:
7770 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
7773 case GFC_ISYM_MINVAL
:
7774 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
7777 case GFC_ISYM_NEAREST
:
7778 gfc_conv_intrinsic_nearest (se
, expr
);
7781 case GFC_ISYM_NORM2
:
7782 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
7786 gfc_conv_intrinsic_not (se
, expr
);
7790 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
7793 case GFC_ISYM_PARITY
:
7794 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
7797 case GFC_ISYM_PRESENT
:
7798 gfc_conv_intrinsic_present (se
, expr
);
7801 case GFC_ISYM_PRODUCT
:
7802 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
7806 gfc_conv_intrinsic_rank (se
, expr
);
7809 case GFC_ISYM_RRSPACING
:
7810 gfc_conv_intrinsic_rrspacing (se
, expr
);
7813 case GFC_ISYM_SET_EXPONENT
:
7814 gfc_conv_intrinsic_set_exponent (se
, expr
);
7817 case GFC_ISYM_SCALE
:
7818 gfc_conv_intrinsic_scale (se
, expr
);
7822 gfc_conv_intrinsic_sign (se
, expr
);
7826 gfc_conv_intrinsic_size (se
, expr
);
7829 case GFC_ISYM_SIZEOF
:
7830 case GFC_ISYM_C_SIZEOF
:
7831 gfc_conv_intrinsic_sizeof (se
, expr
);
7834 case GFC_ISYM_STORAGE_SIZE
:
7835 gfc_conv_intrinsic_storage_size (se
, expr
);
7838 case GFC_ISYM_SPACING
:
7839 gfc_conv_intrinsic_spacing (se
, expr
);
7842 case GFC_ISYM_STRIDE
:
7843 conv_intrinsic_stride (se
, expr
);
7847 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
7850 case GFC_ISYM_TRANSFER
:
7851 if (se
->ss
&& se
->ss
->info
->useflags
)
7852 /* Access the previously obtained result. */
7853 gfc_conv_tmp_array_ref (se
);
7855 gfc_conv_intrinsic_transfer (se
, expr
);
7858 case GFC_ISYM_TTYNAM
:
7859 gfc_conv_intrinsic_ttynam (se
, expr
);
7862 case GFC_ISYM_UBOUND
:
7863 gfc_conv_intrinsic_bound (se
, expr
, 1);
7866 case GFC_ISYM_UCOBOUND
:
7867 conv_intrinsic_cobound (se
, expr
);
7871 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
7875 gfc_conv_intrinsic_loc (se
, expr
);
7878 case GFC_ISYM_THIS_IMAGE
:
7879 /* For num_images() == 1, handle as LCOBOUND. */
7880 if (expr
->value
.function
.actual
->expr
7881 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
7882 conv_intrinsic_cobound (se
, expr
);
7884 trans_this_image (se
, expr
);
7887 case GFC_ISYM_IMAGE_INDEX
:
7888 trans_image_index (se
, expr
);
7891 case GFC_ISYM_NUM_IMAGES
:
7892 trans_num_images (se
, expr
);
7895 case GFC_ISYM_ACCESS
:
7896 case GFC_ISYM_CHDIR
:
7897 case GFC_ISYM_CHMOD
:
7898 case GFC_ISYM_DTIME
:
7899 case GFC_ISYM_ETIME
:
7900 case GFC_ISYM_EXTENDS_TYPE_OF
:
7902 case GFC_ISYM_FGETC
:
7905 case GFC_ISYM_FPUTC
:
7906 case GFC_ISYM_FSTAT
:
7907 case GFC_ISYM_FTELL
:
7908 case GFC_ISYM_GETCWD
:
7909 case GFC_ISYM_GETGID
:
7910 case GFC_ISYM_GETPID
:
7911 case GFC_ISYM_GETUID
:
7912 case GFC_ISYM_HOSTNM
:
7914 case GFC_ISYM_IERRNO
:
7915 case GFC_ISYM_IRAND
:
7916 case GFC_ISYM_ISATTY
:
7919 case GFC_ISYM_LSTAT
:
7920 case GFC_ISYM_MALLOC
:
7921 case GFC_ISYM_MATMUL
:
7922 case GFC_ISYM_MCLOCK
:
7923 case GFC_ISYM_MCLOCK8
:
7925 case GFC_ISYM_RENAME
:
7926 case GFC_ISYM_SECOND
:
7927 case GFC_ISYM_SECNDS
:
7928 case GFC_ISYM_SIGNAL
:
7930 case GFC_ISYM_SYMLNK
:
7931 case GFC_ISYM_SYSTEM
:
7933 case GFC_ISYM_TIME8
:
7934 case GFC_ISYM_UMASK
:
7935 case GFC_ISYM_UNLINK
:
7937 gfc_conv_intrinsic_funcall (se
, expr
);
7940 case GFC_ISYM_EOSHIFT
:
7942 case GFC_ISYM_RESHAPE
:
7943 /* For those, expr->rank should always be >0 and thus the if above the
7944 switch should have matched. */
7949 gfc_conv_intrinsic_lib_function (se
, expr
);
7956 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
7958 gfc_ss
*arg_ss
, *tmp_ss
;
7959 gfc_actual_arglist
*arg
;
7961 arg
= expr
->value
.function
.actual
;
7963 gcc_assert (arg
->expr
);
7965 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
7966 gcc_assert (arg_ss
!= gfc_ss_terminator
);
7968 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
7970 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
7971 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
7975 gcc_assert (tmp_ss
->dimen
== 2);
7977 /* We just invert dimensions. */
7978 tmp_dim
= tmp_ss
->dim
[0];
7979 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
7980 tmp_ss
->dim
[1] = tmp_dim
;
7983 /* Stop when tmp_ss points to the last valid element of the chain... */
7984 if (tmp_ss
->next
== gfc_ss_terminator
)
7988 /* ... so that we can attach the rest of the chain to it. */
7995 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
7996 This has the side effect of reversing the nested list, so there is no
7997 need to call gfc_reverse_ss on it (the given list is assumed not to be
8001 nest_loop_dimension (gfc_ss
*ss
, int dim
)
8004 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
8005 gfc_loopinfo
*new_loop
;
8007 gcc_assert (ss
!= gfc_ss_terminator
);
8009 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
8011 new_ss
= gfc_get_ss ();
8012 new_ss
->next
= prev_ss
;
8013 new_ss
->parent
= ss
;
8014 new_ss
->info
= ss
->info
;
8015 new_ss
->info
->refcount
++;
8018 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
8019 && ss
->info
->type
!= GFC_SS_REFERENCE
);
8022 new_ss
->dim
[0] = ss
->dim
[dim
];
8024 gcc_assert (dim
< ss
->dimen
);
8026 ss_dim
= --ss
->dimen
;
8027 for (i
= dim
; i
< ss_dim
; i
++)
8028 ss
->dim
[i
] = ss
->dim
[i
+ 1];
8030 ss
->dim
[ss_dim
] = 0;
8036 ss
->nested_ss
->parent
= new_ss
;
8037 new_ss
->nested_ss
= ss
->nested_ss
;
8039 ss
->nested_ss
= new_ss
;
8042 new_loop
= gfc_get_loopinfo ();
8043 gfc_init_loopinfo (new_loop
);
8045 gcc_assert (prev_ss
!= NULL
);
8046 gcc_assert (prev_ss
!= gfc_ss_terminator
);
8047 gfc_add_ss_to_loop (new_loop
, prev_ss
);
8048 return new_ss
->parent
;
8052 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
8053 is to be inlined. */
8056 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
8058 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
8059 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
8061 bool scalar_mask
= false;
8063 /* The rank of the result will be determined later. */
8064 arg1
= expr
->value
.function
.actual
;
8067 gcc_assert (arg3
!= NULL
);
8069 if (expr
->rank
== 0)
8072 tmp_ss
= gfc_ss_terminator
;
8078 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
8079 if (mask_ss
== tmp_ss
)
8085 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
8086 gcc_assert (array_ss
!= tmp_ss
);
8088 /* Odd thing: If the mask is scalar, it is used by the frontend after
8089 the array (to make an if around the nested loop). Thus it shall
8090 be after array_ss once the gfc_ss list is reversed. */
8092 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
8096 /* "Hide" the dimension on which we will sum in the first arg's scalarization
8098 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
8099 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
8107 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
8110 switch (expr
->value
.function
.isym
->id
)
8112 case GFC_ISYM_PRODUCT
:
8114 return walk_inline_intrinsic_arith (ss
, expr
);
8116 case GFC_ISYM_TRANSPOSE
:
8117 return walk_inline_intrinsic_transpose (ss
, expr
);
8126 /* This generates code to execute before entering the scalarization loop.
8127 Currently does nothing. */
8130 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
8132 switch (ss
->info
->expr
->value
.function
.isym
->id
)
8134 case GFC_ISYM_UBOUND
:
8135 case GFC_ISYM_LBOUND
:
8136 case GFC_ISYM_UCOBOUND
:
8137 case GFC_ISYM_LCOBOUND
:
8138 case GFC_ISYM_THIS_IMAGE
:
8147 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
8148 are expanded into code inside the scalarization loop. */
8151 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
8153 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
8154 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
8156 /* The two argument version returns a scalar. */
8157 if (expr
->value
.function
.actual
->next
->expr
)
8160 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
8164 /* Walk an intrinsic array libcall. */
8167 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
8169 gcc_assert (expr
->rank
> 0);
8170 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8174 /* Return whether the function call expression EXPR will be expanded
8175 inline by gfc_conv_intrinsic_function. */
8178 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
8180 gfc_actual_arglist
*args
;
8182 if (!expr
->value
.function
.isym
)
8185 switch (expr
->value
.function
.isym
->id
)
8187 case GFC_ISYM_PRODUCT
:
8189 /* Disable inline expansion if code size matters. */
8193 args
= expr
->value
.function
.actual
;
8194 /* We need to be able to subset the SUM argument at compile-time. */
8195 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
8200 case GFC_ISYM_TRANSPOSE
:
8209 /* Returns nonzero if the specified intrinsic function call maps directly to
8210 an external library call. Should only be used for functions that return
8214 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
8216 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
8217 gcc_assert (expr
->rank
> 0);
8219 if (gfc_inline_intrinsic_function_p (expr
))
8222 switch (expr
->value
.function
.isym
->id
)
8226 case GFC_ISYM_COUNT
:
8230 case GFC_ISYM_IPARITY
:
8231 case GFC_ISYM_MATMUL
:
8232 case GFC_ISYM_MAXLOC
:
8233 case GFC_ISYM_MAXVAL
:
8234 case GFC_ISYM_MINLOC
:
8235 case GFC_ISYM_MINVAL
:
8236 case GFC_ISYM_NORM2
:
8237 case GFC_ISYM_PARITY
:
8238 case GFC_ISYM_PRODUCT
:
8240 case GFC_ISYM_SHAPE
:
8241 case GFC_ISYM_SPREAD
:
8243 /* Ignore absent optional parameters. */
8246 case GFC_ISYM_RESHAPE
:
8247 case GFC_ISYM_CSHIFT
:
8248 case GFC_ISYM_EOSHIFT
:
8250 case GFC_ISYM_UNPACK
:
8251 /* Pass absent optional parameters. */
8259 /* Walk an intrinsic function. */
8261 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
8262 gfc_intrinsic_sym
* isym
)
8266 if (isym
->elemental
)
8267 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8268 NULL
, GFC_SS_SCALAR
);
8270 if (expr
->rank
== 0)
8273 if (gfc_inline_intrinsic_function_p (expr
))
8274 return walk_inline_intrinsic_function (ss
, expr
);
8276 if (gfc_is_intrinsic_libcall (expr
))
8277 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8279 /* Special cases. */
8282 case GFC_ISYM_LBOUND
:
8283 case GFC_ISYM_LCOBOUND
:
8284 case GFC_ISYM_UBOUND
:
8285 case GFC_ISYM_UCOBOUND
:
8286 case GFC_ISYM_THIS_IMAGE
:
8287 return gfc_walk_intrinsic_bound (ss
, expr
);
8289 case GFC_ISYM_TRANSFER
:
8290 case GFC_ISYM_CAF_GET
:
8291 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8294 /* This probably meant someone forgot to add an intrinsic to the above
8295 list(s) when they implemented it, or something's gone horribly
8303 conv_co_minmaxsum (gfc_code
*code
)
8306 stmtblock_t block
, post_block
;
8307 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
8309 gfc_start_block (&block
);
8310 gfc_init_block (&post_block
);
8313 if (code
->ext
.actual
->next
->next
->expr
)
8315 gfc_init_se (&argse
, NULL
);
8316 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
8317 gfc_add_block_to_block (&block
, &argse
.pre
);
8318 gfc_add_block_to_block (&post_block
, &argse
.post
);
8320 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
8321 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
8323 else if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
8326 stat
= null_pointer_node
;
8328 /* Early exit for GFC_FCOARRAY_SINGLE. */
8329 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
8331 if (stat
!= NULL_TREE
)
8332 gfc_add_modify (&block
, stat
,
8333 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
8334 return gfc_finish_block (&block
);
8337 /* Handle the array. */
8338 gfc_init_se (&argse
, NULL
);
8339 if (code
->ext
.actual
->expr
->rank
== 0)
8341 symbol_attribute attr
;
8342 gfc_clear_attr (&attr
);
8343 gfc_init_se (&argse
, NULL
);
8344 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8345 gfc_add_block_to_block (&block
, &argse
.pre
);
8346 gfc_add_block_to_block (&post_block
, &argse
.post
);
8347 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
8348 array
= gfc_build_addr_expr (NULL_TREE
, array
);
8352 argse
.want_pointer
= 1;
8353 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
8356 gfc_add_block_to_block (&block
, &argse
.pre
);
8357 gfc_add_block_to_block (&post_block
, &argse
.post
);
8359 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
8360 strlen
= argse
.string_length
;
8362 strlen
= integer_zero_node
;
8365 if (code
->ext
.actual
->next
->expr
)
8367 gfc_init_se (&argse
, NULL
);
8368 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
8369 gfc_add_block_to_block (&block
, &argse
.pre
);
8370 gfc_add_block_to_block (&post_block
, &argse
.post
);
8371 image_index
= fold_convert (integer_type_node
, argse
.expr
);
8374 image_index
= integer_zero_node
;
8377 if (code
->ext
.actual
->next
->next
->next
->expr
)
8379 gfc_init_se (&argse
, NULL
);
8380 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
8381 gfc_add_block_to_block (&block
, &argse
.pre
);
8382 gfc_add_block_to_block (&post_block
, &argse
.post
);
8383 errmsg
= argse
.expr
;
8384 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
8388 errmsg
= null_pointer_node
;
8389 errmsg_len
= integer_zero_node
;
8392 /* Generate the function call. */
8393 if (code
->resolved_isym
->id
== GFC_ISYM_CO_MAX
)
8394 fndecl
= gfor_fndecl_co_max
;
8395 else if (code
->resolved_isym
->id
== GFC_ISYM_CO_MIN
)
8396 fndecl
= gfor_fndecl_co_min
;
8397 else if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
)
8398 fndecl
= gfor_fndecl_co_sum
;
8402 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
)
8403 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
8404 image_index
, stat
, errmsg
, errmsg_len
);
8406 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
8407 stat
, errmsg
, strlen
, errmsg_len
);
8408 gfc_add_expr_to_block (&block
, fndecl
);
8409 gfc_add_block_to_block (&block
, &post_block
);
8411 /* Add CALL to CO_SUM/MIN/MAX: array descriptor, vector descriptor, stat, errmsg, strlen, errmsglen */
8412 return gfc_finish_block (&block
);
8417 conv_intrinsic_atomic_op (gfc_code
*code
)
8420 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
8421 stmtblock_t block
, post_block
;
8422 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
8423 gfc_expr
*stat_expr
;
8424 built_in_function fn
;
8426 if (atom_expr
->expr_type
== EXPR_FUNCTION
8427 && atom_expr
->value
.function
.isym
8428 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8429 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8431 gfc_start_block (&block
);
8432 gfc_init_block (&post_block
);
8434 gfc_init_se (&argse
, NULL
);
8435 argse
.want_pointer
= 1;
8436 gfc_conv_expr (&argse
, atom_expr
);
8437 gfc_add_block_to_block (&block
, &argse
.pre
);
8438 gfc_add_block_to_block (&post_block
, &argse
.post
);
8441 gfc_init_se (&argse
, NULL
);
8442 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
8443 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8444 argse
.want_pointer
= 1;
8445 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
8446 gfc_add_block_to_block (&block
, &argse
.pre
);
8447 gfc_add_block_to_block (&post_block
, &argse
.post
);
8450 switch (code
->resolved_isym
->id
)
8452 case GFC_ISYM_ATOMIC_ADD
:
8453 case GFC_ISYM_ATOMIC_AND
:
8454 case GFC_ISYM_ATOMIC_DEF
:
8455 case GFC_ISYM_ATOMIC_OR
:
8456 case GFC_ISYM_ATOMIC_XOR
:
8457 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8458 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8459 old
= null_pointer_node
;
8462 gfc_init_se (&argse
, NULL
);
8463 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8464 argse
.want_pointer
= 1;
8465 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
8466 gfc_add_block_to_block (&block
, &argse
.pre
);
8467 gfc_add_block_to_block (&post_block
, &argse
.post
);
8469 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8473 if (stat_expr
!= NULL
)
8475 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
8476 gfc_init_se (&argse
, NULL
);
8477 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8478 argse
.want_pointer
= 1;
8479 gfc_conv_expr_val (&argse
, stat_expr
);
8480 gfc_add_block_to_block (&block
, &argse
.pre
);
8481 gfc_add_block_to_block (&post_block
, &argse
.post
);
8484 else if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8485 stat
= null_pointer_node
;
8487 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8489 tree image_index
, caf_decl
, offset
, token
;
8492 switch (code
->resolved_isym
->id
)
8494 case GFC_ISYM_ATOMIC_ADD
:
8495 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8496 op
= (int) GFC_CAF_ATOMIC_ADD
;
8498 case GFC_ISYM_ATOMIC_AND
:
8499 case GFC_ISYM_ATOMIC_FETCH_AND
:
8500 op
= (int) GFC_CAF_ATOMIC_AND
;
8502 case GFC_ISYM_ATOMIC_OR
:
8503 case GFC_ISYM_ATOMIC_FETCH_OR
:
8504 op
= (int) GFC_CAF_ATOMIC_OR
;
8506 case GFC_ISYM_ATOMIC_XOR
:
8507 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8508 op
= (int) GFC_CAF_ATOMIC_XOR
;
8510 case GFC_ISYM_ATOMIC_DEF
:
8511 op
= 0; /* Unused. */
8517 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
8518 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8519 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8521 if (gfc_is_coindexed (atom_expr
))
8522 image_index
= caf_get_image_index (&block
, atom_expr
, caf_decl
);
8524 image_index
= integer_zero_node
;
8526 if (TREE_TYPE (TREE_TYPE (atom
)) != TREE_TYPE (TREE_TYPE (value
)))
8528 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
8529 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
8530 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8533 get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
8535 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
8536 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
8537 token
, offset
, image_index
, value
, stat
,
8538 build_int_cst (integer_type_node
,
8539 (int) atom_expr
->ts
.type
),
8540 build_int_cst (integer_type_node
,
8541 (int) atom_expr
->ts
.kind
));
8543 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
8544 build_int_cst (integer_type_node
, op
),
8545 token
, offset
, image_index
, value
, old
, stat
,
8546 build_int_cst (integer_type_node
,
8547 (int) atom_expr
->ts
.type
),
8548 build_int_cst (integer_type_node
,
8549 (int) atom_expr
->ts
.kind
));
8551 gfc_add_expr_to_block (&block
, tmp
);
8552 gfc_add_block_to_block (&block
, &post_block
);
8553 return gfc_finish_block (&block
);
8557 switch (code
->resolved_isym
->id
)
8559 case GFC_ISYM_ATOMIC_ADD
:
8560 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8561 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
8563 case GFC_ISYM_ATOMIC_AND
:
8564 case GFC_ISYM_ATOMIC_FETCH_AND
:
8565 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
8567 case GFC_ISYM_ATOMIC_DEF
:
8568 fn
= BUILT_IN_ATOMIC_STORE_N
;
8570 case GFC_ISYM_ATOMIC_OR
:
8571 case GFC_ISYM_ATOMIC_FETCH_OR
:
8572 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
8574 case GFC_ISYM_ATOMIC_XOR
:
8575 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8576 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
8582 tmp
= TREE_TYPE (TREE_TYPE (atom
));
8583 fn
= (built_in_function
) ((int) fn
8584 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
8586 tmp
= builtin_decl_explicit (fn
);
8587 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
8588 tmp
= builtin_decl_explicit (fn
);
8590 switch (code
->resolved_isym
->id
)
8592 case GFC_ISYM_ATOMIC_ADD
:
8593 case GFC_ISYM_ATOMIC_AND
:
8594 case GFC_ISYM_ATOMIC_DEF
:
8595 case GFC_ISYM_ATOMIC_OR
:
8596 case GFC_ISYM_ATOMIC_XOR
:
8597 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
8598 fold_convert (itype
, value
),
8599 build_int_cst (NULL
, MEMMODEL_RELAXED
));
8600 gfc_add_expr_to_block (&block
, tmp
);
8603 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
8604 fold_convert (itype
, value
),
8605 build_int_cst (NULL
, MEMMODEL_RELAXED
));
8606 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
8610 if (stat
!= NULL_TREE
)
8611 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
8612 gfc_add_block_to_block (&block
, &post_block
);
8613 return gfc_finish_block (&block
);
8618 conv_intrinsic_atomic_ref (gfc_code
*code
)
8621 tree tmp
, atom
, value
, stat
= NULL_TREE
;
8622 stmtblock_t block
, post_block
;
8623 built_in_function fn
;
8624 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
8626 if (atom_expr
->expr_type
== EXPR_FUNCTION
8627 && atom_expr
->value
.function
.isym
8628 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8629 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8631 gfc_start_block (&block
);
8632 gfc_init_block (&post_block
);
8633 gfc_init_se (&argse
, NULL
);
8634 argse
.want_pointer
= 1;
8635 gfc_conv_expr (&argse
, atom_expr
);
8636 gfc_add_block_to_block (&block
, &argse
.pre
);
8637 gfc_add_block_to_block (&post_block
, &argse
.post
);
8640 gfc_init_se (&argse
, NULL
);
8641 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
8642 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8643 argse
.want_pointer
= 1;
8644 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8645 gfc_add_block_to_block (&block
, &argse
.pre
);
8646 gfc_add_block_to_block (&post_block
, &argse
.post
);
8650 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
8652 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
8654 gfc_init_se (&argse
, NULL
);
8655 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8656 argse
.want_pointer
= 1;
8657 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
8658 gfc_add_block_to_block (&block
, &argse
.pre
);
8659 gfc_add_block_to_block (&post_block
, &argse
.post
);
8662 else if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8663 stat
= null_pointer_node
;
8665 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8667 tree image_index
, caf_decl
, offset
, token
;
8668 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
8670 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
8671 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8672 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8674 if (gfc_is_coindexed (atom_expr
))
8675 image_index
= caf_get_image_index (&block
, atom_expr
, caf_decl
);
8677 image_index
= integer_zero_node
;
8679 get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
8681 /* Different type, need type conversion. */
8682 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
8684 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
8686 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
8689 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
8690 token
, offset
, image_index
, value
, stat
,
8691 build_int_cst (integer_type_node
,
8692 (int) atom_expr
->ts
.type
),
8693 build_int_cst (integer_type_node
,
8694 (int) atom_expr
->ts
.kind
));
8695 gfc_add_expr_to_block (&block
, tmp
);
8696 if (vardecl
!= NULL_TREE
)
8697 gfc_add_modify (&block
, orig_value
,
8698 fold_convert (TREE_TYPE (orig_value
), vardecl
));
8699 gfc_add_block_to_block (&block
, &post_block
);
8700 return gfc_finish_block (&block
);
8703 tmp
= TREE_TYPE (TREE_TYPE (atom
));
8704 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
8705 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
8707 tmp
= builtin_decl_explicit (fn
);
8708 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
8709 build_int_cst (integer_type_node
,
8711 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
8713 if (stat
!= NULL_TREE
)
8714 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
8715 gfc_add_block_to_block (&block
, &post_block
);
8716 return gfc_finish_block (&block
);
8721 conv_intrinsic_atomic_cas (gfc_code
*code
)
8724 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
8725 stmtblock_t block
, post_block
;
8726 built_in_function fn
;
8727 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
8729 if (atom_expr
->expr_type
== EXPR_FUNCTION
8730 && atom_expr
->value
.function
.isym
8731 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8732 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8734 gfc_init_block (&block
);
8735 gfc_init_block (&post_block
);
8736 gfc_init_se (&argse
, NULL
);
8737 argse
.want_pointer
= 1;
8738 gfc_conv_expr (&argse
, atom_expr
);
8741 gfc_init_se (&argse
, NULL
);
8742 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8743 argse
.want_pointer
= 1;
8744 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
8745 gfc_add_block_to_block (&block
, &argse
.pre
);
8746 gfc_add_block_to_block (&post_block
, &argse
.post
);
8749 gfc_init_se (&argse
, NULL
);
8750 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8751 argse
.want_pointer
= 1;
8752 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
8753 gfc_add_block_to_block (&block
, &argse
.pre
);
8754 gfc_add_block_to_block (&post_block
, &argse
.post
);
8757 gfc_init_se (&argse
, NULL
);
8758 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
8759 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
8760 == atom_expr
->ts
.kind
)
8761 argse
.want_pointer
= 1;
8762 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
8763 gfc_add_block_to_block (&block
, &argse
.pre
);
8764 gfc_add_block_to_block (&post_block
, &argse
.post
);
8765 new_val
= argse
.expr
;
8768 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
8770 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
8772 gfc_init_se (&argse
, NULL
);
8773 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8774 argse
.want_pointer
= 1;
8775 gfc_conv_expr_val (&argse
,
8776 code
->ext
.actual
->next
->next
->next
->next
->expr
);
8777 gfc_add_block_to_block (&block
, &argse
.pre
);
8778 gfc_add_block_to_block (&post_block
, &argse
.post
);
8781 else if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8782 stat
= null_pointer_node
;
8784 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8786 tree image_index
, caf_decl
, offset
, token
;
8788 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
8789 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8790 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8792 if (gfc_is_coindexed (atom_expr
))
8793 image_index
= caf_get_image_index (&block
, atom_expr
, caf_decl
);
8795 image_index
= integer_zero_node
;
8797 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
8799 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
8800 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
8801 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8804 /* Convert a constant to a pointer. */
8805 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
8807 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
8808 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
8809 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8812 get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
8814 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
8815 token
, offset
, image_index
, old
, comp
, new_val
,
8816 stat
, build_int_cst (integer_type_node
,
8817 (int) atom_expr
->ts
.type
),
8818 build_int_cst (integer_type_node
,
8819 (int) atom_expr
->ts
.kind
));
8820 gfc_add_expr_to_block (&block
, tmp
);
8821 gfc_add_block_to_block (&block
, &post_block
);
8822 return gfc_finish_block (&block
);
8825 tmp
= TREE_TYPE (TREE_TYPE (atom
));
8826 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
8827 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
8829 tmp
= builtin_decl_explicit (fn
);
8831 gfc_add_modify (&block
, old
, comp
);
8832 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
8833 gfc_build_addr_expr (NULL
, old
),
8834 fold_convert (TREE_TYPE (old
), new_val
),
8836 build_int_cst (NULL
, MEMMODEL_RELAXED
),
8837 build_int_cst (NULL
, MEMMODEL_RELAXED
));
8838 gfc_add_expr_to_block (&block
, tmp
);
8840 if (stat
!= NULL_TREE
)
8841 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
8842 gfc_add_block_to_block (&block
, &post_block
);
8843 return gfc_finish_block (&block
);
8848 conv_intrinsic_move_alloc (gfc_code
*code
)
8851 gfc_expr
*from_expr
, *to_expr
;
8852 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
8853 gfc_se from_se
, to_se
;
8857 gfc_start_block (&block
);
8859 from_expr
= code
->ext
.actual
->expr
;
8860 to_expr
= code
->ext
.actual
->next
->expr
;
8862 gfc_init_se (&from_se
, NULL
);
8863 gfc_init_se (&to_se
, NULL
);
8865 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
8866 || to_expr
->ts
.type
== BT_CLASS
);
8867 coarray
= gfc_get_corank (from_expr
) != 0;
8869 if (from_expr
->rank
== 0 && !coarray
)
8871 if (from_expr
->ts
.type
!= BT_CLASS
)
8872 from_expr2
= from_expr
;
8875 from_expr2
= gfc_copy_expr (from_expr
);
8876 gfc_add_data_component (from_expr2
);
8879 if (to_expr
->ts
.type
!= BT_CLASS
)
8883 to_expr2
= gfc_copy_expr (to_expr
);
8884 gfc_add_data_component (to_expr2
);
8887 from_se
.want_pointer
= 1;
8888 to_se
.want_pointer
= 1;
8889 gfc_conv_expr (&from_se
, from_expr2
);
8890 gfc_conv_expr (&to_se
, to_expr2
);
8891 gfc_add_block_to_block (&block
, &from_se
.pre
);
8892 gfc_add_block_to_block (&block
, &to_se
.pre
);
8894 /* Deallocate "to". */
8895 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
8896 to_expr
, to_expr
->ts
);
8897 gfc_add_expr_to_block (&block
, tmp
);
8899 /* Assign (_data) pointers. */
8900 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
8901 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
8903 /* Set "from" to NULL. */
8904 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
8905 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
8907 gfc_add_block_to_block (&block
, &from_se
.post
);
8908 gfc_add_block_to_block (&block
, &to_se
.post
);
8911 if (to_expr
->ts
.type
== BT_CLASS
)
8915 gfc_free_expr (to_expr2
);
8916 gfc_init_se (&to_se
, NULL
);
8917 to_se
.want_pointer
= 1;
8918 gfc_add_vptr_component (to_expr
);
8919 gfc_conv_expr (&to_se
, to_expr
);
8921 if (from_expr
->ts
.type
== BT_CLASS
)
8923 if (UNLIMITED_POLY (from_expr
))
8927 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
8931 gfc_free_expr (from_expr2
);
8932 gfc_init_se (&from_se
, NULL
);
8933 from_se
.want_pointer
= 1;
8934 gfc_add_vptr_component (from_expr
);
8935 gfc_conv_expr (&from_se
, from_expr
);
8936 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
8937 fold_convert (TREE_TYPE (to_se
.expr
),
8940 /* Reset _vptr component to declared type. */
8942 /* Unlimited polymorphic. */
8943 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
8944 fold_convert (TREE_TYPE (from_se
.expr
),
8945 null_pointer_node
));
8948 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
8949 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
8950 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
8955 vtab
= gfc_find_vtab (&from_expr
->ts
);
8957 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
8958 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
8959 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
8963 return gfc_finish_block (&block
);
8966 /* Update _vptr component. */
8967 if (to_expr
->ts
.type
== BT_CLASS
)
8971 to_se
.want_pointer
= 1;
8972 to_expr2
= gfc_copy_expr (to_expr
);
8973 gfc_add_vptr_component (to_expr2
);
8974 gfc_conv_expr (&to_se
, to_expr2
);
8976 if (from_expr
->ts
.type
== BT_CLASS
)
8978 if (UNLIMITED_POLY (from_expr
))
8982 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
8986 from_se
.want_pointer
= 1;
8987 from_expr2
= gfc_copy_expr (from_expr
);
8988 gfc_add_vptr_component (from_expr2
);
8989 gfc_conv_expr (&from_se
, from_expr2
);
8990 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
8991 fold_convert (TREE_TYPE (to_se
.expr
),
8994 /* Reset _vptr component to declared type. */
8996 /* Unlimited polymorphic. */
8997 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
8998 fold_convert (TREE_TYPE (from_se
.expr
),
8999 null_pointer_node
));
9002 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9003 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9004 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9009 vtab
= gfc_find_vtab (&from_expr
->ts
);
9011 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9012 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9013 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9016 gfc_free_expr (to_expr2
);
9017 gfc_init_se (&to_se
, NULL
);
9019 if (from_expr
->ts
.type
== BT_CLASS
)
9021 gfc_free_expr (from_expr2
);
9022 gfc_init_se (&from_se
, NULL
);
9027 /* Deallocate "to". */
9028 if (from_expr
->rank
== 0)
9030 to_se
.want_coarray
= 1;
9031 from_se
.want_coarray
= 1;
9033 gfc_conv_expr_descriptor (&to_se
, to_expr
);
9034 gfc_conv_expr_descriptor (&from_se
, from_expr
);
9036 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
9037 is an image control "statement", cf. IR F08/0040 in 12-006A. */
9038 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
9042 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
9043 NULL_TREE
, NULL_TREE
, true, to_expr
,
9045 gfc_add_expr_to_block (&block
, tmp
);
9047 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9048 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9049 boolean_type_node
, tmp
,
9050 fold_convert (TREE_TYPE (tmp
),
9051 null_pointer_node
));
9052 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
9053 3, null_pointer_node
, null_pointer_node
,
9054 build_int_cst (integer_type_node
, 0));
9056 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
9057 tmp
, build_empty_stmt (input_location
));
9058 gfc_add_expr_to_block (&block
, tmp
);
9062 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9063 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9064 NULL_TREE
, true, to_expr
, false);
9065 gfc_add_expr_to_block (&block
, tmp
);
9068 /* Move the pointer and update the array descriptor data. */
9069 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
9071 /* Set "from" to NULL. */
9072 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
9073 gfc_add_modify_loc (input_location
, &block
, tmp
,
9074 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
9076 return gfc_finish_block (&block
);
9081 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
9085 gcc_assert (code
->resolved_isym
);
9087 switch (code
->resolved_isym
->id
)
9089 case GFC_ISYM_MOVE_ALLOC
:
9090 res
= conv_intrinsic_move_alloc (code
);
9093 case GFC_ISYM_ATOMIC_CAS
:
9094 res
= conv_intrinsic_atomic_cas (code
);
9097 case GFC_ISYM_ATOMIC_ADD
:
9098 case GFC_ISYM_ATOMIC_AND
:
9099 case GFC_ISYM_ATOMIC_DEF
:
9100 case GFC_ISYM_ATOMIC_OR
:
9101 case GFC_ISYM_ATOMIC_XOR
:
9102 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9103 case GFC_ISYM_ATOMIC_FETCH_AND
:
9104 case GFC_ISYM_ATOMIC_FETCH_OR
:
9105 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9106 res
= conv_intrinsic_atomic_op (code
);
9109 case GFC_ISYM_ATOMIC_REF
:
9110 res
= conv_intrinsic_atomic_ref (code
);
9113 case GFC_ISYM_C_F_POINTER
:
9114 case GFC_ISYM_C_F_PROCPOINTER
:
9115 res
= conv_isocbinding_subroutine (code
);
9118 case GFC_ISYM_CAF_SEND
:
9119 res
= conv_caf_send (code
);
9122 case GFC_ISYM_CO_MIN
:
9123 case GFC_ISYM_CO_MAX
:
9124 case GFC_ISYM_CO_SUM
:
9125 res
= conv_co_minmaxsum (code
);
9128 case GFC_ISYM_SYSTEM_CLOCK
:
9129 res
= conv_intrinsic_system_clock (code
);
9140 #include "gt-fortran-trans-intrinsic.h"