1 /* Intrinsic translation
2 Copyright (C) 2002-2015 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
27 #include "tm.h" /* For UNITS_PER_WORD. */
31 #include "double-int.h"
39 #include "fold-const.h"
40 #include "stringpool.h"
41 #include "tree-nested.h"
42 #include "stor-layout.h"
45 #include "diagnostic-core.h" /* For internal_error. */
46 #include "toplev.h" /* For rest_of_decl_compilation. */
49 #include "intrinsic.h"
51 #include "trans-const.h"
52 #include "trans-types.h"
53 #include "trans-array.h"
54 #include "dependency.h" /* For CAF array alias analysis. */
55 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
56 #include "trans-stmt.h"
57 #include "tree-nested.h"
59 /* This maps Fortran intrinsic math functions to external library or GCC
61 typedef struct GTY(()) gfc_intrinsic_map_t
{
62 /* The explicit enum is required to work around inadequacies in the
63 garbage collection/gengtype parsing mechanism. */
66 /* Enum value from the "language-independent", aka C-centric, part
67 of gcc, or END_BUILTINS of no such value set. */
68 enum built_in_function float_built_in
;
69 enum built_in_function double_built_in
;
70 enum built_in_function long_double_built_in
;
71 enum built_in_function complex_float_built_in
;
72 enum built_in_function complex_double_built_in
;
73 enum built_in_function complex_long_double_built_in
;
75 /* True if the naming pattern is to prepend "c" for complex and
76 append "f" for kind=4. False if the naming pattern is to
77 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
80 /* True if a complex version of the function exists. */
81 bool complex_available
;
83 /* True if the function should be marked const. */
86 /* The base library name of this function. */
89 /* Cache decls created for the various operand types. */
101 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
102 defines complex variants of all of the entries in mathbuiltins.def
104 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
105 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
106 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
108 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
110 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
111 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
112 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
113 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
114 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
116 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
117 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
118 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
119 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
120 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
122 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
123 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
124 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
125 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
126 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
128 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
130 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
131 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
132 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
133 #include "mathbuiltins.def"
135 /* Functions in libgfortran. */
136 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
139 LIB_FUNCTION (NONE
, NULL
, false)
144 #undef DEFINE_MATH_BUILTIN
145 #undef DEFINE_MATH_BUILTIN_C
148 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
151 /* Find the correct variant of a given builtin from its argument. */
153 builtin_decl_for_precision (enum built_in_function base_built_in
,
156 enum built_in_function i
= END_BUILTINS
;
158 gfc_intrinsic_map_t
*m
;
159 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
162 if (precision
== TYPE_PRECISION (float_type_node
))
163 i
= m
->float_built_in
;
164 else if (precision
== TYPE_PRECISION (double_type_node
))
165 i
= m
->double_built_in
;
166 else if (precision
== TYPE_PRECISION (long_double_type_node
))
167 i
= m
->long_double_built_in
;
168 else if (precision
== TYPE_PRECISION (float128_type_node
))
170 /* Special treatment, because it is not exactly a built-in, but
171 a library function. */
172 return m
->real16_decl
;
175 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
180 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
183 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
185 if (gfc_real_kinds
[i
].c_float128
)
187 /* For __float128, the story is a bit different, because we return
188 a decl to a library function rather than a built-in. */
189 gfc_intrinsic_map_t
*m
;
190 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
193 return m
->real16_decl
;
196 return builtin_decl_for_precision (double_built_in
,
197 gfc_real_kinds
[i
].mode_precision
);
201 /* Evaluate the arguments to an intrinsic function. The value
202 of NARGS may be less than the actual number of arguments in EXPR
203 to allow optional "KIND" arguments that are not included in the
204 generated code to be ignored. */
207 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
208 tree
*argarray
, int nargs
)
210 gfc_actual_arglist
*actual
;
212 gfc_intrinsic_arg
*formal
;
216 formal
= expr
->value
.function
.isym
->formal
;
217 actual
= expr
->value
.function
.actual
;
219 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
220 actual
= actual
->next
,
221 formal
= formal
? formal
->next
: NULL
)
225 /* Skip omitted optional arguments. */
232 /* Evaluate the parameter. This will substitute scalarized
233 references automatically. */
234 gfc_init_se (&argse
, se
);
236 if (e
->ts
.type
== BT_CHARACTER
)
238 gfc_conv_expr (&argse
, e
);
239 gfc_conv_string_parameter (&argse
);
240 argarray
[curr_arg
++] = argse
.string_length
;
241 gcc_assert (curr_arg
< nargs
);
244 gfc_conv_expr_val (&argse
, e
);
246 /* If an optional argument is itself an optional dummy argument,
247 check its presence and substitute a null if absent. */
248 if (e
->expr_type
== EXPR_VARIABLE
249 && e
->symtree
->n
.sym
->attr
.optional
252 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
254 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
255 gfc_add_block_to_block (&se
->post
, &argse
.post
);
256 argarray
[curr_arg
] = argse
.expr
;
260 /* Count the number of actual arguments to the intrinsic function EXPR
261 including any "hidden" string length arguments. */
264 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
267 gfc_actual_arglist
*actual
;
269 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
274 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
284 /* Conversions between different types are output by the frontend as
285 intrinsic functions. We implement these directly with inline code. */
288 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
294 nargs
= gfc_intrinsic_argument_list_length (expr
);
295 args
= XALLOCAVEC (tree
, nargs
);
297 /* Evaluate all the arguments passed. Whilst we're only interested in the
298 first one here, there are other parts of the front-end that assume this
299 and will trigger an ICE if it's not the case. */
300 type
= gfc_typenode_for_spec (&expr
->ts
);
301 gcc_assert (expr
->value
.function
.actual
->expr
);
302 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
304 /* Conversion between character kinds involves a call to a library
306 if (expr
->ts
.type
== BT_CHARACTER
)
308 tree fndecl
, var
, addr
, tmp
;
310 if (expr
->ts
.kind
== 1
311 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
312 fndecl
= gfor_fndecl_convert_char4_to_char1
;
313 else if (expr
->ts
.kind
== 4
314 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
315 fndecl
= gfor_fndecl_convert_char1_to_char4
;
319 /* Create the variable storing the converted value. */
320 type
= gfc_get_pchar_type (expr
->ts
.kind
);
321 var
= gfc_create_var (type
, "str");
322 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
324 /* Call the library function that will perform the conversion. */
325 gcc_assert (nargs
>= 2);
326 tmp
= build_call_expr_loc (input_location
,
327 fndecl
, 3, addr
, args
[0], args
[1]);
328 gfc_add_expr_to_block (&se
->pre
, tmp
);
330 /* Free the temporary afterwards. */
331 tmp
= gfc_call_free (var
);
332 gfc_add_expr_to_block (&se
->post
, tmp
);
335 se
->string_length
= args
[0];
340 /* Conversion from complex to non-complex involves taking the real
341 component of the value. */
342 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
343 && expr
->ts
.type
!= BT_COMPLEX
)
347 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
348 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
352 se
->expr
= convert (type
, args
[0]);
355 /* This is needed because the gcc backend only implements
356 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
357 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
358 Similarly for CEILING. */
361 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
368 argtype
= TREE_TYPE (arg
);
369 arg
= gfc_evaluate_now (arg
, pblock
);
371 intval
= convert (type
, arg
);
372 intval
= gfc_evaluate_now (intval
, pblock
);
374 tmp
= convert (argtype
, intval
);
375 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
376 boolean_type_node
, tmp
, arg
);
378 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
379 intval
, build_int_cst (type
, 1));
380 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
385 /* Round to nearest integer, away from zero. */
388 build_round_expr (tree arg
, tree restype
)
392 int argprec
, resprec
;
394 argtype
= TREE_TYPE (arg
);
395 argprec
= TYPE_PRECISION (argtype
);
396 resprec
= TYPE_PRECISION (restype
);
398 /* Depending on the type of the result, choose the int intrinsic
399 (iround, available only as a builtin, therefore cannot use it for
400 __float128), long int intrinsic (lround family) or long long
401 intrinsic (llround). We might also need to convert the result
403 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
404 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
405 else if (resprec
<= LONG_TYPE_SIZE
)
406 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
407 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
408 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
412 return fold_convert (restype
, build_call_expr_loc (input_location
,
417 /* Convert a real to an integer using a specific rounding mode.
418 Ideally we would just build the corresponding GENERIC node,
419 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
422 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
423 enum rounding_mode op
)
428 return build_fixbound_expr (pblock
, arg
, type
, 0);
432 return build_fixbound_expr (pblock
, arg
, type
, 1);
436 return build_round_expr (arg
, type
);
440 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
449 /* Round a real value using the specified rounding mode.
450 We use a temporary integer of that same kind size as the result.
451 Values larger than those that can be represented by this kind are
452 unchanged, as they will not be accurate enough to represent the
454 huge = HUGE (KIND (a))
455 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
459 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
471 kind
= expr
->ts
.kind
;
472 nargs
= gfc_intrinsic_argument_list_length (expr
);
475 /* We have builtin functions for some cases. */
479 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
483 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
490 /* Evaluate the argument. */
491 gcc_assert (expr
->value
.function
.actual
->expr
);
492 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
494 /* Use a builtin function if one exists. */
495 if (decl
!= NULL_TREE
)
497 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
501 /* This code is probably redundant, but we'll keep it lying around just
503 type
= gfc_typenode_for_spec (&expr
->ts
);
504 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
506 /* Test if the value is too large to handle sensibly. */
507 gfc_set_model_kind (kind
);
509 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
510 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
511 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
512 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
515 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
516 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
517 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
519 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
521 itype
= gfc_get_int_type (kind
);
523 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
524 tmp
= convert (type
, tmp
);
525 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
531 /* Convert to an integer using the specified rounding mode. */
534 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
540 nargs
= gfc_intrinsic_argument_list_length (expr
);
541 args
= XALLOCAVEC (tree
, nargs
);
543 /* Evaluate the argument, we process all arguments even though we only
544 use the first one for code generation purposes. */
545 type
= gfc_typenode_for_spec (&expr
->ts
);
546 gcc_assert (expr
->value
.function
.actual
->expr
);
547 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
549 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
551 /* Conversion to a different integer kind. */
552 se
->expr
= convert (type
, args
[0]);
556 /* Conversion from complex to non-complex involves taking the real
557 component of the value. */
558 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
559 && expr
->ts
.type
!= BT_COMPLEX
)
563 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
564 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
568 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
573 /* Get the imaginary component of a value. */
576 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
580 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
581 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
582 TREE_TYPE (TREE_TYPE (arg
)), arg
);
586 /* Get the complex conjugate of a value. */
589 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
593 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
594 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
600 define_quad_builtin (const char *name
, tree type
, bool is_const
)
603 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
606 /* Mark the decl as external. */
607 DECL_EXTERNAL (fndecl
) = 1;
608 TREE_PUBLIC (fndecl
) = 1;
610 /* Mark it __attribute__((const)). */
611 TREE_READONLY (fndecl
) = is_const
;
613 rest_of_decl_compilation (fndecl
, 1, 0);
620 /* Initialize function decls for library functions. The external functions
621 are created as required. Builtin functions are added here. */
624 gfc_build_intrinsic_lib_fndecls (void)
626 gfc_intrinsic_map_t
*m
;
627 tree quad_decls
[END_BUILTINS
+ 1];
629 if (gfc_real16_is_float128
)
631 /* If we have soft-float types, we create the decls for their
632 C99-like library functions. For now, we only handle __float128
633 q-suffixed functions. */
635 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
636 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
638 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
640 type
= float128_type_node
;
641 complex_type
= complex_float128_type_node
;
642 /* type (*) (type) */
643 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
645 func_iround
= build_function_type_list (integer_type_node
,
647 /* long (*) (type) */
648 func_lround
= build_function_type_list (long_integer_type_node
,
650 /* long long (*) (type) */
651 func_llround
= build_function_type_list (long_long_integer_type_node
,
653 /* type (*) (type, type) */
654 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
655 /* type (*) (type, &int) */
657 = build_function_type_list (type
,
659 build_pointer_type (integer_type_node
),
661 /* type (*) (type, int) */
662 func_scalbn
= build_function_type_list (type
,
663 type
, integer_type_node
, NULL_TREE
);
664 /* type (*) (complex type) */
665 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
666 /* complex type (*) (complex type, complex type) */
668 = build_function_type_list (complex_type
,
669 complex_type
, complex_type
, NULL_TREE
);
671 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
672 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
673 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
675 /* Only these built-ins are actually needed here. These are used directly
676 from the code, when calling builtin_decl_for_precision() or
677 builtin_decl_for_float_type(). The others are all constructed by
678 gfc_get_intrinsic_lib_fndecl(). */
679 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
680 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
682 #include "mathbuiltins.def"
686 #undef DEFINE_MATH_BUILTIN
687 #undef DEFINE_MATH_BUILTIN_C
691 /* Add GCC builtin functions. */
692 for (m
= gfc_intrinsic_map
;
693 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
695 if (m
->float_built_in
!= END_BUILTINS
)
696 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
697 if (m
->complex_float_built_in
!= END_BUILTINS
)
698 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
699 if (m
->double_built_in
!= END_BUILTINS
)
700 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
701 if (m
->complex_double_built_in
!= END_BUILTINS
)
702 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
704 /* If real(kind=10) exists, it is always long double. */
705 if (m
->long_double_built_in
!= END_BUILTINS
)
706 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
707 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
709 = builtin_decl_explicit (m
->complex_long_double_built_in
);
711 if (!gfc_real16_is_float128
)
713 if (m
->long_double_built_in
!= END_BUILTINS
)
714 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
715 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
717 = builtin_decl_explicit (m
->complex_long_double_built_in
);
719 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
721 /* Quad-precision function calls are constructed when first
722 needed by builtin_decl_for_precision(), except for those
723 that will be used directly (define by OTHER_BUILTIN). */
724 m
->real16_decl
= quad_decls
[m
->double_built_in
];
726 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
728 /* Same thing for the complex ones. */
729 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
735 /* Create a fndecl for a simple intrinsic library function. */
738 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
741 vec
<tree
, va_gc
> *argtypes
;
743 gfc_actual_arglist
*actual
;
746 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
749 if (ts
->type
== BT_REAL
)
754 pdecl
= &m
->real4_decl
;
757 pdecl
= &m
->real8_decl
;
760 pdecl
= &m
->real10_decl
;
763 pdecl
= &m
->real16_decl
;
769 else if (ts
->type
== BT_COMPLEX
)
771 gcc_assert (m
->complex_available
);
776 pdecl
= &m
->complex4_decl
;
779 pdecl
= &m
->complex8_decl
;
782 pdecl
= &m
->complex10_decl
;
785 pdecl
= &m
->complex16_decl
;
799 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
800 if (gfc_real_kinds
[n
].c_float
)
801 snprintf (name
, sizeof (name
), "%s%s%s",
802 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
803 else if (gfc_real_kinds
[n
].c_double
)
804 snprintf (name
, sizeof (name
), "%s%s",
805 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
806 else if (gfc_real_kinds
[n
].c_long_double
)
807 snprintf (name
, sizeof (name
), "%s%s%s",
808 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
809 else if (gfc_real_kinds
[n
].c_float128
)
810 snprintf (name
, sizeof (name
), "%s%s%s",
811 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
817 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
818 ts
->type
== BT_COMPLEX
? 'c' : 'r',
823 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
825 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
826 vec_safe_push (argtypes
, type
);
828 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
829 fndecl
= build_decl (input_location
,
830 FUNCTION_DECL
, get_identifier (name
), type
);
832 /* Mark the decl as external. */
833 DECL_EXTERNAL (fndecl
) = 1;
834 TREE_PUBLIC (fndecl
) = 1;
836 /* Mark it __attribute__((const)), if possible. */
837 TREE_READONLY (fndecl
) = m
->is_constant
;
839 rest_of_decl_compilation (fndecl
, 1, 0);
846 /* Convert an intrinsic function into an external or builtin call. */
849 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
851 gfc_intrinsic_map_t
*m
;
855 unsigned int num_args
;
858 id
= expr
->value
.function
.isym
->id
;
859 /* Find the entry for this function. */
860 for (m
= gfc_intrinsic_map
;
861 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
867 if (m
->id
== GFC_ISYM_NONE
)
869 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
870 expr
->value
.function
.name
, id
);
873 /* Get the decl and generate the call. */
874 num_args
= gfc_intrinsic_argument_list_length (expr
);
875 args
= XALLOCAVEC (tree
, num_args
);
877 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
878 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
879 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
881 fndecl
= build_addr (fndecl
, current_function_decl
);
882 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
886 /* If bounds-checking is enabled, create code to verify at runtime that the
887 string lengths for both expressions are the same (needed for e.g. MERGE).
888 If bounds-checking is not enabled, does nothing. */
891 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
892 tree a
, tree b
, stmtblock_t
* target
)
897 /* If bounds-checking is disabled, do nothing. */
898 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
901 /* Compare the two string lengths. */
902 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
904 /* Output the runtime-check. */
905 name
= gfc_build_cstring_const (intr_name
);
906 name
= gfc_build_addr_expr (pchar_type_node
, name
);
907 gfc_trans_runtime_check (true, false, cond
, target
, where
,
908 "Unequal character lengths (%ld/%ld) in %s",
909 fold_convert (long_integer_type_node
, a
),
910 fold_convert (long_integer_type_node
, b
), name
);
914 /* The EXPONENT(X) intrinsic function is translated into
916 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
917 so that if X is a NaN or infinity, the result is HUGE(0).
921 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
923 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
926 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
927 expr
->value
.function
.actual
->expr
->ts
.kind
);
929 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
930 arg
= gfc_evaluate_now (arg
, &se
->pre
);
932 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
933 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
934 cond
= build_call_expr_loc (input_location
,
935 builtin_decl_explicit (BUILT_IN_ISFINITE
),
938 res
= gfc_create_var (integer_type_node
, NULL
);
939 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
940 gfc_build_addr_expr (NULL_TREE
, res
));
941 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
943 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
946 type
= gfc_typenode_for_spec (&expr
->ts
);
947 se
->expr
= fold_convert (type
, se
->expr
);
951 /* Fill in the following structure
952 struct caf_vector_t {
953 size_t nvec; // size of the vector
960 ptrdiff_t lower_bound;
961 ptrdiff_t upper_bound;
968 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
969 tree lower
, tree upper
, tree stride
,
970 tree vector
, int kind
, tree nvec
)
972 tree field
, type
, tmp
;
974 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
975 type
= TREE_TYPE (desc
);
977 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
978 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
979 desc
, field
, NULL_TREE
);
980 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
983 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
984 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
985 desc
, field
, NULL_TREE
);
986 type
= TREE_TYPE (desc
);
988 /* Access the inner struct. */
989 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
990 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
991 desc
, field
, NULL_TREE
);
992 type
= TREE_TYPE (desc
);
994 if (vector
!= NULL_TREE
)
996 /* Set dim.lower/upper/stride. */
997 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
998 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
999 desc
, field
, NULL_TREE
);
1000 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
1001 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1002 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1003 desc
, field
, NULL_TREE
);
1004 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
1008 /* Set vector and kind. */
1009 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1010 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1011 desc
, field
, NULL_TREE
);
1012 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1014 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1015 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1016 desc
, field
, NULL_TREE
);
1017 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1019 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
1020 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1021 desc
, field
, NULL_TREE
);
1022 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), stride
));
1028 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1031 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1032 tree lbound
, ubound
, tmp
;
1035 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1037 for (i
= 0; i
< ar
->dimen
; i
++)
1038 switch (ar
->dimen_type
[i
])
1043 gfc_init_se (&argse
, NULL
);
1044 gfc_conv_expr (&argse
, ar
->end
[i
]);
1045 gfc_add_block_to_block (block
, &argse
.pre
);
1046 upper
= gfc_evaluate_now (argse
.expr
, block
);
1049 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1052 gfc_init_se (&argse
, NULL
);
1053 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1054 gfc_add_block_to_block (block
, &argse
.pre
);
1055 stride
= gfc_evaluate_now (argse
.expr
, block
);
1058 stride
= gfc_index_one_node
;
1064 gfc_init_se (&argse
, NULL
);
1065 gfc_conv_expr (&argse
, ar
->start
[i
]);
1066 gfc_add_block_to_block (block
, &argse
.pre
);
1067 lower
= gfc_evaluate_now (argse
.expr
, block
);
1070 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1071 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1074 stride
= gfc_index_one_node
;
1077 nvec
= size_zero_node
;
1078 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1083 gfc_init_se (&argse
, NULL
);
1084 argse
.descriptor_only
= 1;
1085 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1086 gfc_add_block_to_block (block
, &argse
.pre
);
1087 vector
= argse
.expr
;
1088 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1089 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1090 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1091 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1092 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1093 TREE_TYPE (nvec
), nvec
, tmp
);
1094 lower
= gfc_index_zero_node
;
1095 upper
= gfc_index_zero_node
;
1096 stride
= gfc_index_zero_node
;
1097 vector
= gfc_conv_descriptor_data_get (vector
);
1098 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1099 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1104 return gfc_build_addr_expr (NULL_TREE
, var
);
1108 /* Get data from a remote coarray. */
1111 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1112 tree may_require_tmp
)
1114 gfc_expr
*array_expr
;
1116 tree caf_decl
, token
, offset
, image_index
, tmp
;
1117 tree res_var
, dst_var
, type
, kind
, vec
;
1119 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1121 if (se
->ss
&& se
->ss
->info
->useflags
)
1123 /* Access the previously obtained result. */
1124 gfc_conv_tmp_array_ref (se
);
1128 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1129 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1130 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1135 vec
= null_pointer_node
;
1137 gfc_init_se (&argse
, NULL
);
1138 if (array_expr
->rank
== 0)
1140 symbol_attribute attr
;
1142 gfc_clear_attr (&attr
);
1143 gfc_conv_expr (&argse
, array_expr
);
1145 if (lhs
== NULL_TREE
)
1147 gfc_clear_attr (&attr
);
1148 if (array_expr
->ts
.type
== BT_CHARACTER
)
1149 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1150 argse
.string_length
);
1152 res_var
= gfc_create_var (type
, "caf_res");
1153 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1154 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1156 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1157 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1161 /* If has_vector, pass descriptor for whole array and the
1162 vector bounds separately. */
1163 gfc_array_ref
*ar
, ar2
;
1164 bool has_vector
= false;
1166 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1169 ar
= gfc_find_array_ref (expr
);
1171 memset (ar
, '\0', sizeof (*ar
));
1175 gfc_conv_expr_descriptor (&argse
, array_expr
);
1176 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1177 has the wrong type if component references are done. */
1178 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1179 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1184 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, &ar2
);
1188 if (lhs
== NULL_TREE
)
1190 /* Create temporary. */
1191 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1192 if (se
->loop
->to
[n
] == NULL_TREE
)
1195 gfc_conv_descriptor_lbound_get (argse
.expr
, gfc_rank_cst
[n
]);
1197 gfc_conv_descriptor_ubound_get (argse
.expr
, gfc_rank_cst
[n
]);
1199 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1200 NULL_TREE
, false, true, false,
1201 &array_expr
->where
);
1202 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1203 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1205 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1208 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1209 if (lhs_kind
== NULL_TREE
)
1212 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1213 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1215 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1216 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1217 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1218 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1219 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, argse
.expr
, array_expr
);
1221 /* No overlap possible as we have generated a temporary. */
1222 if (lhs
== NULL_TREE
)
1223 may_require_tmp
= boolean_false_node
;
1225 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 9,
1226 token
, offset
, image_index
, argse
.expr
, vec
,
1227 dst_var
, kind
, lhs_kind
, may_require_tmp
);
1228 gfc_add_expr_to_block (&se
->pre
, tmp
);
1231 gfc_advance_se_ss_chain (se
);
1234 if (array_expr
->ts
.type
== BT_CHARACTER
)
1235 se
->string_length
= argse
.string_length
;
1239 /* Send data to a remove coarray. */
1242 conv_caf_send (gfc_code
*code
) {
1243 gfc_expr
*lhs_expr
, *rhs_expr
;
1244 gfc_se lhs_se
, rhs_se
;
1246 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1247 tree may_require_tmp
;
1248 tree lhs_type
= NULL_TREE
;
1249 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1251 gcc_assert (flag_coarray
== GFC_FCOARRAY_LIB
);
1253 lhs_expr
= code
->ext
.actual
->expr
;
1254 rhs_expr
= code
->ext
.actual
->next
->expr
;
1255 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1256 ? boolean_false_node
: boolean_true_node
;
1257 gfc_init_block (&block
);
1260 gfc_init_se (&lhs_se
, NULL
);
1261 if (lhs_expr
->rank
== 0)
1263 symbol_attribute attr
;
1264 gfc_clear_attr (&attr
);
1265 gfc_conv_expr (&lhs_se
, lhs_expr
);
1266 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1267 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1268 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1272 /* If has_vector, pass descriptor for whole array and the
1273 vector bounds separately. */
1274 gfc_array_ref
*ar
, ar2
;
1275 bool has_vector
= false;
1277 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1280 ar
= gfc_find_array_ref (lhs_expr
);
1282 memset (ar
, '\0', sizeof (*ar
));
1286 lhs_se
.want_pointer
= 1;
1287 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1288 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1289 has the wrong type if component references are done. */
1290 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1291 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1292 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1293 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1298 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, &ar2
);
1303 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1304 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1306 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1307 temporary and a loop. */
1308 if (!gfc_is_coindexed (lhs_expr
))
1310 gcc_assert (gfc_is_coindexed (rhs_expr
));
1311 gfc_init_se (&rhs_se
, NULL
);
1312 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1314 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1315 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1316 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1317 return gfc_finish_block (&block
);
1320 /* Obtain token, offset and image index for the LHS. */
1322 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1323 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1324 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1325 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1326 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, lhs_se
.expr
, lhs_expr
);
1329 gfc_init_se (&rhs_se
, NULL
);
1330 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1331 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1332 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1333 if (rhs_expr
->rank
== 0)
1335 symbol_attribute attr
;
1336 gfc_clear_attr (&attr
);
1337 gfc_conv_expr (&rhs_se
, rhs_expr
);
1338 if (!gfc_is_coindexed (rhs_expr
) && rhs_expr
->ts
.type
!= BT_CHARACTER
)
1339 rhs_se
.expr
= fold_convert (lhs_type
, rhs_se
.expr
);
1340 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
1341 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
1345 /* If has_vector, pass descriptor for whole array and the
1346 vector bounds separately. */
1347 gfc_array_ref
*ar
, ar2
;
1348 bool has_vector
= false;
1351 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
1354 ar
= gfc_find_array_ref (rhs_expr
);
1356 memset (ar
, '\0', sizeof (*ar
));
1360 rhs_se
.want_pointer
= 1;
1361 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
1362 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1363 has the wrong type if component references are done. */
1364 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
1365 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
1366 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1367 gfc_get_dtype_rank_type (has_vector
? ar2
.dimen
1372 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, &ar2
);
1377 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1379 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
1381 if (!gfc_is_coindexed (rhs_expr
))
1382 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 9, token
,
1383 offset
, image_index
, lhs_se
.expr
, vec
,
1384 rhs_se
.expr
, lhs_kind
, rhs_kind
, may_require_tmp
);
1387 tree rhs_token
, rhs_offset
, rhs_image_index
;
1389 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
1390 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1391 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1392 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
1393 gfc_get_caf_token_offset (&rhs_token
, &rhs_offset
, caf_decl
, rhs_se
.expr
,
1395 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
, 13,
1396 token
, offset
, image_index
, lhs_se
.expr
, vec
,
1397 rhs_token
, rhs_offset
, rhs_image_index
,
1398 rhs_se
.expr
, rhs_vec
, lhs_kind
, rhs_kind
,
1401 gfc_add_expr_to_block (&block
, tmp
);
1402 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1403 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1404 return gfc_finish_block (&block
);
1409 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
1412 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
1413 lbound
, ubound
, extent
, ml
;
1416 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
1418 if (expr
->value
.function
.actual
->expr
1419 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
1420 distance
= expr
->value
.function
.actual
->expr
;
1422 /* The case -fcoarray=single is handled elsewhere. */
1423 gcc_assert (flag_coarray
!= GFC_FCOARRAY_SINGLE
);
1425 /* Argument-free version: THIS_IMAGE(). */
1426 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
1430 gfc_init_se (&argse
, NULL
);
1431 gfc_conv_expr_val (&argse
, distance
);
1432 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1433 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1434 tmp
= fold_convert (integer_type_node
, argse
.expr
);
1437 tmp
= integer_zero_node
;
1438 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1440 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1445 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1447 type
= gfc_get_int_type (gfc_default_integer_kind
);
1448 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1449 rank
= expr
->value
.function
.actual
->expr
->rank
;
1451 /* Obtain the descriptor of the COARRAY. */
1452 gfc_init_se (&argse
, NULL
);
1453 argse
.want_coarray
= 1;
1454 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1455 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1456 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1461 /* Create an implicit second parameter from the loop variable. */
1462 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
1463 gcc_assert (corank
> 0);
1464 gcc_assert (se
->loop
->dimen
== 1);
1465 gcc_assert (se
->ss
->info
->expr
== expr
);
1467 dim_arg
= se
->loop
->loopvar
[0];
1468 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
1469 gfc_array_index_type
, dim_arg
,
1470 build_int_cst (TREE_TYPE (dim_arg
), 1));
1471 gfc_advance_se_ss_chain (se
);
1475 /* Use the passed DIM= argument. */
1476 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
1477 gfc_init_se (&argse
, NULL
);
1478 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
1479 gfc_array_index_type
);
1480 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1481 dim_arg
= argse
.expr
;
1483 if (INTEGER_CST_P (dim_arg
))
1485 if (wi::ltu_p (dim_arg
, 1)
1486 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
1487 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1488 "dimension index", expr
->value
.function
.isym
->name
,
1491 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1493 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1494 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1496 build_int_cst (TREE_TYPE (dim_arg
), 1));
1497 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1498 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1500 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1501 boolean_type_node
, cond
, tmp
);
1502 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1507 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1508 one always has a dim_arg argument.
1510 m = this_image() - 1
1513 sub(1) = m + lcobound(corank)
1517 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1520 extent = gfc_extent(i)
1528 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1529 : m + lcobound(corank)
1532 /* this_image () - 1. */
1533 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1535 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
1536 fold_convert (type
, tmp
), build_int_cst (type
, 1));
1539 /* sub(1) = m + lcobound(corank). */
1540 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1541 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1543 lbound
= fold_convert (type
, lbound
);
1544 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1550 m
= gfc_create_var (type
, NULL
);
1551 ml
= gfc_create_var (type
, NULL
);
1552 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1553 min_var
= gfc_create_var (integer_type_node
, NULL
);
1555 /* m = this_image () - 1. */
1556 gfc_add_modify (&se
->pre
, m
, tmp
);
1558 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1559 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1560 fold_convert (integer_type_node
, dim_arg
),
1561 build_int_cst (integer_type_node
, rank
- 1));
1562 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1563 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1565 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1568 tmp
= build_int_cst (integer_type_node
, rank
);
1569 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1571 exit_label
= gfc_build_label_decl (NULL_TREE
);
1572 TREE_USED (exit_label
) = 1;
1575 gfc_init_block (&loop
);
1578 gfc_add_modify (&loop
, ml
, m
);
1581 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1582 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1583 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1584 extent
= fold_convert (type
, extent
);
1587 gfc_add_modify (&loop
, m
,
1588 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1591 /* Exit condition: if (i >= min_var) goto exit_label. */
1592 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1594 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1595 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1596 build_empty_stmt (input_location
));
1597 gfc_add_expr_to_block (&loop
, tmp
);
1599 /* Increment loop variable: i++. */
1600 gfc_add_modify (&loop
, loop_var
,
1601 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1603 build_int_cst (integer_type_node
, 1)));
1605 /* Making the loop... actually loop! */
1606 tmp
= gfc_finish_block (&loop
);
1607 tmp
= build1_v (LOOP_EXPR
, tmp
);
1608 gfc_add_expr_to_block (&se
->pre
, tmp
);
1610 /* The exit label. */
1611 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1612 gfc_add_expr_to_block (&se
->pre
, tmp
);
1614 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1615 : m + lcobound(corank) */
1617 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1618 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1620 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1621 fold_build2_loc (input_location
, PLUS_EXPR
,
1622 gfc_array_index_type
, dim_arg
,
1623 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1624 lbound
= fold_convert (type
, lbound
);
1626 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1627 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1629 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1631 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1632 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1638 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1640 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1642 gfc_se argse
, subse
;
1643 int rank
, corank
, codim
;
1645 type
= gfc_get_int_type (gfc_default_integer_kind
);
1646 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1647 rank
= expr
->value
.function
.actual
->expr
->rank
;
1649 /* Obtain the descriptor of the COARRAY. */
1650 gfc_init_se (&argse
, NULL
);
1651 argse
.want_coarray
= 1;
1652 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1653 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1654 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1657 /* Obtain a handle to the SUB argument. */
1658 gfc_init_se (&subse
, NULL
);
1659 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1660 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1661 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1662 subdesc
= build_fold_indirect_ref_loc (input_location
,
1663 gfc_conv_descriptor_data_get (subse
.expr
));
1665 /* Fortran 2008 does not require that the values remain in the cobounds,
1666 thus we need explicitly check this - and return 0 if they are exceeded. */
1668 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1669 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1670 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1671 fold_convert (gfc_array_index_type
, tmp
),
1674 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1676 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1677 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1678 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1679 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1680 fold_convert (gfc_array_index_type
, tmp
),
1682 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1683 boolean_type_node
, invalid_bound
, cond
);
1684 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1685 fold_convert (gfc_array_index_type
, tmp
),
1687 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1688 boolean_type_node
, invalid_bound
, cond
);
1691 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
1693 /* See Fortran 2008, C.10 for the following algorithm. */
1695 /* coindex = sub(corank) - lcobound(n). */
1696 coindex
= fold_convert (gfc_array_index_type
,
1697 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1699 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1700 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1701 fold_convert (gfc_array_index_type
, coindex
),
1704 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1706 tree extent
, ubound
;
1708 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1709 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1710 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1711 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1713 /* coindex *= extent. */
1714 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1715 gfc_array_index_type
, coindex
, extent
);
1717 /* coindex += sub(codim). */
1718 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1719 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1720 gfc_array_index_type
, coindex
,
1721 fold_convert (gfc_array_index_type
, tmp
));
1723 /* coindex -= lbound(codim). */
1724 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1725 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1726 gfc_array_index_type
, coindex
, lbound
);
1729 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1730 fold_convert(type
, coindex
),
1731 build_int_cst (type
, 1));
1733 /* Return 0 if "coindex" exceeds num_images(). */
1735 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
1736 num_images
= build_int_cst (type
, 1);
1739 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1741 build_int_cst (integer_type_node
, -1));
1742 num_images
= fold_convert (type
, tmp
);
1745 tmp
= gfc_create_var (type
, NULL
);
1746 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1748 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1750 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1752 fold_convert (boolean_type_node
, invalid_bound
));
1753 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1754 build_int_cst (type
, 0), tmp
);
1759 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
1761 tree tmp
, distance
, failed
;
1764 if (expr
->value
.function
.actual
->expr
)
1766 gfc_init_se (&argse
, NULL
);
1767 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
1768 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1769 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1770 distance
= fold_convert (integer_type_node
, argse
.expr
);
1773 distance
= integer_zero_node
;
1775 if (expr
->value
.function
.actual
->next
->expr
)
1777 gfc_init_se (&argse
, NULL
);
1778 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
1779 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1780 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1781 failed
= fold_convert (integer_type_node
, argse
.expr
);
1784 failed
= build_int_cst (integer_type_node
, -1);
1786 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1788 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
1793 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1797 gfc_init_se (&argse
, NULL
);
1798 argse
.data_not_needed
= 1;
1799 argse
.descriptor_only
= 1;
1801 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1802 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1803 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1805 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1809 /* Evaluate a single upper or lower bound. */
1810 /* TODO: bound intrinsic generates way too much unnecessary code. */
1813 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1815 gfc_actual_arglist
*arg
;
1816 gfc_actual_arglist
*arg2
;
1821 tree cond
, cond1
, cond3
, cond4
, size
;
1825 gfc_array_spec
* as
;
1826 bool assumed_rank_lb_one
;
1828 arg
= expr
->value
.function
.actual
;
1833 /* Create an implicit second parameter from the loop variable. */
1834 gcc_assert (!arg2
->expr
);
1835 gcc_assert (se
->loop
->dimen
== 1);
1836 gcc_assert (se
->ss
->info
->expr
== expr
);
1837 gfc_advance_se_ss_chain (se
);
1838 bound
= se
->loop
->loopvar
[0];
1839 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1840 gfc_array_index_type
, bound
,
1845 /* use the passed argument. */
1846 gcc_assert (arg2
->expr
);
1847 gfc_init_se (&argse
, NULL
);
1848 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1849 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1851 /* Convert from one based to zero based. */
1852 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1853 gfc_array_index_type
, bound
,
1854 gfc_index_one_node
);
1857 /* TODO: don't re-evaluate the descriptor on each iteration. */
1858 /* Get a descriptor for the first parameter. */
1859 gfc_init_se (&argse
, NULL
);
1860 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1861 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1862 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1866 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1868 if (INTEGER_CST_P (bound
))
1870 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1871 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
1872 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
1873 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1874 "dimension index", upper
? "UBOUND" : "LBOUND",
1878 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1880 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1882 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1883 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1884 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1885 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1886 tmp
= gfc_conv_descriptor_rank (desc
);
1888 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1889 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1890 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1891 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1892 boolean_type_node
, cond
, tmp
);
1893 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1898 /* Take care of the lbound shift for assumed-rank arrays, which are
1899 nonallocatable and nonpointers. Those has a lbound of 1. */
1900 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1901 && ((arg
->expr
->ts
.type
!= BT_CLASS
1902 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1903 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1904 || (arg
->expr
->ts
.type
== BT_CLASS
1905 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1906 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1908 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1909 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1911 /* 13.14.53: Result value for LBOUND
1913 Case (i): For an array section or for an array expression other than a
1914 whole array or array structure component, LBOUND(ARRAY, DIM)
1915 has the value 1. For a whole array or array structure
1916 component, LBOUND(ARRAY, DIM) has the value:
1917 (a) equal to the lower bound for subscript DIM of ARRAY if
1918 dimension DIM of ARRAY does not have extent zero
1919 or if ARRAY is an assumed-size array of rank DIM,
1922 13.14.113: Result value for UBOUND
1924 Case (i): For an array section or for an array expression other than a
1925 whole array or array structure component, UBOUND(ARRAY, DIM)
1926 has the value equal to the number of elements in the given
1927 dimension; otherwise, it has a value equal to the upper bound
1928 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1929 not have size zero and has value zero if dimension DIM has
1932 if (!upper
&& assumed_rank_lb_one
)
1933 se
->expr
= gfc_index_one_node
;
1936 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1938 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1940 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1941 stride
, gfc_index_zero_node
);
1942 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1943 boolean_type_node
, cond3
, cond1
);
1944 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1945 stride
, gfc_index_zero_node
);
1950 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1951 boolean_type_node
, cond3
, cond4
);
1952 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1953 gfc_index_one_node
, lbound
);
1954 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1955 boolean_type_node
, cond4
, cond5
);
1957 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1958 boolean_type_node
, cond
, cond5
);
1960 if (assumed_rank_lb_one
)
1962 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1963 gfc_array_index_type
, ubound
, lbound
);
1964 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1965 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1970 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1971 gfc_array_index_type
, cond
,
1972 tmp
, gfc_index_zero_node
);
1976 if (as
->type
== AS_ASSUMED_SIZE
)
1977 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1978 bound
, build_int_cst (TREE_TYPE (bound
),
1979 arg
->expr
->rank
- 1));
1981 cond
= boolean_false_node
;
1983 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1984 boolean_type_node
, cond3
, cond4
);
1985 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1986 boolean_type_node
, cond
, cond1
);
1988 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1989 gfc_array_index_type
, cond
,
1990 lbound
, gfc_index_one_node
);
1997 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1998 gfc_array_index_type
, ubound
, lbound
);
1999 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
2000 gfc_array_index_type
, size
,
2001 gfc_index_one_node
);
2002 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
2003 gfc_array_index_type
, se
->expr
,
2004 gfc_index_zero_node
);
2007 se
->expr
= gfc_index_one_node
;
2010 type
= gfc_typenode_for_spec (&expr
->ts
);
2011 se
->expr
= convert (type
, se
->expr
);
2016 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2018 gfc_actual_arglist
*arg
;
2019 gfc_actual_arglist
*arg2
;
2021 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2025 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2026 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2027 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2029 arg
= expr
->value
.function
.actual
;
2032 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2033 corank
= gfc_get_corank (arg
->expr
);
2035 gfc_init_se (&argse
, NULL
);
2036 argse
.want_coarray
= 1;
2038 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2039 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2040 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2045 /* Create an implicit second parameter from the loop variable. */
2046 gcc_assert (!arg2
->expr
);
2047 gcc_assert (corank
> 0);
2048 gcc_assert (se
->loop
->dimen
== 1);
2049 gcc_assert (se
->ss
->info
->expr
== expr
);
2051 bound
= se
->loop
->loopvar
[0];
2052 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2053 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2054 gfc_advance_se_ss_chain (se
);
2058 /* use the passed argument. */
2059 gcc_assert (arg2
->expr
);
2060 gfc_init_se (&argse
, NULL
);
2061 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2062 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2065 if (INTEGER_CST_P (bound
))
2067 if (wi::ltu_p (bound
, 1)
2068 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2069 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2070 "dimension index", expr
->value
.function
.isym
->name
,
2073 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2075 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2076 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2077 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2078 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2079 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2081 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2082 boolean_type_node
, cond
, tmp
);
2083 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2088 /* Subtract 1 to get to zero based and add dimensions. */
2089 switch (arg
->expr
->rank
)
2092 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2093 gfc_array_index_type
, bound
,
2094 gfc_index_one_node
);
2098 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2099 gfc_array_index_type
, bound
,
2100 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2104 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2106 /* Handle UCOBOUND with special handling of the last codimension. */
2107 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2109 /* Last codimension: For -fcoarray=single just return
2110 the lcobound - otherwise add
2111 ceiling (real (num_images ()) / real (size)) - 1
2112 = (num_images () + size - 1) / size - 1
2113 = (num_images - 1) / size(),
2114 where size is the product of the extent of all but the last
2117 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2121 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2122 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2123 2, integer_zero_node
,
2124 build_int_cst (integer_type_node
, -1));
2125 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2126 gfc_array_index_type
,
2127 fold_convert (gfc_array_index_type
, tmp
),
2128 build_int_cst (gfc_array_index_type
, 1));
2129 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2130 gfc_array_index_type
, tmp
,
2131 fold_convert (gfc_array_index_type
, cosize
));
2132 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2133 gfc_array_index_type
, resbound
, tmp
);
2135 else if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
2137 /* ubound = lbound + num_images() - 1. */
2138 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2139 2, integer_zero_node
,
2140 build_int_cst (integer_type_node
, -1));
2141 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2142 gfc_array_index_type
,
2143 fold_convert (gfc_array_index_type
, tmp
),
2144 build_int_cst (gfc_array_index_type
, 1));
2145 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2146 gfc_array_index_type
, resbound
, tmp
);
2151 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2153 build_int_cst (TREE_TYPE (bound
),
2154 arg
->expr
->rank
+ corank
- 1));
2156 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2157 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2158 gfc_array_index_type
, cond
,
2159 resbound
, resbound2
);
2162 se
->expr
= resbound
;
2165 se
->expr
= resbound
;
2167 type
= gfc_typenode_for_spec (&expr
->ts
);
2168 se
->expr
= convert (type
, se
->expr
);
2173 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2175 gfc_actual_arglist
*array_arg
;
2176 gfc_actual_arglist
*dim_arg
;
2180 array_arg
= expr
->value
.function
.actual
;
2181 dim_arg
= array_arg
->next
;
2183 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2185 gfc_init_se (&argse
, NULL
);
2186 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2187 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2188 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2191 gcc_assert (dim_arg
->expr
);
2192 gfc_init_se (&argse
, NULL
);
2193 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2194 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2195 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2196 argse
.expr
, gfc_index_one_node
);
2197 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2202 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2206 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2208 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
2212 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
2217 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
2218 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
2227 /* Create a complex value from one or two real components. */
2230 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
2236 unsigned int num_args
;
2238 num_args
= gfc_intrinsic_argument_list_length (expr
);
2239 args
= XALLOCAVEC (tree
, num_args
);
2241 type
= gfc_typenode_for_spec (&expr
->ts
);
2242 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2243 real
= convert (TREE_TYPE (type
), args
[0]);
2245 imag
= convert (TREE_TYPE (type
), args
[1]);
2246 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
2248 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2249 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
2250 imag
= convert (TREE_TYPE (type
), imag
);
2253 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
2255 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
2259 /* Remainder function MOD(A, P) = A - INT(A / P) * P
2260 MODULO(A, P) = A - FLOOR (A / P) * P
2262 The obvious algorithms above are numerically instable for large
2263 arguments, hence these intrinsics are instead implemented via calls
2264 to the fmod family of functions. It is the responsibility of the
2265 user to ensure that the second argument is non-zero. */
2268 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
2278 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2280 switch (expr
->ts
.type
)
2283 /* Integer case is easy, we've got a builtin op. */
2284 type
= TREE_TYPE (args
[0]);
2287 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
2290 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
2296 /* Check if we have a builtin fmod. */
2297 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
2299 /* The builtin should always be available. */
2300 gcc_assert (fmod
!= NULL_TREE
);
2302 tmp
= build_addr (fmod
, current_function_decl
);
2303 se
->expr
= build_call_array_loc (input_location
,
2304 TREE_TYPE (TREE_TYPE (fmod
)),
2309 type
= TREE_TYPE (args
[0]);
2311 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2312 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
2315 modulo = arg - floor (arg/arg2) * arg2
2317 In order to calculate the result accurately, we use the fmod
2318 function as follows.
2320 res = fmod (arg, arg2);
2323 if ((arg < 0) xor (arg2 < 0))
2327 res = copysign (0., arg2);
2329 => As two nested ternary exprs:
2331 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2332 : copysign (0., arg2);
2336 zero
= gfc_build_const (type
, integer_zero_node
);
2337 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2338 if (!flag_signed_zeros
)
2340 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2342 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2344 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2345 boolean_type_node
, test
, test2
);
2346 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2348 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2349 boolean_type_node
, test
, test2
);
2350 test
= gfc_evaluate_now (test
, &se
->pre
);
2351 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2352 fold_build2_loc (input_location
,
2354 type
, tmp
, args
[1]),
2359 tree expr1
, copysign
, cscall
;
2360 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
2362 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2364 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2366 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2367 boolean_type_node
, test
, test2
);
2368 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
2369 fold_build2_loc (input_location
,
2371 type
, tmp
, args
[1]),
2373 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2375 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
2377 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2387 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2388 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2389 where the right shifts are logical (i.e. 0's are shifted in).
2390 Because SHIFT_EXPR's want shifts strictly smaller than the integral
2391 type width, we have to special-case both S == 0 and S == BITSIZE(J):
2393 DSHIFTL(I,J,BITSIZE) = J
2395 DSHIFTR(I,J,BITSIZE) = I. */
2398 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
2400 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
2401 tree args
[3], cond
, tmp
;
2404 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2406 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
2407 type
= TREE_TYPE (args
[0]);
2408 bitsize
= TYPE_PRECISION (type
);
2409 utype
= unsigned_type_for (type
);
2410 stype
= TREE_TYPE (args
[2]);
2412 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
2413 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
2414 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
2416 /* The generic case. */
2417 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
2418 build_int_cst (stype
, bitsize
), shift
);
2419 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
2420 arg1
, dshiftl
? shift
: tmp
);
2422 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
2423 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
2424 right
= fold_convert (type
, right
);
2426 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
2428 /* Special cases. */
2429 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2430 build_int_cst (stype
, 0));
2431 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2432 dshiftl
? arg1
: arg2
, res
);
2434 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2435 build_int_cst (stype
, bitsize
));
2436 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2437 dshiftl
? arg2
: arg1
, res
);
2443 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
2446 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
2454 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2455 type
= TREE_TYPE (args
[0]);
2457 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
2458 val
= gfc_evaluate_now (val
, &se
->pre
);
2460 zero
= gfc_build_const (type
, integer_zero_node
);
2461 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
2462 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
2466 /* SIGN(A, B) is absolute value of A times sign of B.
2467 The real value versions use library functions to ensure the correct
2468 handling of negative zero. Integer case implemented as:
2469 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
2473 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
2479 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2480 if (expr
->ts
.type
== BT_REAL
)
2484 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
2485 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
2487 /* We explicitly have to ignore the minus sign. We do so by using
2488 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
2490 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
2493 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
2494 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2496 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2497 TREE_TYPE (args
[0]), cond
,
2498 build_call_expr_loc (input_location
, abs
, 1,
2500 build_call_expr_loc (input_location
, tmp
, 2,
2504 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
2509 /* Having excluded floating point types, we know we are now dealing
2510 with signed integer types. */
2511 type
= TREE_TYPE (args
[0]);
2513 /* Args[0] is used multiple times below. */
2514 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2516 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2517 the signs of A and B are the same, and of all ones if they differ. */
2518 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2519 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2520 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2521 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2523 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2524 is all ones (i.e. -1). */
2525 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2526 fold_build2_loc (input_location
, PLUS_EXPR
,
2527 type
, args
[0], tmp
), tmp
);
2531 /* Test for the presence of an optional argument. */
2534 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2538 arg
= expr
->value
.function
.actual
->expr
;
2539 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2540 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2541 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2545 /* Calculate the double precision product of two single precision values. */
2548 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2553 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2555 /* Convert the args to double precision before multiplying. */
2556 type
= gfc_typenode_for_spec (&expr
->ts
);
2557 args
[0] = convert (type
, args
[0]);
2558 args
[1] = convert (type
, args
[1]);
2559 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2564 /* Return a length one character string containing an ascii character. */
2567 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2572 unsigned int num_args
;
2574 num_args
= gfc_intrinsic_argument_list_length (expr
);
2575 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2577 type
= gfc_get_char_type (expr
->ts
.kind
);
2578 var
= gfc_create_var (type
, "char");
2580 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2581 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2582 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2583 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2588 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2596 unsigned int num_args
;
2598 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2599 args
= XALLOCAVEC (tree
, num_args
);
2601 var
= gfc_create_var (pchar_type_node
, "pstr");
2602 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2604 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2605 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2606 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2608 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2609 tmp
= build_call_array_loc (input_location
,
2610 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2611 fndecl
, num_args
, args
);
2612 gfc_add_expr_to_block (&se
->pre
, tmp
);
2614 /* Free the temporary afterwards, if necessary. */
2615 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2616 len
, build_int_cst (TREE_TYPE (len
), 0));
2617 tmp
= gfc_call_free (var
);
2618 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2619 gfc_add_expr_to_block (&se
->post
, tmp
);
2622 se
->string_length
= len
;
2627 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2635 unsigned int num_args
;
2637 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2638 args
= XALLOCAVEC (tree
, num_args
);
2640 var
= gfc_create_var (pchar_type_node
, "pstr");
2641 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2643 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2644 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2645 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2647 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2648 tmp
= build_call_array_loc (input_location
,
2649 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2650 fndecl
, num_args
, args
);
2651 gfc_add_expr_to_block (&se
->pre
, tmp
);
2653 /* Free the temporary afterwards, if necessary. */
2654 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2655 len
, build_int_cst (TREE_TYPE (len
), 0));
2656 tmp
= gfc_call_free (var
);
2657 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2658 gfc_add_expr_to_block (&se
->post
, tmp
);
2661 se
->string_length
= len
;
2665 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
2669 conv_intrinsic_system_clock (gfc_code
*code
)
2672 gfc_se count_se
, count_rate_se
, count_max_se
;
2673 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
2677 gfc_expr
*count
= code
->ext
.actual
->expr
;
2678 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
2679 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
2681 /* The INTEGER(8) version has higher precision, it is used if both COUNT
2682 and COUNT_MAX can hold 64-bit values, or are absent. */
2683 if ((!count
|| count
->ts
.kind
>= 8)
2684 && (!count_max
|| count_max
->ts
.kind
>= 8))
2687 kind
= gfc_default_integer_kind
;
2688 type
= gfc_get_int_type (kind
);
2690 /* Evaluate our arguments. */
2693 gfc_init_se (&count_se
, NULL
);
2694 gfc_conv_expr (&count_se
, count
);
2699 gfc_init_se (&count_rate_se
, NULL
);
2700 gfc_conv_expr (&count_rate_se
, count_rate
);
2705 gfc_init_se (&count_max_se
, NULL
);
2706 gfc_conv_expr (&count_max_se
, count_max
);
2709 /* Prepare temporary variables if we need them. */
2710 if (count
&& count
->ts
.kind
!= kind
)
2711 arg1
= gfc_create_var (type
, "count");
2713 arg1
= count_se
.expr
;
2715 if (count_rate
&& (count_rate
->ts
.kind
!= kind
2716 || count_rate
->ts
.type
!= BT_INTEGER
))
2717 arg2
= gfc_create_var (type
, "count_rate");
2718 else if (count_rate
)
2719 arg2
= count_rate_se
.expr
;
2721 if (count_max
&& count_max
->ts
.kind
!= kind
)
2722 arg3
= gfc_create_var (type
, "count_max");
2724 arg3
= count_max_se
.expr
;
2726 /* Make the function call. */
2727 gfc_init_block (&block
);
2728 tmp
= build_call_expr_loc (input_location
,
2729 kind
== 4 ? gfor_fndecl_system_clock4
2730 : gfor_fndecl_system_clock8
,
2732 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2733 : null_pointer_node
,
2734 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2735 : null_pointer_node
,
2736 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2737 : null_pointer_node
);
2738 gfc_add_expr_to_block (&block
, tmp
);
2740 /* And store values back if needed. */
2741 if (arg1
&& arg1
!= count_se
.expr
)
2742 gfc_add_modify (&block
, count_se
.expr
,
2743 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
2744 if (arg2
&& arg2
!= count_rate_se
.expr
)
2745 gfc_add_modify (&block
, count_rate_se
.expr
,
2746 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
2747 if (arg3
&& arg3
!= count_max_se
.expr
)
2748 gfc_add_modify (&block
, count_max_se
.expr
,
2749 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
2751 return gfc_finish_block (&block
);
2755 /* Return a character string containing the tty name. */
2758 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2766 unsigned int num_args
;
2768 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2769 args
= XALLOCAVEC (tree
, num_args
);
2771 var
= gfc_create_var (pchar_type_node
, "pstr");
2772 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2774 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2775 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2776 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2778 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2779 tmp
= build_call_array_loc (input_location
,
2780 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2781 fndecl
, num_args
, args
);
2782 gfc_add_expr_to_block (&se
->pre
, tmp
);
2784 /* Free the temporary afterwards, if necessary. */
2785 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2786 len
, build_int_cst (TREE_TYPE (len
), 0));
2787 tmp
= gfc_call_free (var
);
2788 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2789 gfc_add_expr_to_block (&se
->post
, tmp
);
2792 se
->string_length
= len
;
2796 /* Get the minimum/maximum value of all the parameters.
2797 minmax (a1, a2, a3, ...)
2800 if (a2 .op. mvar || isnan (mvar))
2802 if (a3 .op. mvar || isnan (mvar))
2809 /* TODO: Mismatching types can occur when specific names are used.
2810 These should be handled during resolution. */
2812 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2820 gfc_actual_arglist
*argexpr
;
2821 unsigned int i
, nargs
;
2823 nargs
= gfc_intrinsic_argument_list_length (expr
);
2824 args
= XALLOCAVEC (tree
, nargs
);
2826 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2827 type
= gfc_typenode_for_spec (&expr
->ts
);
2829 argexpr
= expr
->value
.function
.actual
;
2830 if (TREE_TYPE (args
[0]) != type
)
2831 args
[0] = convert (type
, args
[0]);
2832 /* Only evaluate the argument once. */
2833 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2834 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2836 mvar
= gfc_create_var (type
, "M");
2837 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2838 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2844 /* Handle absent optional arguments by ignoring the comparison. */
2845 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2846 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2847 && TREE_CODE (val
) == INDIRECT_REF
)
2848 cond
= fold_build2_loc (input_location
,
2849 NE_EXPR
, boolean_type_node
,
2850 TREE_OPERAND (val
, 0),
2851 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2856 /* Only evaluate the argument once. */
2857 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2858 val
= gfc_evaluate_now (val
, &se
->pre
);
2861 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2863 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2864 convert (type
, val
), mvar
);
2866 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2867 __builtin_isnan might be made dependent on that module being loaded,
2868 to help performance of programs that don't rely on IEEE semantics. */
2869 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2871 isnan
= build_call_expr_loc (input_location
,
2872 builtin_decl_explicit (BUILT_IN_ISNAN
),
2874 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2875 boolean_type_node
, tmp
,
2876 fold_convert (boolean_type_node
, isnan
));
2878 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2879 build_empty_stmt (input_location
));
2881 if (cond
!= NULL_TREE
)
2882 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2883 build_empty_stmt (input_location
));
2885 gfc_add_expr_to_block (&se
->pre
, tmp
);
2886 argexpr
= argexpr
->next
;
2892 /* Generate library calls for MIN and MAX intrinsics for character
2895 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2898 tree var
, len
, fndecl
, tmp
, cond
, function
;
2901 nargs
= gfc_intrinsic_argument_list_length (expr
);
2902 args
= XALLOCAVEC (tree
, nargs
+ 4);
2903 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2905 /* Create the result variables. */
2906 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2907 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2908 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2909 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2910 args
[2] = build_int_cst (integer_type_node
, op
);
2911 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2913 if (expr
->ts
.kind
== 1)
2914 function
= gfor_fndecl_string_minmax
;
2915 else if (expr
->ts
.kind
== 4)
2916 function
= gfor_fndecl_string_minmax_char4
;
2920 /* Make the function call. */
2921 fndecl
= build_addr (function
, current_function_decl
);
2922 tmp
= build_call_array_loc (input_location
,
2923 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2925 gfc_add_expr_to_block (&se
->pre
, tmp
);
2927 /* Free the temporary afterwards, if necessary. */
2928 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2929 len
, build_int_cst (TREE_TYPE (len
), 0));
2930 tmp
= gfc_call_free (var
);
2931 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2932 gfc_add_expr_to_block (&se
->post
, tmp
);
2935 se
->string_length
= len
;
2939 /* Create a symbol node for this intrinsic. The symbol from the frontend
2940 has the generic name. */
2943 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
2947 /* TODO: Add symbols for intrinsic function to the global namespace. */
2948 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2949 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2952 sym
->attr
.external
= 1;
2953 sym
->attr
.function
= 1;
2954 sym
->attr
.always_explicit
= 1;
2955 sym
->attr
.proc
= PROC_INTRINSIC
;
2956 sym
->attr
.flavor
= FL_PROCEDURE
;
2960 sym
->attr
.dimension
= 1;
2961 sym
->as
= gfc_get_array_spec ();
2962 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2963 sym
->as
->rank
= expr
->rank
;
2966 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
2967 ignore_optional
? expr
->value
.function
.actual
2973 /* Generate a call to an external intrinsic function. */
2975 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2978 vec
<tree
, va_gc
> *append_args
;
2980 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2983 gcc_assert (expr
->rank
> 0);
2985 gcc_assert (expr
->rank
== 0);
2987 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
2989 /* Calls to libgfortran_matmul need to be appended special arguments,
2990 to be able to call the BLAS ?gemm functions if required and possible. */
2992 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2993 && sym
->ts
.type
!= BT_LOGICAL
)
2995 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2997 if (flag_external_blas
2998 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2999 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
3003 if (sym
->ts
.type
== BT_REAL
)
3005 if (sym
->ts
.kind
== 4)
3006 gemm_fndecl
= gfor_fndecl_sgemm
;
3008 gemm_fndecl
= gfor_fndecl_dgemm
;
3012 if (sym
->ts
.kind
== 4)
3013 gemm_fndecl
= gfor_fndecl_cgemm
;
3015 gemm_fndecl
= gfor_fndecl_zgemm
;
3018 vec_alloc (append_args
, 3);
3019 append_args
->quick_push (build_int_cst (cint
, 1));
3020 append_args
->quick_push (build_int_cst (cint
,
3021 flag_blas_matmul_limit
));
3022 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3027 vec_alloc (append_args
, 3);
3028 append_args
->quick_push (build_int_cst (cint
, 0));
3029 append_args
->quick_push (build_int_cst (cint
, 0));
3030 append_args
->quick_push (null_pointer_node
);
3034 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3036 gfc_free_symbol (sym
);
3039 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3059 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3068 gfc_actual_arglist
*actual
;
3075 gfc_conv_intrinsic_funcall (se
, expr
);
3079 actual
= expr
->value
.function
.actual
;
3080 type
= gfc_typenode_for_spec (&expr
->ts
);
3081 /* Initialize the result. */
3082 resvar
= gfc_create_var (type
, "test");
3084 tmp
= convert (type
, boolean_true_node
);
3086 tmp
= convert (type
, boolean_false_node
);
3087 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3089 /* Walk the arguments. */
3090 arrayss
= gfc_walk_expr (actual
->expr
);
3091 gcc_assert (arrayss
!= gfc_ss_terminator
);
3093 /* Initialize the scalarizer. */
3094 gfc_init_loopinfo (&loop
);
3095 exit_label
= gfc_build_label_decl (NULL_TREE
);
3096 TREE_USED (exit_label
) = 1;
3097 gfc_add_ss_to_loop (&loop
, arrayss
);
3099 /* Initialize the loop. */
3100 gfc_conv_ss_startstride (&loop
);
3101 gfc_conv_loop_setup (&loop
, &expr
->where
);
3103 gfc_mark_ss_chain_used (arrayss
, 1);
3104 /* Generate the loop body. */
3105 gfc_start_scalarized_body (&loop
, &body
);
3107 /* If the condition matches then set the return value. */
3108 gfc_start_block (&block
);
3110 tmp
= convert (type
, boolean_false_node
);
3112 tmp
= convert (type
, boolean_true_node
);
3113 gfc_add_modify (&block
, resvar
, tmp
);
3115 /* And break out of the loop. */
3116 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3117 gfc_add_expr_to_block (&block
, tmp
);
3119 found
= gfc_finish_block (&block
);
3121 /* Check this element. */
3122 gfc_init_se (&arrayse
, NULL
);
3123 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3124 arrayse
.ss
= arrayss
;
3125 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3127 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3128 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3129 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3130 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3131 gfc_add_expr_to_block (&body
, tmp
);
3132 gfc_add_block_to_block (&body
, &arrayse
.post
);
3134 gfc_trans_scalarizing_loops (&loop
, &body
);
3136 /* Add the exit label. */
3137 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3138 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3140 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3141 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3142 gfc_cleanup_loop (&loop
);
3147 /* COUNT(A) = Number of true elements in A. */
3149 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
3156 gfc_actual_arglist
*actual
;
3162 gfc_conv_intrinsic_funcall (se
, expr
);
3166 actual
= expr
->value
.function
.actual
;
3168 type
= gfc_typenode_for_spec (&expr
->ts
);
3169 /* Initialize the result. */
3170 resvar
= gfc_create_var (type
, "count");
3171 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
3173 /* Walk the arguments. */
3174 arrayss
= gfc_walk_expr (actual
->expr
);
3175 gcc_assert (arrayss
!= gfc_ss_terminator
);
3177 /* Initialize the scalarizer. */
3178 gfc_init_loopinfo (&loop
);
3179 gfc_add_ss_to_loop (&loop
, arrayss
);
3181 /* Initialize the loop. */
3182 gfc_conv_ss_startstride (&loop
);
3183 gfc_conv_loop_setup (&loop
, &expr
->where
);
3185 gfc_mark_ss_chain_used (arrayss
, 1);
3186 /* Generate the loop body. */
3187 gfc_start_scalarized_body (&loop
, &body
);
3189 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
3190 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
3191 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
3193 gfc_init_se (&arrayse
, NULL
);
3194 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3195 arrayse
.ss
= arrayss
;
3196 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3197 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
3198 build_empty_stmt (input_location
));
3200 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3201 gfc_add_expr_to_block (&body
, tmp
);
3202 gfc_add_block_to_block (&body
, &arrayse
.post
);
3204 gfc_trans_scalarizing_loops (&loop
, &body
);
3206 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3207 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3208 gfc_cleanup_loop (&loop
);
3214 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
3215 struct and return the corresponding loopinfo. */
3217 static gfc_loopinfo
*
3218 enter_nested_loop (gfc_se
*se
)
3220 se
->ss
= se
->ss
->nested_ss
;
3221 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
3223 return se
->ss
->loop
;
3227 /* Inline implementation of the sum and product intrinsics. */
3229 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
3233 tree scale
= NULL_TREE
;
3238 gfc_loopinfo loop
, *ploop
;
3239 gfc_actual_arglist
*arg_array
, *arg_mask
;
3240 gfc_ss
*arrayss
= NULL
;
3241 gfc_ss
*maskss
= NULL
;
3245 gfc_expr
*arrayexpr
;
3250 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
3256 type
= gfc_typenode_for_spec (&expr
->ts
);
3257 /* Initialize the result. */
3258 resvar
= gfc_create_var (type
, "val");
3263 scale
= gfc_create_var (type
, "scale");
3264 gfc_add_modify (&se
->pre
, scale
,
3265 gfc_build_const (type
, integer_one_node
));
3266 tmp
= gfc_build_const (type
, integer_zero_node
);
3268 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
3269 tmp
= gfc_build_const (type
, integer_zero_node
);
3270 else if (op
== NE_EXPR
)
3272 tmp
= convert (type
, boolean_false_node
);
3273 else if (op
== BIT_AND_EXPR
)
3274 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
3275 type
, integer_one_node
));
3277 tmp
= gfc_build_const (type
, integer_one_node
);
3279 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3281 arg_array
= expr
->value
.function
.actual
;
3283 arrayexpr
= arg_array
->expr
;
3285 if (op
== NE_EXPR
|| norm2
)
3286 /* PARITY and NORM2. */
3290 arg_mask
= arg_array
->next
->next
;
3291 gcc_assert (arg_mask
!= NULL
);
3292 maskexpr
= arg_mask
->expr
;
3295 if (expr
->rank
== 0)
3297 /* Walk the arguments. */
3298 arrayss
= gfc_walk_expr (arrayexpr
);
3299 gcc_assert (arrayss
!= gfc_ss_terminator
);
3301 if (maskexpr
&& maskexpr
->rank
> 0)
3303 maskss
= gfc_walk_expr (maskexpr
);
3304 gcc_assert (maskss
!= gfc_ss_terminator
);
3309 /* Initialize the scalarizer. */
3310 gfc_init_loopinfo (&loop
);
3311 gfc_add_ss_to_loop (&loop
, arrayss
);
3312 if (maskexpr
&& maskexpr
->rank
> 0)
3313 gfc_add_ss_to_loop (&loop
, maskss
);
3315 /* Initialize the loop. */
3316 gfc_conv_ss_startstride (&loop
);
3317 gfc_conv_loop_setup (&loop
, &expr
->where
);
3319 gfc_mark_ss_chain_used (arrayss
, 1);
3320 if (maskexpr
&& maskexpr
->rank
> 0)
3321 gfc_mark_ss_chain_used (maskss
, 1);
3326 /* All the work has been done in the parent loops. */
3327 ploop
= enter_nested_loop (se
);
3331 /* Generate the loop body. */
3332 gfc_start_scalarized_body (ploop
, &body
);
3334 /* If we have a mask, only add this element if the mask is set. */
3335 if (maskexpr
&& maskexpr
->rank
> 0)
3337 gfc_init_se (&maskse
, parent_se
);
3338 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
3339 if (expr
->rank
== 0)
3341 gfc_conv_expr_val (&maskse
, maskexpr
);
3342 gfc_add_block_to_block (&body
, &maskse
.pre
);
3344 gfc_start_block (&block
);
3347 gfc_init_block (&block
);
3349 /* Do the actual summation/product. */
3350 gfc_init_se (&arrayse
, parent_se
);
3351 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
3352 if (expr
->rank
== 0)
3353 arrayse
.ss
= arrayss
;
3354 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3355 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3359 /* if (x (i) != 0.0)
3365 result = 1.0 + result * val * val;
3371 result += val * val;
3374 tree res1
, res2
, cond
, absX
, val
;
3375 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
3377 gfc_init_block (&ifblock1
);
3379 absX
= gfc_create_var (type
, "absX");
3380 gfc_add_modify (&ifblock1
, absX
,
3381 fold_build1_loc (input_location
, ABS_EXPR
, type
,
3383 val
= gfc_create_var (type
, "val");
3384 gfc_add_expr_to_block (&ifblock1
, val
);
3386 gfc_init_block (&ifblock2
);
3387 gfc_add_modify (&ifblock2
, val
,
3388 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
3390 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3391 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
3392 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
3393 gfc_build_const (type
, integer_one_node
));
3394 gfc_add_modify (&ifblock2
, resvar
, res1
);
3395 gfc_add_modify (&ifblock2
, scale
, absX
);
3396 res1
= gfc_finish_block (&ifblock2
);
3398 gfc_init_block (&ifblock3
);
3399 gfc_add_modify (&ifblock3
, val
,
3400 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
3402 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3403 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
3404 gfc_add_modify (&ifblock3
, resvar
, res2
);
3405 res2
= gfc_finish_block (&ifblock3
);
3407 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3409 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
3410 gfc_add_expr_to_block (&ifblock1
, tmp
);
3411 tmp
= gfc_finish_block (&ifblock1
);
3413 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3415 gfc_build_const (type
, integer_zero_node
));
3417 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3418 gfc_add_expr_to_block (&block
, tmp
);
3422 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
3423 gfc_add_modify (&block
, resvar
, tmp
);
3426 gfc_add_block_to_block (&block
, &arrayse
.post
);
3428 if (maskexpr
&& maskexpr
->rank
> 0)
3430 /* We enclose the above in if (mask) {...} . */
3432 tmp
= gfc_finish_block (&block
);
3433 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3434 build_empty_stmt (input_location
));
3437 tmp
= gfc_finish_block (&block
);
3438 gfc_add_expr_to_block (&body
, tmp
);
3440 gfc_trans_scalarizing_loops (ploop
, &body
);
3442 /* For a scalar mask, enclose the loop in an if statement. */
3443 if (maskexpr
&& maskexpr
->rank
== 0)
3445 gfc_init_block (&block
);
3446 gfc_add_block_to_block (&block
, &ploop
->pre
);
3447 gfc_add_block_to_block (&block
, &ploop
->post
);
3448 tmp
= gfc_finish_block (&block
);
3452 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
3453 build_empty_stmt (input_location
));
3454 gfc_advance_se_ss_chain (se
);
3458 gcc_assert (expr
->rank
== 0);
3459 gfc_init_se (&maskse
, NULL
);
3460 gfc_conv_expr_val (&maskse
, maskexpr
);
3461 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3462 build_empty_stmt (input_location
));
3465 gfc_add_expr_to_block (&block
, tmp
);
3466 gfc_add_block_to_block (&se
->pre
, &block
);
3467 gcc_assert (se
->post
.head
== NULL
);
3471 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
3472 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
3475 if (expr
->rank
== 0)
3476 gfc_cleanup_loop (ploop
);
3480 /* result = scale * sqrt(result). */
3482 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
3483 resvar
= build_call_expr_loc (input_location
,
3485 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
3492 /* Inline implementation of the dot_product intrinsic. This function
3493 is based on gfc_conv_intrinsic_arith (the previous function). */
3495 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
3503 gfc_actual_arglist
*actual
;
3504 gfc_ss
*arrayss1
, *arrayss2
;
3505 gfc_se arrayse1
, arrayse2
;
3506 gfc_expr
*arrayexpr1
, *arrayexpr2
;
3508 type
= gfc_typenode_for_spec (&expr
->ts
);
3510 /* Initialize the result. */
3511 resvar
= gfc_create_var (type
, "val");
3512 if (expr
->ts
.type
== BT_LOGICAL
)
3513 tmp
= build_int_cst (type
, 0);
3515 tmp
= gfc_build_const (type
, integer_zero_node
);
3517 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3519 /* Walk argument #1. */
3520 actual
= expr
->value
.function
.actual
;
3521 arrayexpr1
= actual
->expr
;
3522 arrayss1
= gfc_walk_expr (arrayexpr1
);
3523 gcc_assert (arrayss1
!= gfc_ss_terminator
);
3525 /* Walk argument #2. */
3526 actual
= actual
->next
;
3527 arrayexpr2
= actual
->expr
;
3528 arrayss2
= gfc_walk_expr (arrayexpr2
);
3529 gcc_assert (arrayss2
!= gfc_ss_terminator
);
3531 /* Initialize the scalarizer. */
3532 gfc_init_loopinfo (&loop
);
3533 gfc_add_ss_to_loop (&loop
, arrayss1
);
3534 gfc_add_ss_to_loop (&loop
, arrayss2
);
3536 /* Initialize the loop. */
3537 gfc_conv_ss_startstride (&loop
);
3538 gfc_conv_loop_setup (&loop
, &expr
->where
);
3540 gfc_mark_ss_chain_used (arrayss1
, 1);
3541 gfc_mark_ss_chain_used (arrayss2
, 1);
3543 /* Generate the loop body. */
3544 gfc_start_scalarized_body (&loop
, &body
);
3545 gfc_init_block (&block
);
3547 /* Make the tree expression for [conjg(]array1[)]. */
3548 gfc_init_se (&arrayse1
, NULL
);
3549 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
3550 arrayse1
.ss
= arrayss1
;
3551 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
3552 if (expr
->ts
.type
== BT_COMPLEX
)
3553 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
3555 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
3557 /* Make the tree expression for array2. */
3558 gfc_init_se (&arrayse2
, NULL
);
3559 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
3560 arrayse2
.ss
= arrayss2
;
3561 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
3562 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
3564 /* Do the actual product and sum. */
3565 if (expr
->ts
.type
== BT_LOGICAL
)
3567 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
3568 arrayse1
.expr
, arrayse2
.expr
);
3569 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
3573 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
3575 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
3577 gfc_add_modify (&block
, resvar
, tmp
);
3579 /* Finish up the loop block and the loop. */
3580 tmp
= gfc_finish_block (&block
);
3581 gfc_add_expr_to_block (&body
, tmp
);
3583 gfc_trans_scalarizing_loops (&loop
, &body
);
3584 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3585 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3586 gfc_cleanup_loop (&loop
);
3592 /* Emit code for minloc or maxloc intrinsic. There are many different cases
3593 we need to handle. For performance reasons we sometimes create two
3594 loops instead of one, where the second one is much simpler.
3595 Examples for minloc intrinsic:
3596 1) Result is an array, a call is generated
3597 2) Array mask is used and NaNs need to be supported:
3603 if (pos == 0) pos = S + (1 - from);
3604 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3611 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3615 3) NaNs need to be supported, but it is known at compile time or cheaply
3616 at runtime whether array is nonempty or not:
3621 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3624 if (from <= to) pos = 1;
3628 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3632 4) NaNs aren't supported, array mask is used:
3633 limit = infinities_supported ? Infinity : huge (limit);
3637 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3643 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3647 5) Same without array mask:
3648 limit = infinities_supported ? Infinity : huge (limit);
3649 pos = (from <= to) ? 1 : 0;
3652 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3655 For 3) and 5), if mask is scalar, this all goes into a conditional,
3656 setting pos = 0; in the else branch. */
3659 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3663 stmtblock_t ifblock
;
3664 stmtblock_t elseblock
;
3675 gfc_actual_arglist
*actual
;
3680 gfc_expr
*arrayexpr
;
3687 gfc_conv_intrinsic_funcall (se
, expr
);
3691 /* Initialize the result. */
3692 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3693 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3694 type
= gfc_typenode_for_spec (&expr
->ts
);
3696 /* Walk the arguments. */
3697 actual
= expr
->value
.function
.actual
;
3698 arrayexpr
= actual
->expr
;
3699 arrayss
= gfc_walk_expr (arrayexpr
);
3700 gcc_assert (arrayss
!= gfc_ss_terminator
);
3702 actual
= actual
->next
->next
;
3703 gcc_assert (actual
);
3704 maskexpr
= actual
->expr
;
3706 if (maskexpr
&& maskexpr
->rank
!= 0)
3708 maskss
= gfc_walk_expr (maskexpr
);
3709 gcc_assert (maskss
!= gfc_ss_terminator
);
3714 if (gfc_array_size (arrayexpr
, &asize
))
3716 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3718 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3719 boolean_type_node
, nonempty
,
3720 gfc_index_zero_node
);
3725 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3726 switch (arrayexpr
->ts
.type
)
3729 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3733 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3734 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3735 arrayexpr
->ts
.kind
);
3742 /* We start with the most negative possible value for MAXLOC, and the most
3743 positive possible value for MINLOC. The most negative possible value is
3744 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3745 possible value is HUGE in both cases. */
3747 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3748 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
3749 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3750 build_int_cst (TREE_TYPE (tmp
), 1));
3752 gfc_add_modify (&se
->pre
, limit
, tmp
);
3754 /* Initialize the scalarizer. */
3755 gfc_init_loopinfo (&loop
);
3756 gfc_add_ss_to_loop (&loop
, arrayss
);
3758 gfc_add_ss_to_loop (&loop
, maskss
);
3760 /* Initialize the loop. */
3761 gfc_conv_ss_startstride (&loop
);
3763 /* The code generated can have more than one loop in sequence (see the
3764 comment at the function header). This doesn't work well with the
3765 scalarizer, which changes arrays' offset when the scalarization loops
3766 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3767 are currently inlined in the scalar case only (for which loop is of rank
3768 one). As there is no dependency to care about in that case, there is no
3769 temporary, so that we can use the scalarizer temporary code to handle
3770 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3771 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3773 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3774 should eventually go away. We could either create two loops properly,
3775 or find another way to save/restore the array offsets between the two
3776 loops (without conflicting with temporary management), or use a single
3777 loop minmaxloc implementation. See PR 31067. */
3778 loop
.temp_dim
= loop
.dimen
;
3779 gfc_conv_loop_setup (&loop
, &expr
->where
);
3781 gcc_assert (loop
.dimen
== 1);
3782 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3783 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3784 loop
.from
[0], loop
.to
[0]);
3788 /* Initialize the position to zero, following Fortran 2003. We are free
3789 to do this because Fortran 95 allows the result of an entirely false
3790 mask to be processor dependent. If we know at compile time the array
3791 is non-empty and no MASK is used, we can initialize to 1 to simplify
3793 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3794 gfc_add_modify (&loop
.pre
, pos
,
3795 fold_build3_loc (input_location
, COND_EXPR
,
3796 gfc_array_index_type
,
3797 nonempty
, gfc_index_one_node
,
3798 gfc_index_zero_node
));
3801 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3802 lab1
= gfc_build_label_decl (NULL_TREE
);
3803 TREE_USED (lab1
) = 1;
3804 lab2
= gfc_build_label_decl (NULL_TREE
);
3805 TREE_USED (lab2
) = 1;
3808 /* An offset must be added to the loop
3809 counter to obtain the required position. */
3810 gcc_assert (loop
.from
[0]);
3812 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3813 gfc_index_one_node
, loop
.from
[0]);
3814 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3816 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3818 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3819 /* Generate the loop body. */
3820 gfc_start_scalarized_body (&loop
, &body
);
3822 /* If we have a mask, only check this element if the mask is set. */
3825 gfc_init_se (&maskse
, NULL
);
3826 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3828 gfc_conv_expr_val (&maskse
, maskexpr
);
3829 gfc_add_block_to_block (&body
, &maskse
.pre
);
3831 gfc_start_block (&block
);
3834 gfc_init_block (&block
);
3836 /* Compare with the current limit. */
3837 gfc_init_se (&arrayse
, NULL
);
3838 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3839 arrayse
.ss
= arrayss
;
3840 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3841 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3843 /* We do the following if this is a more extreme value. */
3844 gfc_start_block (&ifblock
);
3846 /* Assign the value to the limit... */
3847 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3849 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3851 stmtblock_t ifblock2
;
3854 gfc_start_block (&ifblock2
);
3855 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3856 loop
.loopvar
[0], offset
);
3857 gfc_add_modify (&ifblock2
, pos
, tmp
);
3858 ifbody2
= gfc_finish_block (&ifblock2
);
3859 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3860 gfc_index_zero_node
);
3861 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3862 build_empty_stmt (input_location
));
3863 gfc_add_expr_to_block (&block
, tmp
);
3866 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3867 loop
.loopvar
[0], offset
);
3868 gfc_add_modify (&ifblock
, pos
, tmp
);
3871 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3873 ifbody
= gfc_finish_block (&ifblock
);
3875 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3878 cond
= fold_build2_loc (input_location
,
3879 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3880 boolean_type_node
, arrayse
.expr
, limit
);
3882 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3883 arrayse
.expr
, limit
);
3885 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3886 build_empty_stmt (input_location
));
3888 gfc_add_expr_to_block (&block
, ifbody
);
3892 /* We enclose the above in if (mask) {...}. */
3893 tmp
= gfc_finish_block (&block
);
3895 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3896 build_empty_stmt (input_location
));
3899 tmp
= gfc_finish_block (&block
);
3900 gfc_add_expr_to_block (&body
, tmp
);
3904 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3906 if (HONOR_NANS (DECL_MODE (limit
)))
3908 if (nonempty
!= NULL
)
3910 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3911 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3912 build_empty_stmt (input_location
));
3913 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3917 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3918 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3920 /* If we have a mask, only check this element if the mask is set. */
3923 gfc_init_se (&maskse
, NULL
);
3924 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3926 gfc_conv_expr_val (&maskse
, maskexpr
);
3927 gfc_add_block_to_block (&body
, &maskse
.pre
);
3929 gfc_start_block (&block
);
3932 gfc_init_block (&block
);
3934 /* Compare with the current limit. */
3935 gfc_init_se (&arrayse
, NULL
);
3936 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3937 arrayse
.ss
= arrayss
;
3938 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3939 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3941 /* We do the following if this is a more extreme value. */
3942 gfc_start_block (&ifblock
);
3944 /* Assign the value to the limit... */
3945 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3947 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3948 loop
.loopvar
[0], offset
);
3949 gfc_add_modify (&ifblock
, pos
, tmp
);
3951 ifbody
= gfc_finish_block (&ifblock
);
3953 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3954 arrayse
.expr
, limit
);
3956 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3957 build_empty_stmt (input_location
));
3958 gfc_add_expr_to_block (&block
, tmp
);
3962 /* We enclose the above in if (mask) {...}. */
3963 tmp
= gfc_finish_block (&block
);
3965 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3966 build_empty_stmt (input_location
));
3969 tmp
= gfc_finish_block (&block
);
3970 gfc_add_expr_to_block (&body
, tmp
);
3971 /* Avoid initializing loopvar[0] again, it should be left where
3972 it finished by the first loop. */
3973 loop
.from
[0] = loop
.loopvar
[0];
3976 gfc_trans_scalarizing_loops (&loop
, &body
);
3979 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3981 /* For a scalar mask, enclose the loop in an if statement. */
3982 if (maskexpr
&& maskss
== NULL
)
3984 gfc_init_se (&maskse
, NULL
);
3985 gfc_conv_expr_val (&maskse
, maskexpr
);
3986 gfc_init_block (&block
);
3987 gfc_add_block_to_block (&block
, &loop
.pre
);
3988 gfc_add_block_to_block (&block
, &loop
.post
);
3989 tmp
= gfc_finish_block (&block
);
3991 /* For the else part of the scalar mask, just initialize
3992 the pos variable the same way as above. */
3994 gfc_init_block (&elseblock
);
3995 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3996 elsetmp
= gfc_finish_block (&elseblock
);
3998 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3999 gfc_add_expr_to_block (&block
, tmp
);
4000 gfc_add_block_to_block (&se
->pre
, &block
);
4004 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4005 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4007 gfc_cleanup_loop (&loop
);
4009 se
->expr
= convert (type
, pos
);
4012 /* Emit code for minval or maxval intrinsic. There are many different cases
4013 we need to handle. For performance reasons we sometimes create two
4014 loops instead of one, where the second one is much simpler.
4015 Examples for minval intrinsic:
4016 1) Result is an array, a call is generated
4017 2) Array mask is used and NaNs need to be supported, rank 1:
4022 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4025 limit = nonempty ? NaN : huge (limit);
4027 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4028 3) NaNs need to be supported, but it is known at compile time or cheaply
4029 at runtime whether array is nonempty or not, rank 1:
4032 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4033 limit = (from <= to) ? NaN : huge (limit);
4035 while (S <= to) { limit = min (a[S], limit); S++; }
4036 4) Array mask is used and NaNs need to be supported, rank > 1:
4045 if (fast) limit = min (a[S1][S2], limit);
4048 if (a[S1][S2] <= limit) {
4059 limit = nonempty ? NaN : huge (limit);
4060 5) NaNs need to be supported, but it is known at compile time or cheaply
4061 at runtime whether array is nonempty or not, rank > 1:
4068 if (fast) limit = min (a[S1][S2], limit);
4070 if (a[S1][S2] <= limit) {
4080 limit = (nonempty_array) ? NaN : huge (limit);
4081 6) NaNs aren't supported, but infinities are. Array mask is used:
4086 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4089 limit = nonempty ? limit : huge (limit);
4090 7) Same without array mask:
4093 while (S <= to) { limit = min (a[S], limit); S++; }
4094 limit = (from <= to) ? limit : huge (limit);
4095 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4096 limit = huge (limit);
4098 while (S <= to) { limit = min (a[S], limit); S++); }
4100 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4101 with array mask instead).
4102 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4103 setting limit = huge (limit); in the else branch. */
4106 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4116 tree huge_cst
= NULL
, nan_cst
= NULL
;
4118 stmtblock_t block
, block2
;
4120 gfc_actual_arglist
*actual
;
4125 gfc_expr
*arrayexpr
;
4131 gfc_conv_intrinsic_funcall (se
, expr
);
4135 type
= gfc_typenode_for_spec (&expr
->ts
);
4136 /* Initialize the result. */
4137 limit
= gfc_create_var (type
, "limit");
4138 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
4139 switch (expr
->ts
.type
)
4142 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
4144 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4146 REAL_VALUE_TYPE real
;
4148 tmp
= build_real (type
, real
);
4152 if (HONOR_NANS (DECL_MODE (limit
)))
4153 nan_cst
= gfc_build_nan (type
, "");
4157 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
4164 /* We start with the most negative possible value for MAXVAL, and the most
4165 positive possible value for MINVAL. The most negative possible value is
4166 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4167 possible value is HUGE in both cases. */
4170 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4172 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
4173 TREE_TYPE (huge_cst
), huge_cst
);
4176 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
4177 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
4178 tmp
, build_int_cst (type
, 1));
4180 gfc_add_modify (&se
->pre
, limit
, tmp
);
4182 /* Walk the arguments. */
4183 actual
= expr
->value
.function
.actual
;
4184 arrayexpr
= actual
->expr
;
4185 arrayss
= gfc_walk_expr (arrayexpr
);
4186 gcc_assert (arrayss
!= gfc_ss_terminator
);
4188 actual
= actual
->next
->next
;
4189 gcc_assert (actual
);
4190 maskexpr
= actual
->expr
;
4192 if (maskexpr
&& maskexpr
->rank
!= 0)
4194 maskss
= gfc_walk_expr (maskexpr
);
4195 gcc_assert (maskss
!= gfc_ss_terminator
);
4200 if (gfc_array_size (arrayexpr
, &asize
))
4202 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4204 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4205 boolean_type_node
, nonempty
,
4206 gfc_index_zero_node
);
4211 /* Initialize the scalarizer. */
4212 gfc_init_loopinfo (&loop
);
4213 gfc_add_ss_to_loop (&loop
, arrayss
);
4215 gfc_add_ss_to_loop (&loop
, maskss
);
4217 /* Initialize the loop. */
4218 gfc_conv_ss_startstride (&loop
);
4220 /* The code generated can have more than one loop in sequence (see the
4221 comment at the function header). This doesn't work well with the
4222 scalarizer, which changes arrays' offset when the scalarization loops
4223 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
4224 are currently inlined in the scalar case only. As there is no dependency
4225 to care about in that case, there is no temporary, so that we can use the
4226 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
4227 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
4228 gfc_trans_scalarized_loop_boundary even later to restore offset.
4229 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
4230 should eventually go away. We could either create two loops properly,
4231 or find another way to save/restore the array offsets between the two
4232 loops (without conflicting with temporary management), or use a single
4233 loop minmaxval implementation. See PR 31067. */
4234 loop
.temp_dim
= loop
.dimen
;
4235 gfc_conv_loop_setup (&loop
, &expr
->where
);
4237 if (nonempty
== NULL
&& maskss
== NULL
4238 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
4239 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4240 loop
.from
[0], loop
.to
[0]);
4241 nonempty_var
= NULL
;
4242 if (nonempty
== NULL
4243 && (HONOR_INFINITIES (DECL_MODE (limit
))
4244 || HONOR_NANS (DECL_MODE (limit
))))
4246 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
4247 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
4248 nonempty
= nonempty_var
;
4252 if (HONOR_NANS (DECL_MODE (limit
)))
4254 if (loop
.dimen
== 1)
4256 lab
= gfc_build_label_decl (NULL_TREE
);
4257 TREE_USED (lab
) = 1;
4261 fast
= gfc_create_var (boolean_type_node
, "fast");
4262 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
4266 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
4268 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
4269 /* Generate the loop body. */
4270 gfc_start_scalarized_body (&loop
, &body
);
4272 /* If we have a mask, only add this element if the mask is set. */
4275 gfc_init_se (&maskse
, NULL
);
4276 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4278 gfc_conv_expr_val (&maskse
, maskexpr
);
4279 gfc_add_block_to_block (&body
, &maskse
.pre
);
4281 gfc_start_block (&block
);
4284 gfc_init_block (&block
);
4286 /* Compare with the current limit. */
4287 gfc_init_se (&arrayse
, NULL
);
4288 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4289 arrayse
.ss
= arrayss
;
4290 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4291 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4293 gfc_init_block (&block2
);
4296 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
4298 if (HONOR_NANS (DECL_MODE (limit
)))
4300 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4301 boolean_type_node
, arrayse
.expr
, limit
);
4303 ifbody
= build1_v (GOTO_EXPR
, lab
);
4306 stmtblock_t ifblock
;
4308 gfc_init_block (&ifblock
);
4309 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4310 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
4311 ifbody
= gfc_finish_block (&ifblock
);
4313 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4314 build_empty_stmt (input_location
));
4315 gfc_add_expr_to_block (&block2
, tmp
);
4319 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4321 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4323 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4324 arrayse
.expr
, limit
);
4325 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4326 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4327 build_empty_stmt (input_location
));
4328 gfc_add_expr_to_block (&block2
, tmp
);
4332 tmp
= fold_build2_loc (input_location
,
4333 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4334 type
, arrayse
.expr
, limit
);
4335 gfc_add_modify (&block2
, limit
, tmp
);
4341 tree elsebody
= gfc_finish_block (&block2
);
4343 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4345 if (HONOR_NANS (DECL_MODE (limit
))
4346 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4348 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4349 arrayse
.expr
, limit
);
4350 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4351 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
4352 build_empty_stmt (input_location
));
4356 tmp
= fold_build2_loc (input_location
,
4357 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4358 type
, arrayse
.expr
, limit
);
4359 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4361 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
4362 gfc_add_expr_to_block (&block
, tmp
);
4365 gfc_add_block_to_block (&block
, &block2
);
4367 gfc_add_block_to_block (&block
, &arrayse
.post
);
4369 tmp
= gfc_finish_block (&block
);
4371 /* We enclose the above in if (mask) {...}. */
4372 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4373 build_empty_stmt (input_location
));
4374 gfc_add_expr_to_block (&body
, tmp
);
4378 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4380 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4382 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
4383 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
4385 /* If we have a mask, only add this element if the mask is set. */
4388 gfc_init_se (&maskse
, NULL
);
4389 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4391 gfc_conv_expr_val (&maskse
, maskexpr
);
4392 gfc_add_block_to_block (&body
, &maskse
.pre
);
4394 gfc_start_block (&block
);
4397 gfc_init_block (&block
);
4399 /* Compare with the current limit. */
4400 gfc_init_se (&arrayse
, NULL
);
4401 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4402 arrayse
.ss
= arrayss
;
4403 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4404 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4406 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4408 if (HONOR_NANS (DECL_MODE (limit
))
4409 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4411 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4412 arrayse
.expr
, limit
);
4413 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4414 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4415 build_empty_stmt (input_location
));
4416 gfc_add_expr_to_block (&block
, tmp
);
4420 tmp
= fold_build2_loc (input_location
,
4421 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4422 type
, arrayse
.expr
, limit
);
4423 gfc_add_modify (&block
, limit
, tmp
);
4426 gfc_add_block_to_block (&block
, &arrayse
.post
);
4428 tmp
= gfc_finish_block (&block
);
4430 /* We enclose the above in if (mask) {...}. */
4431 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4432 build_empty_stmt (input_location
));
4433 gfc_add_expr_to_block (&body
, tmp
);
4434 /* Avoid initializing loopvar[0] again, it should be left where
4435 it finished by the first loop. */
4436 loop
.from
[0] = loop
.loopvar
[0];
4438 gfc_trans_scalarizing_loops (&loop
, &body
);
4442 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4444 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4445 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
4447 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4449 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
4451 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
4453 gfc_add_modify (&loop
.pre
, limit
, tmp
);
4456 /* For a scalar mask, enclose the loop in an if statement. */
4457 if (maskexpr
&& maskss
== NULL
)
4461 gfc_init_se (&maskse
, NULL
);
4462 gfc_conv_expr_val (&maskse
, maskexpr
);
4463 gfc_init_block (&block
);
4464 gfc_add_block_to_block (&block
, &loop
.pre
);
4465 gfc_add_block_to_block (&block
, &loop
.post
);
4466 tmp
= gfc_finish_block (&block
);
4468 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4469 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
4471 else_stmt
= build_empty_stmt (input_location
);
4472 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
4473 gfc_add_expr_to_block (&block
, tmp
);
4474 gfc_add_block_to_block (&se
->pre
, &block
);
4478 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4479 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4482 gfc_cleanup_loop (&loop
);
4487 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
4489 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
4495 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4496 type
= TREE_TYPE (args
[0]);
4498 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4499 build_int_cst (type
, 1), args
[1]);
4500 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
4501 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
4502 build_int_cst (type
, 0));
4503 type
= gfc_typenode_for_spec (&expr
->ts
);
4504 se
->expr
= convert (type
, tmp
);
4508 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
4510 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4514 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4516 /* Convert both arguments to the unsigned type of the same size. */
4517 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
4518 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
4520 /* If they have unequal type size, convert to the larger one. */
4521 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
4522 > TYPE_PRECISION (TREE_TYPE (args
[1])))
4523 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
4524 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
4525 > TYPE_PRECISION (TREE_TYPE (args
[0])))
4526 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
4528 /* Now, we compare them. */
4529 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4534 /* Generate code to perform the specified operation. */
4536 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4540 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4541 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
4547 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
4551 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4552 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4553 TREE_TYPE (arg
), arg
);
4556 /* Set or clear a single bit. */
4558 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
4565 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4566 type
= TREE_TYPE (args
[0]);
4568 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4569 build_int_cst (type
, 1), args
[1]);
4575 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
4577 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
4580 /* Extract a sequence of bits.
4581 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
4583 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
4590 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4591 type
= TREE_TYPE (args
[0]);
4593 mask
= build_int_cst (type
, -1);
4594 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
4595 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
4597 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
4599 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4603 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4606 tree args
[2], type
, num_bits
, cond
;
4608 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4610 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4611 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4612 type
= TREE_TYPE (args
[0]);
4615 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4617 gcc_assert (right_shift
);
4619 se
->expr
= fold_build2_loc (input_location
,
4620 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4621 TREE_TYPE (args
[0]), args
[0], args
[1]);
4624 se
->expr
= fold_convert (type
, se
->expr
);
4626 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4627 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4629 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4630 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4633 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4634 build_int_cst (type
, 0), se
->expr
);
4637 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4639 : ((shift >= 0) ? i << shift : i >> -shift)
4640 where all shifts are logical shifts. */
4642 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4654 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4656 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4657 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4659 type
= TREE_TYPE (args
[0]);
4660 utype
= unsigned_type_for (type
);
4662 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4665 /* Left shift if positive. */
4666 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4668 /* Right shift if negative.
4669 We convert to an unsigned type because we want a logical shift.
4670 The standard doesn't define the case of shifting negative
4671 numbers, and we try to be compatible with other compilers, most
4672 notably g77, here. */
4673 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4674 utype
, convert (utype
, args
[0]), width
));
4676 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4677 build_int_cst (TREE_TYPE (args
[1]), 0));
4678 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4680 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4681 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4683 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4684 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4686 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4687 build_int_cst (type
, 0), tmp
);
4691 /* Circular shift. AKA rotate or barrel shift. */
4694 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4702 unsigned int num_args
;
4704 num_args
= gfc_intrinsic_argument_list_length (expr
);
4705 args
= XALLOCAVEC (tree
, num_args
);
4707 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4711 /* Use a library function for the 3 parameter version. */
4712 tree int4type
= gfc_get_int_type (4);
4714 type
= TREE_TYPE (args
[0]);
4715 /* We convert the first argument to at least 4 bytes, and
4716 convert back afterwards. This removes the need for library
4717 functions for all argument sizes, and function will be
4718 aligned to at least 32 bits, so there's no loss. */
4719 if (expr
->ts
.kind
< 4)
4720 args
[0] = convert (int4type
, args
[0]);
4722 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4723 need loads of library functions. They cannot have values >
4724 BIT_SIZE (I) so the conversion is safe. */
4725 args
[1] = convert (int4type
, args
[1]);
4726 args
[2] = convert (int4type
, args
[2]);
4728 switch (expr
->ts
.kind
)
4733 tmp
= gfor_fndecl_math_ishftc4
;
4736 tmp
= gfor_fndecl_math_ishftc8
;
4739 tmp
= gfor_fndecl_math_ishftc16
;
4744 se
->expr
= build_call_expr_loc (input_location
,
4745 tmp
, 3, args
[0], args
[1], args
[2]);
4746 /* Convert the result back to the original type, if we extended
4747 the first argument's width above. */
4748 if (expr
->ts
.kind
< 4)
4749 se
->expr
= convert (type
, se
->expr
);
4753 type
= TREE_TYPE (args
[0]);
4755 /* Evaluate arguments only once. */
4756 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4757 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4759 /* Rotate left if positive. */
4760 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4762 /* Rotate right if negative. */
4763 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4765 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4767 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4768 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4770 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4772 /* Do nothing if shift == 0. */
4773 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4775 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4780 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4781 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4783 The conditional expression is necessary because the result of LEADZ(0)
4784 is defined, but the result of __builtin_clz(0) is undefined for most
4787 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4788 difference in bit size between the argument of LEADZ and the C int. */
4791 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4803 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4804 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4806 /* Which variant of __builtin_clz* should we call? */
4807 if (argsize
<= INT_TYPE_SIZE
)
4809 arg_type
= unsigned_type_node
;
4810 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4812 else if (argsize
<= LONG_TYPE_SIZE
)
4814 arg_type
= long_unsigned_type_node
;
4815 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4817 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4819 arg_type
= long_long_unsigned_type_node
;
4820 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4824 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4825 arg_type
= gfc_build_uint_type (argsize
);
4829 /* Convert the actual argument twice: first, to the unsigned type of the
4830 same size; then, to the proper argument type for the built-in
4831 function. But the return type is of the default INTEGER kind. */
4832 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4833 arg
= fold_convert (arg_type
, arg
);
4834 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4835 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4837 /* Compute LEADZ for the case i .ne. 0. */
4840 s
= TYPE_PRECISION (arg_type
) - argsize
;
4841 tmp
= fold_convert (result_type
,
4842 build_call_expr_loc (input_location
, func
,
4844 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4845 tmp
, build_int_cst (result_type
, s
));
4849 /* We end up here if the argument type is larger than 'long long'.
4850 We generate this code:
4852 if (x & (ULL_MAX << ULL_SIZE) != 0)
4853 return clzll ((unsigned long long) (x >> ULLSIZE));
4855 return ULL_SIZE + clzll ((unsigned long long) x);
4856 where ULL_MAX is the largest value that a ULL_MAX can hold
4857 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4858 is the bit-size of the long long type (64 in this example). */
4859 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4861 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4862 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4863 long_long_unsigned_type_node
,
4864 build_int_cst (long_long_unsigned_type_node
,
4867 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4868 fold_convert (arg_type
, ullmax
), ullsize
);
4869 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4871 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4872 cond
, build_int_cst (arg_type
, 0));
4874 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4876 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4877 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4878 tmp1
= fold_convert (result_type
,
4879 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4881 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4882 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4883 tmp2
= fold_convert (result_type
,
4884 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4885 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4888 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4892 /* Build BIT_SIZE. */
4893 bit_size
= build_int_cst (result_type
, argsize
);
4895 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4896 arg
, build_int_cst (arg_type
, 0));
4897 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4902 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4904 The conditional expression is necessary because the result of TRAILZ(0)
4905 is defined, but the result of __builtin_ctz(0) is undefined for most
4909 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4920 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4921 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4923 /* Which variant of __builtin_ctz* should we call? */
4924 if (argsize
<= INT_TYPE_SIZE
)
4926 arg_type
= unsigned_type_node
;
4927 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4929 else if (argsize
<= LONG_TYPE_SIZE
)
4931 arg_type
= long_unsigned_type_node
;
4932 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4934 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4936 arg_type
= long_long_unsigned_type_node
;
4937 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4941 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4942 arg_type
= gfc_build_uint_type (argsize
);
4946 /* Convert the actual argument twice: first, to the unsigned type of the
4947 same size; then, to the proper argument type for the built-in
4948 function. But the return type is of the default INTEGER kind. */
4949 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4950 arg
= fold_convert (arg_type
, arg
);
4951 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4952 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4954 /* Compute TRAILZ for the case i .ne. 0. */
4956 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4960 /* We end up here if the argument type is larger than 'long long'.
4961 We generate this code:
4963 if ((x & ULL_MAX) == 0)
4964 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4966 return ctzll ((unsigned long long) x);
4968 where ULL_MAX is the largest value that a ULL_MAX can hold
4969 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4970 is the bit-size of the long long type (64 in this example). */
4971 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4973 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4974 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4975 long_long_unsigned_type_node
,
4976 build_int_cst (long_long_unsigned_type_node
, 0));
4978 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4979 fold_convert (arg_type
, ullmax
));
4980 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4981 build_int_cst (arg_type
, 0));
4983 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4985 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4986 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4987 tmp1
= fold_convert (result_type
,
4988 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4989 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4992 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4993 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4994 tmp2
= fold_convert (result_type
,
4995 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4997 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
5001 /* Build BIT_SIZE. */
5002 bit_size
= build_int_cst (result_type
, argsize
);
5004 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5005 arg
, build_int_cst (arg_type
, 0));
5006 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
5010 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5011 for types larger than "long long", we call the long long built-in for
5012 the lower and higher bits and combine the result. */
5015 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5023 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5024 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5025 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5027 /* Which variant of the builtin should we call? */
5028 if (argsize
<= INT_TYPE_SIZE
)
5030 arg_type
= unsigned_type_node
;
5031 func
= builtin_decl_explicit (parity
5033 : BUILT_IN_POPCOUNT
);
5035 else if (argsize
<= LONG_TYPE_SIZE
)
5037 arg_type
= long_unsigned_type_node
;
5038 func
= builtin_decl_explicit (parity
5040 : BUILT_IN_POPCOUNTL
);
5042 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5044 arg_type
= long_long_unsigned_type_node
;
5045 func
= builtin_decl_explicit (parity
5047 : BUILT_IN_POPCOUNTLL
);
5051 /* Our argument type is larger than 'long long', which mean none
5052 of the POPCOUNT builtins covers it. We thus call the 'long long'
5053 variant multiple times, and add the results. */
5054 tree utype
, arg2
, call1
, call2
;
5056 /* For now, we only cover the case where argsize is twice as large
5058 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5060 func
= builtin_decl_explicit (parity
5062 : BUILT_IN_POPCOUNTLL
);
5064 /* Convert it to an integer, and store into a variable. */
5065 utype
= gfc_build_uint_type (argsize
);
5066 arg
= fold_convert (utype
, arg
);
5067 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5069 /* Call the builtin twice. */
5070 call1
= build_call_expr_loc (input_location
, func
, 1,
5071 fold_convert (long_long_unsigned_type_node
,
5074 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5075 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5076 call2
= build_call_expr_loc (input_location
, func
, 1,
5077 fold_convert (long_long_unsigned_type_node
,
5080 /* Combine the results. */
5082 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5085 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5091 /* Convert the actual argument twice: first, to the unsigned type of the
5092 same size; then, to the proper argument type for the built-in
5094 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5095 arg
= fold_convert (arg_type
, arg
);
5097 se
->expr
= fold_convert (result_type
,
5098 build_call_expr_loc (input_location
, func
, 1, arg
));
5102 /* Process an intrinsic with unspecified argument-types that has an optional
5103 argument (which could be of type character), e.g. EOSHIFT. For those, we
5104 need to append the string length of the optional argument if it is not
5105 present and the type is really character.
5106 primary specifies the position (starting at 1) of the non-optional argument
5107 specifying the type and optional gives the position of the optional
5108 argument in the arglist. */
5111 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5112 unsigned primary
, unsigned optional
)
5114 gfc_actual_arglist
* prim_arg
;
5115 gfc_actual_arglist
* opt_arg
;
5117 gfc_actual_arglist
* arg
;
5119 vec
<tree
, va_gc
> *append_args
;
5121 /* Find the two arguments given as position. */
5125 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5129 if (cur_pos
== primary
)
5131 if (cur_pos
== optional
)
5134 if (cur_pos
>= primary
&& cur_pos
>= optional
)
5137 gcc_assert (prim_arg
);
5138 gcc_assert (prim_arg
->expr
);
5139 gcc_assert (opt_arg
);
5141 /* If we do have type CHARACTER and the optional argument is really absent,
5142 append a dummy 0 as string length. */
5144 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
5148 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
5149 vec_alloc (append_args
, 1);
5150 append_args
->quick_push (dummy
);
5153 /* Build the call itself. */
5154 gcc_assert (!se
->ignore_optional
);
5155 sym
= gfc_get_symbol_for_expr (expr
, false);
5156 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5158 gfc_free_symbol (sym
);
5162 /* The length of a character string. */
5164 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
5173 gcc_assert (!se
->ss
);
5175 arg
= expr
->value
.function
.actual
->expr
;
5177 type
= gfc_typenode_for_spec (&expr
->ts
);
5178 switch (arg
->expr_type
)
5181 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
5185 /* Obtain the string length from the function used by
5186 trans-array.c(gfc_trans_array_constructor). */
5188 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
5192 if (arg
->ref
== NULL
5193 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
5195 /* This doesn't catch all cases.
5196 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
5197 and the surrounding thread. */
5198 sym
= arg
->symtree
->n
.sym
;
5199 decl
= gfc_get_symbol_decl (sym
);
5200 if (decl
== current_function_decl
&& sym
->attr
.function
5201 && (sym
->result
== sym
))
5202 decl
= gfc_get_fake_result_decl (sym
, 0);
5204 len
= sym
->ts
.u
.cl
->backend_decl
;
5209 /* Otherwise fall through. */
5212 /* Anybody stupid enough to do this deserves inefficient code. */
5213 gfc_init_se (&argse
, se
);
5215 gfc_conv_expr (&argse
, arg
);
5217 gfc_conv_expr_descriptor (&argse
, arg
);
5218 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5219 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5220 len
= argse
.string_length
;
5223 se
->expr
= convert (type
, len
);
5226 /* The length of a character string not including trailing blanks. */
5228 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
5230 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5231 tree args
[2], type
, fndecl
;
5233 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5234 type
= gfc_typenode_for_spec (&expr
->ts
);
5237 fndecl
= gfor_fndecl_string_len_trim
;
5239 fndecl
= gfor_fndecl_string_len_trim_char4
;
5243 se
->expr
= build_call_expr_loc (input_location
,
5244 fndecl
, 2, args
[0], args
[1]);
5245 se
->expr
= convert (type
, se
->expr
);
5249 /* Returns the starting position of a substring within a string. */
5252 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
5255 tree logical4_type_node
= gfc_get_logical_type (4);
5259 unsigned int num_args
;
5261 args
= XALLOCAVEC (tree
, 5);
5263 /* Get number of arguments; characters count double due to the
5264 string length argument. Kind= is not passed to the library
5265 and thus ignored. */
5266 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
5271 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5272 type
= gfc_typenode_for_spec (&expr
->ts
);
5275 args
[4] = build_int_cst (logical4_type_node
, 0);
5277 args
[4] = convert (logical4_type_node
, args
[4]);
5279 fndecl
= build_addr (function
, current_function_decl
);
5280 se
->expr
= build_call_array_loc (input_location
,
5281 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
5283 se
->expr
= convert (type
, se
->expr
);
5287 /* The ascii value for a single character. */
5289 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
5291 tree args
[3], type
, pchartype
;
5294 nargs
= gfc_intrinsic_argument_list_length (expr
);
5295 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
5296 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
5297 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
5298 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
5299 type
= gfc_typenode_for_spec (&expr
->ts
);
5301 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5303 se
->expr
= convert (type
, se
->expr
);
5307 /* Intrinsic ISNAN calls __builtin_isnan. */
5310 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
5314 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5315 se
->expr
= build_call_expr_loc (input_location
,
5316 builtin_decl_explicit (BUILT_IN_ISNAN
),
5318 STRIP_TYPE_NOPS (se
->expr
);
5319 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5323 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
5324 their argument against a constant integer value. */
5327 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
5331 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5332 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
5333 gfc_typenode_for_spec (&expr
->ts
),
5334 arg
, build_int_cst (TREE_TYPE (arg
), value
));
5339 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
5342 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
5350 unsigned int num_args
;
5352 num_args
= gfc_intrinsic_argument_list_length (expr
);
5353 args
= XALLOCAVEC (tree
, num_args
);
5355 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5356 if (expr
->ts
.type
!= BT_CHARACTER
)
5364 /* We do the same as in the non-character case, but the argument
5365 list is different because of the string length arguments. We
5366 also have to set the string length for the result. */
5373 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
5375 se
->string_length
= len
;
5377 type
= TREE_TYPE (tsource
);
5378 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
5379 fold_convert (type
, fsource
));
5383 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
5386 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
5388 tree args
[3], mask
, type
;
5390 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5391 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
5393 type
= TREE_TYPE (args
[0]);
5394 gcc_assert (TREE_TYPE (args
[1]) == type
);
5395 gcc_assert (TREE_TYPE (mask
) == type
);
5397 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
5398 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
5399 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5401 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
5406 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
5407 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
5410 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
5412 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
5415 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5416 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5418 type
= gfc_get_int_type (expr
->ts
.kind
);
5419 utype
= unsigned_type_for (type
);
5421 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
5422 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
5424 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
5425 build_int_cst (utype
, 0));
5429 /* Left-justified mask. */
5430 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
5432 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5433 fold_convert (utype
, res
));
5435 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
5436 smaller than type width. */
5437 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5438 build_int_cst (TREE_TYPE (arg
), 0));
5439 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
5440 build_int_cst (utype
, 0), res
);
5444 /* Right-justified mask. */
5445 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5446 fold_convert (utype
, arg
));
5447 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
5449 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
5450 strictly smaller than type width. */
5451 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5453 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
5454 cond
, allones
, res
);
5457 se
->expr
= fold_convert (type
, res
);
5461 /* FRACTION (s) is translated into:
5462 isfinite (s) ? frexp (s, &dummy_int) : NaN */
5464 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
5466 tree arg
, type
, tmp
, res
, frexp
, cond
;
5468 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5470 type
= gfc_typenode_for_spec (&expr
->ts
);
5471 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5472 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5474 cond
= build_call_expr_loc (input_location
,
5475 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5478 tmp
= gfc_create_var (integer_type_node
, NULL
);
5479 res
= build_call_expr_loc (input_location
, frexp
, 2,
5480 fold_convert (type
, arg
),
5481 gfc_build_addr_expr (NULL_TREE
, tmp
));
5482 res
= fold_convert (type
, res
);
5484 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
5485 cond
, res
, gfc_build_nan (type
, ""));
5489 /* NEAREST (s, dir) is translated into
5490 tmp = copysign (HUGE_VAL, dir);
5491 return nextafter (s, tmp);
5494 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
5496 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
5498 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
5499 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
5501 type
= gfc_typenode_for_spec (&expr
->ts
);
5502 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5504 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
5505 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
5506 fold_convert (type
, args
[1]));
5507 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
5508 fold_convert (type
, args
[0]), tmp
);
5509 se
->expr
= fold_convert (type
, se
->expr
);
5513 /* SPACING (s) is translated into
5523 e = MAX_EXPR (e, emin);
5524 res = scalbn (1., e);
5528 where prec is the precision of s, gfc_real_kinds[k].digits,
5529 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
5530 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
5533 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
5535 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
5536 tree cond
, nan
, tmp
, frexp
, scalbn
;
5540 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5541 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
5542 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
5543 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
5545 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5546 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5548 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5549 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5551 type
= gfc_typenode_for_spec (&expr
->ts
);
5552 e
= gfc_create_var (integer_type_node
, NULL
);
5553 res
= gfc_create_var (type
, NULL
);
5556 /* Build the block for s /= 0. */
5557 gfc_start_block (&block
);
5558 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5559 gfc_build_addr_expr (NULL_TREE
, e
));
5560 gfc_add_expr_to_block (&block
, tmp
);
5562 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
5564 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
5565 integer_type_node
, tmp
, emin
));
5567 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
5568 build_real_from_int_cst (type
, integer_one_node
), e
);
5569 gfc_add_modify (&block
, res
, tmp
);
5571 /* Finish by building the IF statement for value zero. */
5572 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5573 build_real_from_int_cst (type
, integer_zero_node
));
5574 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
5575 gfc_finish_block (&block
));
5577 /* And deal with infinities and NaNs. */
5578 cond
= build_call_expr_loc (input_location
,
5579 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5581 nan
= gfc_build_nan (type
, "");
5582 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
5584 gfc_add_expr_to_block (&se
->pre
, tmp
);
5589 /* RRSPACING (s) is translated into
5598 x = scalbn (x, precision - e);
5605 where precision is gfc_real_kinds[k].digits. */
5608 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
5610 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
5614 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5615 prec
= gfc_real_kinds
[k
].digits
;
5617 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5618 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5619 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
5621 type
= gfc_typenode_for_spec (&expr
->ts
);
5622 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5623 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5625 e
= gfc_create_var (integer_type_node
, NULL
);
5626 x
= gfc_create_var (type
, NULL
);
5627 gfc_add_modify (&se
->pre
, x
,
5628 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5631 gfc_start_block (&block
);
5632 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5633 gfc_build_addr_expr (NULL_TREE
, e
));
5634 gfc_add_expr_to_block (&block
, tmp
);
5636 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5637 build_int_cst (integer_type_node
, prec
), e
);
5638 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5639 gfc_add_modify (&block
, x
, tmp
);
5640 stmt
= gfc_finish_block (&block
);
5643 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5644 build_real_from_int_cst (type
, integer_zero_node
));
5645 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5647 /* And deal with infinities and NaNs. */
5648 cond
= build_call_expr_loc (input_location
,
5649 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5651 nan
= gfc_build_nan (type
, "");
5652 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
5654 gfc_add_expr_to_block (&se
->pre
, tmp
);
5655 se
->expr
= fold_convert (type
, x
);
5659 /* SCALE (s, i) is translated into scalbn (s, i). */
5661 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5663 tree args
[2], type
, scalbn
;
5665 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5667 type
= gfc_typenode_for_spec (&expr
->ts
);
5668 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5669 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5670 fold_convert (type
, args
[0]),
5671 fold_convert (integer_type_node
, args
[1]));
5672 se
->expr
= fold_convert (type
, se
->expr
);
5676 /* SET_EXPONENT (s, i) is translated into
5677 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
5679 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5681 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
5683 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5684 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5686 type
= gfc_typenode_for_spec (&expr
->ts
);
5687 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5688 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5690 tmp
= gfc_create_var (integer_type_node
, NULL
);
5691 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5692 fold_convert (type
, args
[0]),
5693 gfc_build_addr_expr (NULL_TREE
, tmp
));
5694 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5695 fold_convert (integer_type_node
, args
[1]));
5696 res
= fold_convert (type
, res
);
5698 /* Call to isfinite */
5699 cond
= build_call_expr_loc (input_location
,
5700 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5702 nan
= gfc_build_nan (type
, "");
5704 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5710 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5712 gfc_actual_arglist
*actual
;
5719 gfc_init_se (&argse
, NULL
);
5720 actual
= expr
->value
.function
.actual
;
5722 if (actual
->expr
->ts
.type
== BT_CLASS
)
5723 gfc_add_class_array_ref (actual
->expr
);
5725 argse
.want_pointer
= 1;
5726 argse
.data_not_needed
= 1;
5727 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5728 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5729 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5730 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5732 /* Build the call to size0. */
5733 fncall0
= build_call_expr_loc (input_location
,
5734 gfor_fndecl_size0
, 1, arg1
);
5736 actual
= actual
->next
;
5740 gfc_init_se (&argse
, NULL
);
5741 gfc_conv_expr_type (&argse
, actual
->expr
,
5742 gfc_array_index_type
);
5743 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5745 /* Unusually, for an intrinsic, size does not exclude
5746 an optional arg2, so we must test for it. */
5747 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5748 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5749 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5752 /* Build the call to size1. */
5753 fncall1
= build_call_expr_loc (input_location
,
5754 gfor_fndecl_size1
, 2,
5757 gfc_init_se (&argse
, NULL
);
5758 argse
.want_pointer
= 1;
5759 argse
.data_not_needed
= 1;
5760 gfc_conv_expr (&argse
, actual
->expr
);
5761 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5762 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5763 argse
.expr
, null_pointer_node
);
5764 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5765 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5766 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5770 se
->expr
= NULL_TREE
;
5771 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5772 gfc_array_index_type
,
5773 argse
.expr
, gfc_index_one_node
);
5776 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5778 argse
.expr
= gfc_index_zero_node
;
5779 se
->expr
= NULL_TREE
;
5784 if (se
->expr
== NULL_TREE
)
5786 tree ubound
, lbound
;
5788 arg1
= build_fold_indirect_ref_loc (input_location
,
5790 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5791 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5792 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5793 gfc_array_index_type
, ubound
, lbound
);
5794 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5795 gfc_array_index_type
,
5796 se
->expr
, gfc_index_one_node
);
5797 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5798 gfc_array_index_type
, se
->expr
,
5799 gfc_index_zero_node
);
5802 type
= gfc_typenode_for_spec (&expr
->ts
);
5803 se
->expr
= convert (type
, se
->expr
);
5807 /* Helper function to compute the size of a character variable,
5808 excluding the terminating null characters. The result has
5809 gfc_array_index_type type. */
5812 size_of_string_in_bytes (int kind
, tree string_length
)
5815 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5817 bytesize
= build_int_cst (gfc_array_index_type
,
5818 gfc_character_kinds
[i
].bit_size
/ 8);
5820 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5822 fold_convert (gfc_array_index_type
, string_length
));
5827 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5838 gfc_init_se (&argse
, NULL
);
5839 arg
= expr
->value
.function
.actual
->expr
;
5841 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
5842 gfc_conv_expr_descriptor (&argse
, arg
);
5844 gfc_conv_expr_reference (&argse
, arg
);
5846 if (arg
->ts
.type
== BT_ASSUMED
)
5848 /* This only works if an array descriptor has been passed; thus, extract
5849 the size from the descriptor. */
5850 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
5851 == TYPE_PRECISION (size_type_node
));
5852 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
5853 tmp
= DECL_LANG_SPECIFIC (tmp
)
5854 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
5855 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
5856 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
5857 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5858 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
5859 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
5860 build_int_cst (TREE_TYPE (tmp
),
5861 GFC_DTYPE_SIZE_SHIFT
));
5862 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
5864 else if (arg
->ts
.type
== BT_CLASS
)
5867 byte_size
= gfc_vtable_size_get (TREE_OPERAND (argse
.expr
, 0));
5869 byte_size
= gfc_vtable_size_get (argse
.expr
);
5873 if (arg
->ts
.type
== BT_CHARACTER
)
5874 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5878 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5881 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5882 byte_size
= fold_convert (gfc_array_index_type
,
5883 size_in_bytes (byte_size
));
5888 se
->expr
= byte_size
;
5891 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5892 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
5894 if (arg
->rank
== -1)
5896 tree cond
, loop_var
, exit_label
;
5899 tmp
= fold_convert (gfc_array_index_type
,
5900 gfc_conv_descriptor_rank (argse
.expr
));
5901 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
5902 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
5903 exit_label
= gfc_build_label_decl (NULL_TREE
);
5910 source_bytes = source_bytes * array.dim[i].extent;
5914 gfc_start_block (&body
);
5915 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5917 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5918 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5919 cond
, tmp
, build_empty_stmt (input_location
));
5920 gfc_add_expr_to_block (&body
, tmp
);
5922 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
5923 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
5924 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
5925 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5926 gfc_array_index_type
, tmp
, source_bytes
);
5927 gfc_add_modify (&body
, source_bytes
, tmp
);
5929 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5930 gfc_array_index_type
, loop_var
,
5931 gfc_index_one_node
);
5932 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
5934 tmp
= gfc_finish_block (&body
);
5936 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
5938 gfc_add_expr_to_block (&argse
.pre
, tmp
);
5940 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5941 gfc_add_expr_to_block (&argse
.pre
, tmp
);
5945 /* Obtain the size of the array in bytes. */
5946 for (n
= 0; n
< arg
->rank
; n
++)
5949 idx
= gfc_rank_cst
[n
];
5950 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5951 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5952 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
5953 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5954 gfc_array_index_type
, tmp
, source_bytes
);
5955 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5958 se
->expr
= source_bytes
;
5961 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5966 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
5970 tree type
, result_type
, tmp
;
5972 arg
= expr
->value
.function
.actual
->expr
;
5974 gfc_init_se (&argse
, NULL
);
5975 result_type
= gfc_get_int_type (expr
->ts
.kind
);
5979 if (arg
->ts
.type
== BT_CLASS
)
5981 gfc_add_vptr_component (arg
);
5982 gfc_add_size_component (arg
);
5983 gfc_conv_expr (&argse
, arg
);
5984 tmp
= fold_convert (result_type
, argse
.expr
);
5988 gfc_conv_expr_reference (&argse
, arg
);
5989 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5994 argse
.want_pointer
= 0;
5995 gfc_conv_expr_descriptor (&argse
, arg
);
5996 if (arg
->ts
.type
== BT_CLASS
)
5998 tmp
= gfc_vtable_size_get (TREE_OPERAND (argse
.expr
, 0));
5999 tmp
= fold_convert (result_type
, tmp
);
6002 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6005 /* Obtain the argument's word length. */
6006 if (arg
->ts
.type
== BT_CHARACTER
)
6007 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
6009 tmp
= size_in_bytes (type
);
6010 tmp
= fold_convert (result_type
, tmp
);
6013 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
6014 build_int_cst (result_type
, BITS_PER_UNIT
));
6015 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6019 /* Intrinsic string comparison functions. */
6022 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6026 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6029 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6030 expr
->value
.function
.actual
->expr
->ts
.kind
,
6032 se
->expr
= fold_build2_loc (input_location
, op
,
6033 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6034 build_int_cst (TREE_TYPE (se
->expr
), 0));
6037 /* Generate a call to the adjustl/adjustr library function. */
6039 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6047 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6050 type
= TREE_TYPE (args
[2]);
6051 var
= gfc_conv_string_tmp (se
, type
, len
);
6054 tmp
= build_call_expr_loc (input_location
,
6055 fndecl
, 3, args
[0], args
[1], args
[2]);
6056 gfc_add_expr_to_block (&se
->pre
, tmp
);
6058 se
->string_length
= len
;
6062 /* Generate code for the TRANSFER intrinsic:
6064 DEST = TRANSFER (SOURCE, MOLD)
6066 typeof<DEST> = typeof<MOLD>
6071 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6073 typeof<DEST> = typeof<MOLD>
6075 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6076 sizeof (DEST(0) * SIZE). */
6078 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6094 gfc_actual_arglist
*arg
;
6096 gfc_array_info
*info
;
6100 gfc_expr
*source_expr
, *mold_expr
;
6104 info
= &se
->ss
->info
->data
.array
;
6106 /* Convert SOURCE. The output from this stage is:-
6107 source_bytes = length of the source in bytes
6108 source = pointer to the source data. */
6109 arg
= expr
->value
.function
.actual
;
6110 source_expr
= arg
->expr
;
6112 /* Ensure double transfer through LOGICAL preserves all
6114 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6115 && arg
->expr
->value
.function
.esym
== NULL
6116 && arg
->expr
->value
.function
.isym
!= NULL
6117 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6118 && arg
->expr
->ts
.type
== BT_LOGICAL
6119 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6120 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6122 gfc_init_se (&argse
, NULL
);
6124 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6126 /* Obtain the pointer to source and the length of source in bytes. */
6127 if (arg
->expr
->rank
== 0)
6129 gfc_conv_expr_reference (&argse
, arg
->expr
);
6130 if (arg
->expr
->ts
.type
== BT_CLASS
)
6131 source
= gfc_class_data_get (argse
.expr
);
6133 source
= argse
.expr
;
6135 /* Obtain the source word length. */
6136 switch (arg
->expr
->ts
.type
)
6139 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6140 argse
.string_length
);
6143 tmp
= gfc_vtable_size_get (argse
.expr
);
6146 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6148 tmp
= fold_convert (gfc_array_index_type
,
6149 size_in_bytes (source_type
));
6155 argse
.want_pointer
= 0;
6156 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6157 source
= gfc_conv_descriptor_data_get (argse
.expr
);
6158 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6160 /* Repack the source if not simply contiguous. */
6161 if (!gfc_is_simply_contiguous (arg
->expr
, false))
6163 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
6165 if (warn_array_temporaries
)
6166 gfc_warning (OPT_Warray_temporaries
,
6167 "Creating array temporary at %L", &expr
->where
);
6169 source
= build_call_expr_loc (input_location
,
6170 gfor_fndecl_in_pack
, 1, tmp
);
6171 source
= gfc_evaluate_now (source
, &argse
.pre
);
6173 /* Free the temporary. */
6174 gfc_start_block (&block
);
6175 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
6176 gfc_add_expr_to_block (&block
, tmp
);
6177 stmt
= gfc_finish_block (&block
);
6179 /* Clean up if it was repacked. */
6180 gfc_init_block (&block
);
6181 tmp
= gfc_conv_array_data (argse
.expr
);
6182 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6184 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
6185 build_empty_stmt (input_location
));
6186 gfc_add_expr_to_block (&block
, tmp
);
6187 gfc_add_block_to_block (&block
, &se
->post
);
6188 gfc_init_block (&se
->post
);
6189 gfc_add_block_to_block (&se
->post
, &block
);
6192 /* Obtain the source word length. */
6193 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
6194 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6195 argse
.string_length
);
6197 tmp
= fold_convert (gfc_array_index_type
,
6198 size_in_bytes (source_type
));
6200 /* Obtain the size of the array in bytes. */
6201 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
6202 for (n
= 0; n
< arg
->expr
->rank
; n
++)
6205 idx
= gfc_rank_cst
[n
];
6206 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6207 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6208 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6209 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6210 gfc_array_index_type
, upper
, lower
);
6211 gfc_add_modify (&argse
.pre
, extent
, tmp
);
6212 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6213 gfc_array_index_type
, extent
,
6214 gfc_index_one_node
);
6215 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6216 gfc_array_index_type
, tmp
, source_bytes
);
6220 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6221 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6222 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6224 /* Now convert MOLD. The outputs are:
6225 mold_type = the TREE type of MOLD
6226 dest_word_len = destination word length in bytes. */
6228 mold_expr
= arg
->expr
;
6230 gfc_init_se (&argse
, NULL
);
6232 scalar_mold
= arg
->expr
->rank
== 0;
6234 if (arg
->expr
->rank
== 0)
6236 gfc_conv_expr_reference (&argse
, arg
->expr
);
6237 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6242 gfc_init_se (&argse
, NULL
);
6243 argse
.want_pointer
= 0;
6244 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6245 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6248 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6249 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6251 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
6253 /* If this TRANSFER is nested in another TRANSFER, use a type
6254 that preserves all bits. */
6255 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
6256 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
6259 /* Obtain the destination word length. */
6260 switch (arg
->expr
->ts
.type
)
6263 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
6264 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
6267 tmp
= gfc_vtable_size_get (argse
.expr
);
6270 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
6273 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
6274 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
6276 /* Finally convert SIZE, if it is present. */
6278 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
6282 gfc_init_se (&argse
, NULL
);
6283 gfc_conv_expr_reference (&argse
, arg
->expr
);
6284 tmp
= convert (gfc_array_index_type
,
6285 build_fold_indirect_ref_loc (input_location
,
6287 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6288 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6293 /* Separate array and scalar results. */
6294 if (scalar_mold
&& tmp
== NULL_TREE
)
6295 goto scalar_transfer
;
6297 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6298 if (tmp
!= NULL_TREE
)
6299 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6300 tmp
, dest_word_len
);
6304 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
6305 gfc_add_modify (&se
->pre
, size_words
,
6306 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
6307 gfc_array_index_type
,
6308 size_bytes
, dest_word_len
));
6310 /* Evaluate the bounds of the result. If the loop range exists, we have
6311 to check if it is too large. If so, we modify loop->to be consistent
6312 with min(size, size(source)). Otherwise, size is made consistent with
6313 the loop range, so that the right number of bytes is transferred.*/
6314 n
= se
->loop
->order
[0];
6315 if (se
->loop
->to
[n
] != NULL_TREE
)
6317 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6318 se
->loop
->to
[n
], se
->loop
->from
[n
]);
6319 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6320 tmp
, gfc_index_one_node
);
6321 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6323 gfc_add_modify (&se
->pre
, size_words
, tmp
);
6324 gfc_add_modify (&se
->pre
, size_bytes
,
6325 fold_build2_loc (input_location
, MULT_EXPR
,
6326 gfc_array_index_type
,
6327 size_words
, dest_word_len
));
6328 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6329 size_words
, se
->loop
->from
[n
]);
6330 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6331 upper
, gfc_index_one_node
);
6335 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6336 size_words
, gfc_index_one_node
);
6337 se
->loop
->from
[n
] = gfc_index_zero_node
;
6340 se
->loop
->to
[n
] = upper
;
6342 /* Build a destination descriptor, using the pointer, source, as the
6344 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
6345 NULL_TREE
, false, true, false, &expr
->where
);
6347 /* Cast the pointer to the result. */
6348 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6349 tmp
= fold_convert (pvoid_type_node
, tmp
);
6351 /* Use memcpy to do the transfer. */
6353 = build_call_expr_loc (input_location
,
6354 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
6355 fold_convert (pvoid_type_node
, source
),
6356 fold_convert (size_type_node
,
6357 fold_build2_loc (input_location
,
6359 gfc_array_index_type
,
6362 gfc_add_expr_to_block (&se
->pre
, tmp
);
6364 se
->expr
= info
->descriptor
;
6365 if (expr
->ts
.type
== BT_CHARACTER
)
6366 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6370 /* Deal with scalar results. */
6372 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6373 dest_word_len
, source_bytes
);
6374 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6375 extent
, gfc_index_zero_node
);
6377 if (expr
->ts
.type
== BT_CHARACTER
)
6379 tree direct
, indirect
, free
;
6381 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
6382 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
6385 /* If source is longer than the destination, use a pointer to
6386 the source directly. */
6387 gfc_init_block (&block
);
6388 gfc_add_modify (&block
, tmpdecl
, ptr
);
6389 direct
= gfc_finish_block (&block
);
6391 /* Otherwise, allocate a string with the length of the destination
6392 and copy the source into it. */
6393 gfc_init_block (&block
);
6394 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
6395 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
6396 gfc_add_modify (&block
, tmpdecl
,
6397 fold_convert (TREE_TYPE (ptr
), tmp
));
6398 tmp
= build_call_expr_loc (input_location
,
6399 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6400 fold_convert (pvoid_type_node
, tmpdecl
),
6401 fold_convert (pvoid_type_node
, ptr
),
6402 fold_convert (size_type_node
, extent
));
6403 gfc_add_expr_to_block (&block
, tmp
);
6404 indirect
= gfc_finish_block (&block
);
6406 /* Wrap it up with the condition. */
6407 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
6408 dest_word_len
, source_bytes
);
6409 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
6410 gfc_add_expr_to_block (&se
->pre
, tmp
);
6412 /* Free the temporary string, if necessary. */
6413 free
= gfc_call_free (tmpdecl
);
6414 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6415 dest_word_len
, source_bytes
);
6416 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
6417 gfc_add_expr_to_block (&se
->post
, tmp
);
6420 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6424 tmpdecl
= gfc_create_var (mold_type
, "transfer");
6426 ptr
= convert (build_pointer_type (mold_type
), source
);
6428 /* For CLASS results, allocate the needed memory first. */
6429 if (mold_expr
->ts
.type
== BT_CLASS
)
6432 cdata
= gfc_class_data_get (tmpdecl
);
6433 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
6434 gfc_add_modify (&se
->pre
, cdata
, tmp
);
6437 /* Use memcpy to do the transfer. */
6438 if (mold_expr
->ts
.type
== BT_CLASS
)
6439 tmp
= gfc_class_data_get (tmpdecl
);
6441 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
6443 tmp
= build_call_expr_loc (input_location
,
6444 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6445 fold_convert (pvoid_type_node
, tmp
),
6446 fold_convert (pvoid_type_node
, ptr
),
6447 fold_convert (size_type_node
, extent
));
6448 gfc_add_expr_to_block (&se
->pre
, tmp
);
6450 /* For CLASS results, set the _vptr. */
6451 if (mold_expr
->ts
.type
== BT_CLASS
)
6455 vptr
= gfc_class_vptr_get (tmpdecl
);
6456 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
6458 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
6459 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
6467 /* Generate code for the ALLOCATED intrinsic.
6468 Generate inline code that directly check the address of the argument. */
6471 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
6473 gfc_actual_arglist
*arg1
;
6477 gfc_init_se (&arg1se
, NULL
);
6478 arg1
= expr
->value
.function
.actual
;
6480 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6482 /* Make sure that class array expressions have both a _data
6483 component reference and an array reference.... */
6484 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
6485 gfc_add_class_array_ref (arg1
->expr
);
6486 /* .... whilst scalars only need the _data component. */
6488 gfc_add_data_component (arg1
->expr
);
6491 if (arg1
->expr
->rank
== 0)
6493 /* Allocatable scalar. */
6494 arg1se
.want_pointer
= 1;
6495 gfc_conv_expr (&arg1se
, arg1
->expr
);
6500 /* Allocatable array. */
6501 arg1se
.descriptor_only
= 1;
6502 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6503 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6506 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
6507 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6508 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6512 /* Generate code for the ASSOCIATED intrinsic.
6513 If both POINTER and TARGET are arrays, generate a call to library function
6514 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
6515 In other cases, generate inline code that directly compare the address of
6516 POINTER with the address of TARGET. */
6519 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
6521 gfc_actual_arglist
*arg1
;
6522 gfc_actual_arglist
*arg2
;
6527 tree nonzero_charlen
;
6528 tree nonzero_arraylen
;
6532 gfc_init_se (&arg1se
, NULL
);
6533 gfc_init_se (&arg2se
, NULL
);
6534 arg1
= expr
->value
.function
.actual
;
6537 /* Check whether the expression is a scalar or not; we cannot use
6538 arg1->expr->rank as it can be nonzero for proc pointers. */
6539 ss
= gfc_walk_expr (arg1
->expr
);
6540 scalar
= ss
== gfc_ss_terminator
;
6542 gfc_free_ss_chain (ss
);
6546 /* No optional target. */
6549 /* A pointer to a scalar. */
6550 arg1se
.want_pointer
= 1;
6551 gfc_conv_expr (&arg1se
, arg1
->expr
);
6552 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6553 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6554 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6556 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6558 tmp2
= gfc_class_data_get (arg1se
.expr
);
6559 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6560 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6567 /* A pointer to an array. */
6568 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6569 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6571 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6572 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6573 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
6574 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
6579 /* An optional target. */
6580 if (arg2
->expr
->ts
.type
== BT_CLASS
)
6581 gfc_add_data_component (arg2
->expr
);
6583 nonzero_charlen
= NULL_TREE
;
6584 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
6585 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
6587 arg1
->expr
->ts
.u
.cl
->backend_decl
,
6591 /* A pointer to a scalar. */
6592 arg1se
.want_pointer
= 1;
6593 gfc_conv_expr (&arg1se
, arg1
->expr
);
6594 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6595 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6596 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6598 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6599 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
6601 arg2se
.want_pointer
= 1;
6602 gfc_conv_expr (&arg2se
, arg2
->expr
);
6603 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6604 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
6605 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
6607 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6608 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6609 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6610 arg1se
.expr
, arg2se
.expr
);
6611 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6612 arg1se
.expr
, null_pointer_node
);
6613 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6614 boolean_type_node
, tmp
, tmp2
);
6618 /* An array pointer of zero length is not associated if target is
6620 arg1se
.descriptor_only
= 1;
6621 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
6622 if (arg1
->expr
->rank
== -1)
6624 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
6625 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6626 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
6629 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
6630 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
6631 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
6632 boolean_type_node
, tmp
,
6633 build_int_cst (TREE_TYPE (tmp
), 0));
6635 /* A pointer to an array, call library function _gfor_associated. */
6636 arg1se
.want_pointer
= 1;
6637 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6639 arg2se
.want_pointer
= 1;
6640 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
6641 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6642 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6643 se
->expr
= build_call_expr_loc (input_location
,
6644 gfor_fndecl_associated
, 2,
6645 arg1se
.expr
, arg2se
.expr
);
6646 se
->expr
= convert (boolean_type_node
, se
->expr
);
6647 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6648 boolean_type_node
, se
->expr
,
6652 /* If target is present zero character length pointers cannot
6654 if (nonzero_charlen
!= NULL_TREE
)
6655 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6657 se
->expr
, nonzero_charlen
);
6660 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6664 /* Generate code for the SAME_TYPE_AS intrinsic.
6665 Generate inline code that directly checks the vindices. */
6668 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
6673 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
6675 gfc_init_se (&se1
, NULL
);
6676 gfc_init_se (&se2
, NULL
);
6678 a
= expr
->value
.function
.actual
->expr
;
6679 b
= expr
->value
.function
.actual
->next
->expr
;
6681 if (UNLIMITED_POLY (a
))
6683 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
6684 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6685 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6688 if (UNLIMITED_POLY (b
))
6690 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
6691 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6692 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6695 if (a
->ts
.type
== BT_CLASS
)
6697 gfc_add_vptr_component (a
);
6698 gfc_add_hash_component (a
);
6700 else if (a
->ts
.type
== BT_DERIVED
)
6701 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6702 a
->ts
.u
.derived
->hash_value
);
6704 if (b
->ts
.type
== BT_CLASS
)
6706 gfc_add_vptr_component (b
);
6707 gfc_add_hash_component (b
);
6709 else if (b
->ts
.type
== BT_DERIVED
)
6710 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6711 b
->ts
.u
.derived
->hash_value
);
6713 gfc_conv_expr (&se1
, a
);
6714 gfc_conv_expr (&se2
, b
);
6716 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6717 boolean_type_node
, se1
.expr
,
6718 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
6721 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6722 boolean_type_node
, conda
, tmp
);
6725 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6726 boolean_type_node
, condb
, tmp
);
6728 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6732 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6735 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6739 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6740 se
->expr
= build_call_expr_loc (input_location
,
6741 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6742 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6746 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6749 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6753 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6755 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6756 type
= gfc_get_int_type (4);
6757 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6759 /* Convert it to the required type. */
6760 type
= gfc_typenode_for_spec (&expr
->ts
);
6761 se
->expr
= build_call_expr_loc (input_location
,
6762 gfor_fndecl_si_kind
, 1, arg
);
6763 se
->expr
= fold_convert (type
, se
->expr
);
6767 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6770 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6772 gfc_actual_arglist
*actual
;
6775 vec
<tree
, va_gc
> *args
= NULL
;
6777 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6779 gfc_init_se (&argse
, se
);
6781 /* Pass a NULL pointer for an absent arg. */
6782 if (actual
->expr
== NULL
)
6783 argse
.expr
= null_pointer_node
;
6789 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6791 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6792 ts
.type
= BT_INTEGER
;
6793 ts
.kind
= gfc_c_int_kind
;
6794 gfc_convert_type (actual
->expr
, &ts
, 2);
6796 gfc_conv_expr_reference (&argse
, actual
->expr
);
6799 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6800 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6801 vec_safe_push (args
, argse
.expr
);
6804 /* Convert it to the required type. */
6805 type
= gfc_typenode_for_spec (&expr
->ts
);
6806 se
->expr
= build_call_expr_loc_vec (input_location
,
6807 gfor_fndecl_sr_kind
, args
);
6808 se
->expr
= fold_convert (type
, se
->expr
);
6812 /* Generate code for TRIM (A) intrinsic function. */
6815 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6825 unsigned int num_args
;
6827 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6828 args
= XALLOCAVEC (tree
, num_args
);
6830 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6831 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6832 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6834 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6835 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6838 if (expr
->ts
.kind
== 1)
6839 function
= gfor_fndecl_string_trim
;
6840 else if (expr
->ts
.kind
== 4)
6841 function
= gfor_fndecl_string_trim_char4
;
6845 fndecl
= build_addr (function
, current_function_decl
);
6846 tmp
= build_call_array_loc (input_location
,
6847 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6849 gfc_add_expr_to_block (&se
->pre
, tmp
);
6851 /* Free the temporary afterwards, if necessary. */
6852 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6853 len
, build_int_cst (TREE_TYPE (len
), 0));
6854 tmp
= gfc_call_free (var
);
6855 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6856 gfc_add_expr_to_block (&se
->post
, tmp
);
6859 se
->string_length
= len
;
6863 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6866 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6868 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6869 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6871 stmtblock_t block
, body
;
6874 /* We store in charsize the size of a character. */
6875 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6876 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6878 /* Get the arguments. */
6879 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6880 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6882 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6883 ncopies_type
= TREE_TYPE (ncopies
);
6885 /* Check that NCOPIES is not negative. */
6886 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6887 build_int_cst (ncopies_type
, 0));
6888 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6889 "Argument NCOPIES of REPEAT intrinsic is negative "
6890 "(its value is %ld)",
6891 fold_convert (long_integer_type_node
, ncopies
));
6893 /* If the source length is zero, any non negative value of NCOPIES
6894 is valid, and nothing happens. */
6895 n
= gfc_create_var (ncopies_type
, "ncopies");
6896 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6897 build_int_cst (size_type_node
, 0));
6898 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6899 build_int_cst (ncopies_type
, 0), ncopies
);
6900 gfc_add_modify (&se
->pre
, n
, tmp
);
6903 /* Check that ncopies is not too large: ncopies should be less than
6904 (or equal to) MAX / slen, where MAX is the maximal integer of
6905 the gfc_charlen_type_node type. If slen == 0, we need a special
6906 case to avoid the division by zero. */
6907 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6908 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6909 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6910 fold_convert (size_type_node
, max
), slen
);
6911 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6912 ? size_type_node
: ncopies_type
;
6913 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6914 fold_convert (largest
, ncopies
),
6915 fold_convert (largest
, max
));
6916 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6917 build_int_cst (size_type_node
, 0));
6918 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6919 boolean_false_node
, cond
);
6920 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6921 "Argument NCOPIES of REPEAT intrinsic is too large");
6923 /* Compute the destination length. */
6924 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6925 fold_convert (gfc_charlen_type_node
, slen
),
6926 fold_convert (gfc_charlen_type_node
, ncopies
));
6927 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6928 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6930 /* Generate the code to do the repeat operation:
6931 for (i = 0; i < ncopies; i++)
6932 memmove (dest + (i * slen * size), src, slen*size); */
6933 gfc_start_block (&block
);
6934 count
= gfc_create_var (ncopies_type
, "count");
6935 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6936 exit_label
= gfc_build_label_decl (NULL_TREE
);
6938 /* Start the loop body. */
6939 gfc_start_block (&body
);
6941 /* Exit the loop if count >= ncopies. */
6942 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6944 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6945 TREE_USED (exit_label
) = 1;
6946 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6947 build_empty_stmt (input_location
));
6948 gfc_add_expr_to_block (&body
, tmp
);
6950 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6951 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6952 fold_convert (gfc_charlen_type_node
, slen
),
6953 fold_convert (gfc_charlen_type_node
, count
));
6954 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6955 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6956 tmp
= fold_build_pointer_plus_loc (input_location
,
6957 fold_convert (pvoid_type_node
, dest
), tmp
);
6958 tmp
= build_call_expr_loc (input_location
,
6959 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6961 fold_build2_loc (input_location
, MULT_EXPR
,
6962 size_type_node
, slen
,
6963 fold_convert (size_type_node
,
6965 gfc_add_expr_to_block (&body
, tmp
);
6967 /* Increment count. */
6968 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6969 count
, build_int_cst (TREE_TYPE (count
), 1));
6970 gfc_add_modify (&body
, count
, tmp
);
6972 /* Build the loop. */
6973 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6974 gfc_add_expr_to_block (&block
, tmp
);
6976 /* Add the exit label. */
6977 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6978 gfc_add_expr_to_block (&block
, tmp
);
6980 /* Finish the block. */
6981 tmp
= gfc_finish_block (&block
);
6982 gfc_add_expr_to_block (&se
->pre
, tmp
);
6984 /* Set the result value. */
6986 se
->string_length
= dlen
;
6990 /* Generate code for the IARGC intrinsic. */
6993 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6999 /* Call the library function. This always returns an INTEGER(4). */
7000 fndecl
= gfor_fndecl_iargc
;
7001 tmp
= build_call_expr_loc (input_location
,
7004 /* Convert it to the required type. */
7005 type
= gfc_typenode_for_spec (&expr
->ts
);
7006 tmp
= fold_convert (type
, tmp
);
7012 /* The loc intrinsic returns the address of its argument as
7013 gfc_index_integer_kind integer. */
7016 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7021 gcc_assert (!se
->ss
);
7023 arg_expr
= expr
->value
.function
.actual
->expr
;
7024 if (arg_expr
->rank
== 0)
7025 gfc_conv_expr_reference (se
, arg_expr
);
7027 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7028 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7030 /* Create a temporary variable for loc return value. Without this,
7031 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7032 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7033 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7034 se
->expr
= temp_var
;
7038 /* The following routine generates code for the intrinsic
7039 functions from the ISO_C_BINDING module:
7045 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7047 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7049 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7051 if (arg
->expr
->rank
== 0)
7052 gfc_conv_expr_reference (se
, arg
->expr
);
7053 else if (gfc_is_simply_contiguous (arg
->expr
, false))
7054 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7057 gfc_conv_expr_descriptor (se
, arg
->expr
);
7058 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7061 /* TODO -- the following two lines shouldn't be necessary, but if
7062 they're removed, a bug is exposed later in the code path.
7063 This workaround was thus introduced, but will have to be
7064 removed; please see PR 35150 for details about the issue. */
7065 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7066 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7068 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7069 gfc_conv_expr_reference (se
, arg
->expr
);
7070 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7075 /* Build the addr_expr for the first argument. The argument is
7076 already an *address* so we don't need to set want_pointer in
7078 gfc_init_se (&arg1se
, NULL
);
7079 gfc_conv_expr (&arg1se
, arg
->expr
);
7080 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7081 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7083 /* See if we were given two arguments. */
7084 if (arg
->next
->expr
== NULL
)
7085 /* Only given one arg so generate a null and do a
7086 not-equal comparison against the first arg. */
7087 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7089 fold_convert (TREE_TYPE (arg1se
.expr
),
7090 null_pointer_node
));
7096 /* Given two arguments so build the arg2se from second arg. */
7097 gfc_init_se (&arg2se
, NULL
);
7098 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
7099 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7100 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7102 /* Generate test to compare that the two args are equal. */
7103 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7104 arg1se
.expr
, arg2se
.expr
);
7105 /* Generate test to ensure that the first arg is not null. */
7106 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
7108 arg1se
.expr
, null_pointer_node
);
7110 /* Finally, the generated test must check that both arg1 is not
7111 NULL and that it is equal to the second arg. */
7112 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7114 not_null_expr
, eq_expr
);
7122 /* The following routine generates code for the intrinsic
7123 subroutines from the ISO_C_BINDING module:
7125 * C_F_PROCPOINTER. */
7128 conv_isocbinding_subroutine (gfc_code
*code
)
7135 tree desc
, dim
, tmp
, stride
, offset
;
7136 stmtblock_t body
, block
;
7138 gfc_actual_arglist
*arg
= code
->ext
.actual
;
7140 gfc_init_se (&se
, NULL
);
7141 gfc_init_se (&cptrse
, NULL
);
7142 gfc_conv_expr (&cptrse
, arg
->expr
);
7143 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
7144 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
7146 gfc_init_se (&fptrse
, NULL
);
7147 if (arg
->next
->expr
->rank
== 0)
7149 fptrse
.want_pointer
= 1;
7150 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
7151 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
7152 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
7153 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7154 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
7155 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
7157 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7158 TREE_TYPE (fptrse
.expr
),
7160 fold_convert (TREE_TYPE (fptrse
.expr
),
7162 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
7163 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7164 return gfc_finish_block (&se
.pre
);
7167 gfc_start_block (&block
);
7169 /* Get the descriptor of the Fortran pointer. */
7170 fptrse
.descriptor_only
= 1;
7171 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
7172 gfc_add_block_to_block (&block
, &fptrse
.pre
);
7175 /* Set data value, dtype, and offset. */
7176 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
7177 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
7178 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7179 gfc_get_dtype (TREE_TYPE (desc
)));
7181 /* Start scalarization of the bounds, using the shape argument. */
7183 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
7184 gcc_assert (shape_ss
!= gfc_ss_terminator
);
7185 gfc_init_se (&shapese
, NULL
);
7187 gfc_init_loopinfo (&loop
);
7188 gfc_add_ss_to_loop (&loop
, shape_ss
);
7189 gfc_conv_ss_startstride (&loop
);
7190 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
7191 gfc_mark_ss_chain_used (shape_ss
, 1);
7193 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
7194 shapese
.ss
= shape_ss
;
7196 stride
= gfc_create_var (gfc_array_index_type
, "stride");
7197 offset
= gfc_create_var (gfc_array_index_type
, "offset");
7198 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
7199 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7202 gfc_start_scalarized_body (&loop
, &body
);
7204 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7205 loop
.loopvar
[0], loop
.from
[0]);
7207 /* Set bounds and stride. */
7208 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
7209 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
7211 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
7212 gfc_add_block_to_block (&body
, &shapese
.pre
);
7213 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
7214 gfc_add_block_to_block (&body
, &shapese
.post
);
7216 /* Calculate offset. */
7217 gfc_add_modify (&body
, offset
,
7218 fold_build2_loc (input_location
, PLUS_EXPR
,
7219 gfc_array_index_type
, offset
, stride
));
7220 /* Update stride. */
7221 gfc_add_modify (&body
, stride
,
7222 fold_build2_loc (input_location
, MULT_EXPR
,
7223 gfc_array_index_type
, stride
,
7224 fold_convert (gfc_array_index_type
,
7226 /* Finish scalarization loop. */
7227 gfc_trans_scalarizing_loops (&loop
, &body
);
7228 gfc_add_block_to_block (&block
, &loop
.pre
);
7229 gfc_add_block_to_block (&block
, &loop
.post
);
7230 gfc_add_block_to_block (&block
, &fptrse
.post
);
7231 gfc_cleanup_loop (&loop
);
7233 gfc_add_modify (&block
, offset
,
7234 fold_build1_loc (input_location
, NEGATE_EXPR
,
7235 gfc_array_index_type
, offset
));
7236 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
7238 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
7239 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7240 return gfc_finish_block (&se
.pre
);
7244 /* Save and restore floating-point state. */
7247 gfc_save_fp_state (stmtblock_t
*block
)
7249 tree type
, fpstate
, tmp
;
7251 type
= build_array_type (char_type_node
,
7252 build_range_type (size_type_node
, size_zero_node
,
7253 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
7254 fpstate
= gfc_create_var (type
, "fpstate");
7255 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
7257 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
7259 gfc_add_expr_to_block (block
, tmp
);
7266 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
7270 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
7272 gfc_add_expr_to_block (block
, tmp
);
7276 /* Generate code for arguments of IEEE functions. */
7279 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
7282 gfc_actual_arglist
*actual
;
7287 actual
= expr
->value
.function
.actual
;
7288 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
7290 gcc_assert (actual
);
7293 gfc_init_se (&argse
, se
);
7294 gfc_conv_expr_val (&argse
, e
);
7296 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7297 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7298 argarray
[arg
] = argse
.expr
;
7303 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
7304 and IEEE_UNORDERED, which translate directly to GCC type-generic
7308 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
7309 enum built_in_function code
, int nargs
)
7312 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
7314 conv_ieee_function_args (se
, expr
, args
, nargs
);
7315 se
->expr
= build_call_expr_loc_array (input_location
,
7316 builtin_decl_explicit (code
),
7318 STRIP_TYPE_NOPS (se
->expr
);
7319 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7323 /* Generate code for IEEE_IS_NORMAL intrinsic:
7324 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
7327 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
7329 tree arg
, isnormal
, iszero
;
7331 /* Convert arg, evaluate it only once. */
7332 conv_ieee_function_args (se
, expr
, &arg
, 1);
7333 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7335 isnormal
= build_call_expr_loc (input_location
,
7336 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
7338 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
7339 build_real_from_int_cst (TREE_TYPE (arg
),
7340 integer_zero_node
));
7341 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7342 boolean_type_node
, isnormal
, iszero
);
7343 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7347 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
7348 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
7351 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
7353 tree arg
, signbit
, isnan
, decl
;
7356 /* Convert arg, evaluate it only once. */
7357 conv_ieee_function_args (se
, expr
, &arg
, 1);
7358 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7360 isnan
= build_call_expr_loc (input_location
,
7361 builtin_decl_explicit (BUILT_IN_ISNAN
),
7363 STRIP_TYPE_NOPS (isnan
);
7365 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
7366 decl
= builtin_decl_for_precision (BUILT_IN_SIGNBIT
, argprec
);
7367 signbit
= build_call_expr_loc (input_location
, decl
, 1, arg
);
7368 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7369 signbit
, integer_zero_node
);
7371 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7372 boolean_type_node
, signbit
,
7373 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
7374 TREE_TYPE(isnan
), isnan
));
7376 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7380 /* Generate code for IEEE_LOGB and IEEE_RINT. */
7383 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
7384 enum built_in_function code
)
7386 tree arg
, decl
, call
, fpstate
;
7389 conv_ieee_function_args (se
, expr
, &arg
, 1);
7390 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
7391 decl
= builtin_decl_for_precision (code
, argprec
);
7393 /* Save floating-point state. */
7394 fpstate
= gfc_save_fp_state (&se
->pre
);
7396 /* Make the function call. */
7397 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
7398 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
7400 /* Restore floating-point state. */
7401 gfc_restore_fp_state (&se
->post
, fpstate
);
7405 /* Generate code for IEEE_REM. */
7408 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
7410 tree args
[2], decl
, call
, fpstate
;
7413 conv_ieee_function_args (se
, expr
, args
, 2);
7415 /* If arguments have unequal size, convert them to the larger. */
7416 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
7417 > TYPE_PRECISION (TREE_TYPE (args
[1])))
7418 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7419 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
7420 > TYPE_PRECISION (TREE_TYPE (args
[0])))
7421 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
7423 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7424 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
7426 /* Save floating-point state. */
7427 fpstate
= gfc_save_fp_state (&se
->pre
);
7429 /* Make the function call. */
7430 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7431 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7433 /* Restore floating-point state. */
7434 gfc_restore_fp_state (&se
->post
, fpstate
);
7438 /* Generate code for IEEE_NEXT_AFTER. */
7441 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
7443 tree args
[2], decl
, call
, fpstate
;
7446 conv_ieee_function_args (se
, expr
, args
, 2);
7448 /* Result has the characteristics of first argument. */
7449 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7450 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7451 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
7453 /* Save floating-point state. */
7454 fpstate
= gfc_save_fp_state (&se
->pre
);
7456 /* Make the function call. */
7457 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7458 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7460 /* Restore floating-point state. */
7461 gfc_restore_fp_state (&se
->post
, fpstate
);
7465 /* Generate code for IEEE_SCALB. */
7468 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
7470 tree args
[2], decl
, call
, huge
, type
;
7473 conv_ieee_function_args (se
, expr
, args
, 2);
7475 /* Result has the characteristics of first argument. */
7476 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7477 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
7479 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
7481 /* We need to fold the integer into the range of a C int. */
7482 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
7483 type
= TREE_TYPE (args
[1]);
7485 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
7486 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
7488 huge
= fold_convert (type
, huge
);
7489 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
7491 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
7492 fold_build1_loc (input_location
, NEGATE_EXPR
,
7496 args
[1] = fold_convert (integer_type_node
, args
[1]);
7498 /* Make the function call. */
7499 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7500 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7504 /* Generate code for IEEE_COPY_SIGN. */
7507 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
7509 tree args
[2], decl
, sign
;
7512 conv_ieee_function_args (se
, expr
, args
, 2);
7514 /* Get the sign of the second argument. */
7515 argprec
= TYPE_PRECISION (TREE_TYPE (args
[1]));
7516 decl
= builtin_decl_for_precision (BUILT_IN_SIGNBIT
, argprec
);
7517 sign
= build_call_expr_loc (input_location
, decl
, 1, args
[1]);
7518 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7519 sign
, integer_zero_node
);
7521 /* Create a value of one, with the right sign. */
7522 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
7524 fold_build1_loc (input_location
, NEGATE_EXPR
,
7528 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
7530 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7531 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
7533 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7537 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
7541 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
7543 const char *name
= expr
->value
.function
.name
;
7545 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
7547 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
7548 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
7549 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
7550 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
7551 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
7552 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
7553 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
7554 conv_intrinsic_ieee_is_normal (se
, expr
);
7555 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
7556 conv_intrinsic_ieee_is_negative (se
, expr
);
7557 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
7558 conv_intrinsic_ieee_copy_sign (se
, expr
);
7559 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
7560 conv_intrinsic_ieee_scalb (se
, expr
);
7561 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
7562 conv_intrinsic_ieee_next_after (se
, expr
);
7563 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
7564 conv_intrinsic_ieee_rem (se
, expr
);
7565 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
7566 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
7567 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
7568 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
7570 /* It is not among the functions we translate directly. We return
7571 false, so a library function call is emitted. */
7580 /* Generate code for an intrinsic function. Some map directly to library
7581 calls, others get special handling. In some cases the name of the function
7582 used depends on the type specifiers. */
7585 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
7591 name
= &expr
->value
.function
.name
[2];
7595 lib
= gfc_is_intrinsic_libcall (expr
);
7599 se
->ignore_optional
= 1;
7601 switch (expr
->value
.function
.isym
->id
)
7603 case GFC_ISYM_EOSHIFT
:
7605 case GFC_ISYM_RESHAPE
:
7606 /* For all of those the first argument specifies the type and the
7607 third is optional. */
7608 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
7612 gfc_conv_intrinsic_funcall (se
, expr
);
7620 switch (expr
->value
.function
.isym
->id
)
7625 case GFC_ISYM_REPEAT
:
7626 gfc_conv_intrinsic_repeat (se
, expr
);
7630 gfc_conv_intrinsic_trim (se
, expr
);
7633 case GFC_ISYM_SC_KIND
:
7634 gfc_conv_intrinsic_sc_kind (se
, expr
);
7637 case GFC_ISYM_SI_KIND
:
7638 gfc_conv_intrinsic_si_kind (se
, expr
);
7641 case GFC_ISYM_SR_KIND
:
7642 gfc_conv_intrinsic_sr_kind (se
, expr
);
7645 case GFC_ISYM_EXPONENT
:
7646 gfc_conv_intrinsic_exponent (se
, expr
);
7650 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7652 fndecl
= gfor_fndecl_string_scan
;
7654 fndecl
= gfor_fndecl_string_scan_char4
;
7658 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7661 case GFC_ISYM_VERIFY
:
7662 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7664 fndecl
= gfor_fndecl_string_verify
;
7666 fndecl
= gfor_fndecl_string_verify_char4
;
7670 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7673 case GFC_ISYM_ALLOCATED
:
7674 gfc_conv_allocated (se
, expr
);
7677 case GFC_ISYM_ASSOCIATED
:
7678 gfc_conv_associated(se
, expr
);
7681 case GFC_ISYM_SAME_TYPE_AS
:
7682 gfc_conv_same_type_as (se
, expr
);
7686 gfc_conv_intrinsic_abs (se
, expr
);
7689 case GFC_ISYM_ADJUSTL
:
7690 if (expr
->ts
.kind
== 1)
7691 fndecl
= gfor_fndecl_adjustl
;
7692 else if (expr
->ts
.kind
== 4)
7693 fndecl
= gfor_fndecl_adjustl_char4
;
7697 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7700 case GFC_ISYM_ADJUSTR
:
7701 if (expr
->ts
.kind
== 1)
7702 fndecl
= gfor_fndecl_adjustr
;
7703 else if (expr
->ts
.kind
== 4)
7704 fndecl
= gfor_fndecl_adjustr_char4
;
7708 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7711 case GFC_ISYM_AIMAG
:
7712 gfc_conv_intrinsic_imagpart (se
, expr
);
7716 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
7720 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
7723 case GFC_ISYM_ANINT
:
7724 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
7728 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7732 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
7735 case GFC_ISYM_BTEST
:
7736 gfc_conv_intrinsic_btest (se
, expr
);
7740 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
7744 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
7748 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
7752 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
7755 case GFC_ISYM_C_ASSOCIATED
:
7756 case GFC_ISYM_C_FUNLOC
:
7757 case GFC_ISYM_C_LOC
:
7758 conv_isocbinding_function (se
, expr
);
7761 case GFC_ISYM_ACHAR
:
7763 gfc_conv_intrinsic_char (se
, expr
);
7766 case GFC_ISYM_CONVERSION
:
7768 case GFC_ISYM_LOGICAL
:
7770 gfc_conv_intrinsic_conversion (se
, expr
);
7773 /* Integer conversions are handled separately to make sure we get the
7774 correct rounding mode. */
7779 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
7783 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
7786 case GFC_ISYM_CEILING
:
7787 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
7790 case GFC_ISYM_FLOOR
:
7791 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
7795 gfc_conv_intrinsic_mod (se
, expr
, 0);
7798 case GFC_ISYM_MODULO
:
7799 gfc_conv_intrinsic_mod (se
, expr
, 1);
7802 case GFC_ISYM_CAF_GET
:
7803 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
);
7806 case GFC_ISYM_CMPLX
:
7807 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
7810 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
7811 gfc_conv_intrinsic_iargc (se
, expr
);
7814 case GFC_ISYM_COMPLEX
:
7815 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
7818 case GFC_ISYM_CONJG
:
7819 gfc_conv_intrinsic_conjg (se
, expr
);
7822 case GFC_ISYM_COUNT
:
7823 gfc_conv_intrinsic_count (se
, expr
);
7826 case GFC_ISYM_CTIME
:
7827 gfc_conv_intrinsic_ctime (se
, expr
);
7831 gfc_conv_intrinsic_dim (se
, expr
);
7834 case GFC_ISYM_DOT_PRODUCT
:
7835 gfc_conv_intrinsic_dot_product (se
, expr
);
7838 case GFC_ISYM_DPROD
:
7839 gfc_conv_intrinsic_dprod (se
, expr
);
7842 case GFC_ISYM_DSHIFTL
:
7843 gfc_conv_intrinsic_dshift (se
, expr
, true);
7846 case GFC_ISYM_DSHIFTR
:
7847 gfc_conv_intrinsic_dshift (se
, expr
, false);
7850 case GFC_ISYM_FDATE
:
7851 gfc_conv_intrinsic_fdate (se
, expr
);
7854 case GFC_ISYM_FRACTION
:
7855 gfc_conv_intrinsic_fraction (se
, expr
);
7859 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
7863 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7867 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
7870 case GFC_ISYM_IBCLR
:
7871 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
7874 case GFC_ISYM_IBITS
:
7875 gfc_conv_intrinsic_ibits (se
, expr
);
7878 case GFC_ISYM_IBSET
:
7879 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
7882 case GFC_ISYM_IACHAR
:
7883 case GFC_ISYM_ICHAR
:
7884 /* We assume ASCII character sequence. */
7885 gfc_conv_intrinsic_ichar (se
, expr
);
7888 case GFC_ISYM_IARGC
:
7889 gfc_conv_intrinsic_iargc (se
, expr
);
7893 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
7896 case GFC_ISYM_INDEX
:
7897 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7899 fndecl
= gfor_fndecl_string_index
;
7901 fndecl
= gfor_fndecl_string_index_char4
;
7905 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7909 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
7912 case GFC_ISYM_IPARITY
:
7913 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
7916 case GFC_ISYM_IS_IOSTAT_END
:
7917 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
7920 case GFC_ISYM_IS_IOSTAT_EOR
:
7921 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
7924 case GFC_ISYM_ISNAN
:
7925 gfc_conv_intrinsic_isnan (se
, expr
);
7928 case GFC_ISYM_LSHIFT
:
7929 gfc_conv_intrinsic_shift (se
, expr
, false, false);
7932 case GFC_ISYM_RSHIFT
:
7933 gfc_conv_intrinsic_shift (se
, expr
, true, true);
7936 case GFC_ISYM_SHIFTA
:
7937 gfc_conv_intrinsic_shift (se
, expr
, true, true);
7940 case GFC_ISYM_SHIFTL
:
7941 gfc_conv_intrinsic_shift (se
, expr
, false, false);
7944 case GFC_ISYM_SHIFTR
:
7945 gfc_conv_intrinsic_shift (se
, expr
, true, false);
7948 case GFC_ISYM_ISHFT
:
7949 gfc_conv_intrinsic_ishft (se
, expr
);
7952 case GFC_ISYM_ISHFTC
:
7953 gfc_conv_intrinsic_ishftc (se
, expr
);
7956 case GFC_ISYM_LEADZ
:
7957 gfc_conv_intrinsic_leadz (se
, expr
);
7960 case GFC_ISYM_TRAILZ
:
7961 gfc_conv_intrinsic_trailz (se
, expr
);
7964 case GFC_ISYM_POPCNT
:
7965 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
7968 case GFC_ISYM_POPPAR
:
7969 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
7972 case GFC_ISYM_LBOUND
:
7973 gfc_conv_intrinsic_bound (se
, expr
, 0);
7976 case GFC_ISYM_LCOBOUND
:
7977 conv_intrinsic_cobound (se
, expr
);
7980 case GFC_ISYM_TRANSPOSE
:
7981 /* The scalarizer has already been set up for reversed dimension access
7982 order ; now we just get the argument value normally. */
7983 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
7987 gfc_conv_intrinsic_len (se
, expr
);
7990 case GFC_ISYM_LEN_TRIM
:
7991 gfc_conv_intrinsic_len_trim (se
, expr
);
7995 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
7999 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
8003 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
8007 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
8010 case GFC_ISYM_MASKL
:
8011 gfc_conv_intrinsic_mask (se
, expr
, 1);
8014 case GFC_ISYM_MASKR
:
8015 gfc_conv_intrinsic_mask (se
, expr
, 0);
8019 if (expr
->ts
.type
== BT_CHARACTER
)
8020 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
8022 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
8025 case GFC_ISYM_MAXLOC
:
8026 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8029 case GFC_ISYM_MAXVAL
:
8030 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
8033 case GFC_ISYM_MERGE
:
8034 gfc_conv_intrinsic_merge (se
, expr
);
8037 case GFC_ISYM_MERGE_BITS
:
8038 gfc_conv_intrinsic_merge_bits (se
, expr
);
8042 if (expr
->ts
.type
== BT_CHARACTER
)
8043 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
8045 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
8048 case GFC_ISYM_MINLOC
:
8049 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8052 case GFC_ISYM_MINVAL
:
8053 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
8056 case GFC_ISYM_NEAREST
:
8057 gfc_conv_intrinsic_nearest (se
, expr
);
8060 case GFC_ISYM_NORM2
:
8061 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
8065 gfc_conv_intrinsic_not (se
, expr
);
8069 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8072 case GFC_ISYM_PARITY
:
8073 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
8076 case GFC_ISYM_PRESENT
:
8077 gfc_conv_intrinsic_present (se
, expr
);
8080 case GFC_ISYM_PRODUCT
:
8081 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
8085 gfc_conv_intrinsic_rank (se
, expr
);
8088 case GFC_ISYM_RRSPACING
:
8089 gfc_conv_intrinsic_rrspacing (se
, expr
);
8092 case GFC_ISYM_SET_EXPONENT
:
8093 gfc_conv_intrinsic_set_exponent (se
, expr
);
8096 case GFC_ISYM_SCALE
:
8097 gfc_conv_intrinsic_scale (se
, expr
);
8101 gfc_conv_intrinsic_sign (se
, expr
);
8105 gfc_conv_intrinsic_size (se
, expr
);
8108 case GFC_ISYM_SIZEOF
:
8109 case GFC_ISYM_C_SIZEOF
:
8110 gfc_conv_intrinsic_sizeof (se
, expr
);
8113 case GFC_ISYM_STORAGE_SIZE
:
8114 gfc_conv_intrinsic_storage_size (se
, expr
);
8117 case GFC_ISYM_SPACING
:
8118 gfc_conv_intrinsic_spacing (se
, expr
);
8121 case GFC_ISYM_STRIDE
:
8122 conv_intrinsic_stride (se
, expr
);
8126 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
8129 case GFC_ISYM_TRANSFER
:
8130 if (se
->ss
&& se
->ss
->info
->useflags
)
8131 /* Access the previously obtained result. */
8132 gfc_conv_tmp_array_ref (se
);
8134 gfc_conv_intrinsic_transfer (se
, expr
);
8137 case GFC_ISYM_TTYNAM
:
8138 gfc_conv_intrinsic_ttynam (se
, expr
);
8141 case GFC_ISYM_UBOUND
:
8142 gfc_conv_intrinsic_bound (se
, expr
, 1);
8145 case GFC_ISYM_UCOBOUND
:
8146 conv_intrinsic_cobound (se
, expr
);
8150 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8154 gfc_conv_intrinsic_loc (se
, expr
);
8157 case GFC_ISYM_THIS_IMAGE
:
8158 /* For num_images() == 1, handle as LCOBOUND. */
8159 if (expr
->value
.function
.actual
->expr
8160 && flag_coarray
== GFC_FCOARRAY_SINGLE
)
8161 conv_intrinsic_cobound (se
, expr
);
8163 trans_this_image (se
, expr
);
8166 case GFC_ISYM_IMAGE_INDEX
:
8167 trans_image_index (se
, expr
);
8170 case GFC_ISYM_NUM_IMAGES
:
8171 trans_num_images (se
, expr
);
8174 case GFC_ISYM_ACCESS
:
8175 case GFC_ISYM_CHDIR
:
8176 case GFC_ISYM_CHMOD
:
8177 case GFC_ISYM_DTIME
:
8178 case GFC_ISYM_ETIME
:
8179 case GFC_ISYM_EXTENDS_TYPE_OF
:
8181 case GFC_ISYM_FGETC
:
8184 case GFC_ISYM_FPUTC
:
8185 case GFC_ISYM_FSTAT
:
8186 case GFC_ISYM_FTELL
:
8187 case GFC_ISYM_GETCWD
:
8188 case GFC_ISYM_GETGID
:
8189 case GFC_ISYM_GETPID
:
8190 case GFC_ISYM_GETUID
:
8191 case GFC_ISYM_HOSTNM
:
8193 case GFC_ISYM_IERRNO
:
8194 case GFC_ISYM_IRAND
:
8195 case GFC_ISYM_ISATTY
:
8198 case GFC_ISYM_LSTAT
:
8199 case GFC_ISYM_MALLOC
:
8200 case GFC_ISYM_MATMUL
:
8201 case GFC_ISYM_MCLOCK
:
8202 case GFC_ISYM_MCLOCK8
:
8204 case GFC_ISYM_RENAME
:
8205 case GFC_ISYM_SECOND
:
8206 case GFC_ISYM_SECNDS
:
8207 case GFC_ISYM_SIGNAL
:
8209 case GFC_ISYM_SYMLNK
:
8210 case GFC_ISYM_SYSTEM
:
8212 case GFC_ISYM_TIME8
:
8213 case GFC_ISYM_UMASK
:
8214 case GFC_ISYM_UNLINK
:
8216 gfc_conv_intrinsic_funcall (se
, expr
);
8219 case GFC_ISYM_EOSHIFT
:
8221 case GFC_ISYM_RESHAPE
:
8222 /* For those, expr->rank should always be >0 and thus the if above the
8223 switch should have matched. */
8228 gfc_conv_intrinsic_lib_function (se
, expr
);
8235 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
8237 gfc_ss
*arg_ss
, *tmp_ss
;
8238 gfc_actual_arglist
*arg
;
8240 arg
= expr
->value
.function
.actual
;
8242 gcc_assert (arg
->expr
);
8244 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
8245 gcc_assert (arg_ss
!= gfc_ss_terminator
);
8247 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
8249 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
8250 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
8254 gcc_assert (tmp_ss
->dimen
== 2);
8256 /* We just invert dimensions. */
8257 tmp_dim
= tmp_ss
->dim
[0];
8258 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
8259 tmp_ss
->dim
[1] = tmp_dim
;
8262 /* Stop when tmp_ss points to the last valid element of the chain... */
8263 if (tmp_ss
->next
== gfc_ss_terminator
)
8267 /* ... so that we can attach the rest of the chain to it. */
8274 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
8275 This has the side effect of reversing the nested list, so there is no
8276 need to call gfc_reverse_ss on it (the given list is assumed not to be
8280 nest_loop_dimension (gfc_ss
*ss
, int dim
)
8283 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
8284 gfc_loopinfo
*new_loop
;
8286 gcc_assert (ss
!= gfc_ss_terminator
);
8288 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
8290 new_ss
= gfc_get_ss ();
8291 new_ss
->next
= prev_ss
;
8292 new_ss
->parent
= ss
;
8293 new_ss
->info
= ss
->info
;
8294 new_ss
->info
->refcount
++;
8297 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
8298 && ss
->info
->type
!= GFC_SS_REFERENCE
);
8301 new_ss
->dim
[0] = ss
->dim
[dim
];
8303 gcc_assert (dim
< ss
->dimen
);
8305 ss_dim
= --ss
->dimen
;
8306 for (i
= dim
; i
< ss_dim
; i
++)
8307 ss
->dim
[i
] = ss
->dim
[i
+ 1];
8309 ss
->dim
[ss_dim
] = 0;
8315 ss
->nested_ss
->parent
= new_ss
;
8316 new_ss
->nested_ss
= ss
->nested_ss
;
8318 ss
->nested_ss
= new_ss
;
8321 new_loop
= gfc_get_loopinfo ();
8322 gfc_init_loopinfo (new_loop
);
8324 gcc_assert (prev_ss
!= NULL
);
8325 gcc_assert (prev_ss
!= gfc_ss_terminator
);
8326 gfc_add_ss_to_loop (new_loop
, prev_ss
);
8327 return new_ss
->parent
;
8331 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
8332 is to be inlined. */
8335 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
8337 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
8338 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
8340 bool scalar_mask
= false;
8342 /* The rank of the result will be determined later. */
8343 arg1
= expr
->value
.function
.actual
;
8346 gcc_assert (arg3
!= NULL
);
8348 if (expr
->rank
== 0)
8351 tmp_ss
= gfc_ss_terminator
;
8357 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
8358 if (mask_ss
== tmp_ss
)
8364 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
8365 gcc_assert (array_ss
!= tmp_ss
);
8367 /* Odd thing: If the mask is scalar, it is used by the frontend after
8368 the array (to make an if around the nested loop). Thus it shall
8369 be after array_ss once the gfc_ss list is reversed. */
8371 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
8375 /* "Hide" the dimension on which we will sum in the first arg's scalarization
8377 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
8378 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
8386 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
8389 switch (expr
->value
.function
.isym
->id
)
8391 case GFC_ISYM_PRODUCT
:
8393 return walk_inline_intrinsic_arith (ss
, expr
);
8395 case GFC_ISYM_TRANSPOSE
:
8396 return walk_inline_intrinsic_transpose (ss
, expr
);
8405 /* This generates code to execute before entering the scalarization loop.
8406 Currently does nothing. */
8409 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
8411 switch (ss
->info
->expr
->value
.function
.isym
->id
)
8413 case GFC_ISYM_UBOUND
:
8414 case GFC_ISYM_LBOUND
:
8415 case GFC_ISYM_UCOBOUND
:
8416 case GFC_ISYM_LCOBOUND
:
8417 case GFC_ISYM_THIS_IMAGE
:
8426 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
8427 are expanded into code inside the scalarization loop. */
8430 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
8432 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
8433 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
8435 /* The two argument version returns a scalar. */
8436 if (expr
->value
.function
.actual
->next
->expr
)
8439 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
8443 /* Walk an intrinsic array libcall. */
8446 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
8448 gcc_assert (expr
->rank
> 0);
8449 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8453 /* Return whether the function call expression EXPR will be expanded
8454 inline by gfc_conv_intrinsic_function. */
8457 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
8459 gfc_actual_arglist
*args
;
8461 if (!expr
->value
.function
.isym
)
8464 switch (expr
->value
.function
.isym
->id
)
8466 case GFC_ISYM_PRODUCT
:
8468 /* Disable inline expansion if code size matters. */
8472 args
= expr
->value
.function
.actual
;
8473 /* We need to be able to subset the SUM argument at compile-time. */
8474 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
8479 case GFC_ISYM_TRANSPOSE
:
8488 /* Returns nonzero if the specified intrinsic function call maps directly to
8489 an external library call. Should only be used for functions that return
8493 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
8495 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
8496 gcc_assert (expr
->rank
> 0);
8498 if (gfc_inline_intrinsic_function_p (expr
))
8501 switch (expr
->value
.function
.isym
->id
)
8505 case GFC_ISYM_COUNT
:
8509 case GFC_ISYM_IPARITY
:
8510 case GFC_ISYM_MATMUL
:
8511 case GFC_ISYM_MAXLOC
:
8512 case GFC_ISYM_MAXVAL
:
8513 case GFC_ISYM_MINLOC
:
8514 case GFC_ISYM_MINVAL
:
8515 case GFC_ISYM_NORM2
:
8516 case GFC_ISYM_PARITY
:
8517 case GFC_ISYM_PRODUCT
:
8519 case GFC_ISYM_SHAPE
:
8520 case GFC_ISYM_SPREAD
:
8522 /* Ignore absent optional parameters. */
8525 case GFC_ISYM_RESHAPE
:
8526 case GFC_ISYM_CSHIFT
:
8527 case GFC_ISYM_EOSHIFT
:
8529 case GFC_ISYM_UNPACK
:
8530 /* Pass absent optional parameters. */
8538 /* Walk an intrinsic function. */
8540 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
8541 gfc_intrinsic_sym
* isym
)
8545 if (isym
->elemental
)
8546 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8547 NULL
, GFC_SS_SCALAR
);
8549 if (expr
->rank
== 0)
8552 if (gfc_inline_intrinsic_function_p (expr
))
8553 return walk_inline_intrinsic_function (ss
, expr
);
8555 if (gfc_is_intrinsic_libcall (expr
))
8556 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8558 /* Special cases. */
8561 case GFC_ISYM_LBOUND
:
8562 case GFC_ISYM_LCOBOUND
:
8563 case GFC_ISYM_UBOUND
:
8564 case GFC_ISYM_UCOBOUND
:
8565 case GFC_ISYM_THIS_IMAGE
:
8566 return gfc_walk_intrinsic_bound (ss
, expr
);
8568 case GFC_ISYM_TRANSFER
:
8569 case GFC_ISYM_CAF_GET
:
8570 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8573 /* This probably meant someone forgot to add an intrinsic to the above
8574 list(s) when they implemented it, or something's gone horribly
8582 conv_co_collective (gfc_code
*code
)
8585 stmtblock_t block
, post_block
;
8586 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
8587 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
8589 gfc_start_block (&block
);
8590 gfc_init_block (&post_block
);
8592 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
8594 opr_expr
= code
->ext
.actual
->next
->expr
;
8595 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
8596 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8597 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
8602 image_idx_expr
= code
->ext
.actual
->next
->expr
;
8603 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8604 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8610 gfc_init_se (&argse
, NULL
);
8611 gfc_conv_expr (&argse
, stat_expr
);
8612 gfc_add_block_to_block (&block
, &argse
.pre
);
8613 gfc_add_block_to_block (&post_block
, &argse
.post
);
8615 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8616 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
8618 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8621 stat
= null_pointer_node
;
8623 /* Early exit for GFC_FCOARRAY_SINGLE. */
8624 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
8626 if (stat
!= NULL_TREE
)
8627 gfc_add_modify (&block
, stat
,
8628 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
8629 return gfc_finish_block (&block
);
8632 /* Handle the array. */
8633 gfc_init_se (&argse
, NULL
);
8634 if (code
->ext
.actual
->expr
->rank
== 0)
8636 symbol_attribute attr
;
8637 gfc_clear_attr (&attr
);
8638 gfc_init_se (&argse
, NULL
);
8639 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8640 gfc_add_block_to_block (&block
, &argse
.pre
);
8641 gfc_add_block_to_block (&post_block
, &argse
.post
);
8642 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
8643 array
= gfc_build_addr_expr (NULL_TREE
, array
);
8647 argse
.want_pointer
= 1;
8648 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
8651 gfc_add_block_to_block (&block
, &argse
.pre
);
8652 gfc_add_block_to_block (&post_block
, &argse
.post
);
8654 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
8655 strlen
= argse
.string_length
;
8657 strlen
= integer_zero_node
;
8662 gfc_init_se (&argse
, NULL
);
8663 gfc_conv_expr (&argse
, image_idx_expr
);
8664 gfc_add_block_to_block (&block
, &argse
.pre
);
8665 gfc_add_block_to_block (&post_block
, &argse
.post
);
8666 image_index
= fold_convert (integer_type_node
, argse
.expr
);
8669 image_index
= integer_zero_node
;
8674 gfc_init_se (&argse
, NULL
);
8675 gfc_conv_expr (&argse
, errmsg_expr
);
8676 gfc_add_block_to_block (&block
, &argse
.pre
);
8677 gfc_add_block_to_block (&post_block
, &argse
.post
);
8678 errmsg
= argse
.expr
;
8679 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
8683 errmsg
= null_pointer_node
;
8684 errmsg_len
= integer_zero_node
;
8687 /* Generate the function call. */
8688 switch (code
->resolved_isym
->id
)
8690 case GFC_ISYM_CO_BROADCAST
:
8691 fndecl
= gfor_fndecl_co_broadcast
;
8693 case GFC_ISYM_CO_MAX
:
8694 fndecl
= gfor_fndecl_co_max
;
8696 case GFC_ISYM_CO_MIN
:
8697 fndecl
= gfor_fndecl_co_min
;
8699 case GFC_ISYM_CO_REDUCE
:
8700 fndecl
= gfor_fndecl_co_reduce
;
8702 case GFC_ISYM_CO_SUM
:
8703 fndecl
= gfor_fndecl_co_sum
;
8709 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
8710 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
8711 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
8712 image_index
, stat
, errmsg
, errmsg_len
);
8713 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
8714 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
8715 stat
, errmsg
, strlen
, errmsg_len
);
8718 tree opr
, opr_flags
;
8720 // FIXME: Handle TS29113's bind(C) strings with descriptor.
8722 if (gfc_is_proc_ptr_comp (opr_expr
))
8724 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
8725 opr_flag_int
= sym
->attr
.dimension
8726 || (sym
->ts
.type
== BT_CHARACTER
8727 && !sym
->attr
.is_bind_c
)
8728 ? GFC_CAF_BYREF
: 0;
8729 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8730 && !sym
->attr
.is_bind_c
8731 ? GFC_CAF_HIDDENLEN
: 0;
8732 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
8736 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
8737 ? GFC_CAF_BYREF
: 0;
8738 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8739 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
8740 ? GFC_CAF_HIDDENLEN
: 0;
8741 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
8742 ? GFC_CAF_ARG_VALUE
: 0;
8744 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
8745 gfc_conv_expr (&argse
, opr_expr
);
8746 opr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
8747 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
8748 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
8751 gfc_add_expr_to_block (&block
, fndecl
);
8752 gfc_add_block_to_block (&block
, &post_block
);
8754 return gfc_finish_block (&block
);
8759 conv_intrinsic_atomic_op (gfc_code
*code
)
8762 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
8763 stmtblock_t block
, post_block
;
8764 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
8765 gfc_expr
*stat_expr
;
8766 built_in_function fn
;
8768 if (atom_expr
->expr_type
== EXPR_FUNCTION
8769 && atom_expr
->value
.function
.isym
8770 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8771 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8773 gfc_start_block (&block
);
8774 gfc_init_block (&post_block
);
8776 gfc_init_se (&argse
, NULL
);
8777 argse
.want_pointer
= 1;
8778 gfc_conv_expr (&argse
, atom_expr
);
8779 gfc_add_block_to_block (&block
, &argse
.pre
);
8780 gfc_add_block_to_block (&post_block
, &argse
.post
);
8783 gfc_init_se (&argse
, NULL
);
8784 if (flag_coarray
== GFC_FCOARRAY_LIB
8785 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8786 argse
.want_pointer
= 1;
8787 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
8788 gfc_add_block_to_block (&block
, &argse
.pre
);
8789 gfc_add_block_to_block (&post_block
, &argse
.post
);
8792 switch (code
->resolved_isym
->id
)
8794 case GFC_ISYM_ATOMIC_ADD
:
8795 case GFC_ISYM_ATOMIC_AND
:
8796 case GFC_ISYM_ATOMIC_DEF
:
8797 case GFC_ISYM_ATOMIC_OR
:
8798 case GFC_ISYM_ATOMIC_XOR
:
8799 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8800 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8801 old
= null_pointer_node
;
8804 gfc_init_se (&argse
, NULL
);
8805 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8806 argse
.want_pointer
= 1;
8807 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
8808 gfc_add_block_to_block (&block
, &argse
.pre
);
8809 gfc_add_block_to_block (&post_block
, &argse
.post
);
8811 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8815 if (stat_expr
!= NULL
)
8817 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
8818 gfc_init_se (&argse
, NULL
);
8819 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8820 argse
.want_pointer
= 1;
8821 gfc_conv_expr_val (&argse
, stat_expr
);
8822 gfc_add_block_to_block (&block
, &argse
.pre
);
8823 gfc_add_block_to_block (&post_block
, &argse
.post
);
8826 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
8827 stat
= null_pointer_node
;
8829 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8831 tree image_index
, caf_decl
, offset
, token
;
8834 switch (code
->resolved_isym
->id
)
8836 case GFC_ISYM_ATOMIC_ADD
:
8837 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8838 op
= (int) GFC_CAF_ATOMIC_ADD
;
8840 case GFC_ISYM_ATOMIC_AND
:
8841 case GFC_ISYM_ATOMIC_FETCH_AND
:
8842 op
= (int) GFC_CAF_ATOMIC_AND
;
8844 case GFC_ISYM_ATOMIC_OR
:
8845 case GFC_ISYM_ATOMIC_FETCH_OR
:
8846 op
= (int) GFC_CAF_ATOMIC_OR
;
8848 case GFC_ISYM_ATOMIC_XOR
:
8849 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8850 op
= (int) GFC_CAF_ATOMIC_XOR
;
8852 case GFC_ISYM_ATOMIC_DEF
:
8853 op
= 0; /* Unused. */
8859 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
8860 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8861 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8863 if (gfc_is_coindexed (atom_expr
))
8864 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
8866 image_index
= integer_zero_node
;
8868 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
8870 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
8871 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
8872 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8875 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
8877 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
8878 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
8879 token
, offset
, image_index
, value
, stat
,
8880 build_int_cst (integer_type_node
,
8881 (int) atom_expr
->ts
.type
),
8882 build_int_cst (integer_type_node
,
8883 (int) atom_expr
->ts
.kind
));
8885 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
8886 build_int_cst (integer_type_node
, op
),
8887 token
, offset
, image_index
, value
, old
, stat
,
8888 build_int_cst (integer_type_node
,
8889 (int) atom_expr
->ts
.type
),
8890 build_int_cst (integer_type_node
,
8891 (int) atom_expr
->ts
.kind
));
8893 gfc_add_expr_to_block (&block
, tmp
);
8894 gfc_add_block_to_block (&block
, &post_block
);
8895 return gfc_finish_block (&block
);
8899 switch (code
->resolved_isym
->id
)
8901 case GFC_ISYM_ATOMIC_ADD
:
8902 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8903 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
8905 case GFC_ISYM_ATOMIC_AND
:
8906 case GFC_ISYM_ATOMIC_FETCH_AND
:
8907 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
8909 case GFC_ISYM_ATOMIC_DEF
:
8910 fn
= BUILT_IN_ATOMIC_STORE_N
;
8912 case GFC_ISYM_ATOMIC_OR
:
8913 case GFC_ISYM_ATOMIC_FETCH_OR
:
8914 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
8916 case GFC_ISYM_ATOMIC_XOR
:
8917 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8918 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
8924 tmp
= TREE_TYPE (TREE_TYPE (atom
));
8925 fn
= (built_in_function
) ((int) fn
8926 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
8928 tmp
= builtin_decl_explicit (fn
);
8929 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
8930 tmp
= builtin_decl_explicit (fn
);
8932 switch (code
->resolved_isym
->id
)
8934 case GFC_ISYM_ATOMIC_ADD
:
8935 case GFC_ISYM_ATOMIC_AND
:
8936 case GFC_ISYM_ATOMIC_DEF
:
8937 case GFC_ISYM_ATOMIC_OR
:
8938 case GFC_ISYM_ATOMIC_XOR
:
8939 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
8940 fold_convert (itype
, value
),
8941 build_int_cst (NULL
, MEMMODEL_RELAXED
));
8942 gfc_add_expr_to_block (&block
, tmp
);
8945 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
8946 fold_convert (itype
, value
),
8947 build_int_cst (NULL
, MEMMODEL_RELAXED
));
8948 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
8952 if (stat
!= NULL_TREE
)
8953 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
8954 gfc_add_block_to_block (&block
, &post_block
);
8955 return gfc_finish_block (&block
);
8960 conv_intrinsic_atomic_ref (gfc_code
*code
)
8963 tree tmp
, atom
, value
, stat
= NULL_TREE
;
8964 stmtblock_t block
, post_block
;
8965 built_in_function fn
;
8966 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
8968 if (atom_expr
->expr_type
== EXPR_FUNCTION
8969 && atom_expr
->value
.function
.isym
8970 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8971 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8973 gfc_start_block (&block
);
8974 gfc_init_block (&post_block
);
8975 gfc_init_se (&argse
, NULL
);
8976 argse
.want_pointer
= 1;
8977 gfc_conv_expr (&argse
, atom_expr
);
8978 gfc_add_block_to_block (&block
, &argse
.pre
);
8979 gfc_add_block_to_block (&post_block
, &argse
.post
);
8982 gfc_init_se (&argse
, NULL
);
8983 if (flag_coarray
== GFC_FCOARRAY_LIB
8984 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8985 argse
.want_pointer
= 1;
8986 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8987 gfc_add_block_to_block (&block
, &argse
.pre
);
8988 gfc_add_block_to_block (&post_block
, &argse
.post
);
8992 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
8994 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
8996 gfc_init_se (&argse
, NULL
);
8997 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8998 argse
.want_pointer
= 1;
8999 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
9000 gfc_add_block_to_block (&block
, &argse
.pre
);
9001 gfc_add_block_to_block (&post_block
, &argse
.post
);
9004 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9005 stat
= null_pointer_node
;
9007 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9009 tree image_index
, caf_decl
, offset
, token
;
9010 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
9012 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9013 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9014 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9016 if (gfc_is_coindexed (atom_expr
))
9017 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9019 image_index
= integer_zero_node
;
9021 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9023 /* Different type, need type conversion. */
9024 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9026 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9028 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
9031 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
9032 token
, offset
, image_index
, value
, stat
,
9033 build_int_cst (integer_type_node
,
9034 (int) atom_expr
->ts
.type
),
9035 build_int_cst (integer_type_node
,
9036 (int) atom_expr
->ts
.kind
));
9037 gfc_add_expr_to_block (&block
, tmp
);
9038 if (vardecl
!= NULL_TREE
)
9039 gfc_add_modify (&block
, orig_value
,
9040 fold_convert (TREE_TYPE (orig_value
), vardecl
));
9041 gfc_add_block_to_block (&block
, &post_block
);
9042 return gfc_finish_block (&block
);
9045 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9046 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
9047 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9049 tmp
= builtin_decl_explicit (fn
);
9050 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
9051 build_int_cst (integer_type_node
,
9053 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
9055 if (stat
!= NULL_TREE
)
9056 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9057 gfc_add_block_to_block (&block
, &post_block
);
9058 return gfc_finish_block (&block
);
9063 conv_intrinsic_atomic_cas (gfc_code
*code
)
9066 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
9067 stmtblock_t block
, post_block
;
9068 built_in_function fn
;
9069 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9071 if (atom_expr
->expr_type
== EXPR_FUNCTION
9072 && atom_expr
->value
.function
.isym
9073 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9074 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9076 gfc_init_block (&block
);
9077 gfc_init_block (&post_block
);
9078 gfc_init_se (&argse
, NULL
);
9079 argse
.want_pointer
= 1;
9080 gfc_conv_expr (&argse
, atom_expr
);
9083 gfc_init_se (&argse
, NULL
);
9084 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9085 argse
.want_pointer
= 1;
9086 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9087 gfc_add_block_to_block (&block
, &argse
.pre
);
9088 gfc_add_block_to_block (&post_block
, &argse
.post
);
9091 gfc_init_se (&argse
, NULL
);
9092 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9093 argse
.want_pointer
= 1;
9094 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9095 gfc_add_block_to_block (&block
, &argse
.pre
);
9096 gfc_add_block_to_block (&post_block
, &argse
.post
);
9099 gfc_init_se (&argse
, NULL
);
9100 if (flag_coarray
== GFC_FCOARRAY_LIB
9101 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
9102 == atom_expr
->ts
.kind
)
9103 argse
.want_pointer
= 1;
9104 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
9105 gfc_add_block_to_block (&block
, &argse
.pre
);
9106 gfc_add_block_to_block (&post_block
, &argse
.post
);
9107 new_val
= argse
.expr
;
9110 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
9112 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
9114 gfc_init_se (&argse
, NULL
);
9115 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9116 argse
.want_pointer
= 1;
9117 gfc_conv_expr_val (&argse
,
9118 code
->ext
.actual
->next
->next
->next
->next
->expr
);
9119 gfc_add_block_to_block (&block
, &argse
.pre
);
9120 gfc_add_block_to_block (&post_block
, &argse
.post
);
9123 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
9124 stat
= null_pointer_node
;
9126 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9128 tree image_index
, caf_decl
, offset
, token
;
9130 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9131 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9132 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9134 if (gfc_is_coindexed (atom_expr
))
9135 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9137 image_index
= integer_zero_node
;
9139 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
9141 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
9142 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
9143 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9146 /* Convert a constant to a pointer. */
9147 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
9149 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
9150 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
9151 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9154 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9156 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
9157 token
, offset
, image_index
, old
, comp
, new_val
,
9158 stat
, build_int_cst (integer_type_node
,
9159 (int) atom_expr
->ts
.type
),
9160 build_int_cst (integer_type_node
,
9161 (int) atom_expr
->ts
.kind
));
9162 gfc_add_expr_to_block (&block
, tmp
);
9163 gfc_add_block_to_block (&block
, &post_block
);
9164 return gfc_finish_block (&block
);
9167 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9168 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
9169 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9171 tmp
= builtin_decl_explicit (fn
);
9173 gfc_add_modify (&block
, old
, comp
);
9174 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
9175 gfc_build_addr_expr (NULL
, old
),
9176 fold_convert (TREE_TYPE (old
), new_val
),
9178 build_int_cst (NULL
, MEMMODEL_RELAXED
),
9179 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9180 gfc_add_expr_to_block (&block
, tmp
);
9182 if (stat
!= NULL_TREE
)
9183 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9184 gfc_add_block_to_block (&block
, &post_block
);
9185 return gfc_finish_block (&block
);
9190 conv_intrinsic_move_alloc (gfc_code
*code
)
9193 gfc_expr
*from_expr
, *to_expr
;
9194 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
9195 gfc_se from_se
, to_se
;
9199 gfc_start_block (&block
);
9201 from_expr
= code
->ext
.actual
->expr
;
9202 to_expr
= code
->ext
.actual
->next
->expr
;
9204 gfc_init_se (&from_se
, NULL
);
9205 gfc_init_se (&to_se
, NULL
);
9207 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
9208 || to_expr
->ts
.type
== BT_CLASS
);
9209 coarray
= gfc_get_corank (from_expr
) != 0;
9211 if (from_expr
->rank
== 0 && !coarray
)
9213 if (from_expr
->ts
.type
!= BT_CLASS
)
9214 from_expr2
= from_expr
;
9217 from_expr2
= gfc_copy_expr (from_expr
);
9218 gfc_add_data_component (from_expr2
);
9221 if (to_expr
->ts
.type
!= BT_CLASS
)
9225 to_expr2
= gfc_copy_expr (to_expr
);
9226 gfc_add_data_component (to_expr2
);
9229 from_se
.want_pointer
= 1;
9230 to_se
.want_pointer
= 1;
9231 gfc_conv_expr (&from_se
, from_expr2
);
9232 gfc_conv_expr (&to_se
, to_expr2
);
9233 gfc_add_block_to_block (&block
, &from_se
.pre
);
9234 gfc_add_block_to_block (&block
, &to_se
.pre
);
9236 /* Deallocate "to". */
9237 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
9238 to_expr
, to_expr
->ts
);
9239 gfc_add_expr_to_block (&block
, tmp
);
9241 /* Assign (_data) pointers. */
9242 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9243 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
9245 /* Set "from" to NULL. */
9246 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9247 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
9249 gfc_add_block_to_block (&block
, &from_se
.post
);
9250 gfc_add_block_to_block (&block
, &to_se
.post
);
9253 if (to_expr
->ts
.type
== BT_CLASS
)
9257 gfc_free_expr (to_expr2
);
9258 gfc_init_se (&to_se
, NULL
);
9259 to_se
.want_pointer
= 1;
9260 gfc_add_vptr_component (to_expr
);
9261 gfc_conv_expr (&to_se
, to_expr
);
9263 if (from_expr
->ts
.type
== BT_CLASS
)
9265 if (UNLIMITED_POLY (from_expr
))
9269 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9273 gfc_free_expr (from_expr2
);
9274 gfc_init_se (&from_se
, NULL
);
9275 from_se
.want_pointer
= 1;
9276 gfc_add_vptr_component (from_expr
);
9277 gfc_conv_expr (&from_se
, from_expr
);
9278 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9279 fold_convert (TREE_TYPE (to_se
.expr
),
9282 /* Reset _vptr component to declared type. */
9284 /* Unlimited polymorphic. */
9285 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9286 fold_convert (TREE_TYPE (from_se
.expr
),
9287 null_pointer_node
));
9290 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9291 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9292 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9297 vtab
= gfc_find_vtab (&from_expr
->ts
);
9299 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9300 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9301 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9305 return gfc_finish_block (&block
);
9308 /* Update _vptr component. */
9309 if (to_expr
->ts
.type
== BT_CLASS
)
9313 to_se
.want_pointer
= 1;
9314 to_expr2
= gfc_copy_expr (to_expr
);
9315 gfc_add_vptr_component (to_expr2
);
9316 gfc_conv_expr (&to_se
, to_expr2
);
9318 if (from_expr
->ts
.type
== BT_CLASS
)
9320 if (UNLIMITED_POLY (from_expr
))
9324 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9328 from_se
.want_pointer
= 1;
9329 from_expr2
= gfc_copy_expr (from_expr
);
9330 gfc_add_vptr_component (from_expr2
);
9331 gfc_conv_expr (&from_se
, from_expr2
);
9332 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9333 fold_convert (TREE_TYPE (to_se
.expr
),
9336 /* Reset _vptr component to declared type. */
9338 /* Unlimited polymorphic. */
9339 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9340 fold_convert (TREE_TYPE (from_se
.expr
),
9341 null_pointer_node
));
9344 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9345 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9346 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9351 vtab
= gfc_find_vtab (&from_expr
->ts
);
9353 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9354 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9355 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9358 gfc_free_expr (to_expr2
);
9359 gfc_init_se (&to_se
, NULL
);
9361 if (from_expr
->ts
.type
== BT_CLASS
)
9363 gfc_free_expr (from_expr2
);
9364 gfc_init_se (&from_se
, NULL
);
9369 /* Deallocate "to". */
9370 if (from_expr
->rank
== 0)
9372 to_se
.want_coarray
= 1;
9373 from_se
.want_coarray
= 1;
9375 gfc_conv_expr_descriptor (&to_se
, to_expr
);
9376 gfc_conv_expr_descriptor (&from_se
, from_expr
);
9378 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
9379 is an image control "statement", cf. IR F08/0040 in 12-006A. */
9380 if (coarray
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9384 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
9385 NULL_TREE
, NULL_TREE
, true, to_expr
,
9387 gfc_add_expr_to_block (&block
, tmp
);
9389 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9390 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9391 boolean_type_node
, tmp
,
9392 fold_convert (TREE_TYPE (tmp
),
9393 null_pointer_node
));
9394 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
9395 3, null_pointer_node
, null_pointer_node
,
9396 build_int_cst (integer_type_node
, 0));
9398 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
9399 tmp
, build_empty_stmt (input_location
));
9400 gfc_add_expr_to_block (&block
, tmp
);
9404 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9405 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9406 NULL_TREE
, true, to_expr
, false);
9407 gfc_add_expr_to_block (&block
, tmp
);
9410 /* Move the pointer and update the array descriptor data. */
9411 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
9413 /* Set "from" to NULL. */
9414 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
9415 gfc_add_modify_loc (input_location
, &block
, tmp
,
9416 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
9418 return gfc_finish_block (&block
);
9423 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
9427 gcc_assert (code
->resolved_isym
);
9429 switch (code
->resolved_isym
->id
)
9431 case GFC_ISYM_MOVE_ALLOC
:
9432 res
= conv_intrinsic_move_alloc (code
);
9435 case GFC_ISYM_ATOMIC_CAS
:
9436 res
= conv_intrinsic_atomic_cas (code
);
9439 case GFC_ISYM_ATOMIC_ADD
:
9440 case GFC_ISYM_ATOMIC_AND
:
9441 case GFC_ISYM_ATOMIC_DEF
:
9442 case GFC_ISYM_ATOMIC_OR
:
9443 case GFC_ISYM_ATOMIC_XOR
:
9444 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9445 case GFC_ISYM_ATOMIC_FETCH_AND
:
9446 case GFC_ISYM_ATOMIC_FETCH_OR
:
9447 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9448 res
= conv_intrinsic_atomic_op (code
);
9451 case GFC_ISYM_ATOMIC_REF
:
9452 res
= conv_intrinsic_atomic_ref (code
);
9455 case GFC_ISYM_C_F_POINTER
:
9456 case GFC_ISYM_C_F_PROCPOINTER
:
9457 res
= conv_isocbinding_subroutine (code
);
9460 case GFC_ISYM_CAF_SEND
:
9461 res
= conv_caf_send (code
);
9464 case GFC_ISYM_CO_BROADCAST
:
9465 case GFC_ISYM_CO_MIN
:
9466 case GFC_ISYM_CO_MAX
:
9467 case GFC_ISYM_CO_REDUCE
:
9468 case GFC_ISYM_CO_SUM
:
9469 res
= conv_co_collective (code
);
9472 case GFC_ISYM_SYSTEM_CLOCK
:
9473 res
= conv_intrinsic_system_clock (code
);
9484 #include "gt-fortran-trans-intrinsic.h"