1 /* Intrinsic translation
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
27 #include "tm.h" /* For UNITS_PER_WORD. */
29 #include "stringpool.h"
30 #include "tree-nested.h"
31 #include "stor-layout.h"
34 #include "diagnostic-core.h" /* For internal_error. */
35 #include "toplev.h" /* For rest_of_decl_compilation. */
38 #include "intrinsic.h"
40 #include "trans-const.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 #include "dependency.h" /* For CAF array alias analysis. */
44 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
45 #include "trans-stmt.h"
46 #include "tree-nested.h"
49 /* This maps Fortran intrinsic math functions to external library or GCC
51 typedef struct GTY(()) gfc_intrinsic_map_t
{
52 /* The explicit enum is required to work around inadequacies in the
53 garbage collection/gengtype parsing mechanism. */
56 /* Enum value from the "language-independent", aka C-centric, part
57 of gcc, or END_BUILTINS of no such value set. */
58 enum built_in_function float_built_in
;
59 enum built_in_function double_built_in
;
60 enum built_in_function long_double_built_in
;
61 enum built_in_function complex_float_built_in
;
62 enum built_in_function complex_double_built_in
;
63 enum built_in_function complex_long_double_built_in
;
65 /* True if the naming pattern is to prepend "c" for complex and
66 append "f" for kind=4. False if the naming pattern is to
67 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
70 /* True if a complex version of the function exists. */
71 bool complex_available
;
73 /* True if the function should be marked const. */
76 /* The base library name of this function. */
79 /* Cache decls created for the various operand types. */
91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
92 defines complex variants of all of the entries in mathbuiltins.def
94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
97 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
101 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
102 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
103 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
104 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
106 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
107 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
112 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
113 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
114 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
116 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
118 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
120 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
121 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
122 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
123 #include "mathbuiltins.def"
125 /* Functions in libgfortran. */
126 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
129 LIB_FUNCTION (NONE
, NULL
, false)
134 #undef DEFINE_MATH_BUILTIN
135 #undef DEFINE_MATH_BUILTIN_C
138 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
141 /* Find the correct variant of a given builtin from its argument. */
143 builtin_decl_for_precision (enum built_in_function base_built_in
,
146 enum built_in_function i
= END_BUILTINS
;
148 gfc_intrinsic_map_t
*m
;
149 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
152 if (precision
== TYPE_PRECISION (float_type_node
))
153 i
= m
->float_built_in
;
154 else if (precision
== TYPE_PRECISION (double_type_node
))
155 i
= m
->double_built_in
;
156 else if (precision
== TYPE_PRECISION (long_double_type_node
))
157 i
= m
->long_double_built_in
;
158 else if (precision
== TYPE_PRECISION (float128_type_node
))
160 /* Special treatment, because it is not exactly a built-in, but
161 a library function. */
162 return m
->real16_decl
;
165 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
170 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
173 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
175 if (gfc_real_kinds
[i
].c_float128
)
177 /* For __float128, the story is a bit different, because we return
178 a decl to a library function rather than a built-in. */
179 gfc_intrinsic_map_t
*m
;
180 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
183 return m
->real16_decl
;
186 return builtin_decl_for_precision (double_built_in
,
187 gfc_real_kinds
[i
].mode_precision
);
191 /* Evaluate the arguments to an intrinsic function. The value
192 of NARGS may be less than the actual number of arguments in EXPR
193 to allow optional "KIND" arguments that are not included in the
194 generated code to be ignored. */
197 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
198 tree
*argarray
, int nargs
)
200 gfc_actual_arglist
*actual
;
202 gfc_intrinsic_arg
*formal
;
206 formal
= expr
->value
.function
.isym
->formal
;
207 actual
= expr
->value
.function
.actual
;
209 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
210 actual
= actual
->next
,
211 formal
= formal
? formal
->next
: NULL
)
215 /* Skip omitted optional arguments. */
222 /* Evaluate the parameter. This will substitute scalarized
223 references automatically. */
224 gfc_init_se (&argse
, se
);
226 if (e
->ts
.type
== BT_CHARACTER
)
228 gfc_conv_expr (&argse
, e
);
229 gfc_conv_string_parameter (&argse
);
230 argarray
[curr_arg
++] = argse
.string_length
;
231 gcc_assert (curr_arg
< nargs
);
234 gfc_conv_expr_val (&argse
, e
);
236 /* If an optional argument is itself an optional dummy argument,
237 check its presence and substitute a null if absent. */
238 if (e
->expr_type
== EXPR_VARIABLE
239 && e
->symtree
->n
.sym
->attr
.optional
242 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
244 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
245 gfc_add_block_to_block (&se
->post
, &argse
.post
);
246 argarray
[curr_arg
] = argse
.expr
;
250 /* Count the number of actual arguments to the intrinsic function EXPR
251 including any "hidden" string length arguments. */
254 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
257 gfc_actual_arglist
*actual
;
259 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
264 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
274 /* Conversions between different types are output by the frontend as
275 intrinsic functions. We implement these directly with inline code. */
278 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
284 nargs
= gfc_intrinsic_argument_list_length (expr
);
285 args
= XALLOCAVEC (tree
, nargs
);
287 /* Evaluate all the arguments passed. Whilst we're only interested in the
288 first one here, there are other parts of the front-end that assume this
289 and will trigger an ICE if it's not the case. */
290 type
= gfc_typenode_for_spec (&expr
->ts
);
291 gcc_assert (expr
->value
.function
.actual
->expr
);
292 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
294 /* Conversion between character kinds involves a call to a library
296 if (expr
->ts
.type
== BT_CHARACTER
)
298 tree fndecl
, var
, addr
, tmp
;
300 if (expr
->ts
.kind
== 1
301 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
302 fndecl
= gfor_fndecl_convert_char4_to_char1
;
303 else if (expr
->ts
.kind
== 4
304 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
305 fndecl
= gfor_fndecl_convert_char1_to_char4
;
309 /* Create the variable storing the converted value. */
310 type
= gfc_get_pchar_type (expr
->ts
.kind
);
311 var
= gfc_create_var (type
, "str");
312 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
314 /* Call the library function that will perform the conversion. */
315 gcc_assert (nargs
>= 2);
316 tmp
= build_call_expr_loc (input_location
,
317 fndecl
, 3, addr
, args
[0], args
[1]);
318 gfc_add_expr_to_block (&se
->pre
, tmp
);
320 /* Free the temporary afterwards. */
321 tmp
= gfc_call_free (var
);
322 gfc_add_expr_to_block (&se
->post
, tmp
);
325 se
->string_length
= args
[0];
330 /* Conversion from complex to non-complex involves taking the real
331 component of the value. */
332 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
333 && expr
->ts
.type
!= BT_COMPLEX
)
337 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
338 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
342 se
->expr
= convert (type
, args
[0]);
345 /* This is needed because the gcc backend only implements
346 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
347 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
348 Similarly for CEILING. */
351 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
358 argtype
= TREE_TYPE (arg
);
359 arg
= gfc_evaluate_now (arg
, pblock
);
361 intval
= convert (type
, arg
);
362 intval
= gfc_evaluate_now (intval
, pblock
);
364 tmp
= convert (argtype
, intval
);
365 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
366 boolean_type_node
, tmp
, arg
);
368 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
369 intval
, build_int_cst (type
, 1));
370 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
375 /* Round to nearest integer, away from zero. */
378 build_round_expr (tree arg
, tree restype
)
382 int argprec
, resprec
;
384 argtype
= TREE_TYPE (arg
);
385 argprec
= TYPE_PRECISION (argtype
);
386 resprec
= TYPE_PRECISION (restype
);
388 /* Depending on the type of the result, choose the int intrinsic
389 (iround, available only as a builtin, therefore cannot use it for
390 __float128), long int intrinsic (lround family) or long long
391 intrinsic (llround). We might also need to convert the result
393 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
394 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
395 else if (resprec
<= LONG_TYPE_SIZE
)
396 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
397 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
398 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
402 return fold_convert (restype
, build_call_expr_loc (input_location
,
407 /* Convert a real to an integer using a specific rounding mode.
408 Ideally we would just build the corresponding GENERIC node,
409 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
412 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
413 enum rounding_mode op
)
418 return build_fixbound_expr (pblock
, arg
, type
, 0);
422 return build_fixbound_expr (pblock
, arg
, type
, 1);
426 return build_round_expr (arg
, type
);
430 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
439 /* Round a real value using the specified rounding mode.
440 We use a temporary integer of that same kind size as the result.
441 Values larger than those that can be represented by this kind are
442 unchanged, as they will not be accurate enough to represent the
444 huge = HUGE (KIND (a))
445 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
449 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
461 kind
= expr
->ts
.kind
;
462 nargs
= gfc_intrinsic_argument_list_length (expr
);
465 /* We have builtin functions for some cases. */
469 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
473 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
480 /* Evaluate the argument. */
481 gcc_assert (expr
->value
.function
.actual
->expr
);
482 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
484 /* Use a builtin function if one exists. */
485 if (decl
!= NULL_TREE
)
487 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
491 /* This code is probably redundant, but we'll keep it lying around just
493 type
= gfc_typenode_for_spec (&expr
->ts
);
494 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
496 /* Test if the value is too large to handle sensibly. */
497 gfc_set_model_kind (kind
);
499 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
500 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
501 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
502 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
505 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
506 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
507 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
509 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
511 itype
= gfc_get_int_type (kind
);
513 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
514 tmp
= convert (type
, tmp
);
515 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
521 /* Convert to an integer using the specified rounding mode. */
524 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
530 nargs
= gfc_intrinsic_argument_list_length (expr
);
531 args
= XALLOCAVEC (tree
, nargs
);
533 /* Evaluate the argument, we process all arguments even though we only
534 use the first one for code generation purposes. */
535 type
= gfc_typenode_for_spec (&expr
->ts
);
536 gcc_assert (expr
->value
.function
.actual
->expr
);
537 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
539 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
541 /* Conversion to a different integer kind. */
542 se
->expr
= convert (type
, args
[0]);
546 /* Conversion from complex to non-complex involves taking the real
547 component of the value. */
548 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
549 && expr
->ts
.type
!= BT_COMPLEX
)
553 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
554 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
558 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
563 /* Get the imaginary component of a value. */
566 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
570 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
571 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
572 TREE_TYPE (TREE_TYPE (arg
)), arg
);
576 /* Get the complex conjugate of a value. */
579 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
583 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
584 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
590 define_quad_builtin (const char *name
, tree type
, bool is_const
)
593 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
596 /* Mark the decl as external. */
597 DECL_EXTERNAL (fndecl
) = 1;
598 TREE_PUBLIC (fndecl
) = 1;
600 /* Mark it __attribute__((const)). */
601 TREE_READONLY (fndecl
) = is_const
;
603 rest_of_decl_compilation (fndecl
, 1, 0);
610 /* Initialize function decls for library functions. The external functions
611 are created as required. Builtin functions are added here. */
614 gfc_build_intrinsic_lib_fndecls (void)
616 gfc_intrinsic_map_t
*m
;
617 tree quad_decls
[END_BUILTINS
+ 1];
619 if (gfc_real16_is_float128
)
621 /* If we have soft-float types, we create the decls for their
622 C99-like library functions. For now, we only handle __float128
623 q-suffixed functions. */
625 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
626 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
628 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
630 type
= float128_type_node
;
631 complex_type
= complex_float128_type_node
;
632 /* type (*) (type) */
633 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
635 func_iround
= build_function_type_list (integer_type_node
,
637 /* long (*) (type) */
638 func_lround
= build_function_type_list (long_integer_type_node
,
640 /* long long (*) (type) */
641 func_llround
= build_function_type_list (long_long_integer_type_node
,
643 /* type (*) (type, type) */
644 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
645 /* type (*) (type, &int) */
647 = build_function_type_list (type
,
649 build_pointer_type (integer_type_node
),
651 /* type (*) (type, int) */
652 func_scalbn
= build_function_type_list (type
,
653 type
, integer_type_node
, NULL_TREE
);
654 /* type (*) (complex type) */
655 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
656 /* complex type (*) (complex type, complex type) */
658 = build_function_type_list (complex_type
,
659 complex_type
, complex_type
, NULL_TREE
);
661 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
662 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
663 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
665 /* Only these built-ins are actually needed here. These are used directly
666 from the code, when calling builtin_decl_for_precision() or
667 builtin_decl_for_float_type(). The others are all constructed by
668 gfc_get_intrinsic_lib_fndecl(). */
669 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
670 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
672 #include "mathbuiltins.def"
676 #undef DEFINE_MATH_BUILTIN
677 #undef DEFINE_MATH_BUILTIN_C
681 /* Add GCC builtin functions. */
682 for (m
= gfc_intrinsic_map
;
683 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
685 if (m
->float_built_in
!= END_BUILTINS
)
686 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
687 if (m
->complex_float_built_in
!= END_BUILTINS
)
688 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
689 if (m
->double_built_in
!= END_BUILTINS
)
690 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
691 if (m
->complex_double_built_in
!= END_BUILTINS
)
692 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
694 /* If real(kind=10) exists, it is always long double. */
695 if (m
->long_double_built_in
!= END_BUILTINS
)
696 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
697 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
699 = builtin_decl_explicit (m
->complex_long_double_built_in
);
701 if (!gfc_real16_is_float128
)
703 if (m
->long_double_built_in
!= END_BUILTINS
)
704 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
705 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
707 = builtin_decl_explicit (m
->complex_long_double_built_in
);
709 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
711 /* Quad-precision function calls are constructed when first
712 needed by builtin_decl_for_precision(), except for those
713 that will be used directly (define by OTHER_BUILTIN). */
714 m
->real16_decl
= quad_decls
[m
->double_built_in
];
716 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
718 /* Same thing for the complex ones. */
719 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
725 /* Create a fndecl for a simple intrinsic library function. */
728 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
731 vec
<tree
, va_gc
> *argtypes
;
733 gfc_actual_arglist
*actual
;
736 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
739 if (ts
->type
== BT_REAL
)
744 pdecl
= &m
->real4_decl
;
747 pdecl
= &m
->real8_decl
;
750 pdecl
= &m
->real10_decl
;
753 pdecl
= &m
->real16_decl
;
759 else if (ts
->type
== BT_COMPLEX
)
761 gcc_assert (m
->complex_available
);
766 pdecl
= &m
->complex4_decl
;
769 pdecl
= &m
->complex8_decl
;
772 pdecl
= &m
->complex10_decl
;
775 pdecl
= &m
->complex16_decl
;
789 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
790 if (gfc_real_kinds
[n
].c_float
)
791 snprintf (name
, sizeof (name
), "%s%s%s",
792 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
793 else if (gfc_real_kinds
[n
].c_double
)
794 snprintf (name
, sizeof (name
), "%s%s",
795 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
796 else if (gfc_real_kinds
[n
].c_long_double
)
797 snprintf (name
, sizeof (name
), "%s%s%s",
798 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
799 else if (gfc_real_kinds
[n
].c_float128
)
800 snprintf (name
, sizeof (name
), "%s%s%s",
801 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
807 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
808 ts
->type
== BT_COMPLEX
? 'c' : 'r',
813 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
815 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
816 vec_safe_push (argtypes
, type
);
818 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
819 fndecl
= build_decl (input_location
,
820 FUNCTION_DECL
, get_identifier (name
), type
);
822 /* Mark the decl as external. */
823 DECL_EXTERNAL (fndecl
) = 1;
824 TREE_PUBLIC (fndecl
) = 1;
826 /* Mark it __attribute__((const)), if possible. */
827 TREE_READONLY (fndecl
) = m
->is_constant
;
829 rest_of_decl_compilation (fndecl
, 1, 0);
836 /* Convert an intrinsic function into an external or builtin call. */
839 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
841 gfc_intrinsic_map_t
*m
;
845 unsigned int num_args
;
848 id
= expr
->value
.function
.isym
->id
;
849 /* Find the entry for this function. */
850 for (m
= gfc_intrinsic_map
;
851 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
857 if (m
->id
== GFC_ISYM_NONE
)
859 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
860 expr
->value
.function
.name
, id
);
863 /* Get the decl and generate the call. */
864 num_args
= gfc_intrinsic_argument_list_length (expr
);
865 args
= XALLOCAVEC (tree
, num_args
);
867 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
868 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
869 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
871 fndecl
= build_addr (fndecl
, current_function_decl
);
872 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
876 /* If bounds-checking is enabled, create code to verify at runtime that the
877 string lengths for both expressions are the same (needed for e.g. MERGE).
878 If bounds-checking is not enabled, does nothing. */
881 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
882 tree a
, tree b
, stmtblock_t
* target
)
887 /* If bounds-checking is disabled, do nothing. */
888 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
891 /* Compare the two string lengths. */
892 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
894 /* Output the runtime-check. */
895 name
= gfc_build_cstring_const (intr_name
);
896 name
= gfc_build_addr_expr (pchar_type_node
, name
);
897 gfc_trans_runtime_check (true, false, cond
, target
, where
,
898 "Unequal character lengths (%ld/%ld) in %s",
899 fold_convert (long_integer_type_node
, a
),
900 fold_convert (long_integer_type_node
, b
), name
);
904 /* The EXPONENT(X) intrinsic function is translated into
906 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
907 so that if X is a NaN or infinity, the result is HUGE(0).
911 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
913 tree arg
, type
, res
, tmp
, frexp
, cond
, huge
;
916 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
917 expr
->value
.function
.actual
->expr
->ts
.kind
);
919 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
920 arg
= gfc_evaluate_now (arg
, &se
->pre
);
922 i
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
923 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_c_int_kind
);
924 cond
= build_call_expr_loc (input_location
,
925 builtin_decl_explicit (BUILT_IN_ISFINITE
),
928 res
= gfc_create_var (integer_type_node
, NULL
);
929 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
930 gfc_build_addr_expr (NULL_TREE
, res
));
931 tmp
= fold_build2_loc (input_location
, COMPOUND_EXPR
, integer_type_node
,
933 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
936 type
= gfc_typenode_for_spec (&expr
->ts
);
937 se
->expr
= fold_convert (type
, se
->expr
);
941 /* Fill in the following structure
942 struct caf_vector_t {
943 size_t nvec; // size of the vector
950 ptrdiff_t lower_bound;
951 ptrdiff_t upper_bound;
958 conv_caf_vector_subscript_elem (stmtblock_t
*block
, int i
, tree desc
,
959 tree lower
, tree upper
, tree stride
,
960 tree vector
, int kind
, tree nvec
)
962 tree field
, type
, tmp
;
964 desc
= gfc_build_array_ref (desc
, gfc_rank_cst
[i
], NULL_TREE
);
965 type
= TREE_TYPE (desc
);
967 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
968 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
969 desc
, field
, NULL_TREE
);
970 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), nvec
));
973 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
974 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
975 desc
, field
, NULL_TREE
);
976 type
= TREE_TYPE (desc
);
978 /* Access the inner struct. */
979 field
= gfc_advance_chain (TYPE_FIELDS (type
), vector
!= NULL_TREE
? 0 : 1);
980 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
981 desc
, field
, NULL_TREE
);
982 type
= TREE_TYPE (desc
);
984 if (vector
!= NULL_TREE
)
986 /* Set dim.lower/upper/stride. */
987 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
988 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
989 desc
, field
, NULL_TREE
);
990 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), vector
));
991 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
992 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
993 desc
, field
, NULL_TREE
);
994 gfc_add_modify (block
, tmp
, build_int_cst (integer_type_node
, kind
));
998 /* Set vector and kind. */
999 field
= gfc_advance_chain (TYPE_FIELDS (type
), 0);
1000 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1001 desc
, field
, NULL_TREE
);
1002 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), lower
));
1004 field
= gfc_advance_chain (TYPE_FIELDS (type
), 1);
1005 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1006 desc
, field
, NULL_TREE
);
1007 gfc_add_modify (block
, tmp
, fold_convert (TREE_TYPE (field
), upper
));
1009 field
= gfc_advance_chain (TYPE_FIELDS (type
), 2);
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
), stride
));
1018 conv_caf_vector_subscript (stmtblock_t
*block
, tree desc
, gfc_array_ref
*ar
)
1021 tree var
, lower
, upper
= NULL_TREE
, stride
= NULL_TREE
, vector
, nvec
;
1022 tree lbound
, ubound
, tmp
;
1025 var
= gfc_create_var (gfc_get_caf_vector_type (ar
->dimen
), "vector");
1027 for (i
= 0; i
< ar
->dimen
; i
++)
1028 switch (ar
->dimen_type
[i
])
1033 gfc_init_se (&argse
, NULL
);
1034 gfc_conv_expr (&argse
, ar
->end
[i
]);
1035 gfc_add_block_to_block (block
, &argse
.pre
);
1036 upper
= gfc_evaluate_now (argse
.expr
, block
);
1039 upper
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1042 gfc_init_se (&argse
, NULL
);
1043 gfc_conv_expr (&argse
, ar
->stride
[i
]);
1044 gfc_add_block_to_block (block
, &argse
.pre
);
1045 stride
= gfc_evaluate_now (argse
.expr
, block
);
1048 stride
= gfc_index_one_node
;
1054 gfc_init_se (&argse
, NULL
);
1055 gfc_conv_expr (&argse
, ar
->start
[i
]);
1056 gfc_add_block_to_block (block
, &argse
.pre
);
1057 lower
= gfc_evaluate_now (argse
.expr
, block
);
1060 lower
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1061 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
1064 stride
= gfc_index_one_node
;
1067 nvec
= size_zero_node
;
1068 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1073 gfc_init_se (&argse
, NULL
);
1074 argse
.descriptor_only
= 1;
1075 gfc_conv_expr_descriptor (&argse
, ar
->start
[i
]);
1076 gfc_add_block_to_block (block
, &argse
.pre
);
1077 vector
= argse
.expr
;
1078 lbound
= gfc_conv_descriptor_lbound_get (vector
, gfc_rank_cst
[0]);
1079 ubound
= gfc_conv_descriptor_ubound_get (vector
, gfc_rank_cst
[0]);
1080 nvec
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1081 tmp
= gfc_conv_descriptor_stride_get (vector
, gfc_rank_cst
[0]);
1082 nvec
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1083 TREE_TYPE (nvec
), nvec
, tmp
);
1084 lower
= gfc_index_zero_node
;
1085 upper
= gfc_index_zero_node
;
1086 stride
= gfc_index_zero_node
;
1087 vector
= gfc_conv_descriptor_data_get (vector
);
1088 conv_caf_vector_subscript_elem (block
, i
, var
, lower
, upper
, stride
,
1089 vector
, ar
->start
[i
]->ts
.kind
, nvec
);
1094 return gfc_build_addr_expr (NULL_TREE
, var
);
1098 /* Get data from a remote coarray. */
1101 gfc_conv_intrinsic_caf_get (gfc_se
*se
, gfc_expr
*expr
, tree lhs
, tree lhs_kind
,
1102 tree may_require_tmp
)
1104 gfc_expr
*array_expr
;
1106 tree caf_decl
, token
, offset
, image_index
, tmp
;
1107 tree res_var
, dst_var
, type
, kind
, vec
;
1109 gcc_assert (gfc_option
.coarray
== GFC_FCOARRAY_LIB
);
1111 if (se
->ss
&& se
->ss
->info
->useflags
)
1113 /* Access the previously obtained result. */
1114 gfc_conv_tmp_array_ref (se
);
1118 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1119 array_expr
= (lhs
== NULL_TREE
) ? expr
->value
.function
.actual
->expr
: expr
;
1120 type
= gfc_typenode_for_spec (&array_expr
->ts
);
1125 gfc_init_se (&argse
, NULL
);
1126 if (array_expr
->rank
== 0)
1128 symbol_attribute attr
;
1130 gfc_clear_attr (&attr
);
1131 gfc_conv_expr (&argse
, array_expr
);
1133 if (lhs
== NULL_TREE
)
1135 gfc_clear_attr (&attr
);
1136 if (array_expr
->ts
.type
== BT_CHARACTER
)
1137 res_var
= gfc_conv_string_tmp (se
, build_pointer_type (type
),
1138 argse
.string_length
);
1140 res_var
= gfc_create_var (type
, "caf_res");
1141 dst_var
= gfc_conv_scalar_to_descriptor (&argse
, res_var
, attr
);
1142 dst_var
= gfc_build_addr_expr (NULL_TREE
, dst_var
);
1144 argse
.expr
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
1145 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1149 /* If has_vector, pass descriptor for whole array and the
1150 vector bounds separately. */
1151 gfc_array_ref
*ar
, ar2
;
1152 bool has_vector
= false;
1154 if (gfc_is_coindexed (expr
) && gfc_has_vector_subscript (expr
))
1157 ar
= gfc_find_array_ref (expr
);
1159 memset (ar
, '\0', sizeof (*ar
));
1163 gfc_conv_expr_descriptor (&argse
, array_expr
);
1164 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1165 has the wrong type if component references are done. */
1166 gfc_add_modify (&argse
.pre
, gfc_conv_descriptor_dtype (argse
.expr
),
1167 gfc_get_dtype_rank_type (array_expr
->rank
, type
));
1170 vec
= conv_caf_vector_subscript (&argse
.pre
, argse
.expr
, ar
);
1174 if (lhs
== NULL_TREE
)
1176 /* Create temporary. */
1177 for (int n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
1178 if (se
->loop
->to
[n
] == NULL_TREE
)
1181 gfc_conv_descriptor_lbound_get (argse
.expr
, gfc_rank_cst
[n
]);
1183 gfc_conv_descriptor_ubound_get (argse
.expr
, gfc_rank_cst
[n
]);
1185 gfc_trans_create_temp_array (&argse
.pre
, &argse
.post
, se
->ss
, type
,
1186 NULL_TREE
, false, true, false,
1187 &array_expr
->where
);
1188 res_var
= se
->ss
->info
->data
.array
.descriptor
;
1189 dst_var
= gfc_build_addr_expr (NULL_TREE
, res_var
);
1191 argse
.expr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
1194 kind
= build_int_cst (integer_type_node
, expr
->ts
.kind
);
1195 if (lhs_kind
== NULL_TREE
)
1198 vec
= null_pointer_node
;
1200 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1201 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1203 caf_decl
= gfc_get_tree_for_caf_expr (array_expr
);
1204 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1205 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1206 image_index
= gfc_caf_get_image_index (&se
->pre
, array_expr
, caf_decl
);
1207 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, argse
.expr
, array_expr
);
1209 /* No overlap possible as we have generated a temporary. */
1210 if (lhs
== NULL_TREE
)
1211 may_require_tmp
= boolean_false_node
;
1213 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_get
, 9,
1214 token
, offset
, image_index
, argse
.expr
, vec
,
1215 dst_var
, kind
, lhs_kind
, may_require_tmp
);
1216 gfc_add_expr_to_block (&se
->pre
, tmp
);
1219 gfc_advance_se_ss_chain (se
);
1222 if (array_expr
->ts
.type
== BT_CHARACTER
)
1223 se
->string_length
= argse
.string_length
;
1227 /* Send data to a remove coarray. */
1230 conv_caf_send (gfc_code
*code
) {
1231 gfc_expr
*lhs_expr
, *rhs_expr
;
1232 gfc_se lhs_se
, rhs_se
;
1234 tree caf_decl
, token
, offset
, image_index
, tmp
, lhs_kind
, rhs_kind
;
1235 tree may_require_tmp
;
1236 tree lhs_type
= NULL_TREE
;
1237 tree vec
= null_pointer_node
, rhs_vec
= null_pointer_node
;
1239 gcc_assert (gfc_option
.coarray
== GFC_FCOARRAY_LIB
);
1241 lhs_expr
= code
->ext
.actual
->expr
;
1242 rhs_expr
= code
->ext
.actual
->next
->expr
;
1243 may_require_tmp
= gfc_check_dependency (lhs_expr
, rhs_expr
, false) == 0
1244 ? boolean_false_node
: boolean_true_node
;
1245 gfc_init_block (&block
);
1248 gfc_init_se (&lhs_se
, NULL
);
1249 if (lhs_expr
->rank
== 0)
1251 symbol_attribute attr
;
1252 gfc_clear_attr (&attr
);
1253 gfc_conv_expr (&lhs_se
, lhs_expr
);
1254 lhs_type
= TREE_TYPE (lhs_se
.expr
);
1255 lhs_se
.expr
= gfc_conv_scalar_to_descriptor (&lhs_se
, lhs_se
.expr
, attr
);
1256 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1260 /* If has_vector, pass descriptor for whole array and the
1261 vector bounds separately. */
1262 gfc_array_ref
*ar
, ar2
;
1263 bool has_vector
= false;
1265 if (gfc_is_coindexed (lhs_expr
) && gfc_has_vector_subscript (lhs_expr
))
1268 ar
= gfc_find_array_ref (lhs_expr
);
1270 memset (ar
, '\0', sizeof (*ar
));
1274 lhs_se
.want_pointer
= 1;
1275 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1276 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1277 has the wrong type if component references are done. */
1278 lhs_type
= gfc_typenode_for_spec (&lhs_expr
->ts
);
1279 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1280 gfc_add_modify (&lhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1281 gfc_get_dtype_rank_type (lhs_expr
->rank
, lhs_type
));
1284 vec
= conv_caf_vector_subscript (&block
, lhs_se
.expr
, ar
);
1289 lhs_kind
= build_int_cst (integer_type_node
, lhs_expr
->ts
.kind
);
1290 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1292 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1293 temporary and a loop. */
1294 if (!gfc_is_coindexed (lhs_expr
))
1296 gcc_assert (gfc_is_coindexed (rhs_expr
));
1297 gfc_init_se (&rhs_se
, NULL
);
1298 gfc_conv_intrinsic_caf_get (&rhs_se
, rhs_expr
, lhs_se
.expr
, lhs_kind
,
1300 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1301 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1302 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1303 return gfc_finish_block (&block
);
1306 /* Obtain token, offset and image index for the LHS. */
1308 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1309 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1310 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1311 image_index
= gfc_caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1312 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, lhs_se
.expr
, lhs_expr
);
1315 gfc_init_se (&rhs_se
, NULL
);
1316 if (rhs_expr
->expr_type
== EXPR_FUNCTION
&& rhs_expr
->value
.function
.isym
1317 && rhs_expr
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
)
1318 rhs_expr
= rhs_expr
->value
.function
.actual
->expr
;
1319 if (rhs_expr
->rank
== 0)
1321 symbol_attribute attr
;
1322 gfc_clear_attr (&attr
);
1323 gfc_conv_expr (&rhs_se
, rhs_expr
);
1324 if (!gfc_is_coindexed (rhs_expr
) && rhs_expr
->ts
.type
!= BT_CHARACTER
)
1325 rhs_se
.expr
= fold_convert (lhs_type
, rhs_se
.expr
);
1326 rhs_se
.expr
= gfc_conv_scalar_to_descriptor (&rhs_se
, rhs_se
.expr
, attr
);
1327 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
1331 /* If has_vector, pass descriptor for whole array and the
1332 vector bounds separately. */
1333 gfc_array_ref
*ar
, ar2
;
1334 bool has_vector
= false;
1337 if (gfc_is_coindexed (rhs_expr
) && gfc_has_vector_subscript (rhs_expr
))
1340 ar
= gfc_find_array_ref (rhs_expr
);
1342 memset (ar
, '\0', sizeof (*ar
));
1346 rhs_se
.want_pointer
= 1;
1347 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
1348 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1349 has the wrong type if component references are done. */
1350 tmp
= build_fold_indirect_ref_loc (input_location
, rhs_se
.expr
);
1351 tmp2
= gfc_typenode_for_spec (&rhs_expr
->ts
);
1352 gfc_add_modify (&rhs_se
.pre
, gfc_conv_descriptor_dtype (tmp
),
1353 gfc_get_dtype_rank_type (rhs_expr
->rank
, tmp2
));
1356 rhs_vec
= conv_caf_vector_subscript (&block
, rhs_se
.expr
, ar
);
1361 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1363 rhs_kind
= build_int_cst (integer_type_node
, rhs_expr
->ts
.kind
);
1365 if (!gfc_is_coindexed (rhs_expr
))
1366 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 9, token
,
1367 offset
, image_index
, lhs_se
.expr
, vec
,
1368 rhs_se
.expr
, lhs_kind
, rhs_kind
, may_require_tmp
);
1371 tree rhs_token
, rhs_offset
, rhs_image_index
;
1373 caf_decl
= gfc_get_tree_for_caf_expr (rhs_expr
);
1374 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1375 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1376 rhs_image_index
= gfc_caf_get_image_index (&block
, rhs_expr
, caf_decl
);
1377 gfc_get_caf_token_offset (&rhs_token
, &rhs_offset
, caf_decl
, rhs_se
.expr
,
1379 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sendget
, 13,
1380 token
, offset
, image_index
, lhs_se
.expr
, vec
,
1381 rhs_token
, rhs_offset
, rhs_image_index
,
1382 rhs_se
.expr
, rhs_vec
, lhs_kind
, rhs_kind
,
1385 gfc_add_expr_to_block (&block
, tmp
);
1386 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1387 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1388 return gfc_finish_block (&block
);
1393 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
1396 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
1397 lbound
, ubound
, extent
, ml
;
1400 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
1402 if (expr
->value
.function
.actual
->expr
1403 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
1404 distance
= expr
->value
.function
.actual
->expr
;
1406 /* The case -fcoarray=single is handled elsewhere. */
1407 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
1409 /* Argument-free version: THIS_IMAGE(). */
1410 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
1414 gfc_init_se (&argse
, NULL
);
1415 gfc_conv_expr_val (&argse
, distance
);
1416 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1417 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1418 tmp
= fold_convert (integer_type_node
, argse
.expr
);
1421 tmp
= integer_zero_node
;
1422 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1424 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1429 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1431 type
= gfc_get_int_type (gfc_default_integer_kind
);
1432 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1433 rank
= expr
->value
.function
.actual
->expr
->rank
;
1435 /* Obtain the descriptor of the COARRAY. */
1436 gfc_init_se (&argse
, NULL
);
1437 argse
.want_coarray
= 1;
1438 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1439 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1440 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1445 /* Create an implicit second parameter from the loop variable. */
1446 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
1447 gcc_assert (corank
> 0);
1448 gcc_assert (se
->loop
->dimen
== 1);
1449 gcc_assert (se
->ss
->info
->expr
== expr
);
1451 dim_arg
= se
->loop
->loopvar
[0];
1452 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
1453 gfc_array_index_type
, dim_arg
,
1454 build_int_cst (TREE_TYPE (dim_arg
), 1));
1455 gfc_advance_se_ss_chain (se
);
1459 /* Use the passed DIM= argument. */
1460 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
1461 gfc_init_se (&argse
, NULL
);
1462 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
1463 gfc_array_index_type
);
1464 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1465 dim_arg
= argse
.expr
;
1467 if (INTEGER_CST_P (dim_arg
))
1469 if (wi::ltu_p (dim_arg
, 1)
1470 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
1471 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1472 "dimension index", expr
->value
.function
.isym
->name
,
1475 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1477 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1478 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1480 build_int_cst (TREE_TYPE (dim_arg
), 1));
1481 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1482 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1484 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1485 boolean_type_node
, cond
, tmp
);
1486 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1491 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1492 one always has a dim_arg argument.
1494 m = this_image() - 1
1497 sub(1) = m + lcobound(corank)
1501 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1504 extent = gfc_extent(i)
1512 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1513 : m + lcobound(corank)
1516 /* this_image () - 1. */
1517 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1519 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
1520 fold_convert (type
, tmp
), build_int_cst (type
, 1));
1523 /* sub(1) = m + lcobound(corank). */
1524 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1525 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1527 lbound
= fold_convert (type
, lbound
);
1528 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1534 m
= gfc_create_var (type
, NULL
);
1535 ml
= gfc_create_var (type
, NULL
);
1536 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1537 min_var
= gfc_create_var (integer_type_node
, NULL
);
1539 /* m = this_image () - 1. */
1540 gfc_add_modify (&se
->pre
, m
, tmp
);
1542 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1543 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1544 fold_convert (integer_type_node
, dim_arg
),
1545 build_int_cst (integer_type_node
, rank
- 1));
1546 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1547 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1549 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1552 tmp
= build_int_cst (integer_type_node
, rank
);
1553 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1555 exit_label
= gfc_build_label_decl (NULL_TREE
);
1556 TREE_USED (exit_label
) = 1;
1559 gfc_init_block (&loop
);
1562 gfc_add_modify (&loop
, ml
, m
);
1565 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1566 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1567 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1568 extent
= fold_convert (type
, extent
);
1571 gfc_add_modify (&loop
, m
,
1572 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1575 /* Exit condition: if (i >= min_var) goto exit_label. */
1576 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1578 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1579 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1580 build_empty_stmt (input_location
));
1581 gfc_add_expr_to_block (&loop
, tmp
);
1583 /* Increment loop variable: i++. */
1584 gfc_add_modify (&loop
, loop_var
,
1585 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1587 build_int_cst (integer_type_node
, 1)));
1589 /* Making the loop... actually loop! */
1590 tmp
= gfc_finish_block (&loop
);
1591 tmp
= build1_v (LOOP_EXPR
, tmp
);
1592 gfc_add_expr_to_block (&se
->pre
, tmp
);
1594 /* The exit label. */
1595 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1596 gfc_add_expr_to_block (&se
->pre
, tmp
);
1598 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1599 : m + lcobound(corank) */
1601 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1602 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1604 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1605 fold_build2_loc (input_location
, PLUS_EXPR
,
1606 gfc_array_index_type
, dim_arg
,
1607 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1608 lbound
= fold_convert (type
, lbound
);
1610 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1611 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1613 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1615 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1616 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1622 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1624 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1626 gfc_se argse
, subse
;
1627 int rank
, corank
, codim
;
1629 type
= gfc_get_int_type (gfc_default_integer_kind
);
1630 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1631 rank
= expr
->value
.function
.actual
->expr
->rank
;
1633 /* Obtain the descriptor of the COARRAY. */
1634 gfc_init_se (&argse
, NULL
);
1635 argse
.want_coarray
= 1;
1636 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1637 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1638 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1641 /* Obtain a handle to the SUB argument. */
1642 gfc_init_se (&subse
, NULL
);
1643 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1644 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1645 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1646 subdesc
= build_fold_indirect_ref_loc (input_location
,
1647 gfc_conv_descriptor_data_get (subse
.expr
));
1649 /* Fortran 2008 does not require that the values remain in the cobounds,
1650 thus we need explicitly check this - and return 0 if they are exceeded. */
1652 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1653 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1654 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1655 fold_convert (gfc_array_index_type
, tmp
),
1658 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1660 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1661 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1662 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1663 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1664 fold_convert (gfc_array_index_type
, tmp
),
1666 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1667 boolean_type_node
, invalid_bound
, cond
);
1668 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1669 fold_convert (gfc_array_index_type
, tmp
),
1671 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1672 boolean_type_node
, invalid_bound
, cond
);
1675 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
1677 /* See Fortran 2008, C.10 for the following algorithm. */
1679 /* coindex = sub(corank) - lcobound(n). */
1680 coindex
= fold_convert (gfc_array_index_type
,
1681 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1683 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1684 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1685 fold_convert (gfc_array_index_type
, coindex
),
1688 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1690 tree extent
, ubound
;
1692 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1693 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1694 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1695 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1697 /* coindex *= extent. */
1698 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1699 gfc_array_index_type
, coindex
, extent
);
1701 /* coindex += sub(codim). */
1702 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1703 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1704 gfc_array_index_type
, coindex
,
1705 fold_convert (gfc_array_index_type
, tmp
));
1707 /* coindex -= lbound(codim). */
1708 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1709 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1710 gfc_array_index_type
, coindex
, lbound
);
1713 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1714 fold_convert(type
, coindex
),
1715 build_int_cst (type
, 1));
1717 /* Return 0 if "coindex" exceeds num_images(). */
1719 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1720 num_images
= build_int_cst (type
, 1);
1723 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1725 build_int_cst (integer_type_node
, -1));
1726 num_images
= fold_convert (type
, tmp
);
1729 tmp
= gfc_create_var (type
, NULL
);
1730 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1732 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1734 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1736 fold_convert (boolean_type_node
, invalid_bound
));
1737 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1738 build_int_cst (type
, 0), tmp
);
1743 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
1745 tree tmp
, distance
, failed
;
1748 if (expr
->value
.function
.actual
->expr
)
1750 gfc_init_se (&argse
, NULL
);
1751 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
1752 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1753 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1754 distance
= fold_convert (integer_type_node
, argse
.expr
);
1757 distance
= integer_zero_node
;
1759 if (expr
->value
.function
.actual
->next
->expr
)
1761 gfc_init_se (&argse
, NULL
);
1762 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
1763 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1764 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1765 failed
= fold_convert (integer_type_node
, argse
.expr
);
1768 failed
= build_int_cst (integer_type_node
, -1);
1770 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1772 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
1777 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1781 gfc_init_se (&argse
, NULL
);
1782 argse
.data_not_needed
= 1;
1783 argse
.descriptor_only
= 1;
1785 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1786 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1787 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1789 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1793 /* Evaluate a single upper or lower bound. */
1794 /* TODO: bound intrinsic generates way too much unnecessary code. */
1797 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1799 gfc_actual_arglist
*arg
;
1800 gfc_actual_arglist
*arg2
;
1805 tree cond
, cond1
, cond3
, cond4
, size
;
1809 gfc_array_spec
* as
;
1810 bool assumed_rank_lb_one
;
1812 arg
= expr
->value
.function
.actual
;
1817 /* Create an implicit second parameter from the loop variable. */
1818 gcc_assert (!arg2
->expr
);
1819 gcc_assert (se
->loop
->dimen
== 1);
1820 gcc_assert (se
->ss
->info
->expr
== expr
);
1821 gfc_advance_se_ss_chain (se
);
1822 bound
= se
->loop
->loopvar
[0];
1823 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1824 gfc_array_index_type
, bound
,
1829 /* use the passed argument. */
1830 gcc_assert (arg2
->expr
);
1831 gfc_init_se (&argse
, NULL
);
1832 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1833 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1835 /* Convert from one based to zero based. */
1836 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1837 gfc_array_index_type
, bound
,
1838 gfc_index_one_node
);
1841 /* TODO: don't re-evaluate the descriptor on each iteration. */
1842 /* Get a descriptor for the first parameter. */
1843 gfc_init_se (&argse
, NULL
);
1844 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1845 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1846 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1850 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1852 if (INTEGER_CST_P (bound
))
1854 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1855 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
1856 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
1857 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1858 "dimension index", upper
? "UBOUND" : "LBOUND",
1862 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1864 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1866 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1867 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1868 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1869 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1870 tmp
= gfc_conv_descriptor_rank (desc
);
1872 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1873 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1874 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1875 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1876 boolean_type_node
, cond
, tmp
);
1877 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1882 /* Take care of the lbound shift for assumed-rank arrays, which are
1883 nonallocatable and nonpointers. Those has a lbound of 1. */
1884 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1885 && ((arg
->expr
->ts
.type
!= BT_CLASS
1886 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1887 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1888 || (arg
->expr
->ts
.type
== BT_CLASS
1889 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1890 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1892 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1893 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1895 /* 13.14.53: Result value for LBOUND
1897 Case (i): For an array section or for an array expression other than a
1898 whole array or array structure component, LBOUND(ARRAY, DIM)
1899 has the value 1. For a whole array or array structure
1900 component, LBOUND(ARRAY, DIM) has the value:
1901 (a) equal to the lower bound for subscript DIM of ARRAY if
1902 dimension DIM of ARRAY does not have extent zero
1903 or if ARRAY is an assumed-size array of rank DIM,
1906 13.14.113: Result value for UBOUND
1908 Case (i): For an array section or for an array expression other than a
1909 whole array or array structure component, UBOUND(ARRAY, DIM)
1910 has the value equal to the number of elements in the given
1911 dimension; otherwise, it has a value equal to the upper bound
1912 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1913 not have size zero and has value zero if dimension DIM has
1916 if (!upper
&& assumed_rank_lb_one
)
1917 se
->expr
= gfc_index_one_node
;
1920 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1922 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1924 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1925 stride
, gfc_index_zero_node
);
1926 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1927 boolean_type_node
, cond3
, cond1
);
1928 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1929 stride
, gfc_index_zero_node
);
1934 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1935 boolean_type_node
, cond3
, cond4
);
1936 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1937 gfc_index_one_node
, lbound
);
1938 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1939 boolean_type_node
, cond4
, cond5
);
1941 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1942 boolean_type_node
, cond
, cond5
);
1944 if (assumed_rank_lb_one
)
1946 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1947 gfc_array_index_type
, ubound
, lbound
);
1948 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1949 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1954 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1955 gfc_array_index_type
, cond
,
1956 tmp
, gfc_index_zero_node
);
1960 if (as
->type
== AS_ASSUMED_SIZE
)
1961 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1962 bound
, build_int_cst (TREE_TYPE (bound
),
1963 arg
->expr
->rank
- 1));
1965 cond
= boolean_false_node
;
1967 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1968 boolean_type_node
, cond3
, cond4
);
1969 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1970 boolean_type_node
, cond
, cond1
);
1972 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1973 gfc_array_index_type
, cond
,
1974 lbound
, gfc_index_one_node
);
1981 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1982 gfc_array_index_type
, ubound
, lbound
);
1983 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1984 gfc_array_index_type
, size
,
1985 gfc_index_one_node
);
1986 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1987 gfc_array_index_type
, se
->expr
,
1988 gfc_index_zero_node
);
1991 se
->expr
= gfc_index_one_node
;
1994 type
= gfc_typenode_for_spec (&expr
->ts
);
1995 se
->expr
= convert (type
, se
->expr
);
2000 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
2002 gfc_actual_arglist
*arg
;
2003 gfc_actual_arglist
*arg2
;
2005 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
2009 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2010 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2011 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
2013 arg
= expr
->value
.function
.actual
;
2016 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
2017 corank
= gfc_get_corank (arg
->expr
);
2019 gfc_init_se (&argse
, NULL
);
2020 argse
.want_coarray
= 1;
2022 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
2023 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2024 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2029 /* Create an implicit second parameter from the loop variable. */
2030 gcc_assert (!arg2
->expr
);
2031 gcc_assert (corank
> 0);
2032 gcc_assert (se
->loop
->dimen
== 1);
2033 gcc_assert (se
->ss
->info
->expr
== expr
);
2035 bound
= se
->loop
->loopvar
[0];
2036 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2037 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
2038 gfc_advance_se_ss_chain (se
);
2042 /* use the passed argument. */
2043 gcc_assert (arg2
->expr
);
2044 gfc_init_se (&argse
, NULL
);
2045 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
2046 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2049 if (INTEGER_CST_P (bound
))
2051 if (wi::ltu_p (bound
, 1)
2052 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
2053 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2054 "dimension index", expr
->value
.function
.isym
->name
,
2057 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2059 bound
= gfc_evaluate_now (bound
, &se
->pre
);
2060 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2061 bound
, build_int_cst (TREE_TYPE (bound
), 1));
2062 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
2063 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2065 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
2066 boolean_type_node
, cond
, tmp
);
2067 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
2072 /* Subtract 1 to get to zero based and add dimensions. */
2073 switch (arg
->expr
->rank
)
2076 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
2077 gfc_array_index_type
, bound
,
2078 gfc_index_one_node
);
2082 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2083 gfc_array_index_type
, bound
,
2084 gfc_rank_cst
[arg
->expr
->rank
- 1]);
2088 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
2090 /* Handle UCOBOUND with special handling of the last codimension. */
2091 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
2093 /* Last codimension: For -fcoarray=single just return
2094 the lcobound - otherwise add
2095 ceiling (real (num_images ()) / real (size)) - 1
2096 = (num_images () + size - 1) / size - 1
2097 = (num_images - 1) / size(),
2098 where size is the product of the extent of all but the last
2101 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
2105 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
2106 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
2107 2, integer_zero_node
,
2108 build_int_cst (integer_type_node
, -1));
2109 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2110 gfc_array_index_type
,
2111 fold_convert (gfc_array_index_type
, tmp
),
2112 build_int_cst (gfc_array_index_type
, 1));
2113 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
2114 gfc_array_index_type
, tmp
,
2115 fold_convert (gfc_array_index_type
, cosize
));
2116 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2117 gfc_array_index_type
, resbound
, tmp
);
2119 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
2121 /* ubound = lbound + num_images() - 1. */
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 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
2130 gfc_array_index_type
, resbound
, tmp
);
2135 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2137 build_int_cst (TREE_TYPE (bound
),
2138 arg
->expr
->rank
+ corank
- 1));
2140 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
2141 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2142 gfc_array_index_type
, cond
,
2143 resbound
, resbound2
);
2146 se
->expr
= resbound
;
2149 se
->expr
= resbound
;
2151 type
= gfc_typenode_for_spec (&expr
->ts
);
2152 se
->expr
= convert (type
, se
->expr
);
2157 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
2159 gfc_actual_arglist
*array_arg
;
2160 gfc_actual_arglist
*dim_arg
;
2164 array_arg
= expr
->value
.function
.actual
;
2165 dim_arg
= array_arg
->next
;
2167 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
2169 gfc_init_se (&argse
, NULL
);
2170 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
2171 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2172 gfc_add_block_to_block (&se
->post
, &argse
.post
);
2175 gcc_assert (dim_arg
->expr
);
2176 gfc_init_se (&argse
, NULL
);
2177 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
2178 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
2179 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2180 argse
.expr
, gfc_index_one_node
);
2181 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
2186 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
2190 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
2192 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
2196 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
2201 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
2202 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
2211 /* Create a complex value from one or two real components. */
2214 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
2220 unsigned int num_args
;
2222 num_args
= gfc_intrinsic_argument_list_length (expr
);
2223 args
= XALLOCAVEC (tree
, num_args
);
2225 type
= gfc_typenode_for_spec (&expr
->ts
);
2226 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
2227 real
= convert (TREE_TYPE (type
), args
[0]);
2229 imag
= convert (TREE_TYPE (type
), args
[1]);
2230 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
2232 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2233 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
2234 imag
= convert (TREE_TYPE (type
), imag
);
2237 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
2239 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
2243 /* Remainder function MOD(A, P) = A - INT(A / P) * P
2244 MODULO(A, P) = A - FLOOR (A / P) * P
2246 The obvious algorithms above are numerically instable for large
2247 arguments, hence these intrinsics are instead implemented via calls
2248 to the fmod family of functions. It is the responsibility of the
2249 user to ensure that the second argument is non-zero. */
2252 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
2262 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2264 switch (expr
->ts
.type
)
2267 /* Integer case is easy, we've got a builtin op. */
2268 type
= TREE_TYPE (args
[0]);
2271 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
2274 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
2280 /* Check if we have a builtin fmod. */
2281 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
2283 /* The builtin should always be available. */
2284 gcc_assert (fmod
!= NULL_TREE
);
2286 tmp
= build_addr (fmod
, current_function_decl
);
2287 se
->expr
= build_call_array_loc (input_location
,
2288 TREE_TYPE (TREE_TYPE (fmod
)),
2293 type
= TREE_TYPE (args
[0]);
2295 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2296 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
2299 modulo = arg - floor (arg/arg2) * arg2
2301 In order to calculate the result accurately, we use the fmod
2302 function as follows.
2304 res = fmod (arg, arg2);
2307 if ((arg < 0) xor (arg2 < 0))
2311 res = copysign (0., arg2);
2313 => As two nested ternary exprs:
2315 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2316 : copysign (0., arg2);
2320 zero
= gfc_build_const (type
, integer_zero_node
);
2321 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2322 if (!flag_signed_zeros
)
2324 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2326 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2328 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2329 boolean_type_node
, test
, test2
);
2330 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2332 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2333 boolean_type_node
, test
, test2
);
2334 test
= gfc_evaluate_now (test
, &se
->pre
);
2335 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2336 fold_build2_loc (input_location
,
2338 type
, tmp
, args
[1]),
2343 tree expr1
, copysign
, cscall
;
2344 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
2346 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2348 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2350 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2351 boolean_type_node
, test
, test2
);
2352 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
2353 fold_build2_loc (input_location
,
2355 type
, tmp
, args
[1]),
2357 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2359 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
2361 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2371 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2372 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2373 where the right shifts are logical (i.e. 0's are shifted in).
2374 Because SHIFT_EXPR's want shifts strictly smaller than the integral
2375 type width, we have to special-case both S == 0 and S == BITSIZE(J):
2377 DSHIFTL(I,J,BITSIZE) = J
2379 DSHIFTR(I,J,BITSIZE) = I. */
2382 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
2384 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
2385 tree args
[3], cond
, tmp
;
2388 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2390 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
2391 type
= TREE_TYPE (args
[0]);
2392 bitsize
= TYPE_PRECISION (type
);
2393 utype
= unsigned_type_for (type
);
2394 stype
= TREE_TYPE (args
[2]);
2396 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
2397 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
2398 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
2400 /* The generic case. */
2401 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
2402 build_int_cst (stype
, bitsize
), shift
);
2403 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
2404 arg1
, dshiftl
? shift
: tmp
);
2406 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
2407 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
2408 right
= fold_convert (type
, right
);
2410 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
2412 /* Special cases. */
2413 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2414 build_int_cst (stype
, 0));
2415 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2416 dshiftl
? arg1
: arg2
, res
);
2418 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2419 build_int_cst (stype
, bitsize
));
2420 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2421 dshiftl
? arg2
: arg1
, res
);
2427 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
2430 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
2438 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2439 type
= TREE_TYPE (args
[0]);
2441 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
2442 val
= gfc_evaluate_now (val
, &se
->pre
);
2444 zero
= gfc_build_const (type
, integer_zero_node
);
2445 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
2446 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
2450 /* SIGN(A, B) is absolute value of A times sign of B.
2451 The real value versions use library functions to ensure the correct
2452 handling of negative zero. Integer case implemented as:
2453 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
2457 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
2463 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2464 if (expr
->ts
.type
== BT_REAL
)
2468 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
2469 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
2471 /* We explicitly have to ignore the minus sign. We do so by using
2472 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
2474 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
2477 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
2478 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2480 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2481 TREE_TYPE (args
[0]), cond
,
2482 build_call_expr_loc (input_location
, abs
, 1,
2484 build_call_expr_loc (input_location
, tmp
, 2,
2488 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
2493 /* Having excluded floating point types, we know we are now dealing
2494 with signed integer types. */
2495 type
= TREE_TYPE (args
[0]);
2497 /* Args[0] is used multiple times below. */
2498 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2500 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2501 the signs of A and B are the same, and of all ones if they differ. */
2502 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2503 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2504 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2505 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2507 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2508 is all ones (i.e. -1). */
2509 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2510 fold_build2_loc (input_location
, PLUS_EXPR
,
2511 type
, args
[0], tmp
), tmp
);
2515 /* Test for the presence of an optional argument. */
2518 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2522 arg
= expr
->value
.function
.actual
->expr
;
2523 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2524 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2525 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2529 /* Calculate the double precision product of two single precision values. */
2532 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2537 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2539 /* Convert the args to double precision before multiplying. */
2540 type
= gfc_typenode_for_spec (&expr
->ts
);
2541 args
[0] = convert (type
, args
[0]);
2542 args
[1] = convert (type
, args
[1]);
2543 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2548 /* Return a length one character string containing an ascii character. */
2551 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2556 unsigned int num_args
;
2558 num_args
= gfc_intrinsic_argument_list_length (expr
);
2559 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2561 type
= gfc_get_char_type (expr
->ts
.kind
);
2562 var
= gfc_create_var (type
, "char");
2564 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2565 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2566 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2567 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2572 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2580 unsigned int num_args
;
2582 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2583 args
= XALLOCAVEC (tree
, num_args
);
2585 var
= gfc_create_var (pchar_type_node
, "pstr");
2586 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2588 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2589 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2590 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2592 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2593 tmp
= build_call_array_loc (input_location
,
2594 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2595 fndecl
, num_args
, args
);
2596 gfc_add_expr_to_block (&se
->pre
, tmp
);
2598 /* Free the temporary afterwards, if necessary. */
2599 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2600 len
, build_int_cst (TREE_TYPE (len
), 0));
2601 tmp
= gfc_call_free (var
);
2602 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2603 gfc_add_expr_to_block (&se
->post
, tmp
);
2606 se
->string_length
= len
;
2611 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2619 unsigned int num_args
;
2621 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2622 args
= XALLOCAVEC (tree
, num_args
);
2624 var
= gfc_create_var (pchar_type_node
, "pstr");
2625 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2627 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2628 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2629 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2631 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2632 tmp
= build_call_array_loc (input_location
,
2633 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2634 fndecl
, num_args
, args
);
2635 gfc_add_expr_to_block (&se
->pre
, tmp
);
2637 /* Free the temporary afterwards, if necessary. */
2638 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2639 len
, build_int_cst (TREE_TYPE (len
), 0));
2640 tmp
= gfc_call_free (var
);
2641 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2642 gfc_add_expr_to_block (&se
->post
, tmp
);
2645 se
->string_length
= len
;
2649 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
2653 conv_intrinsic_system_clock (gfc_code
*code
)
2656 gfc_se count_se
, count_rate_se
, count_max_se
;
2657 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
;
2661 gfc_expr
*count
= code
->ext
.actual
->expr
;
2662 gfc_expr
*count_rate
= code
->ext
.actual
->next
->expr
;
2663 gfc_expr
*count_max
= code
->ext
.actual
->next
->next
->expr
;
2665 /* The INTEGER(8) version has higher precision, it is used if both COUNT
2666 and COUNT_MAX can hold 64-bit values, or are absent. */
2667 if ((!count
|| count
->ts
.kind
>= 8)
2668 && (!count_max
|| count_max
->ts
.kind
>= 8))
2671 kind
= gfc_default_integer_kind
;
2672 type
= gfc_get_int_type (kind
);
2674 /* Evaluate our arguments. */
2677 gfc_init_se (&count_se
, NULL
);
2678 gfc_conv_expr (&count_se
, count
);
2683 gfc_init_se (&count_rate_se
, NULL
);
2684 gfc_conv_expr (&count_rate_se
, count_rate
);
2689 gfc_init_se (&count_max_se
, NULL
);
2690 gfc_conv_expr (&count_max_se
, count_max
);
2693 /* Prepare temporary variables if we need them. */
2694 if (count
&& count
->ts
.kind
!= kind
)
2695 arg1
= gfc_create_var (type
, "count");
2697 arg1
= count_se
.expr
;
2699 if (count_rate
&& (count_rate
->ts
.kind
!= kind
2700 || count_rate
->ts
.type
!= BT_INTEGER
))
2701 arg2
= gfc_create_var (type
, "count_rate");
2702 else if (count_rate
)
2703 arg2
= count_rate_se
.expr
;
2705 if (count_max
&& count_max
->ts
.kind
!= kind
)
2706 arg3
= gfc_create_var (type
, "count_max");
2708 arg3
= count_max_se
.expr
;
2710 /* Make the function call. */
2711 gfc_init_block (&block
);
2712 tmp
= build_call_expr_loc (input_location
,
2713 kind
== 4 ? gfor_fndecl_system_clock4
2714 : gfor_fndecl_system_clock8
,
2716 arg1
? gfc_build_addr_expr (NULL_TREE
, arg1
)
2717 : null_pointer_node
,
2718 arg2
? gfc_build_addr_expr (NULL_TREE
, arg2
)
2719 : null_pointer_node
,
2720 arg3
? gfc_build_addr_expr (NULL_TREE
, arg3
)
2721 : null_pointer_node
);
2722 gfc_add_expr_to_block (&block
, tmp
);
2724 /* And store values back if needed. */
2725 if (arg1
&& arg1
!= count_se
.expr
)
2726 gfc_add_modify (&block
, count_se
.expr
,
2727 fold_convert (TREE_TYPE (count_se
.expr
), arg1
));
2728 if (arg2
&& arg2
!= count_rate_se
.expr
)
2729 gfc_add_modify (&block
, count_rate_se
.expr
,
2730 fold_convert (TREE_TYPE (count_rate_se
.expr
), arg2
));
2731 if (arg3
&& arg3
!= count_max_se
.expr
)
2732 gfc_add_modify (&block
, count_max_se
.expr
,
2733 fold_convert (TREE_TYPE (count_max_se
.expr
), arg3
));
2735 return gfc_finish_block (&block
);
2739 /* Return a character string containing the tty name. */
2742 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2750 unsigned int num_args
;
2752 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2753 args
= XALLOCAVEC (tree
, num_args
);
2755 var
= gfc_create_var (pchar_type_node
, "pstr");
2756 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2758 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2759 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2760 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2762 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2763 tmp
= build_call_array_loc (input_location
,
2764 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2765 fndecl
, num_args
, args
);
2766 gfc_add_expr_to_block (&se
->pre
, tmp
);
2768 /* Free the temporary afterwards, if necessary. */
2769 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2770 len
, build_int_cst (TREE_TYPE (len
), 0));
2771 tmp
= gfc_call_free (var
);
2772 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2773 gfc_add_expr_to_block (&se
->post
, tmp
);
2776 se
->string_length
= len
;
2780 /* Get the minimum/maximum value of all the parameters.
2781 minmax (a1, a2, a3, ...)
2784 if (a2 .op. mvar || isnan (mvar))
2786 if (a3 .op. mvar || isnan (mvar))
2793 /* TODO: Mismatching types can occur when specific names are used.
2794 These should be handled during resolution. */
2796 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2804 gfc_actual_arglist
*argexpr
;
2805 unsigned int i
, nargs
;
2807 nargs
= gfc_intrinsic_argument_list_length (expr
);
2808 args
= XALLOCAVEC (tree
, nargs
);
2810 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2811 type
= gfc_typenode_for_spec (&expr
->ts
);
2813 argexpr
= expr
->value
.function
.actual
;
2814 if (TREE_TYPE (args
[0]) != type
)
2815 args
[0] = convert (type
, args
[0]);
2816 /* Only evaluate the argument once. */
2817 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2818 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2820 mvar
= gfc_create_var (type
, "M");
2821 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2822 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2828 /* Handle absent optional arguments by ignoring the comparison. */
2829 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2830 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2831 && TREE_CODE (val
) == INDIRECT_REF
)
2832 cond
= fold_build2_loc (input_location
,
2833 NE_EXPR
, boolean_type_node
,
2834 TREE_OPERAND (val
, 0),
2835 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2840 /* Only evaluate the argument once. */
2841 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2842 val
= gfc_evaluate_now (val
, &se
->pre
);
2845 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2847 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2848 convert (type
, val
), mvar
);
2850 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2851 __builtin_isnan might be made dependent on that module being loaded,
2852 to help performance of programs that don't rely on IEEE semantics. */
2853 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2855 isnan
= build_call_expr_loc (input_location
,
2856 builtin_decl_explicit (BUILT_IN_ISNAN
),
2858 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2859 boolean_type_node
, tmp
,
2860 fold_convert (boolean_type_node
, isnan
));
2862 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2863 build_empty_stmt (input_location
));
2865 if (cond
!= NULL_TREE
)
2866 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2867 build_empty_stmt (input_location
));
2869 gfc_add_expr_to_block (&se
->pre
, tmp
);
2870 argexpr
= argexpr
->next
;
2876 /* Generate library calls for MIN and MAX intrinsics for character
2879 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2882 tree var
, len
, fndecl
, tmp
, cond
, function
;
2885 nargs
= gfc_intrinsic_argument_list_length (expr
);
2886 args
= XALLOCAVEC (tree
, nargs
+ 4);
2887 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2889 /* Create the result variables. */
2890 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2891 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2892 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2893 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2894 args
[2] = build_int_cst (integer_type_node
, op
);
2895 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2897 if (expr
->ts
.kind
== 1)
2898 function
= gfor_fndecl_string_minmax
;
2899 else if (expr
->ts
.kind
== 4)
2900 function
= gfor_fndecl_string_minmax_char4
;
2904 /* Make the function call. */
2905 fndecl
= build_addr (function
, current_function_decl
);
2906 tmp
= build_call_array_loc (input_location
,
2907 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2909 gfc_add_expr_to_block (&se
->pre
, tmp
);
2911 /* Free the temporary afterwards, if necessary. */
2912 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2913 len
, build_int_cst (TREE_TYPE (len
), 0));
2914 tmp
= gfc_call_free (var
);
2915 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2916 gfc_add_expr_to_block (&se
->post
, tmp
);
2919 se
->string_length
= len
;
2923 /* Create a symbol node for this intrinsic. The symbol from the frontend
2924 has the generic name. */
2927 gfc_get_symbol_for_expr (gfc_expr
* expr
, bool ignore_optional
)
2931 /* TODO: Add symbols for intrinsic function to the global namespace. */
2932 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2933 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2936 sym
->attr
.external
= 1;
2937 sym
->attr
.function
= 1;
2938 sym
->attr
.always_explicit
= 1;
2939 sym
->attr
.proc
= PROC_INTRINSIC
;
2940 sym
->attr
.flavor
= FL_PROCEDURE
;
2944 sym
->attr
.dimension
= 1;
2945 sym
->as
= gfc_get_array_spec ();
2946 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2947 sym
->as
->rank
= expr
->rank
;
2950 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
,
2951 ignore_optional
? expr
->value
.function
.actual
2957 /* Generate a call to an external intrinsic function. */
2959 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2962 vec
<tree
, va_gc
> *append_args
;
2964 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2967 gcc_assert (expr
->rank
> 0);
2969 gcc_assert (expr
->rank
== 0);
2971 sym
= gfc_get_symbol_for_expr (expr
, se
->ignore_optional
);
2973 /* Calls to libgfortran_matmul need to be appended special arguments,
2974 to be able to call the BLAS ?gemm functions if required and possible. */
2976 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2977 && sym
->ts
.type
!= BT_LOGICAL
)
2979 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2981 if (flag_external_blas
2982 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2983 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
2987 if (sym
->ts
.type
== BT_REAL
)
2989 if (sym
->ts
.kind
== 4)
2990 gemm_fndecl
= gfor_fndecl_sgemm
;
2992 gemm_fndecl
= gfor_fndecl_dgemm
;
2996 if (sym
->ts
.kind
== 4)
2997 gemm_fndecl
= gfor_fndecl_cgemm
;
2999 gemm_fndecl
= gfor_fndecl_zgemm
;
3002 vec_alloc (append_args
, 3);
3003 append_args
->quick_push (build_int_cst (cint
, 1));
3004 append_args
->quick_push (build_int_cst (cint
,
3005 flag_blas_matmul_limit
));
3006 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
3011 vec_alloc (append_args
, 3);
3012 append_args
->quick_push (build_int_cst (cint
, 0));
3013 append_args
->quick_push (build_int_cst (cint
, 0));
3014 append_args
->quick_push (null_pointer_node
);
3018 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3020 gfc_free_symbol (sym
);
3023 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3043 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3052 gfc_actual_arglist
*actual
;
3059 gfc_conv_intrinsic_funcall (se
, expr
);
3063 actual
= expr
->value
.function
.actual
;
3064 type
= gfc_typenode_for_spec (&expr
->ts
);
3065 /* Initialize the result. */
3066 resvar
= gfc_create_var (type
, "test");
3068 tmp
= convert (type
, boolean_true_node
);
3070 tmp
= convert (type
, boolean_false_node
);
3071 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3073 /* Walk the arguments. */
3074 arrayss
= gfc_walk_expr (actual
->expr
);
3075 gcc_assert (arrayss
!= gfc_ss_terminator
);
3077 /* Initialize the scalarizer. */
3078 gfc_init_loopinfo (&loop
);
3079 exit_label
= gfc_build_label_decl (NULL_TREE
);
3080 TREE_USED (exit_label
) = 1;
3081 gfc_add_ss_to_loop (&loop
, arrayss
);
3083 /* Initialize the loop. */
3084 gfc_conv_ss_startstride (&loop
);
3085 gfc_conv_loop_setup (&loop
, &expr
->where
);
3087 gfc_mark_ss_chain_used (arrayss
, 1);
3088 /* Generate the loop body. */
3089 gfc_start_scalarized_body (&loop
, &body
);
3091 /* If the condition matches then set the return value. */
3092 gfc_start_block (&block
);
3094 tmp
= convert (type
, boolean_false_node
);
3096 tmp
= convert (type
, boolean_true_node
);
3097 gfc_add_modify (&block
, resvar
, tmp
);
3099 /* And break out of the loop. */
3100 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3101 gfc_add_expr_to_block (&block
, tmp
);
3103 found
= gfc_finish_block (&block
);
3105 /* Check this element. */
3106 gfc_init_se (&arrayse
, NULL
);
3107 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3108 arrayse
.ss
= arrayss
;
3109 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3111 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3112 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
3113 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
3114 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
3115 gfc_add_expr_to_block (&body
, tmp
);
3116 gfc_add_block_to_block (&body
, &arrayse
.post
);
3118 gfc_trans_scalarizing_loops (&loop
, &body
);
3120 /* Add the exit label. */
3121 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3122 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3124 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3125 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3126 gfc_cleanup_loop (&loop
);
3131 /* COUNT(A) = Number of true elements in A. */
3133 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
3140 gfc_actual_arglist
*actual
;
3146 gfc_conv_intrinsic_funcall (se
, expr
);
3150 actual
= expr
->value
.function
.actual
;
3152 type
= gfc_typenode_for_spec (&expr
->ts
);
3153 /* Initialize the result. */
3154 resvar
= gfc_create_var (type
, "count");
3155 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
3157 /* Walk the arguments. */
3158 arrayss
= gfc_walk_expr (actual
->expr
);
3159 gcc_assert (arrayss
!= gfc_ss_terminator
);
3161 /* Initialize the scalarizer. */
3162 gfc_init_loopinfo (&loop
);
3163 gfc_add_ss_to_loop (&loop
, arrayss
);
3165 /* Initialize the loop. */
3166 gfc_conv_ss_startstride (&loop
);
3167 gfc_conv_loop_setup (&loop
, &expr
->where
);
3169 gfc_mark_ss_chain_used (arrayss
, 1);
3170 /* Generate the loop body. */
3171 gfc_start_scalarized_body (&loop
, &body
);
3173 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
3174 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
3175 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
3177 gfc_init_se (&arrayse
, NULL
);
3178 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3179 arrayse
.ss
= arrayss
;
3180 gfc_conv_expr_val (&arrayse
, actual
->expr
);
3181 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
3182 build_empty_stmt (input_location
));
3184 gfc_add_block_to_block (&body
, &arrayse
.pre
);
3185 gfc_add_expr_to_block (&body
, tmp
);
3186 gfc_add_block_to_block (&body
, &arrayse
.post
);
3188 gfc_trans_scalarizing_loops (&loop
, &body
);
3190 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3191 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3192 gfc_cleanup_loop (&loop
);
3198 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
3199 struct and return the corresponding loopinfo. */
3201 static gfc_loopinfo
*
3202 enter_nested_loop (gfc_se
*se
)
3204 se
->ss
= se
->ss
->nested_ss
;
3205 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
3207 return se
->ss
->loop
;
3211 /* Inline implementation of the sum and product intrinsics. */
3213 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
3217 tree scale
= NULL_TREE
;
3222 gfc_loopinfo loop
, *ploop
;
3223 gfc_actual_arglist
*arg_array
, *arg_mask
;
3224 gfc_ss
*arrayss
= NULL
;
3225 gfc_ss
*maskss
= NULL
;
3229 gfc_expr
*arrayexpr
;
3234 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
3240 type
= gfc_typenode_for_spec (&expr
->ts
);
3241 /* Initialize the result. */
3242 resvar
= gfc_create_var (type
, "val");
3247 scale
= gfc_create_var (type
, "scale");
3248 gfc_add_modify (&se
->pre
, scale
,
3249 gfc_build_const (type
, integer_one_node
));
3250 tmp
= gfc_build_const (type
, integer_zero_node
);
3252 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
3253 tmp
= gfc_build_const (type
, integer_zero_node
);
3254 else if (op
== NE_EXPR
)
3256 tmp
= convert (type
, boolean_false_node
);
3257 else if (op
== BIT_AND_EXPR
)
3258 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
3259 type
, integer_one_node
));
3261 tmp
= gfc_build_const (type
, integer_one_node
);
3263 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3265 arg_array
= expr
->value
.function
.actual
;
3267 arrayexpr
= arg_array
->expr
;
3269 if (op
== NE_EXPR
|| norm2
)
3270 /* PARITY and NORM2. */
3274 arg_mask
= arg_array
->next
->next
;
3275 gcc_assert (arg_mask
!= NULL
);
3276 maskexpr
= arg_mask
->expr
;
3279 if (expr
->rank
== 0)
3281 /* Walk the arguments. */
3282 arrayss
= gfc_walk_expr (arrayexpr
);
3283 gcc_assert (arrayss
!= gfc_ss_terminator
);
3285 if (maskexpr
&& maskexpr
->rank
> 0)
3287 maskss
= gfc_walk_expr (maskexpr
);
3288 gcc_assert (maskss
!= gfc_ss_terminator
);
3293 /* Initialize the scalarizer. */
3294 gfc_init_loopinfo (&loop
);
3295 gfc_add_ss_to_loop (&loop
, arrayss
);
3296 if (maskexpr
&& maskexpr
->rank
> 0)
3297 gfc_add_ss_to_loop (&loop
, maskss
);
3299 /* Initialize the loop. */
3300 gfc_conv_ss_startstride (&loop
);
3301 gfc_conv_loop_setup (&loop
, &expr
->where
);
3303 gfc_mark_ss_chain_used (arrayss
, 1);
3304 if (maskexpr
&& maskexpr
->rank
> 0)
3305 gfc_mark_ss_chain_used (maskss
, 1);
3310 /* All the work has been done in the parent loops. */
3311 ploop
= enter_nested_loop (se
);
3315 /* Generate the loop body. */
3316 gfc_start_scalarized_body (ploop
, &body
);
3318 /* If we have a mask, only add this element if the mask is set. */
3319 if (maskexpr
&& maskexpr
->rank
> 0)
3321 gfc_init_se (&maskse
, parent_se
);
3322 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
3323 if (expr
->rank
== 0)
3325 gfc_conv_expr_val (&maskse
, maskexpr
);
3326 gfc_add_block_to_block (&body
, &maskse
.pre
);
3328 gfc_start_block (&block
);
3331 gfc_init_block (&block
);
3333 /* Do the actual summation/product. */
3334 gfc_init_se (&arrayse
, parent_se
);
3335 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
3336 if (expr
->rank
== 0)
3337 arrayse
.ss
= arrayss
;
3338 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3339 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3343 /* if (x (i) != 0.0)
3349 result = 1.0 + result * val * val;
3355 result += val * val;
3358 tree res1
, res2
, cond
, absX
, val
;
3359 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
3361 gfc_init_block (&ifblock1
);
3363 absX
= gfc_create_var (type
, "absX");
3364 gfc_add_modify (&ifblock1
, absX
,
3365 fold_build1_loc (input_location
, ABS_EXPR
, type
,
3367 val
= gfc_create_var (type
, "val");
3368 gfc_add_expr_to_block (&ifblock1
, val
);
3370 gfc_init_block (&ifblock2
);
3371 gfc_add_modify (&ifblock2
, val
,
3372 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
3374 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3375 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
3376 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
3377 gfc_build_const (type
, integer_one_node
));
3378 gfc_add_modify (&ifblock2
, resvar
, res1
);
3379 gfc_add_modify (&ifblock2
, scale
, absX
);
3380 res1
= gfc_finish_block (&ifblock2
);
3382 gfc_init_block (&ifblock3
);
3383 gfc_add_modify (&ifblock3
, val
,
3384 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
3386 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3387 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
3388 gfc_add_modify (&ifblock3
, resvar
, res2
);
3389 res2
= gfc_finish_block (&ifblock3
);
3391 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3393 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
3394 gfc_add_expr_to_block (&ifblock1
, tmp
);
3395 tmp
= gfc_finish_block (&ifblock1
);
3397 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3399 gfc_build_const (type
, integer_zero_node
));
3401 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3402 gfc_add_expr_to_block (&block
, tmp
);
3406 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
3407 gfc_add_modify (&block
, resvar
, tmp
);
3410 gfc_add_block_to_block (&block
, &arrayse
.post
);
3412 if (maskexpr
&& maskexpr
->rank
> 0)
3414 /* We enclose the above in if (mask) {...} . */
3416 tmp
= gfc_finish_block (&block
);
3417 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3418 build_empty_stmt (input_location
));
3421 tmp
= gfc_finish_block (&block
);
3422 gfc_add_expr_to_block (&body
, tmp
);
3424 gfc_trans_scalarizing_loops (ploop
, &body
);
3426 /* For a scalar mask, enclose the loop in an if statement. */
3427 if (maskexpr
&& maskexpr
->rank
== 0)
3429 gfc_init_block (&block
);
3430 gfc_add_block_to_block (&block
, &ploop
->pre
);
3431 gfc_add_block_to_block (&block
, &ploop
->post
);
3432 tmp
= gfc_finish_block (&block
);
3436 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
3437 build_empty_stmt (input_location
));
3438 gfc_advance_se_ss_chain (se
);
3442 gcc_assert (expr
->rank
== 0);
3443 gfc_init_se (&maskse
, NULL
);
3444 gfc_conv_expr_val (&maskse
, maskexpr
);
3445 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3446 build_empty_stmt (input_location
));
3449 gfc_add_expr_to_block (&block
, tmp
);
3450 gfc_add_block_to_block (&se
->pre
, &block
);
3451 gcc_assert (se
->post
.head
== NULL
);
3455 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
3456 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
3459 if (expr
->rank
== 0)
3460 gfc_cleanup_loop (ploop
);
3464 /* result = scale * sqrt(result). */
3466 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
3467 resvar
= build_call_expr_loc (input_location
,
3469 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
3476 /* Inline implementation of the dot_product intrinsic. This function
3477 is based on gfc_conv_intrinsic_arith (the previous function). */
3479 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
3487 gfc_actual_arglist
*actual
;
3488 gfc_ss
*arrayss1
, *arrayss2
;
3489 gfc_se arrayse1
, arrayse2
;
3490 gfc_expr
*arrayexpr1
, *arrayexpr2
;
3492 type
= gfc_typenode_for_spec (&expr
->ts
);
3494 /* Initialize the result. */
3495 resvar
= gfc_create_var (type
, "val");
3496 if (expr
->ts
.type
== BT_LOGICAL
)
3497 tmp
= build_int_cst (type
, 0);
3499 tmp
= gfc_build_const (type
, integer_zero_node
);
3501 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3503 /* Walk argument #1. */
3504 actual
= expr
->value
.function
.actual
;
3505 arrayexpr1
= actual
->expr
;
3506 arrayss1
= gfc_walk_expr (arrayexpr1
);
3507 gcc_assert (arrayss1
!= gfc_ss_terminator
);
3509 /* Walk argument #2. */
3510 actual
= actual
->next
;
3511 arrayexpr2
= actual
->expr
;
3512 arrayss2
= gfc_walk_expr (arrayexpr2
);
3513 gcc_assert (arrayss2
!= gfc_ss_terminator
);
3515 /* Initialize the scalarizer. */
3516 gfc_init_loopinfo (&loop
);
3517 gfc_add_ss_to_loop (&loop
, arrayss1
);
3518 gfc_add_ss_to_loop (&loop
, arrayss2
);
3520 /* Initialize the loop. */
3521 gfc_conv_ss_startstride (&loop
);
3522 gfc_conv_loop_setup (&loop
, &expr
->where
);
3524 gfc_mark_ss_chain_used (arrayss1
, 1);
3525 gfc_mark_ss_chain_used (arrayss2
, 1);
3527 /* Generate the loop body. */
3528 gfc_start_scalarized_body (&loop
, &body
);
3529 gfc_init_block (&block
);
3531 /* Make the tree expression for [conjg(]array1[)]. */
3532 gfc_init_se (&arrayse1
, NULL
);
3533 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
3534 arrayse1
.ss
= arrayss1
;
3535 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
3536 if (expr
->ts
.type
== BT_COMPLEX
)
3537 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
3539 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
3541 /* Make the tree expression for array2. */
3542 gfc_init_se (&arrayse2
, NULL
);
3543 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
3544 arrayse2
.ss
= arrayss2
;
3545 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
3546 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
3548 /* Do the actual product and sum. */
3549 if (expr
->ts
.type
== BT_LOGICAL
)
3551 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
3552 arrayse1
.expr
, arrayse2
.expr
);
3553 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
3557 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
3559 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
3561 gfc_add_modify (&block
, resvar
, tmp
);
3563 /* Finish up the loop block and the loop. */
3564 tmp
= gfc_finish_block (&block
);
3565 gfc_add_expr_to_block (&body
, tmp
);
3567 gfc_trans_scalarizing_loops (&loop
, &body
);
3568 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3569 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3570 gfc_cleanup_loop (&loop
);
3576 /* Emit code for minloc or maxloc intrinsic. There are many different cases
3577 we need to handle. For performance reasons we sometimes create two
3578 loops instead of one, where the second one is much simpler.
3579 Examples for minloc intrinsic:
3580 1) Result is an array, a call is generated
3581 2) Array mask is used and NaNs need to be supported:
3587 if (pos == 0) pos = S + (1 - from);
3588 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3595 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3599 3) NaNs need to be supported, but it is known at compile time or cheaply
3600 at runtime whether array is nonempty or not:
3605 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3608 if (from <= to) pos = 1;
3612 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3616 4) NaNs aren't supported, array mask is used:
3617 limit = infinities_supported ? Infinity : huge (limit);
3621 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3627 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3631 5) Same without array mask:
3632 limit = infinities_supported ? Infinity : huge (limit);
3633 pos = (from <= to) ? 1 : 0;
3636 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3639 For 3) and 5), if mask is scalar, this all goes into a conditional,
3640 setting pos = 0; in the else branch. */
3643 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3647 stmtblock_t ifblock
;
3648 stmtblock_t elseblock
;
3659 gfc_actual_arglist
*actual
;
3664 gfc_expr
*arrayexpr
;
3671 gfc_conv_intrinsic_funcall (se
, expr
);
3675 /* Initialize the result. */
3676 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3677 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3678 type
= gfc_typenode_for_spec (&expr
->ts
);
3680 /* Walk the arguments. */
3681 actual
= expr
->value
.function
.actual
;
3682 arrayexpr
= actual
->expr
;
3683 arrayss
= gfc_walk_expr (arrayexpr
);
3684 gcc_assert (arrayss
!= gfc_ss_terminator
);
3686 actual
= actual
->next
->next
;
3687 gcc_assert (actual
);
3688 maskexpr
= actual
->expr
;
3690 if (maskexpr
&& maskexpr
->rank
!= 0)
3692 maskss
= gfc_walk_expr (maskexpr
);
3693 gcc_assert (maskss
!= gfc_ss_terminator
);
3698 if (gfc_array_size (arrayexpr
, &asize
))
3700 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3702 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3703 boolean_type_node
, nonempty
,
3704 gfc_index_zero_node
);
3709 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3710 switch (arrayexpr
->ts
.type
)
3713 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3717 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3718 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3719 arrayexpr
->ts
.kind
);
3726 /* We start with the most negative possible value for MAXLOC, and the most
3727 positive possible value for MINLOC. The most negative possible value is
3728 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3729 possible value is HUGE in both cases. */
3731 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3732 if (op
== GT_EXPR
&& arrayexpr
->ts
.type
== BT_INTEGER
)
3733 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3734 build_int_cst (TREE_TYPE (tmp
), 1));
3736 gfc_add_modify (&se
->pre
, limit
, tmp
);
3738 /* Initialize the scalarizer. */
3739 gfc_init_loopinfo (&loop
);
3740 gfc_add_ss_to_loop (&loop
, arrayss
);
3742 gfc_add_ss_to_loop (&loop
, maskss
);
3744 /* Initialize the loop. */
3745 gfc_conv_ss_startstride (&loop
);
3747 /* The code generated can have more than one loop in sequence (see the
3748 comment at the function header). This doesn't work well with the
3749 scalarizer, which changes arrays' offset when the scalarization loops
3750 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3751 are currently inlined in the scalar case only (for which loop is of rank
3752 one). As there is no dependency to care about in that case, there is no
3753 temporary, so that we can use the scalarizer temporary code to handle
3754 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3755 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3757 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3758 should eventually go away. We could either create two loops properly,
3759 or find another way to save/restore the array offsets between the two
3760 loops (without conflicting with temporary management), or use a single
3761 loop minmaxloc implementation. See PR 31067. */
3762 loop
.temp_dim
= loop
.dimen
;
3763 gfc_conv_loop_setup (&loop
, &expr
->where
);
3765 gcc_assert (loop
.dimen
== 1);
3766 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3767 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3768 loop
.from
[0], loop
.to
[0]);
3772 /* Initialize the position to zero, following Fortran 2003. We are free
3773 to do this because Fortran 95 allows the result of an entirely false
3774 mask to be processor dependent. If we know at compile time the array
3775 is non-empty and no MASK is used, we can initialize to 1 to simplify
3777 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3778 gfc_add_modify (&loop
.pre
, pos
,
3779 fold_build3_loc (input_location
, COND_EXPR
,
3780 gfc_array_index_type
,
3781 nonempty
, gfc_index_one_node
,
3782 gfc_index_zero_node
));
3785 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3786 lab1
= gfc_build_label_decl (NULL_TREE
);
3787 TREE_USED (lab1
) = 1;
3788 lab2
= gfc_build_label_decl (NULL_TREE
);
3789 TREE_USED (lab2
) = 1;
3792 /* An offset must be added to the loop
3793 counter to obtain the required position. */
3794 gcc_assert (loop
.from
[0]);
3796 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3797 gfc_index_one_node
, loop
.from
[0]);
3798 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3800 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3802 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3803 /* Generate the loop body. */
3804 gfc_start_scalarized_body (&loop
, &body
);
3806 /* If we have a mask, only check this element if the mask is set. */
3809 gfc_init_se (&maskse
, NULL
);
3810 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3812 gfc_conv_expr_val (&maskse
, maskexpr
);
3813 gfc_add_block_to_block (&body
, &maskse
.pre
);
3815 gfc_start_block (&block
);
3818 gfc_init_block (&block
);
3820 /* Compare with the current limit. */
3821 gfc_init_se (&arrayse
, NULL
);
3822 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3823 arrayse
.ss
= arrayss
;
3824 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3825 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3827 /* We do the following if this is a more extreme value. */
3828 gfc_start_block (&ifblock
);
3830 /* Assign the value to the limit... */
3831 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3833 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3835 stmtblock_t ifblock2
;
3838 gfc_start_block (&ifblock2
);
3839 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3840 loop
.loopvar
[0], offset
);
3841 gfc_add_modify (&ifblock2
, pos
, tmp
);
3842 ifbody2
= gfc_finish_block (&ifblock2
);
3843 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3844 gfc_index_zero_node
);
3845 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3846 build_empty_stmt (input_location
));
3847 gfc_add_expr_to_block (&block
, tmp
);
3850 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3851 loop
.loopvar
[0], offset
);
3852 gfc_add_modify (&ifblock
, pos
, tmp
);
3855 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3857 ifbody
= gfc_finish_block (&ifblock
);
3859 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3862 cond
= fold_build2_loc (input_location
,
3863 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3864 boolean_type_node
, arrayse
.expr
, limit
);
3866 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3867 arrayse
.expr
, limit
);
3869 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3870 build_empty_stmt (input_location
));
3872 gfc_add_expr_to_block (&block
, ifbody
);
3876 /* We enclose the above in if (mask) {...}. */
3877 tmp
= gfc_finish_block (&block
);
3879 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3880 build_empty_stmt (input_location
));
3883 tmp
= gfc_finish_block (&block
);
3884 gfc_add_expr_to_block (&body
, tmp
);
3888 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3890 if (HONOR_NANS (DECL_MODE (limit
)))
3892 if (nonempty
!= NULL
)
3894 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3895 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3896 build_empty_stmt (input_location
));
3897 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3901 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3902 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3904 /* If we have a mask, only check this element if the mask is set. */
3907 gfc_init_se (&maskse
, NULL
);
3908 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3910 gfc_conv_expr_val (&maskse
, maskexpr
);
3911 gfc_add_block_to_block (&body
, &maskse
.pre
);
3913 gfc_start_block (&block
);
3916 gfc_init_block (&block
);
3918 /* Compare with the current limit. */
3919 gfc_init_se (&arrayse
, NULL
);
3920 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3921 arrayse
.ss
= arrayss
;
3922 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3923 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3925 /* We do the following if this is a more extreme value. */
3926 gfc_start_block (&ifblock
);
3928 /* Assign the value to the limit... */
3929 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3931 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3932 loop
.loopvar
[0], offset
);
3933 gfc_add_modify (&ifblock
, pos
, tmp
);
3935 ifbody
= gfc_finish_block (&ifblock
);
3937 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3938 arrayse
.expr
, limit
);
3940 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3941 build_empty_stmt (input_location
));
3942 gfc_add_expr_to_block (&block
, tmp
);
3946 /* We enclose the above in if (mask) {...}. */
3947 tmp
= gfc_finish_block (&block
);
3949 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3950 build_empty_stmt (input_location
));
3953 tmp
= gfc_finish_block (&block
);
3954 gfc_add_expr_to_block (&body
, tmp
);
3955 /* Avoid initializing loopvar[0] again, it should be left where
3956 it finished by the first loop. */
3957 loop
.from
[0] = loop
.loopvar
[0];
3960 gfc_trans_scalarizing_loops (&loop
, &body
);
3963 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3965 /* For a scalar mask, enclose the loop in an if statement. */
3966 if (maskexpr
&& maskss
== NULL
)
3968 gfc_init_se (&maskse
, NULL
);
3969 gfc_conv_expr_val (&maskse
, maskexpr
);
3970 gfc_init_block (&block
);
3971 gfc_add_block_to_block (&block
, &loop
.pre
);
3972 gfc_add_block_to_block (&block
, &loop
.post
);
3973 tmp
= gfc_finish_block (&block
);
3975 /* For the else part of the scalar mask, just initialize
3976 the pos variable the same way as above. */
3978 gfc_init_block (&elseblock
);
3979 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3980 elsetmp
= gfc_finish_block (&elseblock
);
3982 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3983 gfc_add_expr_to_block (&block
, tmp
);
3984 gfc_add_block_to_block (&se
->pre
, &block
);
3988 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3989 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3991 gfc_cleanup_loop (&loop
);
3993 se
->expr
= convert (type
, pos
);
3996 /* Emit code for minval or maxval intrinsic. There are many different cases
3997 we need to handle. For performance reasons we sometimes create two
3998 loops instead of one, where the second one is much simpler.
3999 Examples for minval intrinsic:
4000 1) Result is an array, a call is generated
4001 2) Array mask is used and NaNs need to be supported, rank 1:
4006 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4009 limit = nonempty ? NaN : huge (limit);
4011 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4012 3) NaNs need to be supported, but it is known at compile time or cheaply
4013 at runtime whether array is nonempty or not, rank 1:
4016 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4017 limit = (from <= to) ? NaN : huge (limit);
4019 while (S <= to) { limit = min (a[S], limit); S++; }
4020 4) Array mask is used and NaNs need to be supported, rank > 1:
4029 if (fast) limit = min (a[S1][S2], limit);
4032 if (a[S1][S2] <= limit) {
4043 limit = nonempty ? NaN : huge (limit);
4044 5) NaNs need to be supported, but it is known at compile time or cheaply
4045 at runtime whether array is nonempty or not, rank > 1:
4052 if (fast) limit = min (a[S1][S2], limit);
4054 if (a[S1][S2] <= limit) {
4064 limit = (nonempty_array) ? NaN : huge (limit);
4065 6) NaNs aren't supported, but infinities are. Array mask is used:
4070 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4073 limit = nonempty ? limit : huge (limit);
4074 7) Same without array mask:
4077 while (S <= to) { limit = min (a[S], limit); S++; }
4078 limit = (from <= to) ? limit : huge (limit);
4079 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4080 limit = huge (limit);
4082 while (S <= to) { limit = min (a[S], limit); S++); }
4084 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4085 with array mask instead).
4086 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4087 setting limit = huge (limit); in the else branch. */
4090 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4100 tree huge_cst
= NULL
, nan_cst
= NULL
;
4102 stmtblock_t block
, block2
;
4104 gfc_actual_arglist
*actual
;
4109 gfc_expr
*arrayexpr
;
4115 gfc_conv_intrinsic_funcall (se
, expr
);
4119 type
= gfc_typenode_for_spec (&expr
->ts
);
4120 /* Initialize the result. */
4121 limit
= gfc_create_var (type
, "limit");
4122 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
4123 switch (expr
->ts
.type
)
4126 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
4128 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4130 REAL_VALUE_TYPE real
;
4132 tmp
= build_real (type
, real
);
4136 if (HONOR_NANS (DECL_MODE (limit
)))
4137 nan_cst
= gfc_build_nan (type
, "");
4141 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
4148 /* We start with the most negative possible value for MAXVAL, and the most
4149 positive possible value for MINVAL. The most negative possible value is
4150 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4151 possible value is HUGE in both cases. */
4154 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
4156 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
4157 TREE_TYPE (huge_cst
), huge_cst
);
4160 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
4161 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
4162 tmp
, build_int_cst (type
, 1));
4164 gfc_add_modify (&se
->pre
, limit
, tmp
);
4166 /* Walk the arguments. */
4167 actual
= expr
->value
.function
.actual
;
4168 arrayexpr
= actual
->expr
;
4169 arrayss
= gfc_walk_expr (arrayexpr
);
4170 gcc_assert (arrayss
!= gfc_ss_terminator
);
4172 actual
= actual
->next
->next
;
4173 gcc_assert (actual
);
4174 maskexpr
= actual
->expr
;
4176 if (maskexpr
&& maskexpr
->rank
!= 0)
4178 maskss
= gfc_walk_expr (maskexpr
);
4179 gcc_assert (maskss
!= gfc_ss_terminator
);
4184 if (gfc_array_size (arrayexpr
, &asize
))
4186 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
4188 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
4189 boolean_type_node
, nonempty
,
4190 gfc_index_zero_node
);
4195 /* Initialize the scalarizer. */
4196 gfc_init_loopinfo (&loop
);
4197 gfc_add_ss_to_loop (&loop
, arrayss
);
4199 gfc_add_ss_to_loop (&loop
, maskss
);
4201 /* Initialize the loop. */
4202 gfc_conv_ss_startstride (&loop
);
4204 /* The code generated can have more than one loop in sequence (see the
4205 comment at the function header). This doesn't work well with the
4206 scalarizer, which changes arrays' offset when the scalarization loops
4207 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
4208 are currently inlined in the scalar case only. As there is no dependency
4209 to care about in that case, there is no temporary, so that we can use the
4210 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
4211 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
4212 gfc_trans_scalarized_loop_boundary even later to restore offset.
4213 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
4214 should eventually go away. We could either create two loops properly,
4215 or find another way to save/restore the array offsets between the two
4216 loops (without conflicting with temporary management), or use a single
4217 loop minmaxval implementation. See PR 31067. */
4218 loop
.temp_dim
= loop
.dimen
;
4219 gfc_conv_loop_setup (&loop
, &expr
->where
);
4221 if (nonempty
== NULL
&& maskss
== NULL
4222 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
4223 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
4224 loop
.from
[0], loop
.to
[0]);
4225 nonempty_var
= NULL
;
4226 if (nonempty
== NULL
4227 && (HONOR_INFINITIES (DECL_MODE (limit
))
4228 || HONOR_NANS (DECL_MODE (limit
))))
4230 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
4231 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
4232 nonempty
= nonempty_var
;
4236 if (HONOR_NANS (DECL_MODE (limit
)))
4238 if (loop
.dimen
== 1)
4240 lab
= gfc_build_label_decl (NULL_TREE
);
4241 TREE_USED (lab
) = 1;
4245 fast
= gfc_create_var (boolean_type_node
, "fast");
4246 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
4250 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
4252 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
4253 /* Generate the loop body. */
4254 gfc_start_scalarized_body (&loop
, &body
);
4256 /* If we have a mask, only add this element if the mask is set. */
4259 gfc_init_se (&maskse
, NULL
);
4260 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4262 gfc_conv_expr_val (&maskse
, maskexpr
);
4263 gfc_add_block_to_block (&body
, &maskse
.pre
);
4265 gfc_start_block (&block
);
4268 gfc_init_block (&block
);
4270 /* Compare with the current limit. */
4271 gfc_init_se (&arrayse
, NULL
);
4272 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4273 arrayse
.ss
= arrayss
;
4274 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4275 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4277 gfc_init_block (&block2
);
4280 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
4282 if (HONOR_NANS (DECL_MODE (limit
)))
4284 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
4285 boolean_type_node
, arrayse
.expr
, limit
);
4287 ifbody
= build1_v (GOTO_EXPR
, lab
);
4290 stmtblock_t ifblock
;
4292 gfc_init_block (&ifblock
);
4293 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
4294 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
4295 ifbody
= gfc_finish_block (&ifblock
);
4297 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4298 build_empty_stmt (input_location
));
4299 gfc_add_expr_to_block (&block2
, tmp
);
4303 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4305 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4307 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4308 arrayse
.expr
, limit
);
4309 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4310 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4311 build_empty_stmt (input_location
));
4312 gfc_add_expr_to_block (&block2
, tmp
);
4316 tmp
= fold_build2_loc (input_location
,
4317 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4318 type
, arrayse
.expr
, limit
);
4319 gfc_add_modify (&block2
, limit
, tmp
);
4325 tree elsebody
= gfc_finish_block (&block2
);
4327 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4329 if (HONOR_NANS (DECL_MODE (limit
))
4330 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4332 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4333 arrayse
.expr
, limit
);
4334 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4335 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
4336 build_empty_stmt (input_location
));
4340 tmp
= fold_build2_loc (input_location
,
4341 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4342 type
, arrayse
.expr
, limit
);
4343 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4345 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
4346 gfc_add_expr_to_block (&block
, tmp
);
4349 gfc_add_block_to_block (&block
, &block2
);
4351 gfc_add_block_to_block (&block
, &arrayse
.post
);
4353 tmp
= gfc_finish_block (&block
);
4355 /* We enclose the above in if (mask) {...}. */
4356 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4357 build_empty_stmt (input_location
));
4358 gfc_add_expr_to_block (&body
, tmp
);
4362 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4364 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4366 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
4367 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
4369 /* If we have a mask, only add this element if the mask is set. */
4372 gfc_init_se (&maskse
, NULL
);
4373 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4375 gfc_conv_expr_val (&maskse
, maskexpr
);
4376 gfc_add_block_to_block (&body
, &maskse
.pre
);
4378 gfc_start_block (&block
);
4381 gfc_init_block (&block
);
4383 /* Compare with the current limit. */
4384 gfc_init_se (&arrayse
, NULL
);
4385 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4386 arrayse
.ss
= arrayss
;
4387 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4388 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4390 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4392 if (HONOR_NANS (DECL_MODE (limit
))
4393 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4395 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4396 arrayse
.expr
, limit
);
4397 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4398 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4399 build_empty_stmt (input_location
));
4400 gfc_add_expr_to_block (&block
, tmp
);
4404 tmp
= fold_build2_loc (input_location
,
4405 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4406 type
, arrayse
.expr
, limit
);
4407 gfc_add_modify (&block
, limit
, tmp
);
4410 gfc_add_block_to_block (&block
, &arrayse
.post
);
4412 tmp
= gfc_finish_block (&block
);
4414 /* We enclose the above in if (mask) {...}. */
4415 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4416 build_empty_stmt (input_location
));
4417 gfc_add_expr_to_block (&body
, tmp
);
4418 /* Avoid initializing loopvar[0] again, it should be left where
4419 it finished by the first loop. */
4420 loop
.from
[0] = loop
.loopvar
[0];
4422 gfc_trans_scalarizing_loops (&loop
, &body
);
4426 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4428 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4429 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
4431 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4433 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
4435 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
4437 gfc_add_modify (&loop
.pre
, limit
, tmp
);
4440 /* For a scalar mask, enclose the loop in an if statement. */
4441 if (maskexpr
&& maskss
== NULL
)
4445 gfc_init_se (&maskse
, NULL
);
4446 gfc_conv_expr_val (&maskse
, maskexpr
);
4447 gfc_init_block (&block
);
4448 gfc_add_block_to_block (&block
, &loop
.pre
);
4449 gfc_add_block_to_block (&block
, &loop
.post
);
4450 tmp
= gfc_finish_block (&block
);
4452 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4453 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
4455 else_stmt
= build_empty_stmt (input_location
);
4456 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
4457 gfc_add_expr_to_block (&block
, tmp
);
4458 gfc_add_block_to_block (&se
->pre
, &block
);
4462 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4463 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4466 gfc_cleanup_loop (&loop
);
4471 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
4473 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
4479 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4480 type
= TREE_TYPE (args
[0]);
4482 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4483 build_int_cst (type
, 1), args
[1]);
4484 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
4485 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
4486 build_int_cst (type
, 0));
4487 type
= gfc_typenode_for_spec (&expr
->ts
);
4488 se
->expr
= convert (type
, tmp
);
4492 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
4494 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4498 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4500 /* Convert both arguments to the unsigned type of the same size. */
4501 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
4502 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
4504 /* If they have unequal type size, convert to the larger one. */
4505 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
4506 > TYPE_PRECISION (TREE_TYPE (args
[1])))
4507 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
4508 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
4509 > TYPE_PRECISION (TREE_TYPE (args
[0])))
4510 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
4512 /* Now, we compare them. */
4513 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4518 /* Generate code to perform the specified operation. */
4520 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4524 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4525 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
4531 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
4535 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4536 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4537 TREE_TYPE (arg
), arg
);
4540 /* Set or clear a single bit. */
4542 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
4549 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4550 type
= TREE_TYPE (args
[0]);
4552 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4553 build_int_cst (type
, 1), args
[1]);
4559 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
4561 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
4564 /* Extract a sequence of bits.
4565 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
4567 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
4574 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4575 type
= TREE_TYPE (args
[0]);
4577 mask
= build_int_cst (type
, -1);
4578 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
4579 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
4581 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
4583 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4587 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4590 tree args
[2], type
, num_bits
, cond
;
4592 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4594 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4595 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4596 type
= TREE_TYPE (args
[0]);
4599 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4601 gcc_assert (right_shift
);
4603 se
->expr
= fold_build2_loc (input_location
,
4604 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4605 TREE_TYPE (args
[0]), args
[0], args
[1]);
4608 se
->expr
= fold_convert (type
, se
->expr
);
4610 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4611 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4613 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4614 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4617 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4618 build_int_cst (type
, 0), se
->expr
);
4621 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4623 : ((shift >= 0) ? i << shift : i >> -shift)
4624 where all shifts are logical shifts. */
4626 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4638 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4640 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4641 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4643 type
= TREE_TYPE (args
[0]);
4644 utype
= unsigned_type_for (type
);
4646 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4649 /* Left shift if positive. */
4650 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4652 /* Right shift if negative.
4653 We convert to an unsigned type because we want a logical shift.
4654 The standard doesn't define the case of shifting negative
4655 numbers, and we try to be compatible with other compilers, most
4656 notably g77, here. */
4657 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4658 utype
, convert (utype
, args
[0]), width
));
4660 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4661 build_int_cst (TREE_TYPE (args
[1]), 0));
4662 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4664 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4665 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4667 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4668 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4670 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4671 build_int_cst (type
, 0), tmp
);
4675 /* Circular shift. AKA rotate or barrel shift. */
4678 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4686 unsigned int num_args
;
4688 num_args
= gfc_intrinsic_argument_list_length (expr
);
4689 args
= XALLOCAVEC (tree
, num_args
);
4691 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4695 /* Use a library function for the 3 parameter version. */
4696 tree int4type
= gfc_get_int_type (4);
4698 type
= TREE_TYPE (args
[0]);
4699 /* We convert the first argument to at least 4 bytes, and
4700 convert back afterwards. This removes the need for library
4701 functions for all argument sizes, and function will be
4702 aligned to at least 32 bits, so there's no loss. */
4703 if (expr
->ts
.kind
< 4)
4704 args
[0] = convert (int4type
, args
[0]);
4706 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4707 need loads of library functions. They cannot have values >
4708 BIT_SIZE (I) so the conversion is safe. */
4709 args
[1] = convert (int4type
, args
[1]);
4710 args
[2] = convert (int4type
, args
[2]);
4712 switch (expr
->ts
.kind
)
4717 tmp
= gfor_fndecl_math_ishftc4
;
4720 tmp
= gfor_fndecl_math_ishftc8
;
4723 tmp
= gfor_fndecl_math_ishftc16
;
4728 se
->expr
= build_call_expr_loc (input_location
,
4729 tmp
, 3, args
[0], args
[1], args
[2]);
4730 /* Convert the result back to the original type, if we extended
4731 the first argument's width above. */
4732 if (expr
->ts
.kind
< 4)
4733 se
->expr
= convert (type
, se
->expr
);
4737 type
= TREE_TYPE (args
[0]);
4739 /* Evaluate arguments only once. */
4740 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4741 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4743 /* Rotate left if positive. */
4744 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4746 /* Rotate right if negative. */
4747 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4749 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4751 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4752 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4754 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4756 /* Do nothing if shift == 0. */
4757 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4759 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4764 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4765 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4767 The conditional expression is necessary because the result of LEADZ(0)
4768 is defined, but the result of __builtin_clz(0) is undefined for most
4771 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4772 difference in bit size between the argument of LEADZ and the C int. */
4775 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4787 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4788 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4790 /* Which variant of __builtin_clz* should we call? */
4791 if (argsize
<= INT_TYPE_SIZE
)
4793 arg_type
= unsigned_type_node
;
4794 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4796 else if (argsize
<= LONG_TYPE_SIZE
)
4798 arg_type
= long_unsigned_type_node
;
4799 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4801 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4803 arg_type
= long_long_unsigned_type_node
;
4804 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4808 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4809 arg_type
= gfc_build_uint_type (argsize
);
4813 /* Convert the actual argument twice: first, to the unsigned type of the
4814 same size; then, to the proper argument type for the built-in
4815 function. But the return type is of the default INTEGER kind. */
4816 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4817 arg
= fold_convert (arg_type
, arg
);
4818 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4819 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4821 /* Compute LEADZ for the case i .ne. 0. */
4824 s
= TYPE_PRECISION (arg_type
) - argsize
;
4825 tmp
= fold_convert (result_type
,
4826 build_call_expr_loc (input_location
, func
,
4828 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4829 tmp
, build_int_cst (result_type
, s
));
4833 /* We end up here if the argument type is larger than 'long long'.
4834 We generate this code:
4836 if (x & (ULL_MAX << ULL_SIZE) != 0)
4837 return clzll ((unsigned long long) (x >> ULLSIZE));
4839 return ULL_SIZE + clzll ((unsigned long long) x);
4840 where ULL_MAX is the largest value that a ULL_MAX can hold
4841 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4842 is the bit-size of the long long type (64 in this example). */
4843 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4845 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4846 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4847 long_long_unsigned_type_node
,
4848 build_int_cst (long_long_unsigned_type_node
,
4851 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4852 fold_convert (arg_type
, ullmax
), ullsize
);
4853 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4855 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4856 cond
, build_int_cst (arg_type
, 0));
4858 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4860 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4861 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4862 tmp1
= fold_convert (result_type
,
4863 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4865 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4866 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4867 tmp2
= fold_convert (result_type
,
4868 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4869 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4872 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4876 /* Build BIT_SIZE. */
4877 bit_size
= build_int_cst (result_type
, argsize
);
4879 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4880 arg
, build_int_cst (arg_type
, 0));
4881 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4886 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4888 The conditional expression is necessary because the result of TRAILZ(0)
4889 is defined, but the result of __builtin_ctz(0) is undefined for most
4893 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4904 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4905 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4907 /* Which variant of __builtin_ctz* should we call? */
4908 if (argsize
<= INT_TYPE_SIZE
)
4910 arg_type
= unsigned_type_node
;
4911 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4913 else if (argsize
<= LONG_TYPE_SIZE
)
4915 arg_type
= long_unsigned_type_node
;
4916 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4918 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4920 arg_type
= long_long_unsigned_type_node
;
4921 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4925 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4926 arg_type
= gfc_build_uint_type (argsize
);
4930 /* Convert the actual argument twice: first, to the unsigned type of the
4931 same size; then, to the proper argument type for the built-in
4932 function. But the return type is of the default INTEGER kind. */
4933 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4934 arg
= fold_convert (arg_type
, arg
);
4935 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4936 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4938 /* Compute TRAILZ for the case i .ne. 0. */
4940 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4944 /* We end up here if the argument type is larger than 'long long'.
4945 We generate this code:
4947 if ((x & ULL_MAX) == 0)
4948 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4950 return ctzll ((unsigned long long) x);
4952 where ULL_MAX is the largest value that a ULL_MAX can hold
4953 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4954 is the bit-size of the long long type (64 in this example). */
4955 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4957 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4958 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4959 long_long_unsigned_type_node
,
4960 build_int_cst (long_long_unsigned_type_node
, 0));
4962 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4963 fold_convert (arg_type
, ullmax
));
4964 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4965 build_int_cst (arg_type
, 0));
4967 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4969 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4970 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4971 tmp1
= fold_convert (result_type
,
4972 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4973 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4976 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4977 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4978 tmp2
= fold_convert (result_type
,
4979 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4981 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4985 /* Build BIT_SIZE. */
4986 bit_size
= build_int_cst (result_type
, argsize
);
4988 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4989 arg
, build_int_cst (arg_type
, 0));
4990 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4994 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4995 for types larger than "long long", we call the long long built-in for
4996 the lower and higher bits and combine the result. */
4999 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
5007 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5008 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
5009 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
5011 /* Which variant of the builtin should we call? */
5012 if (argsize
<= INT_TYPE_SIZE
)
5014 arg_type
= unsigned_type_node
;
5015 func
= builtin_decl_explicit (parity
5017 : BUILT_IN_POPCOUNT
);
5019 else if (argsize
<= LONG_TYPE_SIZE
)
5021 arg_type
= long_unsigned_type_node
;
5022 func
= builtin_decl_explicit (parity
5024 : BUILT_IN_POPCOUNTL
);
5026 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
5028 arg_type
= long_long_unsigned_type_node
;
5029 func
= builtin_decl_explicit (parity
5031 : BUILT_IN_POPCOUNTLL
);
5035 /* Our argument type is larger than 'long long', which mean none
5036 of the POPCOUNT builtins covers it. We thus call the 'long long'
5037 variant multiple times, and add the results. */
5038 tree utype
, arg2
, call1
, call2
;
5040 /* For now, we only cover the case where argsize is twice as large
5042 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
5044 func
= builtin_decl_explicit (parity
5046 : BUILT_IN_POPCOUNTLL
);
5048 /* Convert it to an integer, and store into a variable. */
5049 utype
= gfc_build_uint_type (argsize
);
5050 arg
= fold_convert (utype
, arg
);
5051 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5053 /* Call the builtin twice. */
5054 call1
= build_call_expr_loc (input_location
, func
, 1,
5055 fold_convert (long_long_unsigned_type_node
,
5058 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
5059 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
5060 call2
= build_call_expr_loc (input_location
, func
, 1,
5061 fold_convert (long_long_unsigned_type_node
,
5064 /* Combine the results. */
5066 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
5069 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
5075 /* Convert the actual argument twice: first, to the unsigned type of the
5076 same size; then, to the proper argument type for the built-in
5078 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
5079 arg
= fold_convert (arg_type
, arg
);
5081 se
->expr
= fold_convert (result_type
,
5082 build_call_expr_loc (input_location
, func
, 1, arg
));
5086 /* Process an intrinsic with unspecified argument-types that has an optional
5087 argument (which could be of type character), e.g. EOSHIFT. For those, we
5088 need to append the string length of the optional argument if it is not
5089 present and the type is really character.
5090 primary specifies the position (starting at 1) of the non-optional argument
5091 specifying the type and optional gives the position of the optional
5092 argument in the arglist. */
5095 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
5096 unsigned primary
, unsigned optional
)
5098 gfc_actual_arglist
* prim_arg
;
5099 gfc_actual_arglist
* opt_arg
;
5101 gfc_actual_arglist
* arg
;
5103 vec
<tree
, va_gc
> *append_args
;
5105 /* Find the two arguments given as position. */
5109 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
5113 if (cur_pos
== primary
)
5115 if (cur_pos
== optional
)
5118 if (cur_pos
>= primary
&& cur_pos
>= optional
)
5121 gcc_assert (prim_arg
);
5122 gcc_assert (prim_arg
->expr
);
5123 gcc_assert (opt_arg
);
5125 /* If we do have type CHARACTER and the optional argument is really absent,
5126 append a dummy 0 as string length. */
5128 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
5132 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
5133 vec_alloc (append_args
, 1);
5134 append_args
->quick_push (dummy
);
5137 /* Build the call itself. */
5138 gcc_assert (!se
->ignore_optional
);
5139 sym
= gfc_get_symbol_for_expr (expr
, false);
5140 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5142 gfc_free_symbol (sym
);
5146 /* The length of a character string. */
5148 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
5157 gcc_assert (!se
->ss
);
5159 arg
= expr
->value
.function
.actual
->expr
;
5161 type
= gfc_typenode_for_spec (&expr
->ts
);
5162 switch (arg
->expr_type
)
5165 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
5169 /* Obtain the string length from the function used by
5170 trans-array.c(gfc_trans_array_constructor). */
5172 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
5176 if (arg
->ref
== NULL
5177 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
5179 /* This doesn't catch all cases.
5180 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
5181 and the surrounding thread. */
5182 sym
= arg
->symtree
->n
.sym
;
5183 decl
= gfc_get_symbol_decl (sym
);
5184 if (decl
== current_function_decl
&& sym
->attr
.function
5185 && (sym
->result
== sym
))
5186 decl
= gfc_get_fake_result_decl (sym
, 0);
5188 len
= sym
->ts
.u
.cl
->backend_decl
;
5193 /* Otherwise fall through. */
5196 /* Anybody stupid enough to do this deserves inefficient code. */
5197 gfc_init_se (&argse
, se
);
5199 gfc_conv_expr (&argse
, arg
);
5201 gfc_conv_expr_descriptor (&argse
, arg
);
5202 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5203 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5204 len
= argse
.string_length
;
5207 se
->expr
= convert (type
, len
);
5210 /* The length of a character string not including trailing blanks. */
5212 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
5214 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5215 tree args
[2], type
, fndecl
;
5217 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5218 type
= gfc_typenode_for_spec (&expr
->ts
);
5221 fndecl
= gfor_fndecl_string_len_trim
;
5223 fndecl
= gfor_fndecl_string_len_trim_char4
;
5227 se
->expr
= build_call_expr_loc (input_location
,
5228 fndecl
, 2, args
[0], args
[1]);
5229 se
->expr
= convert (type
, se
->expr
);
5233 /* Returns the starting position of a substring within a string. */
5236 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
5239 tree logical4_type_node
= gfc_get_logical_type (4);
5243 unsigned int num_args
;
5245 args
= XALLOCAVEC (tree
, 5);
5247 /* Get number of arguments; characters count double due to the
5248 string length argument. Kind= is not passed to the library
5249 and thus ignored. */
5250 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
5255 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5256 type
= gfc_typenode_for_spec (&expr
->ts
);
5259 args
[4] = build_int_cst (logical4_type_node
, 0);
5261 args
[4] = convert (logical4_type_node
, args
[4]);
5263 fndecl
= build_addr (function
, current_function_decl
);
5264 se
->expr
= build_call_array_loc (input_location
,
5265 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
5267 se
->expr
= convert (type
, se
->expr
);
5271 /* The ascii value for a single character. */
5273 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
5275 tree args
[3], type
, pchartype
;
5278 nargs
= gfc_intrinsic_argument_list_length (expr
);
5279 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
5280 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
5281 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
5282 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
5283 type
= gfc_typenode_for_spec (&expr
->ts
);
5285 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5287 se
->expr
= convert (type
, se
->expr
);
5291 /* Intrinsic ISNAN calls __builtin_isnan. */
5294 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
5298 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5299 se
->expr
= build_call_expr_loc (input_location
,
5300 builtin_decl_explicit (BUILT_IN_ISNAN
),
5302 STRIP_TYPE_NOPS (se
->expr
);
5303 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5307 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
5308 their argument against a constant integer value. */
5311 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
5315 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5316 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
5317 gfc_typenode_for_spec (&expr
->ts
),
5318 arg
, build_int_cst (TREE_TYPE (arg
), value
));
5323 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
5326 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
5334 unsigned int num_args
;
5336 num_args
= gfc_intrinsic_argument_list_length (expr
);
5337 args
= XALLOCAVEC (tree
, num_args
);
5339 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
5340 if (expr
->ts
.type
!= BT_CHARACTER
)
5348 /* We do the same as in the non-character case, but the argument
5349 list is different because of the string length arguments. We
5350 also have to set the string length for the result. */
5357 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
5359 se
->string_length
= len
;
5361 type
= TREE_TYPE (tsource
);
5362 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
5363 fold_convert (type
, fsource
));
5367 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
5370 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
5372 tree args
[3], mask
, type
;
5374 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5375 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
5377 type
= TREE_TYPE (args
[0]);
5378 gcc_assert (TREE_TYPE (args
[1]) == type
);
5379 gcc_assert (TREE_TYPE (mask
) == type
);
5381 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
5382 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
5383 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5385 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
5390 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
5391 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
5394 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
5396 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
5399 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5400 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5402 type
= gfc_get_int_type (expr
->ts
.kind
);
5403 utype
= unsigned_type_for (type
);
5405 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
5406 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
5408 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
5409 build_int_cst (utype
, 0));
5413 /* Left-justified mask. */
5414 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
5416 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5417 fold_convert (utype
, res
));
5419 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
5420 smaller than type width. */
5421 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5422 build_int_cst (TREE_TYPE (arg
), 0));
5423 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
5424 build_int_cst (utype
, 0), res
);
5428 /* Right-justified mask. */
5429 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5430 fold_convert (utype
, arg
));
5431 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
5433 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
5434 strictly smaller than type width. */
5435 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5437 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
5438 cond
, allones
, res
);
5441 se
->expr
= fold_convert (type
, res
);
5445 /* FRACTION (s) is translated into:
5446 isfinite (s) ? frexp (s, &dummy_int) : NaN */
5448 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
5450 tree arg
, type
, tmp
, res
, frexp
, cond
;
5452 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5454 type
= gfc_typenode_for_spec (&expr
->ts
);
5455 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5456 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5458 cond
= build_call_expr_loc (input_location
,
5459 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5462 tmp
= gfc_create_var (integer_type_node
, NULL
);
5463 res
= build_call_expr_loc (input_location
, frexp
, 2,
5464 fold_convert (type
, arg
),
5465 gfc_build_addr_expr (NULL_TREE
, tmp
));
5466 res
= fold_convert (type
, res
);
5468 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
5469 cond
, res
, gfc_build_nan (type
, ""));
5473 /* NEAREST (s, dir) is translated into
5474 tmp = copysign (HUGE_VAL, dir);
5475 return nextafter (s, tmp);
5478 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
5480 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
5482 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
5483 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
5485 type
= gfc_typenode_for_spec (&expr
->ts
);
5486 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5488 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
5489 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
5490 fold_convert (type
, args
[1]));
5491 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
5492 fold_convert (type
, args
[0]), tmp
);
5493 se
->expr
= fold_convert (type
, se
->expr
);
5497 /* SPACING (s) is translated into
5507 e = MAX_EXPR (e, emin);
5508 res = scalbn (1., e);
5512 where prec is the precision of s, gfc_real_kinds[k].digits,
5513 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
5514 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
5517 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
5519 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
5520 tree cond
, nan
, tmp
, frexp
, scalbn
;
5524 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5525 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
5526 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
5527 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
5529 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5530 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5532 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5533 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5535 type
= gfc_typenode_for_spec (&expr
->ts
);
5536 e
= gfc_create_var (integer_type_node
, NULL
);
5537 res
= gfc_create_var (type
, NULL
);
5540 /* Build the block for s /= 0. */
5541 gfc_start_block (&block
);
5542 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5543 gfc_build_addr_expr (NULL_TREE
, e
));
5544 gfc_add_expr_to_block (&block
, tmp
);
5546 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
5548 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
5549 integer_type_node
, tmp
, emin
));
5551 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
5552 build_real_from_int_cst (type
, integer_one_node
), e
);
5553 gfc_add_modify (&block
, res
, tmp
);
5555 /* Finish by building the IF statement for value zero. */
5556 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5557 build_real_from_int_cst (type
, integer_zero_node
));
5558 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
5559 gfc_finish_block (&block
));
5561 /* And deal with infinities and NaNs. */
5562 cond
= build_call_expr_loc (input_location
,
5563 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5565 nan
= gfc_build_nan (type
, "");
5566 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, res
, nan
));
5568 gfc_add_expr_to_block (&se
->pre
, tmp
);
5573 /* RRSPACING (s) is translated into
5582 x = scalbn (x, precision - e);
5589 where precision is gfc_real_kinds[k].digits. */
5592 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
5594 tree arg
, type
, e
, x
, cond
, nan
, stmt
, tmp
, frexp
, scalbn
, fabs
;
5598 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5599 prec
= gfc_real_kinds
[k
].digits
;
5601 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5602 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5603 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
5605 type
= gfc_typenode_for_spec (&expr
->ts
);
5606 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5607 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5609 e
= gfc_create_var (integer_type_node
, NULL
);
5610 x
= gfc_create_var (type
, NULL
);
5611 gfc_add_modify (&se
->pre
, x
,
5612 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5615 gfc_start_block (&block
);
5616 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5617 gfc_build_addr_expr (NULL_TREE
, e
));
5618 gfc_add_expr_to_block (&block
, tmp
);
5620 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5621 build_int_cst (integer_type_node
, prec
), e
);
5622 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5623 gfc_add_modify (&block
, x
, tmp
);
5624 stmt
= gfc_finish_block (&block
);
5627 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5628 build_real_from_int_cst (type
, integer_zero_node
));
5629 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5631 /* And deal with infinities and NaNs. */
5632 cond
= build_call_expr_loc (input_location
,
5633 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5635 nan
= gfc_build_nan (type
, "");
5636 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build2_v (MODIFY_EXPR
, x
, nan
));
5638 gfc_add_expr_to_block (&se
->pre
, tmp
);
5639 se
->expr
= fold_convert (type
, x
);
5643 /* SCALE (s, i) is translated into scalbn (s, i). */
5645 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5647 tree args
[2], type
, scalbn
;
5649 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5651 type
= gfc_typenode_for_spec (&expr
->ts
);
5652 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5653 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5654 fold_convert (type
, args
[0]),
5655 fold_convert (integer_type_node
, args
[1]));
5656 se
->expr
= fold_convert (type
, se
->expr
);
5660 /* SET_EXPONENT (s, i) is translated into
5661 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
5663 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5665 tree args
[2], type
, tmp
, frexp
, scalbn
, cond
, nan
, res
;
5667 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5668 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5670 type
= gfc_typenode_for_spec (&expr
->ts
);
5671 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5672 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
5674 tmp
= gfc_create_var (integer_type_node
, NULL
);
5675 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5676 fold_convert (type
, args
[0]),
5677 gfc_build_addr_expr (NULL_TREE
, tmp
));
5678 res
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5679 fold_convert (integer_type_node
, args
[1]));
5680 res
= fold_convert (type
, res
);
5682 /* Call to isfinite */
5683 cond
= build_call_expr_loc (input_location
,
5684 builtin_decl_explicit (BUILT_IN_ISFINITE
),
5686 nan
= gfc_build_nan (type
, "");
5688 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
5694 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5696 gfc_actual_arglist
*actual
;
5703 gfc_init_se (&argse
, NULL
);
5704 actual
= expr
->value
.function
.actual
;
5706 if (actual
->expr
->ts
.type
== BT_CLASS
)
5707 gfc_add_class_array_ref (actual
->expr
);
5709 argse
.want_pointer
= 1;
5710 argse
.data_not_needed
= 1;
5711 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5712 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5713 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5714 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5716 /* Build the call to size0. */
5717 fncall0
= build_call_expr_loc (input_location
,
5718 gfor_fndecl_size0
, 1, arg1
);
5720 actual
= actual
->next
;
5724 gfc_init_se (&argse
, NULL
);
5725 gfc_conv_expr_type (&argse
, actual
->expr
,
5726 gfc_array_index_type
);
5727 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5729 /* Unusually, for an intrinsic, size does not exclude
5730 an optional arg2, so we must test for it. */
5731 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5732 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5733 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5736 /* Build the call to size1. */
5737 fncall1
= build_call_expr_loc (input_location
,
5738 gfor_fndecl_size1
, 2,
5741 gfc_init_se (&argse
, NULL
);
5742 argse
.want_pointer
= 1;
5743 argse
.data_not_needed
= 1;
5744 gfc_conv_expr (&argse
, actual
->expr
);
5745 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5746 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5747 argse
.expr
, null_pointer_node
);
5748 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5749 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5750 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5754 se
->expr
= NULL_TREE
;
5755 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5756 gfc_array_index_type
,
5757 argse
.expr
, gfc_index_one_node
);
5760 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5762 argse
.expr
= gfc_index_zero_node
;
5763 se
->expr
= NULL_TREE
;
5768 if (se
->expr
== NULL_TREE
)
5770 tree ubound
, lbound
;
5772 arg1
= build_fold_indirect_ref_loc (input_location
,
5774 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5775 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5776 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5777 gfc_array_index_type
, ubound
, lbound
);
5778 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5779 gfc_array_index_type
,
5780 se
->expr
, gfc_index_one_node
);
5781 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5782 gfc_array_index_type
, se
->expr
,
5783 gfc_index_zero_node
);
5786 type
= gfc_typenode_for_spec (&expr
->ts
);
5787 se
->expr
= convert (type
, se
->expr
);
5791 /* Helper function to compute the size of a character variable,
5792 excluding the terminating null characters. The result has
5793 gfc_array_index_type type. */
5796 size_of_string_in_bytes (int kind
, tree string_length
)
5799 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5801 bytesize
= build_int_cst (gfc_array_index_type
,
5802 gfc_character_kinds
[i
].bit_size
/ 8);
5804 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5806 fold_convert (gfc_array_index_type
, string_length
));
5811 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5822 gfc_init_se (&argse
, NULL
);
5823 arg
= expr
->value
.function
.actual
->expr
;
5825 if (arg
->rank
|| arg
->ts
.type
== BT_ASSUMED
)
5826 gfc_conv_expr_descriptor (&argse
, arg
);
5828 gfc_conv_expr_reference (&argse
, arg
);
5830 if (arg
->ts
.type
== BT_ASSUMED
)
5832 /* This only works if an array descriptor has been passed; thus, extract
5833 the size from the descriptor. */
5834 gcc_assert (TYPE_PRECISION (gfc_array_index_type
)
5835 == TYPE_PRECISION (size_type_node
));
5836 tmp
= arg
->symtree
->n
.sym
->backend_decl
;
5837 tmp
= DECL_LANG_SPECIFIC (tmp
)
5838 && GFC_DECL_SAVED_DESCRIPTOR (tmp
) != NULL_TREE
5839 ? GFC_DECL_SAVED_DESCRIPTOR (tmp
) : tmp
;
5840 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
5841 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5842 tmp
= fold_convert (size_type_node
, gfc_conv_descriptor_dtype (tmp
));
5843 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, TREE_TYPE (tmp
), tmp
,
5844 build_int_cst (TREE_TYPE (tmp
),
5845 GFC_DTYPE_SIZE_SHIFT
));
5846 byte_size
= fold_convert (gfc_array_index_type
, tmp
);
5848 else if (arg
->ts
.type
== BT_CLASS
)
5851 byte_size
= gfc_vtable_size_get (TREE_OPERAND (argse
.expr
, 0));
5853 byte_size
= gfc_vtable_size_get (argse
.expr
);
5857 if (arg
->ts
.type
== BT_CHARACTER
)
5858 byte_size
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5862 byte_size
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5865 byte_size
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5866 byte_size
= fold_convert (gfc_array_index_type
,
5867 size_in_bytes (byte_size
));
5872 se
->expr
= byte_size
;
5875 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5876 gfc_add_modify (&argse
.pre
, source_bytes
, byte_size
);
5878 if (arg
->rank
== -1)
5880 tree cond
, loop_var
, exit_label
;
5883 tmp
= fold_convert (gfc_array_index_type
,
5884 gfc_conv_descriptor_rank (argse
.expr
));
5885 loop_var
= gfc_create_var (gfc_array_index_type
, "i");
5886 gfc_add_modify (&argse
.pre
, loop_var
, gfc_index_zero_node
);
5887 exit_label
= gfc_build_label_decl (NULL_TREE
);
5894 source_bytes = source_bytes * array.dim[i].extent;
5898 gfc_start_block (&body
);
5899 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
5901 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5902 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5903 cond
, tmp
, build_empty_stmt (input_location
));
5904 gfc_add_expr_to_block (&body
, tmp
);
5906 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, loop_var
);
5907 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, loop_var
);
5908 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
5909 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5910 gfc_array_index_type
, tmp
, source_bytes
);
5911 gfc_add_modify (&body
, source_bytes
, tmp
);
5913 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5914 gfc_array_index_type
, loop_var
,
5915 gfc_index_one_node
);
5916 gfc_add_modify_loc (input_location
, &body
, loop_var
, tmp
);
5918 tmp
= gfc_finish_block (&body
);
5920 tmp
= fold_build1_loc (input_location
, LOOP_EXPR
, void_type_node
,
5922 gfc_add_expr_to_block (&argse
.pre
, tmp
);
5924 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5925 gfc_add_expr_to_block (&argse
.pre
, tmp
);
5929 /* Obtain the size of the array in bytes. */
5930 for (n
= 0; n
< arg
->rank
; n
++)
5933 idx
= gfc_rank_cst
[n
];
5934 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5935 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5936 tmp
= gfc_conv_array_extent_dim (lower
, upper
, NULL
);
5937 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5938 gfc_array_index_type
, tmp
, source_bytes
);
5939 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5942 se
->expr
= source_bytes
;
5945 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5950 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
5954 tree type
, result_type
, tmp
;
5956 arg
= expr
->value
.function
.actual
->expr
;
5958 gfc_init_se (&argse
, NULL
);
5959 result_type
= gfc_get_int_type (expr
->ts
.kind
);
5963 if (arg
->ts
.type
== BT_CLASS
)
5965 gfc_add_vptr_component (arg
);
5966 gfc_add_size_component (arg
);
5967 gfc_conv_expr (&argse
, arg
);
5968 tmp
= fold_convert (result_type
, argse
.expr
);
5972 gfc_conv_expr_reference (&argse
, arg
);
5973 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5978 argse
.want_pointer
= 0;
5979 gfc_conv_expr_descriptor (&argse
, arg
);
5980 if (arg
->ts
.type
== BT_CLASS
)
5982 tmp
= gfc_vtable_size_get (TREE_OPERAND (argse
.expr
, 0));
5983 tmp
= fold_convert (result_type
, tmp
);
5986 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5989 /* Obtain the argument's word length. */
5990 if (arg
->ts
.type
== BT_CHARACTER
)
5991 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5993 tmp
= size_in_bytes (type
);
5994 tmp
= fold_convert (result_type
, tmp
);
5997 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
5998 build_int_cst (result_type
, BITS_PER_UNIT
));
5999 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6003 /* Intrinsic string comparison functions. */
6006 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
6010 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
6013 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
6014 expr
->value
.function
.actual
->expr
->ts
.kind
,
6016 se
->expr
= fold_build2_loc (input_location
, op
,
6017 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
6018 build_int_cst (TREE_TYPE (se
->expr
), 0));
6021 /* Generate a call to the adjustl/adjustr library function. */
6023 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
6031 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
6034 type
= TREE_TYPE (args
[2]);
6035 var
= gfc_conv_string_tmp (se
, type
, len
);
6038 tmp
= build_call_expr_loc (input_location
,
6039 fndecl
, 3, args
[0], args
[1], args
[2]);
6040 gfc_add_expr_to_block (&se
->pre
, tmp
);
6042 se
->string_length
= len
;
6046 /* Generate code for the TRANSFER intrinsic:
6048 DEST = TRANSFER (SOURCE, MOLD)
6050 typeof<DEST> = typeof<MOLD>
6055 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6057 typeof<DEST> = typeof<MOLD>
6059 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6060 sizeof (DEST(0) * SIZE). */
6062 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
6078 gfc_actual_arglist
*arg
;
6080 gfc_array_info
*info
;
6084 gfc_expr
*source_expr
, *mold_expr
;
6088 info
= &se
->ss
->info
->data
.array
;
6090 /* Convert SOURCE. The output from this stage is:-
6091 source_bytes = length of the source in bytes
6092 source = pointer to the source data. */
6093 arg
= expr
->value
.function
.actual
;
6094 source_expr
= arg
->expr
;
6096 /* Ensure double transfer through LOGICAL preserves all
6098 if (arg
->expr
->expr_type
== EXPR_FUNCTION
6099 && arg
->expr
->value
.function
.esym
== NULL
6100 && arg
->expr
->value
.function
.isym
!= NULL
6101 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
6102 && arg
->expr
->ts
.type
== BT_LOGICAL
6103 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
6104 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
6106 gfc_init_se (&argse
, NULL
);
6108 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6110 /* Obtain the pointer to source and the length of source in bytes. */
6111 if (arg
->expr
->rank
== 0)
6113 gfc_conv_expr_reference (&argse
, arg
->expr
);
6114 if (arg
->expr
->ts
.type
== BT_CLASS
)
6115 source
= gfc_class_data_get (argse
.expr
);
6117 source
= argse
.expr
;
6119 /* Obtain the source word length. */
6120 switch (arg
->expr
->ts
.type
)
6123 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6124 argse
.string_length
);
6127 tmp
= gfc_vtable_size_get (argse
.expr
);
6130 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6132 tmp
= fold_convert (gfc_array_index_type
,
6133 size_in_bytes (source_type
));
6139 argse
.want_pointer
= 0;
6140 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6141 source
= gfc_conv_descriptor_data_get (argse
.expr
);
6142 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6144 /* Repack the source if not simply contiguous. */
6145 if (!gfc_is_simply_contiguous (arg
->expr
, false))
6147 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
6149 if (warn_array_temporaries
)
6150 gfc_warning (OPT_Warray_temporaries
,
6151 "Creating array temporary at %L", &expr
->where
);
6153 source
= build_call_expr_loc (input_location
,
6154 gfor_fndecl_in_pack
, 1, tmp
);
6155 source
= gfc_evaluate_now (source
, &argse
.pre
);
6157 /* Free the temporary. */
6158 gfc_start_block (&block
);
6159 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
6160 gfc_add_expr_to_block (&block
, tmp
);
6161 stmt
= gfc_finish_block (&block
);
6163 /* Clean up if it was repacked. */
6164 gfc_init_block (&block
);
6165 tmp
= gfc_conv_array_data (argse
.expr
);
6166 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6168 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
6169 build_empty_stmt (input_location
));
6170 gfc_add_expr_to_block (&block
, tmp
);
6171 gfc_add_block_to_block (&block
, &se
->post
);
6172 gfc_init_block (&se
->post
);
6173 gfc_add_block_to_block (&se
->post
, &block
);
6176 /* Obtain the source word length. */
6177 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
6178 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
6179 argse
.string_length
);
6181 tmp
= fold_convert (gfc_array_index_type
,
6182 size_in_bytes (source_type
));
6184 /* Obtain the size of the array in bytes. */
6185 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
6186 for (n
= 0; n
< arg
->expr
->rank
; n
++)
6189 idx
= gfc_rank_cst
[n
];
6190 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6191 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
6192 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
6193 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6194 gfc_array_index_type
, upper
, lower
);
6195 gfc_add_modify (&argse
.pre
, extent
, tmp
);
6196 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6197 gfc_array_index_type
, extent
,
6198 gfc_index_one_node
);
6199 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6200 gfc_array_index_type
, tmp
, source_bytes
);
6204 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
6205 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6206 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6208 /* Now convert MOLD. The outputs are:
6209 mold_type = the TREE type of MOLD
6210 dest_word_len = destination word length in bytes. */
6212 mold_expr
= arg
->expr
;
6214 gfc_init_se (&argse
, NULL
);
6216 scalar_mold
= arg
->expr
->rank
== 0;
6218 if (arg
->expr
->rank
== 0)
6220 gfc_conv_expr_reference (&argse
, arg
->expr
);
6221 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
6226 gfc_init_se (&argse
, NULL
);
6227 argse
.want_pointer
= 0;
6228 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
6229 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
6232 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6233 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6235 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
6237 /* If this TRANSFER is nested in another TRANSFER, use a type
6238 that preserves all bits. */
6239 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
6240 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
6243 /* Obtain the destination word length. */
6244 switch (arg
->expr
->ts
.type
)
6247 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
6248 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
6251 tmp
= gfc_vtable_size_get (argse
.expr
);
6254 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
6257 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
6258 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
6260 /* Finally convert SIZE, if it is present. */
6262 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
6266 gfc_init_se (&argse
, NULL
);
6267 gfc_conv_expr_reference (&argse
, arg
->expr
);
6268 tmp
= convert (gfc_array_index_type
,
6269 build_fold_indirect_ref_loc (input_location
,
6271 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6272 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6277 /* Separate array and scalar results. */
6278 if (scalar_mold
&& tmp
== NULL_TREE
)
6279 goto scalar_transfer
;
6281 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
6282 if (tmp
!= NULL_TREE
)
6283 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6284 tmp
, dest_word_len
);
6288 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
6289 gfc_add_modify (&se
->pre
, size_words
,
6290 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
6291 gfc_array_index_type
,
6292 size_bytes
, dest_word_len
));
6294 /* Evaluate the bounds of the result. If the loop range exists, we have
6295 to check if it is too large. If so, we modify loop->to be consistent
6296 with min(size, size(source)). Otherwise, size is made consistent with
6297 the loop range, so that the right number of bytes is transferred.*/
6298 n
= se
->loop
->order
[0];
6299 if (se
->loop
->to
[n
] != NULL_TREE
)
6301 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6302 se
->loop
->to
[n
], se
->loop
->from
[n
]);
6303 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6304 tmp
, gfc_index_one_node
);
6305 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6307 gfc_add_modify (&se
->pre
, size_words
, tmp
);
6308 gfc_add_modify (&se
->pre
, size_bytes
,
6309 fold_build2_loc (input_location
, MULT_EXPR
,
6310 gfc_array_index_type
,
6311 size_words
, dest_word_len
));
6312 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6313 size_words
, se
->loop
->from
[n
]);
6314 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6315 upper
, gfc_index_one_node
);
6319 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6320 size_words
, gfc_index_one_node
);
6321 se
->loop
->from
[n
] = gfc_index_zero_node
;
6324 se
->loop
->to
[n
] = upper
;
6326 /* Build a destination descriptor, using the pointer, source, as the
6328 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
6329 NULL_TREE
, false, true, false, &expr
->where
);
6331 /* Cast the pointer to the result. */
6332 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6333 tmp
= fold_convert (pvoid_type_node
, tmp
);
6335 /* Use memcpy to do the transfer. */
6337 = build_call_expr_loc (input_location
,
6338 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
6339 fold_convert (pvoid_type_node
, source
),
6340 fold_convert (size_type_node
,
6341 fold_build2_loc (input_location
,
6343 gfc_array_index_type
,
6346 gfc_add_expr_to_block (&se
->pre
, tmp
);
6348 se
->expr
= info
->descriptor
;
6349 if (expr
->ts
.type
== BT_CHARACTER
)
6350 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6354 /* Deal with scalar results. */
6356 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
6357 dest_word_len
, source_bytes
);
6358 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
6359 extent
, gfc_index_zero_node
);
6361 if (expr
->ts
.type
== BT_CHARACTER
)
6363 tree direct
, indirect
, free
;
6365 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
6366 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
6369 /* If source is longer than the destination, use a pointer to
6370 the source directly. */
6371 gfc_init_block (&block
);
6372 gfc_add_modify (&block
, tmpdecl
, ptr
);
6373 direct
= gfc_finish_block (&block
);
6375 /* Otherwise, allocate a string with the length of the destination
6376 and copy the source into it. */
6377 gfc_init_block (&block
);
6378 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
6379 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
6380 gfc_add_modify (&block
, tmpdecl
,
6381 fold_convert (TREE_TYPE (ptr
), tmp
));
6382 tmp
= build_call_expr_loc (input_location
,
6383 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6384 fold_convert (pvoid_type_node
, tmpdecl
),
6385 fold_convert (pvoid_type_node
, ptr
),
6386 fold_convert (size_type_node
, extent
));
6387 gfc_add_expr_to_block (&block
, tmp
);
6388 indirect
= gfc_finish_block (&block
);
6390 /* Wrap it up with the condition. */
6391 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
6392 dest_word_len
, source_bytes
);
6393 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
6394 gfc_add_expr_to_block (&se
->pre
, tmp
);
6396 /* Free the temporary string, if necessary. */
6397 free
= gfc_call_free (tmpdecl
);
6398 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6399 dest_word_len
, source_bytes
);
6400 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
6401 gfc_add_expr_to_block (&se
->post
, tmp
);
6404 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
6408 tmpdecl
= gfc_create_var (mold_type
, "transfer");
6410 ptr
= convert (build_pointer_type (mold_type
), source
);
6412 /* For CLASS results, allocate the needed memory first. */
6413 if (mold_expr
->ts
.type
== BT_CLASS
)
6416 cdata
= gfc_class_data_get (tmpdecl
);
6417 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
6418 gfc_add_modify (&se
->pre
, cdata
, tmp
);
6421 /* Use memcpy to do the transfer. */
6422 if (mold_expr
->ts
.type
== BT_CLASS
)
6423 tmp
= gfc_class_data_get (tmpdecl
);
6425 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
6427 tmp
= build_call_expr_loc (input_location
,
6428 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
6429 fold_convert (pvoid_type_node
, tmp
),
6430 fold_convert (pvoid_type_node
, ptr
),
6431 fold_convert (size_type_node
, extent
));
6432 gfc_add_expr_to_block (&se
->pre
, tmp
);
6434 /* For CLASS results, set the _vptr. */
6435 if (mold_expr
->ts
.type
== BT_CLASS
)
6439 vptr
= gfc_class_vptr_get (tmpdecl
);
6440 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
6442 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
6443 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
6451 /* Generate code for the ALLOCATED intrinsic.
6452 Generate inline code that directly check the address of the argument. */
6455 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
6457 gfc_actual_arglist
*arg1
;
6461 gfc_init_se (&arg1se
, NULL
);
6462 arg1
= expr
->value
.function
.actual
;
6464 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6466 /* Make sure that class array expressions have both a _data
6467 component reference and an array reference.... */
6468 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
6469 gfc_add_class_array_ref (arg1
->expr
);
6470 /* .... whilst scalars only need the _data component. */
6472 gfc_add_data_component (arg1
->expr
);
6475 if (arg1
->expr
->rank
== 0)
6477 /* Allocatable scalar. */
6478 arg1se
.want_pointer
= 1;
6479 gfc_conv_expr (&arg1se
, arg1
->expr
);
6484 /* Allocatable array. */
6485 arg1se
.descriptor_only
= 1;
6486 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6487 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6490 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
6491 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6492 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6496 /* Generate code for the ASSOCIATED intrinsic.
6497 If both POINTER and TARGET are arrays, generate a call to library function
6498 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
6499 In other cases, generate inline code that directly compare the address of
6500 POINTER with the address of TARGET. */
6503 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
6505 gfc_actual_arglist
*arg1
;
6506 gfc_actual_arglist
*arg2
;
6511 tree nonzero_charlen
;
6512 tree nonzero_arraylen
;
6516 gfc_init_se (&arg1se
, NULL
);
6517 gfc_init_se (&arg2se
, NULL
);
6518 arg1
= expr
->value
.function
.actual
;
6521 /* Check whether the expression is a scalar or not; we cannot use
6522 arg1->expr->rank as it can be nonzero for proc pointers. */
6523 ss
= gfc_walk_expr (arg1
->expr
);
6524 scalar
= ss
== gfc_ss_terminator
;
6526 gfc_free_ss_chain (ss
);
6530 /* No optional target. */
6533 /* A pointer to a scalar. */
6534 arg1se
.want_pointer
= 1;
6535 gfc_conv_expr (&arg1se
, arg1
->expr
);
6536 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6537 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6538 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6540 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6541 tmp2
= gfc_class_data_get (arg1se
.expr
);
6547 /* A pointer to an array. */
6548 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6549 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6551 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6552 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6553 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
6554 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
6559 /* An optional target. */
6560 if (arg2
->expr
->ts
.type
== BT_CLASS
)
6561 gfc_add_data_component (arg2
->expr
);
6563 nonzero_charlen
= NULL_TREE
;
6564 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
6565 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
6567 arg1
->expr
->ts
.u
.cl
->backend_decl
,
6571 /* A pointer to a scalar. */
6572 arg1se
.want_pointer
= 1;
6573 gfc_conv_expr (&arg1se
, arg1
->expr
);
6574 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6575 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6576 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6578 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6579 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
6581 arg2se
.want_pointer
= 1;
6582 gfc_conv_expr (&arg2se
, arg2
->expr
);
6583 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6584 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
6585 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
6587 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6588 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6589 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6590 arg1se
.expr
, arg2se
.expr
);
6591 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6592 arg1se
.expr
, null_pointer_node
);
6593 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6594 boolean_type_node
, tmp
, tmp2
);
6598 /* An array pointer of zero length is not associated if target is
6600 arg1se
.descriptor_only
= 1;
6601 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
6602 if (arg1
->expr
->rank
== -1)
6604 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
6605 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6606 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
6609 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
6610 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
6611 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
6612 boolean_type_node
, tmp
,
6613 build_int_cst (TREE_TYPE (tmp
), 0));
6615 /* A pointer to an array, call library function _gfor_associated. */
6616 arg1se
.want_pointer
= 1;
6617 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6619 arg2se
.want_pointer
= 1;
6620 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
6621 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6622 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6623 se
->expr
= build_call_expr_loc (input_location
,
6624 gfor_fndecl_associated
, 2,
6625 arg1se
.expr
, arg2se
.expr
);
6626 se
->expr
= convert (boolean_type_node
, se
->expr
);
6627 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6628 boolean_type_node
, se
->expr
,
6632 /* If target is present zero character length pointers cannot
6634 if (nonzero_charlen
!= NULL_TREE
)
6635 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6637 se
->expr
, nonzero_charlen
);
6640 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6644 /* Generate code for the SAME_TYPE_AS intrinsic.
6645 Generate inline code that directly checks the vindices. */
6648 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
6653 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
6655 gfc_init_se (&se1
, NULL
);
6656 gfc_init_se (&se2
, NULL
);
6658 a
= expr
->value
.function
.actual
->expr
;
6659 b
= expr
->value
.function
.actual
->next
->expr
;
6661 if (UNLIMITED_POLY (a
))
6663 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
6664 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6665 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6668 if (UNLIMITED_POLY (b
))
6670 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
6671 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6672 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6675 if (a
->ts
.type
== BT_CLASS
)
6677 gfc_add_vptr_component (a
);
6678 gfc_add_hash_component (a
);
6680 else if (a
->ts
.type
== BT_DERIVED
)
6681 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6682 a
->ts
.u
.derived
->hash_value
);
6684 if (b
->ts
.type
== BT_CLASS
)
6686 gfc_add_vptr_component (b
);
6687 gfc_add_hash_component (b
);
6689 else if (b
->ts
.type
== BT_DERIVED
)
6690 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6691 b
->ts
.u
.derived
->hash_value
);
6693 gfc_conv_expr (&se1
, a
);
6694 gfc_conv_expr (&se2
, b
);
6696 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6697 boolean_type_node
, se1
.expr
,
6698 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
6701 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6702 boolean_type_node
, conda
, tmp
);
6705 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6706 boolean_type_node
, condb
, tmp
);
6708 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6712 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6715 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6719 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6720 se
->expr
= build_call_expr_loc (input_location
,
6721 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6722 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6726 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6729 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6733 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6735 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6736 type
= gfc_get_int_type (4);
6737 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6739 /* Convert it to the required type. */
6740 type
= gfc_typenode_for_spec (&expr
->ts
);
6741 se
->expr
= build_call_expr_loc (input_location
,
6742 gfor_fndecl_si_kind
, 1, arg
);
6743 se
->expr
= fold_convert (type
, se
->expr
);
6747 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6750 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6752 gfc_actual_arglist
*actual
;
6755 vec
<tree
, va_gc
> *args
= NULL
;
6757 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6759 gfc_init_se (&argse
, se
);
6761 /* Pass a NULL pointer for an absent arg. */
6762 if (actual
->expr
== NULL
)
6763 argse
.expr
= null_pointer_node
;
6769 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6771 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6772 ts
.type
= BT_INTEGER
;
6773 ts
.kind
= gfc_c_int_kind
;
6774 gfc_convert_type (actual
->expr
, &ts
, 2);
6776 gfc_conv_expr_reference (&argse
, actual
->expr
);
6779 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6780 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6781 vec_safe_push (args
, argse
.expr
);
6784 /* Convert it to the required type. */
6785 type
= gfc_typenode_for_spec (&expr
->ts
);
6786 se
->expr
= build_call_expr_loc_vec (input_location
,
6787 gfor_fndecl_sr_kind
, args
);
6788 se
->expr
= fold_convert (type
, se
->expr
);
6792 /* Generate code for TRIM (A) intrinsic function. */
6795 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6805 unsigned int num_args
;
6807 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6808 args
= XALLOCAVEC (tree
, num_args
);
6810 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6811 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6812 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6814 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6815 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6818 if (expr
->ts
.kind
== 1)
6819 function
= gfor_fndecl_string_trim
;
6820 else if (expr
->ts
.kind
== 4)
6821 function
= gfor_fndecl_string_trim_char4
;
6825 fndecl
= build_addr (function
, current_function_decl
);
6826 tmp
= build_call_array_loc (input_location
,
6827 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6829 gfc_add_expr_to_block (&se
->pre
, tmp
);
6831 /* Free the temporary afterwards, if necessary. */
6832 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6833 len
, build_int_cst (TREE_TYPE (len
), 0));
6834 tmp
= gfc_call_free (var
);
6835 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6836 gfc_add_expr_to_block (&se
->post
, tmp
);
6839 se
->string_length
= len
;
6843 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6846 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6848 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6849 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6851 stmtblock_t block
, body
;
6854 /* We store in charsize the size of a character. */
6855 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6856 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6858 /* Get the arguments. */
6859 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6860 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6862 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6863 ncopies_type
= TREE_TYPE (ncopies
);
6865 /* Check that NCOPIES is not negative. */
6866 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6867 build_int_cst (ncopies_type
, 0));
6868 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6869 "Argument NCOPIES of REPEAT intrinsic is negative "
6870 "(its value is %ld)",
6871 fold_convert (long_integer_type_node
, ncopies
));
6873 /* If the source length is zero, any non negative value of NCOPIES
6874 is valid, and nothing happens. */
6875 n
= gfc_create_var (ncopies_type
, "ncopies");
6876 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6877 build_int_cst (size_type_node
, 0));
6878 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6879 build_int_cst (ncopies_type
, 0), ncopies
);
6880 gfc_add_modify (&se
->pre
, n
, tmp
);
6883 /* Check that ncopies is not too large: ncopies should be less than
6884 (or equal to) MAX / slen, where MAX is the maximal integer of
6885 the gfc_charlen_type_node type. If slen == 0, we need a special
6886 case to avoid the division by zero. */
6887 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6888 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6889 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6890 fold_convert (size_type_node
, max
), slen
);
6891 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6892 ? size_type_node
: ncopies_type
;
6893 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6894 fold_convert (largest
, ncopies
),
6895 fold_convert (largest
, max
));
6896 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6897 build_int_cst (size_type_node
, 0));
6898 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6899 boolean_false_node
, cond
);
6900 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6901 "Argument NCOPIES of REPEAT intrinsic is too large");
6903 /* Compute the destination length. */
6904 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6905 fold_convert (gfc_charlen_type_node
, slen
),
6906 fold_convert (gfc_charlen_type_node
, ncopies
));
6907 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6908 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6910 /* Generate the code to do the repeat operation:
6911 for (i = 0; i < ncopies; i++)
6912 memmove (dest + (i * slen * size), src, slen*size); */
6913 gfc_start_block (&block
);
6914 count
= gfc_create_var (ncopies_type
, "count");
6915 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6916 exit_label
= gfc_build_label_decl (NULL_TREE
);
6918 /* Start the loop body. */
6919 gfc_start_block (&body
);
6921 /* Exit the loop if count >= ncopies. */
6922 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6924 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6925 TREE_USED (exit_label
) = 1;
6926 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6927 build_empty_stmt (input_location
));
6928 gfc_add_expr_to_block (&body
, tmp
);
6930 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6931 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6932 fold_convert (gfc_charlen_type_node
, slen
),
6933 fold_convert (gfc_charlen_type_node
, count
));
6934 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6935 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6936 tmp
= fold_build_pointer_plus_loc (input_location
,
6937 fold_convert (pvoid_type_node
, dest
), tmp
);
6938 tmp
= build_call_expr_loc (input_location
,
6939 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6941 fold_build2_loc (input_location
, MULT_EXPR
,
6942 size_type_node
, slen
,
6943 fold_convert (size_type_node
,
6945 gfc_add_expr_to_block (&body
, tmp
);
6947 /* Increment count. */
6948 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6949 count
, build_int_cst (TREE_TYPE (count
), 1));
6950 gfc_add_modify (&body
, count
, tmp
);
6952 /* Build the loop. */
6953 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6954 gfc_add_expr_to_block (&block
, tmp
);
6956 /* Add the exit label. */
6957 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6958 gfc_add_expr_to_block (&block
, tmp
);
6960 /* Finish the block. */
6961 tmp
= gfc_finish_block (&block
);
6962 gfc_add_expr_to_block (&se
->pre
, tmp
);
6964 /* Set the result value. */
6966 se
->string_length
= dlen
;
6970 /* Generate code for the IARGC intrinsic. */
6973 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6979 /* Call the library function. This always returns an INTEGER(4). */
6980 fndecl
= gfor_fndecl_iargc
;
6981 tmp
= build_call_expr_loc (input_location
,
6984 /* Convert it to the required type. */
6985 type
= gfc_typenode_for_spec (&expr
->ts
);
6986 tmp
= fold_convert (type
, tmp
);
6992 /* The loc intrinsic returns the address of its argument as
6993 gfc_index_integer_kind integer. */
6996 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
7001 gcc_assert (!se
->ss
);
7003 arg_expr
= expr
->value
.function
.actual
->expr
;
7004 if (arg_expr
->rank
== 0)
7005 gfc_conv_expr_reference (se
, arg_expr
);
7007 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
7008 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
7010 /* Create a temporary variable for loc return value. Without this,
7011 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
7012 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
7013 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
7014 se
->expr
= temp_var
;
7018 /* The following routine generates code for the intrinsic
7019 functions from the ISO_C_BINDING module:
7025 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
7027 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7029 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
7031 if (arg
->expr
->rank
== 0)
7032 gfc_conv_expr_reference (se
, arg
->expr
);
7033 else if (gfc_is_simply_contiguous (arg
->expr
, false))
7034 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
7037 gfc_conv_expr_descriptor (se
, arg
->expr
);
7038 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
7041 /* TODO -- the following two lines shouldn't be necessary, but if
7042 they're removed, a bug is exposed later in the code path.
7043 This workaround was thus introduced, but will have to be
7044 removed; please see PR 35150 for details about the issue. */
7045 se
->expr
= convert (pvoid_type_node
, se
->expr
);
7046 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7048 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
7049 gfc_conv_expr_reference (se
, arg
->expr
);
7050 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
7055 /* Build the addr_expr for the first argument. The argument is
7056 already an *address* so we don't need to set want_pointer in
7058 gfc_init_se (&arg1se
, NULL
);
7059 gfc_conv_expr (&arg1se
, arg
->expr
);
7060 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
7061 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
7063 /* See if we were given two arguments. */
7064 if (arg
->next
->expr
== NULL
)
7065 /* Only given one arg so generate a null and do a
7066 not-equal comparison against the first arg. */
7067 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7069 fold_convert (TREE_TYPE (arg1se
.expr
),
7070 null_pointer_node
));
7076 /* Given two arguments so build the arg2se from second arg. */
7077 gfc_init_se (&arg2se
, NULL
);
7078 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
7079 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
7080 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
7082 /* Generate test to compare that the two args are equal. */
7083 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7084 arg1se
.expr
, arg2se
.expr
);
7085 /* Generate test to ensure that the first arg is not null. */
7086 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
7088 arg1se
.expr
, null_pointer_node
);
7090 /* Finally, the generated test must check that both arg1 is not
7091 NULL and that it is equal to the second arg. */
7092 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7094 not_null_expr
, eq_expr
);
7102 /* The following routine generates code for the intrinsic
7103 subroutines from the ISO_C_BINDING module:
7105 * C_F_PROCPOINTER. */
7108 conv_isocbinding_subroutine (gfc_code
*code
)
7115 tree desc
, dim
, tmp
, stride
, offset
;
7116 stmtblock_t body
, block
;
7118 gfc_actual_arglist
*arg
= code
->ext
.actual
;
7120 gfc_init_se (&se
, NULL
);
7121 gfc_init_se (&cptrse
, NULL
);
7122 gfc_conv_expr (&cptrse
, arg
->expr
);
7123 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
7124 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
7126 gfc_init_se (&fptrse
, NULL
);
7127 if (arg
->next
->expr
->rank
== 0)
7129 fptrse
.want_pointer
= 1;
7130 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
7131 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
7132 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
7133 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
7134 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
7135 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
7137 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
7138 TREE_TYPE (fptrse
.expr
),
7140 fold_convert (TREE_TYPE (fptrse
.expr
),
7142 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
7143 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7144 return gfc_finish_block (&se
.pre
);
7147 gfc_start_block (&block
);
7149 /* Get the descriptor of the Fortran pointer. */
7150 fptrse
.descriptor_only
= 1;
7151 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
7152 gfc_add_block_to_block (&block
, &fptrse
.pre
);
7155 /* Set data value, dtype, and offset. */
7156 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
7157 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
7158 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7159 gfc_get_dtype (TREE_TYPE (desc
)));
7161 /* Start scalarization of the bounds, using the shape argument. */
7163 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
7164 gcc_assert (shape_ss
!= gfc_ss_terminator
);
7165 gfc_init_se (&shapese
, NULL
);
7167 gfc_init_loopinfo (&loop
);
7168 gfc_add_ss_to_loop (&loop
, shape_ss
);
7169 gfc_conv_ss_startstride (&loop
);
7170 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
7171 gfc_mark_ss_chain_used (shape_ss
, 1);
7173 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
7174 shapese
.ss
= shape_ss
;
7176 stride
= gfc_create_var (gfc_array_index_type
, "stride");
7177 offset
= gfc_create_var (gfc_array_index_type
, "offset");
7178 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
7179 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7182 gfc_start_scalarized_body (&loop
, &body
);
7184 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7185 loop
.loopvar
[0], loop
.from
[0]);
7187 /* Set bounds and stride. */
7188 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
7189 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
7191 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
7192 gfc_add_block_to_block (&body
, &shapese
.pre
);
7193 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
7194 gfc_add_block_to_block (&body
, &shapese
.post
);
7196 /* Calculate offset. */
7197 gfc_add_modify (&body
, offset
,
7198 fold_build2_loc (input_location
, PLUS_EXPR
,
7199 gfc_array_index_type
, offset
, stride
));
7200 /* Update stride. */
7201 gfc_add_modify (&body
, stride
,
7202 fold_build2_loc (input_location
, MULT_EXPR
,
7203 gfc_array_index_type
, stride
,
7204 fold_convert (gfc_array_index_type
,
7206 /* Finish scalarization loop. */
7207 gfc_trans_scalarizing_loops (&loop
, &body
);
7208 gfc_add_block_to_block (&block
, &loop
.pre
);
7209 gfc_add_block_to_block (&block
, &loop
.post
);
7210 gfc_add_block_to_block (&block
, &fptrse
.post
);
7211 gfc_cleanup_loop (&loop
);
7213 gfc_add_modify (&block
, offset
,
7214 fold_build1_loc (input_location
, NEGATE_EXPR
,
7215 gfc_array_index_type
, offset
));
7216 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
7218 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
7219 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7220 return gfc_finish_block (&se
.pre
);
7224 /* Save and restore floating-point state. */
7227 gfc_save_fp_state (stmtblock_t
*block
)
7229 tree type
, fpstate
, tmp
;
7231 type
= build_array_type (char_type_node
,
7232 build_range_type (size_type_node
, size_zero_node
,
7233 size_int (GFC_FPE_STATE_BUFFER_SIZE
)));
7234 fpstate
= gfc_create_var (type
, "fpstate");
7235 fpstate
= gfc_build_addr_expr (pvoid_type_node
, fpstate
);
7237 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_entry
,
7239 gfc_add_expr_to_block (block
, tmp
);
7246 gfc_restore_fp_state (stmtblock_t
*block
, tree fpstate
)
7250 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_ieee_procedure_exit
,
7252 gfc_add_expr_to_block (block
, tmp
);
7256 /* Generate code for arguments of IEEE functions. */
7259 conv_ieee_function_args (gfc_se
*se
, gfc_expr
*expr
, tree
*argarray
,
7262 gfc_actual_arglist
*actual
;
7267 actual
= expr
->value
.function
.actual
;
7268 for (arg
= 0; arg
< nargs
; arg
++, actual
= actual
->next
)
7270 gcc_assert (actual
);
7273 gfc_init_se (&argse
, se
);
7274 gfc_conv_expr_val (&argse
, e
);
7276 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
7277 gfc_add_block_to_block (&se
->post
, &argse
.post
);
7278 argarray
[arg
] = argse
.expr
;
7283 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
7284 and IEEE_UNORDERED, which translate directly to GCC type-generic
7288 conv_intrinsic_ieee_builtin (gfc_se
* se
, gfc_expr
* expr
,
7289 enum built_in_function code
, int nargs
)
7292 gcc_assert ((unsigned) nargs
<= sizeof(args
)/sizeof(args
[0]));
7294 conv_ieee_function_args (se
, expr
, args
, nargs
);
7295 se
->expr
= build_call_expr_loc_array (input_location
,
7296 builtin_decl_explicit (code
),
7298 STRIP_TYPE_NOPS (se
->expr
);
7299 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7303 /* Generate code for IEEE_IS_NORMAL intrinsic:
7304 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
7307 conv_intrinsic_ieee_is_normal (gfc_se
* se
, gfc_expr
* expr
)
7309 tree arg
, isnormal
, iszero
;
7311 /* Convert arg, evaluate it only once. */
7312 conv_ieee_function_args (se
, expr
, &arg
, 1);
7313 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7315 isnormal
= build_call_expr_loc (input_location
,
7316 builtin_decl_explicit (BUILT_IN_ISNORMAL
),
7318 iszero
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
7319 build_real_from_int_cst (TREE_TYPE (arg
),
7320 integer_zero_node
));
7321 se
->expr
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7322 boolean_type_node
, isnormal
, iszero
);
7323 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7327 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
7328 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
7331 conv_intrinsic_ieee_is_negative (gfc_se
* se
, gfc_expr
* expr
)
7333 tree arg
, signbit
, isnan
, decl
;
7336 /* Convert arg, evaluate it only once. */
7337 conv_ieee_function_args (se
, expr
, &arg
, 1);
7338 arg
= gfc_evaluate_now (arg
, &se
->pre
);
7340 isnan
= build_call_expr_loc (input_location
,
7341 builtin_decl_explicit (BUILT_IN_ISNAN
),
7343 STRIP_TYPE_NOPS (isnan
);
7345 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
7346 decl
= builtin_decl_for_precision (BUILT_IN_SIGNBIT
, argprec
);
7347 signbit
= build_call_expr_loc (input_location
, decl
, 1, arg
);
7348 signbit
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7349 signbit
, integer_zero_node
);
7351 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
7352 boolean_type_node
, signbit
,
7353 fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
7354 TREE_TYPE(isnan
), isnan
));
7356 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
7360 /* Generate code for IEEE_LOGB and IEEE_RINT. */
7363 conv_intrinsic_ieee_logb_rint (gfc_se
* se
, gfc_expr
* expr
,
7364 enum built_in_function code
)
7366 tree arg
, decl
, call
, fpstate
;
7369 conv_ieee_function_args (se
, expr
, &arg
, 1);
7370 argprec
= TYPE_PRECISION (TREE_TYPE (arg
));
7371 decl
= builtin_decl_for_precision (code
, argprec
);
7373 /* Save floating-point state. */
7374 fpstate
= gfc_save_fp_state (&se
->pre
);
7376 /* Make the function call. */
7377 call
= build_call_expr_loc (input_location
, decl
, 1, arg
);
7378 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), call
);
7380 /* Restore floating-point state. */
7381 gfc_restore_fp_state (&se
->post
, fpstate
);
7385 /* Generate code for IEEE_REM. */
7388 conv_intrinsic_ieee_rem (gfc_se
* se
, gfc_expr
* expr
)
7390 tree args
[2], decl
, call
, fpstate
;
7393 conv_ieee_function_args (se
, expr
, args
, 2);
7395 /* If arguments have unequal size, convert them to the larger. */
7396 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
7397 > TYPE_PRECISION (TREE_TYPE (args
[1])))
7398 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7399 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
7400 > TYPE_PRECISION (TREE_TYPE (args
[0])))
7401 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
7403 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7404 decl
= builtin_decl_for_precision (BUILT_IN_REMAINDER
, argprec
);
7406 /* Save floating-point state. */
7407 fpstate
= gfc_save_fp_state (&se
->pre
);
7409 /* Make the function call. */
7410 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7411 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7413 /* Restore floating-point state. */
7414 gfc_restore_fp_state (&se
->post
, fpstate
);
7418 /* Generate code for IEEE_NEXT_AFTER. */
7421 conv_intrinsic_ieee_next_after (gfc_se
* se
, gfc_expr
* expr
)
7423 tree args
[2], decl
, call
, fpstate
;
7426 conv_ieee_function_args (se
, expr
, args
, 2);
7428 /* Result has the characteristics of first argument. */
7429 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
7430 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7431 decl
= builtin_decl_for_precision (BUILT_IN_NEXTAFTER
, argprec
);
7433 /* Save floating-point state. */
7434 fpstate
= gfc_save_fp_state (&se
->pre
);
7436 /* Make the function call. */
7437 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7438 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7440 /* Restore floating-point state. */
7441 gfc_restore_fp_state (&se
->post
, fpstate
);
7445 /* Generate code for IEEE_SCALB. */
7448 conv_intrinsic_ieee_scalb (gfc_se
* se
, gfc_expr
* expr
)
7450 tree args
[2], decl
, call
, huge
, type
;
7453 conv_ieee_function_args (se
, expr
, args
, 2);
7455 /* Result has the characteristics of first argument. */
7456 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7457 decl
= builtin_decl_for_precision (BUILT_IN_SCALBN
, argprec
);
7459 if (TYPE_PRECISION (TREE_TYPE (args
[1])) > TYPE_PRECISION (integer_type_node
))
7461 /* We need to fold the integer into the range of a C int. */
7462 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
7463 type
= TREE_TYPE (args
[1]);
7465 n
= gfc_validate_kind (BT_INTEGER
, gfc_c_int_kind
, false);
7466 huge
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
7468 huge
= fold_convert (type
, huge
);
7469 args
[1] = fold_build2_loc (input_location
, MIN_EXPR
, type
, args
[1],
7471 args
[1] = fold_build2_loc (input_location
, MAX_EXPR
, type
, args
[1],
7472 fold_build1_loc (input_location
, NEGATE_EXPR
,
7476 args
[1] = fold_convert (integer_type_node
, args
[1]);
7478 /* Make the function call. */
7479 call
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7480 se
->expr
= fold_convert (TREE_TYPE (args
[0]), call
);
7484 /* Generate code for IEEE_COPY_SIGN. */
7487 conv_intrinsic_ieee_copy_sign (gfc_se
* se
, gfc_expr
* expr
)
7489 tree args
[2], decl
, sign
;
7492 conv_ieee_function_args (se
, expr
, args
, 2);
7494 /* Get the sign of the second argument. */
7495 argprec
= TYPE_PRECISION (TREE_TYPE (args
[1]));
7496 decl
= builtin_decl_for_precision (BUILT_IN_SIGNBIT
, argprec
);
7497 sign
= build_call_expr_loc (input_location
, decl
, 1, args
[1]);
7498 sign
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7499 sign
, integer_zero_node
);
7501 /* Create a value of one, with the right sign. */
7502 sign
= fold_build3_loc (input_location
, COND_EXPR
, integer_type_node
,
7504 fold_build1_loc (input_location
, NEGATE_EXPR
,
7508 args
[1] = fold_convert (TREE_TYPE (args
[0]), sign
);
7510 argprec
= TYPE_PRECISION (TREE_TYPE (args
[0]));
7511 decl
= builtin_decl_for_precision (BUILT_IN_COPYSIGN
, argprec
);
7513 se
->expr
= build_call_expr_loc_array (input_location
, decl
, 2, args
);
7517 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
7521 gfc_conv_ieee_arithmetic_function (gfc_se
* se
, gfc_expr
* expr
)
7523 const char *name
= expr
->value
.function
.name
;
7525 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
7527 if (STARTS_WITH (name
, "_gfortran_ieee_is_nan"))
7528 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISNAN
, 1);
7529 else if (STARTS_WITH (name
, "_gfortran_ieee_is_finite"))
7530 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISFINITE
, 1);
7531 else if (STARTS_WITH (name
, "_gfortran_ieee_unordered"))
7532 conv_intrinsic_ieee_builtin (se
, expr
, BUILT_IN_ISUNORDERED
, 2);
7533 else if (STARTS_WITH (name
, "_gfortran_ieee_is_normal"))
7534 conv_intrinsic_ieee_is_normal (se
, expr
);
7535 else if (STARTS_WITH (name
, "_gfortran_ieee_is_negative"))
7536 conv_intrinsic_ieee_is_negative (se
, expr
);
7537 else if (STARTS_WITH (name
, "_gfortran_ieee_copy_sign"))
7538 conv_intrinsic_ieee_copy_sign (se
, expr
);
7539 else if (STARTS_WITH (name
, "_gfortran_ieee_scalb"))
7540 conv_intrinsic_ieee_scalb (se
, expr
);
7541 else if (STARTS_WITH (name
, "_gfortran_ieee_next_after"))
7542 conv_intrinsic_ieee_next_after (se
, expr
);
7543 else if (STARTS_WITH (name
, "_gfortran_ieee_rem"))
7544 conv_intrinsic_ieee_rem (se
, expr
);
7545 else if (STARTS_WITH (name
, "_gfortran_ieee_logb"))
7546 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_LOGB
);
7547 else if (STARTS_WITH (name
, "_gfortran_ieee_rint"))
7548 conv_intrinsic_ieee_logb_rint (se
, expr
, BUILT_IN_RINT
);
7550 /* It is not among the functions we translate directly. We return
7551 false, so a library function call is emitted. */
7560 /* Generate code for an intrinsic function. Some map directly to library
7561 calls, others get special handling. In some cases the name of the function
7562 used depends on the type specifiers. */
7565 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
7571 name
= &expr
->value
.function
.name
[2];
7575 lib
= gfc_is_intrinsic_libcall (expr
);
7579 se
->ignore_optional
= 1;
7581 switch (expr
->value
.function
.isym
->id
)
7583 case GFC_ISYM_EOSHIFT
:
7585 case GFC_ISYM_RESHAPE
:
7586 /* For all of those the first argument specifies the type and the
7587 third is optional. */
7588 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
7592 gfc_conv_intrinsic_funcall (se
, expr
);
7600 switch (expr
->value
.function
.isym
->id
)
7605 case GFC_ISYM_REPEAT
:
7606 gfc_conv_intrinsic_repeat (se
, expr
);
7610 gfc_conv_intrinsic_trim (se
, expr
);
7613 case GFC_ISYM_SC_KIND
:
7614 gfc_conv_intrinsic_sc_kind (se
, expr
);
7617 case GFC_ISYM_SI_KIND
:
7618 gfc_conv_intrinsic_si_kind (se
, expr
);
7621 case GFC_ISYM_SR_KIND
:
7622 gfc_conv_intrinsic_sr_kind (se
, expr
);
7625 case GFC_ISYM_EXPONENT
:
7626 gfc_conv_intrinsic_exponent (se
, expr
);
7630 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7632 fndecl
= gfor_fndecl_string_scan
;
7634 fndecl
= gfor_fndecl_string_scan_char4
;
7638 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7641 case GFC_ISYM_VERIFY
:
7642 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7644 fndecl
= gfor_fndecl_string_verify
;
7646 fndecl
= gfor_fndecl_string_verify_char4
;
7650 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7653 case GFC_ISYM_ALLOCATED
:
7654 gfc_conv_allocated (se
, expr
);
7657 case GFC_ISYM_ASSOCIATED
:
7658 gfc_conv_associated(se
, expr
);
7661 case GFC_ISYM_SAME_TYPE_AS
:
7662 gfc_conv_same_type_as (se
, expr
);
7666 gfc_conv_intrinsic_abs (se
, expr
);
7669 case GFC_ISYM_ADJUSTL
:
7670 if (expr
->ts
.kind
== 1)
7671 fndecl
= gfor_fndecl_adjustl
;
7672 else if (expr
->ts
.kind
== 4)
7673 fndecl
= gfor_fndecl_adjustl_char4
;
7677 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7680 case GFC_ISYM_ADJUSTR
:
7681 if (expr
->ts
.kind
== 1)
7682 fndecl
= gfor_fndecl_adjustr
;
7683 else if (expr
->ts
.kind
== 4)
7684 fndecl
= gfor_fndecl_adjustr_char4
;
7688 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
7691 case GFC_ISYM_AIMAG
:
7692 gfc_conv_intrinsic_imagpart (se
, expr
);
7696 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
7700 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
7703 case GFC_ISYM_ANINT
:
7704 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
7708 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7712 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
7715 case GFC_ISYM_BTEST
:
7716 gfc_conv_intrinsic_btest (se
, expr
);
7720 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
7724 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
7728 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
7732 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
7735 case GFC_ISYM_C_ASSOCIATED
:
7736 case GFC_ISYM_C_FUNLOC
:
7737 case GFC_ISYM_C_LOC
:
7738 conv_isocbinding_function (se
, expr
);
7741 case GFC_ISYM_ACHAR
:
7743 gfc_conv_intrinsic_char (se
, expr
);
7746 case GFC_ISYM_CONVERSION
:
7748 case GFC_ISYM_LOGICAL
:
7750 gfc_conv_intrinsic_conversion (se
, expr
);
7753 /* Integer conversions are handled separately to make sure we get the
7754 correct rounding mode. */
7759 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
7763 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
7766 case GFC_ISYM_CEILING
:
7767 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
7770 case GFC_ISYM_FLOOR
:
7771 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
7775 gfc_conv_intrinsic_mod (se
, expr
, 0);
7778 case GFC_ISYM_MODULO
:
7779 gfc_conv_intrinsic_mod (se
, expr
, 1);
7782 case GFC_ISYM_CAF_GET
:
7783 gfc_conv_intrinsic_caf_get (se
, expr
, NULL_TREE
, NULL_TREE
, NULL_TREE
);
7786 case GFC_ISYM_CMPLX
:
7787 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
7790 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
7791 gfc_conv_intrinsic_iargc (se
, expr
);
7794 case GFC_ISYM_COMPLEX
:
7795 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
7798 case GFC_ISYM_CONJG
:
7799 gfc_conv_intrinsic_conjg (se
, expr
);
7802 case GFC_ISYM_COUNT
:
7803 gfc_conv_intrinsic_count (se
, expr
);
7806 case GFC_ISYM_CTIME
:
7807 gfc_conv_intrinsic_ctime (se
, expr
);
7811 gfc_conv_intrinsic_dim (se
, expr
);
7814 case GFC_ISYM_DOT_PRODUCT
:
7815 gfc_conv_intrinsic_dot_product (se
, expr
);
7818 case GFC_ISYM_DPROD
:
7819 gfc_conv_intrinsic_dprod (se
, expr
);
7822 case GFC_ISYM_DSHIFTL
:
7823 gfc_conv_intrinsic_dshift (se
, expr
, true);
7826 case GFC_ISYM_DSHIFTR
:
7827 gfc_conv_intrinsic_dshift (se
, expr
, false);
7830 case GFC_ISYM_FDATE
:
7831 gfc_conv_intrinsic_fdate (se
, expr
);
7834 case GFC_ISYM_FRACTION
:
7835 gfc_conv_intrinsic_fraction (se
, expr
);
7839 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
7843 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7847 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
7850 case GFC_ISYM_IBCLR
:
7851 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
7854 case GFC_ISYM_IBITS
:
7855 gfc_conv_intrinsic_ibits (se
, expr
);
7858 case GFC_ISYM_IBSET
:
7859 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
7862 case GFC_ISYM_IACHAR
:
7863 case GFC_ISYM_ICHAR
:
7864 /* We assume ASCII character sequence. */
7865 gfc_conv_intrinsic_ichar (se
, expr
);
7868 case GFC_ISYM_IARGC
:
7869 gfc_conv_intrinsic_iargc (se
, expr
);
7873 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
7876 case GFC_ISYM_INDEX
:
7877 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7879 fndecl
= gfor_fndecl_string_index
;
7881 fndecl
= gfor_fndecl_string_index_char4
;
7885 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7889 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
7892 case GFC_ISYM_IPARITY
:
7893 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
7896 case GFC_ISYM_IS_IOSTAT_END
:
7897 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
7900 case GFC_ISYM_IS_IOSTAT_EOR
:
7901 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
7904 case GFC_ISYM_ISNAN
:
7905 gfc_conv_intrinsic_isnan (se
, expr
);
7908 case GFC_ISYM_LSHIFT
:
7909 gfc_conv_intrinsic_shift (se
, expr
, false, false);
7912 case GFC_ISYM_RSHIFT
:
7913 gfc_conv_intrinsic_shift (se
, expr
, true, true);
7916 case GFC_ISYM_SHIFTA
:
7917 gfc_conv_intrinsic_shift (se
, expr
, true, true);
7920 case GFC_ISYM_SHIFTL
:
7921 gfc_conv_intrinsic_shift (se
, expr
, false, false);
7924 case GFC_ISYM_SHIFTR
:
7925 gfc_conv_intrinsic_shift (se
, expr
, true, false);
7928 case GFC_ISYM_ISHFT
:
7929 gfc_conv_intrinsic_ishft (se
, expr
);
7932 case GFC_ISYM_ISHFTC
:
7933 gfc_conv_intrinsic_ishftc (se
, expr
);
7936 case GFC_ISYM_LEADZ
:
7937 gfc_conv_intrinsic_leadz (se
, expr
);
7940 case GFC_ISYM_TRAILZ
:
7941 gfc_conv_intrinsic_trailz (se
, expr
);
7944 case GFC_ISYM_POPCNT
:
7945 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
7948 case GFC_ISYM_POPPAR
:
7949 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
7952 case GFC_ISYM_LBOUND
:
7953 gfc_conv_intrinsic_bound (se
, expr
, 0);
7956 case GFC_ISYM_LCOBOUND
:
7957 conv_intrinsic_cobound (se
, expr
);
7960 case GFC_ISYM_TRANSPOSE
:
7961 /* The scalarizer has already been set up for reversed dimension access
7962 order ; now we just get the argument value normally. */
7963 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
7967 gfc_conv_intrinsic_len (se
, expr
);
7970 case GFC_ISYM_LEN_TRIM
:
7971 gfc_conv_intrinsic_len_trim (se
, expr
);
7975 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
7979 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
7983 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
7987 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
7990 case GFC_ISYM_MASKL
:
7991 gfc_conv_intrinsic_mask (se
, expr
, 1);
7994 case GFC_ISYM_MASKR
:
7995 gfc_conv_intrinsic_mask (se
, expr
, 0);
7999 if (expr
->ts
.type
== BT_CHARACTER
)
8000 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
8002 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
8005 case GFC_ISYM_MAXLOC
:
8006 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
8009 case GFC_ISYM_MAXVAL
:
8010 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
8013 case GFC_ISYM_MERGE
:
8014 gfc_conv_intrinsic_merge (se
, expr
);
8017 case GFC_ISYM_MERGE_BITS
:
8018 gfc_conv_intrinsic_merge_bits (se
, expr
);
8022 if (expr
->ts
.type
== BT_CHARACTER
)
8023 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
8025 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
8028 case GFC_ISYM_MINLOC
:
8029 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
8032 case GFC_ISYM_MINVAL
:
8033 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
8036 case GFC_ISYM_NEAREST
:
8037 gfc_conv_intrinsic_nearest (se
, expr
);
8040 case GFC_ISYM_NORM2
:
8041 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
8045 gfc_conv_intrinsic_not (se
, expr
);
8049 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
8052 case GFC_ISYM_PARITY
:
8053 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
8056 case GFC_ISYM_PRESENT
:
8057 gfc_conv_intrinsic_present (se
, expr
);
8060 case GFC_ISYM_PRODUCT
:
8061 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
8065 gfc_conv_intrinsic_rank (se
, expr
);
8068 case GFC_ISYM_RRSPACING
:
8069 gfc_conv_intrinsic_rrspacing (se
, expr
);
8072 case GFC_ISYM_SET_EXPONENT
:
8073 gfc_conv_intrinsic_set_exponent (se
, expr
);
8076 case GFC_ISYM_SCALE
:
8077 gfc_conv_intrinsic_scale (se
, expr
);
8081 gfc_conv_intrinsic_sign (se
, expr
);
8085 gfc_conv_intrinsic_size (se
, expr
);
8088 case GFC_ISYM_SIZEOF
:
8089 case GFC_ISYM_C_SIZEOF
:
8090 gfc_conv_intrinsic_sizeof (se
, expr
);
8093 case GFC_ISYM_STORAGE_SIZE
:
8094 gfc_conv_intrinsic_storage_size (se
, expr
);
8097 case GFC_ISYM_SPACING
:
8098 gfc_conv_intrinsic_spacing (se
, expr
);
8101 case GFC_ISYM_STRIDE
:
8102 conv_intrinsic_stride (se
, expr
);
8106 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
8109 case GFC_ISYM_TRANSFER
:
8110 if (se
->ss
&& se
->ss
->info
->useflags
)
8111 /* Access the previously obtained result. */
8112 gfc_conv_tmp_array_ref (se
);
8114 gfc_conv_intrinsic_transfer (se
, expr
);
8117 case GFC_ISYM_TTYNAM
:
8118 gfc_conv_intrinsic_ttynam (se
, expr
);
8121 case GFC_ISYM_UBOUND
:
8122 gfc_conv_intrinsic_bound (se
, expr
, 1);
8125 case GFC_ISYM_UCOBOUND
:
8126 conv_intrinsic_cobound (se
, expr
);
8130 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
8134 gfc_conv_intrinsic_loc (se
, expr
);
8137 case GFC_ISYM_THIS_IMAGE
:
8138 /* For num_images() == 1, handle as LCOBOUND. */
8139 if (expr
->value
.function
.actual
->expr
8140 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
8141 conv_intrinsic_cobound (se
, expr
);
8143 trans_this_image (se
, expr
);
8146 case GFC_ISYM_IMAGE_INDEX
:
8147 trans_image_index (se
, expr
);
8150 case GFC_ISYM_NUM_IMAGES
:
8151 trans_num_images (se
, expr
);
8154 case GFC_ISYM_ACCESS
:
8155 case GFC_ISYM_CHDIR
:
8156 case GFC_ISYM_CHMOD
:
8157 case GFC_ISYM_DTIME
:
8158 case GFC_ISYM_ETIME
:
8159 case GFC_ISYM_EXTENDS_TYPE_OF
:
8161 case GFC_ISYM_FGETC
:
8164 case GFC_ISYM_FPUTC
:
8165 case GFC_ISYM_FSTAT
:
8166 case GFC_ISYM_FTELL
:
8167 case GFC_ISYM_GETCWD
:
8168 case GFC_ISYM_GETGID
:
8169 case GFC_ISYM_GETPID
:
8170 case GFC_ISYM_GETUID
:
8171 case GFC_ISYM_HOSTNM
:
8173 case GFC_ISYM_IERRNO
:
8174 case GFC_ISYM_IRAND
:
8175 case GFC_ISYM_ISATTY
:
8178 case GFC_ISYM_LSTAT
:
8179 case GFC_ISYM_MALLOC
:
8180 case GFC_ISYM_MATMUL
:
8181 case GFC_ISYM_MCLOCK
:
8182 case GFC_ISYM_MCLOCK8
:
8184 case GFC_ISYM_RENAME
:
8185 case GFC_ISYM_SECOND
:
8186 case GFC_ISYM_SECNDS
:
8187 case GFC_ISYM_SIGNAL
:
8189 case GFC_ISYM_SYMLNK
:
8190 case GFC_ISYM_SYSTEM
:
8192 case GFC_ISYM_TIME8
:
8193 case GFC_ISYM_UMASK
:
8194 case GFC_ISYM_UNLINK
:
8196 gfc_conv_intrinsic_funcall (se
, expr
);
8199 case GFC_ISYM_EOSHIFT
:
8201 case GFC_ISYM_RESHAPE
:
8202 /* For those, expr->rank should always be >0 and thus the if above the
8203 switch should have matched. */
8208 gfc_conv_intrinsic_lib_function (se
, expr
);
8215 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
8217 gfc_ss
*arg_ss
, *tmp_ss
;
8218 gfc_actual_arglist
*arg
;
8220 arg
= expr
->value
.function
.actual
;
8222 gcc_assert (arg
->expr
);
8224 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
8225 gcc_assert (arg_ss
!= gfc_ss_terminator
);
8227 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
8229 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
8230 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
8234 gcc_assert (tmp_ss
->dimen
== 2);
8236 /* We just invert dimensions. */
8237 tmp_dim
= tmp_ss
->dim
[0];
8238 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
8239 tmp_ss
->dim
[1] = tmp_dim
;
8242 /* Stop when tmp_ss points to the last valid element of the chain... */
8243 if (tmp_ss
->next
== gfc_ss_terminator
)
8247 /* ... so that we can attach the rest of the chain to it. */
8254 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
8255 This has the side effect of reversing the nested list, so there is no
8256 need to call gfc_reverse_ss on it (the given list is assumed not to be
8260 nest_loop_dimension (gfc_ss
*ss
, int dim
)
8263 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
8264 gfc_loopinfo
*new_loop
;
8266 gcc_assert (ss
!= gfc_ss_terminator
);
8268 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
8270 new_ss
= gfc_get_ss ();
8271 new_ss
->next
= prev_ss
;
8272 new_ss
->parent
= ss
;
8273 new_ss
->info
= ss
->info
;
8274 new_ss
->info
->refcount
++;
8277 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
8278 && ss
->info
->type
!= GFC_SS_REFERENCE
);
8281 new_ss
->dim
[0] = ss
->dim
[dim
];
8283 gcc_assert (dim
< ss
->dimen
);
8285 ss_dim
= --ss
->dimen
;
8286 for (i
= dim
; i
< ss_dim
; i
++)
8287 ss
->dim
[i
] = ss
->dim
[i
+ 1];
8289 ss
->dim
[ss_dim
] = 0;
8295 ss
->nested_ss
->parent
= new_ss
;
8296 new_ss
->nested_ss
= ss
->nested_ss
;
8298 ss
->nested_ss
= new_ss
;
8301 new_loop
= gfc_get_loopinfo ();
8302 gfc_init_loopinfo (new_loop
);
8304 gcc_assert (prev_ss
!= NULL
);
8305 gcc_assert (prev_ss
!= gfc_ss_terminator
);
8306 gfc_add_ss_to_loop (new_loop
, prev_ss
);
8307 return new_ss
->parent
;
8311 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
8312 is to be inlined. */
8315 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
8317 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
8318 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
8320 bool scalar_mask
= false;
8322 /* The rank of the result will be determined later. */
8323 arg1
= expr
->value
.function
.actual
;
8326 gcc_assert (arg3
!= NULL
);
8328 if (expr
->rank
== 0)
8331 tmp_ss
= gfc_ss_terminator
;
8337 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
8338 if (mask_ss
== tmp_ss
)
8344 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
8345 gcc_assert (array_ss
!= tmp_ss
);
8347 /* Odd thing: If the mask is scalar, it is used by the frontend after
8348 the array (to make an if around the nested loop). Thus it shall
8349 be after array_ss once the gfc_ss list is reversed. */
8351 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
8355 /* "Hide" the dimension on which we will sum in the first arg's scalarization
8357 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
8358 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
8366 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
8369 switch (expr
->value
.function
.isym
->id
)
8371 case GFC_ISYM_PRODUCT
:
8373 return walk_inline_intrinsic_arith (ss
, expr
);
8375 case GFC_ISYM_TRANSPOSE
:
8376 return walk_inline_intrinsic_transpose (ss
, expr
);
8385 /* This generates code to execute before entering the scalarization loop.
8386 Currently does nothing. */
8389 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
8391 switch (ss
->info
->expr
->value
.function
.isym
->id
)
8393 case GFC_ISYM_UBOUND
:
8394 case GFC_ISYM_LBOUND
:
8395 case GFC_ISYM_UCOBOUND
:
8396 case GFC_ISYM_LCOBOUND
:
8397 case GFC_ISYM_THIS_IMAGE
:
8406 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
8407 are expanded into code inside the scalarization loop. */
8410 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
8412 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
8413 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
8415 /* The two argument version returns a scalar. */
8416 if (expr
->value
.function
.actual
->next
->expr
)
8419 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
8423 /* Walk an intrinsic array libcall. */
8426 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
8428 gcc_assert (expr
->rank
> 0);
8429 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
8433 /* Return whether the function call expression EXPR will be expanded
8434 inline by gfc_conv_intrinsic_function. */
8437 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
8439 gfc_actual_arglist
*args
;
8441 if (!expr
->value
.function
.isym
)
8444 switch (expr
->value
.function
.isym
->id
)
8446 case GFC_ISYM_PRODUCT
:
8448 /* Disable inline expansion if code size matters. */
8452 args
= expr
->value
.function
.actual
;
8453 /* We need to be able to subset the SUM argument at compile-time. */
8454 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
8459 case GFC_ISYM_TRANSPOSE
:
8468 /* Returns nonzero if the specified intrinsic function call maps directly to
8469 an external library call. Should only be used for functions that return
8473 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
8475 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
8476 gcc_assert (expr
->rank
> 0);
8478 if (gfc_inline_intrinsic_function_p (expr
))
8481 switch (expr
->value
.function
.isym
->id
)
8485 case GFC_ISYM_COUNT
:
8489 case GFC_ISYM_IPARITY
:
8490 case GFC_ISYM_MATMUL
:
8491 case GFC_ISYM_MAXLOC
:
8492 case GFC_ISYM_MAXVAL
:
8493 case GFC_ISYM_MINLOC
:
8494 case GFC_ISYM_MINVAL
:
8495 case GFC_ISYM_NORM2
:
8496 case GFC_ISYM_PARITY
:
8497 case GFC_ISYM_PRODUCT
:
8499 case GFC_ISYM_SHAPE
:
8500 case GFC_ISYM_SPREAD
:
8502 /* Ignore absent optional parameters. */
8505 case GFC_ISYM_RESHAPE
:
8506 case GFC_ISYM_CSHIFT
:
8507 case GFC_ISYM_EOSHIFT
:
8509 case GFC_ISYM_UNPACK
:
8510 /* Pass absent optional parameters. */
8518 /* Walk an intrinsic function. */
8520 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
8521 gfc_intrinsic_sym
* isym
)
8525 if (isym
->elemental
)
8526 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
8527 NULL
, GFC_SS_SCALAR
);
8529 if (expr
->rank
== 0)
8532 if (gfc_inline_intrinsic_function_p (expr
))
8533 return walk_inline_intrinsic_function (ss
, expr
);
8535 if (gfc_is_intrinsic_libcall (expr
))
8536 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8538 /* Special cases. */
8541 case GFC_ISYM_LBOUND
:
8542 case GFC_ISYM_LCOBOUND
:
8543 case GFC_ISYM_UBOUND
:
8544 case GFC_ISYM_UCOBOUND
:
8545 case GFC_ISYM_THIS_IMAGE
:
8546 return gfc_walk_intrinsic_bound (ss
, expr
);
8548 case GFC_ISYM_TRANSFER
:
8549 case GFC_ISYM_CAF_GET
:
8550 return gfc_walk_intrinsic_libfunc (ss
, expr
);
8553 /* This probably meant someone forgot to add an intrinsic to the above
8554 list(s) when they implemented it, or something's gone horribly
8562 conv_co_collective (gfc_code
*code
)
8565 stmtblock_t block
, post_block
;
8566 tree fndecl
, array
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
8567 gfc_expr
*image_idx_expr
, *stat_expr
, *errmsg_expr
, *opr_expr
;
8569 gfc_start_block (&block
);
8570 gfc_init_block (&post_block
);
8572 if (code
->resolved_isym
->id
== GFC_ISYM_CO_REDUCE
)
8574 opr_expr
= code
->ext
.actual
->next
->expr
;
8575 image_idx_expr
= code
->ext
.actual
->next
->next
->expr
;
8576 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8577 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->next
->expr
;
8582 image_idx_expr
= code
->ext
.actual
->next
->expr
;
8583 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8584 errmsg_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8590 gfc_init_se (&argse
, NULL
);
8591 gfc_conv_expr (&argse
, stat_expr
);
8592 gfc_add_block_to_block (&block
, &argse
.pre
);
8593 gfc_add_block_to_block (&post_block
, &argse
.post
);
8595 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
8596 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
8598 else if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
8601 stat
= null_pointer_node
;
8603 /* Early exit for GFC_FCOARRAY_SINGLE. */
8604 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
8606 if (stat
!= NULL_TREE
)
8607 gfc_add_modify (&block
, stat
,
8608 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
8609 return gfc_finish_block (&block
);
8612 /* Handle the array. */
8613 gfc_init_se (&argse
, NULL
);
8614 if (code
->ext
.actual
->expr
->rank
== 0)
8616 symbol_attribute attr
;
8617 gfc_clear_attr (&attr
);
8618 gfc_init_se (&argse
, NULL
);
8619 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8620 gfc_add_block_to_block (&block
, &argse
.pre
);
8621 gfc_add_block_to_block (&post_block
, &argse
.post
);
8622 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
8623 array
= gfc_build_addr_expr (NULL_TREE
, array
);
8627 argse
.want_pointer
= 1;
8628 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
8631 gfc_add_block_to_block (&block
, &argse
.pre
);
8632 gfc_add_block_to_block (&post_block
, &argse
.post
);
8634 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
8635 strlen
= argse
.string_length
;
8637 strlen
= integer_zero_node
;
8642 gfc_init_se (&argse
, NULL
);
8643 gfc_conv_expr (&argse
, image_idx_expr
);
8644 gfc_add_block_to_block (&block
, &argse
.pre
);
8645 gfc_add_block_to_block (&post_block
, &argse
.post
);
8646 image_index
= fold_convert (integer_type_node
, argse
.expr
);
8649 image_index
= integer_zero_node
;
8654 gfc_init_se (&argse
, NULL
);
8655 gfc_conv_expr (&argse
, errmsg_expr
);
8656 gfc_add_block_to_block (&block
, &argse
.pre
);
8657 gfc_add_block_to_block (&post_block
, &argse
.post
);
8658 errmsg
= argse
.expr
;
8659 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
8663 errmsg
= null_pointer_node
;
8664 errmsg_len
= integer_zero_node
;
8667 /* Generate the function call. */
8668 switch (code
->resolved_isym
->id
)
8670 case GFC_ISYM_CO_BROADCAST
:
8671 fndecl
= gfor_fndecl_co_broadcast
;
8673 case GFC_ISYM_CO_MAX
:
8674 fndecl
= gfor_fndecl_co_max
;
8676 case GFC_ISYM_CO_MIN
:
8677 fndecl
= gfor_fndecl_co_min
;
8679 case GFC_ISYM_CO_REDUCE
:
8680 fndecl
= gfor_fndecl_co_reduce
;
8682 case GFC_ISYM_CO_SUM
:
8683 fndecl
= gfor_fndecl_co_sum
;
8689 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
8690 || code
->resolved_isym
->id
== GFC_ISYM_CO_BROADCAST
)
8691 fndecl
= build_call_expr_loc (input_location
, fndecl
, 5, array
,
8692 image_index
, stat
, errmsg
, errmsg_len
);
8693 else if (code
->resolved_isym
->id
!= GFC_ISYM_CO_REDUCE
)
8694 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, image_index
,
8695 stat
, errmsg
, strlen
, errmsg_len
);
8698 tree opr
, opr_flags
;
8700 // FIXME: Handle TS29113's bind(C) strings with descriptor.
8702 if (gfc_is_proc_ptr_comp (opr_expr
))
8704 gfc_symbol
*sym
= gfc_get_proc_ptr_comp (opr_expr
)->ts
.interface
;
8705 opr_flag_int
= sym
->attr
.dimension
8706 || (sym
->ts
.type
== BT_CHARACTER
8707 && !sym
->attr
.is_bind_c
)
8708 ? GFC_CAF_BYREF
: 0;
8709 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8710 && !sym
->attr
.is_bind_c
8711 ? GFC_CAF_HIDDENLEN
: 0;
8712 opr_flag_int
|= sym
->formal
->sym
->attr
.value
? GFC_CAF_ARG_VALUE
: 0;
8716 opr_flag_int
= gfc_return_by_reference (opr_expr
->symtree
->n
.sym
)
8717 ? GFC_CAF_BYREF
: 0;
8718 opr_flag_int
|= opr_expr
->ts
.type
== BT_CHARACTER
8719 && !opr_expr
->symtree
->n
.sym
->attr
.is_bind_c
8720 ? GFC_CAF_HIDDENLEN
: 0;
8721 opr_flag_int
|= opr_expr
->symtree
->n
.sym
->formal
->sym
->attr
.value
8722 ? GFC_CAF_ARG_VALUE
: 0;
8724 opr_flags
= build_int_cst (integer_type_node
, opr_flag_int
);
8725 gfc_conv_expr (&argse
, opr_expr
);
8726 opr
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
8727 fndecl
= build_call_expr_loc (input_location
, fndecl
, 8, array
, opr
, opr_flags
,
8728 image_index
, stat
, errmsg
, strlen
, errmsg_len
);
8731 gfc_add_expr_to_block (&block
, fndecl
);
8732 gfc_add_block_to_block (&block
, &post_block
);
8734 return gfc_finish_block (&block
);
8739 conv_intrinsic_atomic_op (gfc_code
*code
)
8742 tree tmp
, atom
, value
, old
= NULL_TREE
, stat
= NULL_TREE
;
8743 stmtblock_t block
, post_block
;
8744 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
8745 gfc_expr
*stat_expr
;
8746 built_in_function fn
;
8748 if (atom_expr
->expr_type
== EXPR_FUNCTION
8749 && atom_expr
->value
.function
.isym
8750 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8751 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8753 gfc_start_block (&block
);
8754 gfc_init_block (&post_block
);
8756 gfc_init_se (&argse
, NULL
);
8757 argse
.want_pointer
= 1;
8758 gfc_conv_expr (&argse
, atom_expr
);
8759 gfc_add_block_to_block (&block
, &argse
.pre
);
8760 gfc_add_block_to_block (&post_block
, &argse
.post
);
8763 gfc_init_se (&argse
, NULL
);
8764 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
8765 && code
->ext
.actual
->next
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8766 argse
.want_pointer
= 1;
8767 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
8768 gfc_add_block_to_block (&block
, &argse
.pre
);
8769 gfc_add_block_to_block (&post_block
, &argse
.post
);
8772 switch (code
->resolved_isym
->id
)
8774 case GFC_ISYM_ATOMIC_ADD
:
8775 case GFC_ISYM_ATOMIC_AND
:
8776 case GFC_ISYM_ATOMIC_DEF
:
8777 case GFC_ISYM_ATOMIC_OR
:
8778 case GFC_ISYM_ATOMIC_XOR
:
8779 stat_expr
= code
->ext
.actual
->next
->next
->expr
;
8780 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8781 old
= null_pointer_node
;
8784 gfc_init_se (&argse
, NULL
);
8785 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8786 argse
.want_pointer
= 1;
8787 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
8788 gfc_add_block_to_block (&block
, &argse
.pre
);
8789 gfc_add_block_to_block (&post_block
, &argse
.post
);
8791 stat_expr
= code
->ext
.actual
->next
->next
->next
->expr
;
8795 if (stat_expr
!= NULL
)
8797 gcc_assert (stat_expr
->expr_type
== EXPR_VARIABLE
);
8798 gfc_init_se (&argse
, NULL
);
8799 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8800 argse
.want_pointer
= 1;
8801 gfc_conv_expr_val (&argse
, stat_expr
);
8802 gfc_add_block_to_block (&block
, &argse
.pre
);
8803 gfc_add_block_to_block (&post_block
, &argse
.post
);
8806 else if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8807 stat
= null_pointer_node
;
8809 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8811 tree image_index
, caf_decl
, offset
, token
;
8814 switch (code
->resolved_isym
->id
)
8816 case GFC_ISYM_ATOMIC_ADD
:
8817 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8818 op
= (int) GFC_CAF_ATOMIC_ADD
;
8820 case GFC_ISYM_ATOMIC_AND
:
8821 case GFC_ISYM_ATOMIC_FETCH_AND
:
8822 op
= (int) GFC_CAF_ATOMIC_AND
;
8824 case GFC_ISYM_ATOMIC_OR
:
8825 case GFC_ISYM_ATOMIC_FETCH_OR
:
8826 op
= (int) GFC_CAF_ATOMIC_OR
;
8828 case GFC_ISYM_ATOMIC_XOR
:
8829 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8830 op
= (int) GFC_CAF_ATOMIC_XOR
;
8832 case GFC_ISYM_ATOMIC_DEF
:
8833 op
= 0; /* Unused. */
8839 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
8840 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8841 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8843 if (gfc_is_coindexed (atom_expr
))
8844 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
8846 image_index
= integer_zero_node
;
8848 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
8850 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
8851 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), value
));
8852 value
= gfc_build_addr_expr (NULL_TREE
, tmp
);
8855 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
8857 if (code
->resolved_isym
->id
== GFC_ISYM_ATOMIC_DEF
)
8858 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_def
, 7,
8859 token
, offset
, image_index
, value
, stat
,
8860 build_int_cst (integer_type_node
,
8861 (int) atom_expr
->ts
.type
),
8862 build_int_cst (integer_type_node
,
8863 (int) atom_expr
->ts
.kind
));
8865 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_op
, 9,
8866 build_int_cst (integer_type_node
, op
),
8867 token
, offset
, image_index
, value
, old
, stat
,
8868 build_int_cst (integer_type_node
,
8869 (int) atom_expr
->ts
.type
),
8870 build_int_cst (integer_type_node
,
8871 (int) atom_expr
->ts
.kind
));
8873 gfc_add_expr_to_block (&block
, tmp
);
8874 gfc_add_block_to_block (&block
, &post_block
);
8875 return gfc_finish_block (&block
);
8879 switch (code
->resolved_isym
->id
)
8881 case GFC_ISYM_ATOMIC_ADD
:
8882 case GFC_ISYM_ATOMIC_FETCH_ADD
:
8883 fn
= BUILT_IN_ATOMIC_FETCH_ADD_N
;
8885 case GFC_ISYM_ATOMIC_AND
:
8886 case GFC_ISYM_ATOMIC_FETCH_AND
:
8887 fn
= BUILT_IN_ATOMIC_FETCH_AND_N
;
8889 case GFC_ISYM_ATOMIC_DEF
:
8890 fn
= BUILT_IN_ATOMIC_STORE_N
;
8892 case GFC_ISYM_ATOMIC_OR
:
8893 case GFC_ISYM_ATOMIC_FETCH_OR
:
8894 fn
= BUILT_IN_ATOMIC_FETCH_OR_N
;
8896 case GFC_ISYM_ATOMIC_XOR
:
8897 case GFC_ISYM_ATOMIC_FETCH_XOR
:
8898 fn
= BUILT_IN_ATOMIC_FETCH_XOR_N
;
8904 tmp
= TREE_TYPE (TREE_TYPE (atom
));
8905 fn
= (built_in_function
) ((int) fn
8906 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
8908 tmp
= builtin_decl_explicit (fn
);
8909 tree itype
= TREE_TYPE (TREE_TYPE (atom
));
8910 tmp
= builtin_decl_explicit (fn
);
8912 switch (code
->resolved_isym
->id
)
8914 case GFC_ISYM_ATOMIC_ADD
:
8915 case GFC_ISYM_ATOMIC_AND
:
8916 case GFC_ISYM_ATOMIC_DEF
:
8917 case GFC_ISYM_ATOMIC_OR
:
8918 case GFC_ISYM_ATOMIC_XOR
:
8919 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
8920 fold_convert (itype
, value
),
8921 build_int_cst (NULL
, MEMMODEL_RELAXED
));
8922 gfc_add_expr_to_block (&block
, tmp
);
8925 tmp
= build_call_expr_loc (input_location
, tmp
, 3, atom
,
8926 fold_convert (itype
, value
),
8927 build_int_cst (NULL
, MEMMODEL_RELAXED
));
8928 gfc_add_modify (&block
, old
, fold_convert (TREE_TYPE (old
), tmp
));
8932 if (stat
!= NULL_TREE
)
8933 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
8934 gfc_add_block_to_block (&block
, &post_block
);
8935 return gfc_finish_block (&block
);
8940 conv_intrinsic_atomic_ref (gfc_code
*code
)
8943 tree tmp
, atom
, value
, stat
= NULL_TREE
;
8944 stmtblock_t block
, post_block
;
8945 built_in_function fn
;
8946 gfc_expr
*atom_expr
= code
->ext
.actual
->next
->expr
;
8948 if (atom_expr
->expr_type
== EXPR_FUNCTION
8949 && atom_expr
->value
.function
.isym
8950 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8951 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
8953 gfc_start_block (&block
);
8954 gfc_init_block (&post_block
);
8955 gfc_init_se (&argse
, NULL
);
8956 argse
.want_pointer
= 1;
8957 gfc_conv_expr (&argse
, atom_expr
);
8958 gfc_add_block_to_block (&block
, &argse
.pre
);
8959 gfc_add_block_to_block (&post_block
, &argse
.post
);
8962 gfc_init_se (&argse
, NULL
);
8963 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
8964 && code
->ext
.actual
->expr
->ts
.kind
== atom_expr
->ts
.kind
)
8965 argse
.want_pointer
= 1;
8966 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
8967 gfc_add_block_to_block (&block
, &argse
.pre
);
8968 gfc_add_block_to_block (&post_block
, &argse
.post
);
8972 if (code
->ext
.actual
->next
->next
->expr
!= NULL
)
8974 gcc_assert (code
->ext
.actual
->next
->next
->expr
->expr_type
8976 gfc_init_se (&argse
, NULL
);
8977 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8978 argse
.want_pointer
= 1;
8979 gfc_conv_expr_val (&argse
, code
->ext
.actual
->next
->next
->expr
);
8980 gfc_add_block_to_block (&block
, &argse
.pre
);
8981 gfc_add_block_to_block (&post_block
, &argse
.post
);
8984 else if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8985 stat
= null_pointer_node
;
8987 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8989 tree image_index
, caf_decl
, offset
, token
;
8990 tree orig_value
= NULL_TREE
, vardecl
= NULL_TREE
;
8992 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
8993 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
8994 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
8996 if (gfc_is_coindexed (atom_expr
))
8997 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
8999 image_index
= integer_zero_node
;
9001 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9003 /* Different type, need type conversion. */
9004 if (!POINTER_TYPE_P (TREE_TYPE (value
)))
9006 vardecl
= gfc_create_var (TREE_TYPE (TREE_TYPE (atom
)), "value");
9008 value
= gfc_build_addr_expr (NULL_TREE
, vardecl
);
9011 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_ref
, 7,
9012 token
, offset
, image_index
, value
, stat
,
9013 build_int_cst (integer_type_node
,
9014 (int) atom_expr
->ts
.type
),
9015 build_int_cst (integer_type_node
,
9016 (int) atom_expr
->ts
.kind
));
9017 gfc_add_expr_to_block (&block
, tmp
);
9018 if (vardecl
!= NULL_TREE
)
9019 gfc_add_modify (&block
, orig_value
,
9020 fold_convert (TREE_TYPE (orig_value
), vardecl
));
9021 gfc_add_block_to_block (&block
, &post_block
);
9022 return gfc_finish_block (&block
);
9025 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9026 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_LOAD_N
9027 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9029 tmp
= builtin_decl_explicit (fn
);
9030 tmp
= build_call_expr_loc (input_location
, tmp
, 2, atom
,
9031 build_int_cst (integer_type_node
,
9033 gfc_add_modify (&block
, value
, fold_convert (TREE_TYPE (value
), tmp
));
9035 if (stat
!= NULL_TREE
)
9036 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9037 gfc_add_block_to_block (&block
, &post_block
);
9038 return gfc_finish_block (&block
);
9043 conv_intrinsic_atomic_cas (gfc_code
*code
)
9046 tree tmp
, atom
, old
, new_val
, comp
, stat
= NULL_TREE
;
9047 stmtblock_t block
, post_block
;
9048 built_in_function fn
;
9049 gfc_expr
*atom_expr
= code
->ext
.actual
->expr
;
9051 if (atom_expr
->expr_type
== EXPR_FUNCTION
9052 && atom_expr
->value
.function
.isym
9053 && atom_expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9054 atom_expr
= atom_expr
->value
.function
.actual
->expr
;
9056 gfc_init_block (&block
);
9057 gfc_init_block (&post_block
);
9058 gfc_init_se (&argse
, NULL
);
9059 argse
.want_pointer
= 1;
9060 gfc_conv_expr (&argse
, atom_expr
);
9063 gfc_init_se (&argse
, NULL
);
9064 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
9065 argse
.want_pointer
= 1;
9066 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
9067 gfc_add_block_to_block (&block
, &argse
.pre
);
9068 gfc_add_block_to_block (&post_block
, &argse
.post
);
9071 gfc_init_se (&argse
, NULL
);
9072 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
9073 argse
.want_pointer
= 1;
9074 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
9075 gfc_add_block_to_block (&block
, &argse
.pre
);
9076 gfc_add_block_to_block (&post_block
, &argse
.post
);
9079 gfc_init_se (&argse
, NULL
);
9080 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
9081 && code
->ext
.actual
->next
->next
->next
->expr
->ts
.kind
9082 == atom_expr
->ts
.kind
)
9083 argse
.want_pointer
= 1;
9084 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
9085 gfc_add_block_to_block (&block
, &argse
.pre
);
9086 gfc_add_block_to_block (&post_block
, &argse
.post
);
9087 new_val
= argse
.expr
;
9090 if (code
->ext
.actual
->next
->next
->next
->next
->expr
!= NULL
)
9092 gcc_assert (code
->ext
.actual
->next
->next
->next
->next
->expr
->expr_type
9094 gfc_init_se (&argse
, NULL
);
9095 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
9096 argse
.want_pointer
= 1;
9097 gfc_conv_expr_val (&argse
,
9098 code
->ext
.actual
->next
->next
->next
->next
->expr
);
9099 gfc_add_block_to_block (&block
, &argse
.pre
);
9100 gfc_add_block_to_block (&post_block
, &argse
.post
);
9103 else if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
9104 stat
= null_pointer_node
;
9106 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
9108 tree image_index
, caf_decl
, offset
, token
;
9110 caf_decl
= gfc_get_tree_for_caf_expr (atom_expr
);
9111 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
9112 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
9114 if (gfc_is_coindexed (atom_expr
))
9115 image_index
= gfc_caf_get_image_index (&block
, atom_expr
, caf_decl
);
9117 image_index
= integer_zero_node
;
9119 if (TREE_TYPE (TREE_TYPE (new_val
)) != TREE_TYPE (TREE_TYPE (old
)))
9121 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "new");
9122 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), new_val
));
9123 new_val
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9126 /* Convert a constant to a pointer. */
9127 if (!POINTER_TYPE_P (TREE_TYPE (comp
)))
9129 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (old
)), "comp");
9130 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), comp
));
9131 comp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9134 gfc_get_caf_token_offset (&token
, &offset
, caf_decl
, atom
, atom_expr
);
9136 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_atomic_cas
, 9,
9137 token
, offset
, image_index
, old
, comp
, new_val
,
9138 stat
, build_int_cst (integer_type_node
,
9139 (int) atom_expr
->ts
.type
),
9140 build_int_cst (integer_type_node
,
9141 (int) atom_expr
->ts
.kind
));
9142 gfc_add_expr_to_block (&block
, tmp
);
9143 gfc_add_block_to_block (&block
, &post_block
);
9144 return gfc_finish_block (&block
);
9147 tmp
= TREE_TYPE (TREE_TYPE (atom
));
9148 fn
= (built_in_function
) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
9149 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp
)))
9151 tmp
= builtin_decl_explicit (fn
);
9153 gfc_add_modify (&block
, old
, comp
);
9154 tmp
= build_call_expr_loc (input_location
, tmp
, 6, atom
,
9155 gfc_build_addr_expr (NULL
, old
),
9156 fold_convert (TREE_TYPE (old
), new_val
),
9158 build_int_cst (NULL
, MEMMODEL_RELAXED
),
9159 build_int_cst (NULL
, MEMMODEL_RELAXED
));
9160 gfc_add_expr_to_block (&block
, tmp
);
9162 if (stat
!= NULL_TREE
)
9163 gfc_add_modify (&block
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
9164 gfc_add_block_to_block (&block
, &post_block
);
9165 return gfc_finish_block (&block
);
9170 conv_intrinsic_move_alloc (gfc_code
*code
)
9173 gfc_expr
*from_expr
, *to_expr
;
9174 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
9175 gfc_se from_se
, to_se
;
9179 gfc_start_block (&block
);
9181 from_expr
= code
->ext
.actual
->expr
;
9182 to_expr
= code
->ext
.actual
->next
->expr
;
9184 gfc_init_se (&from_se
, NULL
);
9185 gfc_init_se (&to_se
, NULL
);
9187 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
9188 || to_expr
->ts
.type
== BT_CLASS
);
9189 coarray
= gfc_get_corank (from_expr
) != 0;
9191 if (from_expr
->rank
== 0 && !coarray
)
9193 if (from_expr
->ts
.type
!= BT_CLASS
)
9194 from_expr2
= from_expr
;
9197 from_expr2
= gfc_copy_expr (from_expr
);
9198 gfc_add_data_component (from_expr2
);
9201 if (to_expr
->ts
.type
!= BT_CLASS
)
9205 to_expr2
= gfc_copy_expr (to_expr
);
9206 gfc_add_data_component (to_expr2
);
9209 from_se
.want_pointer
= 1;
9210 to_se
.want_pointer
= 1;
9211 gfc_conv_expr (&from_se
, from_expr2
);
9212 gfc_conv_expr (&to_se
, to_expr2
);
9213 gfc_add_block_to_block (&block
, &from_se
.pre
);
9214 gfc_add_block_to_block (&block
, &to_se
.pre
);
9216 /* Deallocate "to". */
9217 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
9218 to_expr
, to_expr
->ts
);
9219 gfc_add_expr_to_block (&block
, tmp
);
9221 /* Assign (_data) pointers. */
9222 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9223 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
9225 /* Set "from" to NULL. */
9226 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9227 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
9229 gfc_add_block_to_block (&block
, &from_se
.post
);
9230 gfc_add_block_to_block (&block
, &to_se
.post
);
9233 if (to_expr
->ts
.type
== BT_CLASS
)
9237 gfc_free_expr (to_expr2
);
9238 gfc_init_se (&to_se
, NULL
);
9239 to_se
.want_pointer
= 1;
9240 gfc_add_vptr_component (to_expr
);
9241 gfc_conv_expr (&to_se
, to_expr
);
9243 if (from_expr
->ts
.type
== BT_CLASS
)
9245 if (UNLIMITED_POLY (from_expr
))
9249 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9253 gfc_free_expr (from_expr2
);
9254 gfc_init_se (&from_se
, NULL
);
9255 from_se
.want_pointer
= 1;
9256 gfc_add_vptr_component (from_expr
);
9257 gfc_conv_expr (&from_se
, from_expr
);
9258 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9259 fold_convert (TREE_TYPE (to_se
.expr
),
9262 /* Reset _vptr component to declared type. */
9264 /* Unlimited polymorphic. */
9265 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9266 fold_convert (TREE_TYPE (from_se
.expr
),
9267 null_pointer_node
));
9270 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9271 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9272 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9277 vtab
= gfc_find_vtab (&from_expr
->ts
);
9279 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9280 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9281 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9285 return gfc_finish_block (&block
);
9288 /* Update _vptr component. */
9289 if (to_expr
->ts
.type
== BT_CLASS
)
9293 to_se
.want_pointer
= 1;
9294 to_expr2
= gfc_copy_expr (to_expr
);
9295 gfc_add_vptr_component (to_expr2
);
9296 gfc_conv_expr (&to_se
, to_expr2
);
9298 if (from_expr
->ts
.type
== BT_CLASS
)
9300 if (UNLIMITED_POLY (from_expr
))
9304 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
9308 from_se
.want_pointer
= 1;
9309 from_expr2
= gfc_copy_expr (from_expr
);
9310 gfc_add_vptr_component (from_expr2
);
9311 gfc_conv_expr (&from_se
, from_expr2
);
9312 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9313 fold_convert (TREE_TYPE (to_se
.expr
),
9316 /* Reset _vptr component to declared type. */
9318 /* Unlimited polymorphic. */
9319 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9320 fold_convert (TREE_TYPE (from_se
.expr
),
9321 null_pointer_node
));
9324 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9325 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
9326 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
9331 vtab
= gfc_find_vtab (&from_expr
->ts
);
9333 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
9334 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
9335 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
9338 gfc_free_expr (to_expr2
);
9339 gfc_init_se (&to_se
, NULL
);
9341 if (from_expr
->ts
.type
== BT_CLASS
)
9343 gfc_free_expr (from_expr2
);
9344 gfc_init_se (&from_se
, NULL
);
9349 /* Deallocate "to". */
9350 if (from_expr
->rank
== 0)
9352 to_se
.want_coarray
= 1;
9353 from_se
.want_coarray
= 1;
9355 gfc_conv_expr_descriptor (&to_se
, to_expr
);
9356 gfc_conv_expr_descriptor (&from_se
, from_expr
);
9358 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
9359 is an image control "statement", cf. IR F08/0040 in 12-006A. */
9360 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
9364 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
9365 NULL_TREE
, NULL_TREE
, true, to_expr
,
9367 gfc_add_expr_to_block (&block
, tmp
);
9369 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9370 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9371 boolean_type_node
, tmp
,
9372 fold_convert (TREE_TYPE (tmp
),
9373 null_pointer_node
));
9374 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
9375 3, null_pointer_node
, null_pointer_node
,
9376 build_int_cst (integer_type_node
, 0));
9378 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
9379 tmp
, build_empty_stmt (input_location
));
9380 gfc_add_expr_to_block (&block
, tmp
);
9384 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
9385 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
9386 NULL_TREE
, true, to_expr
, false);
9387 gfc_add_expr_to_block (&block
, tmp
);
9390 /* Move the pointer and update the array descriptor data. */
9391 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
9393 /* Set "from" to NULL. */
9394 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
9395 gfc_add_modify_loc (input_location
, &block
, tmp
,
9396 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
9398 return gfc_finish_block (&block
);
9403 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
9407 gcc_assert (code
->resolved_isym
);
9409 switch (code
->resolved_isym
->id
)
9411 case GFC_ISYM_MOVE_ALLOC
:
9412 res
= conv_intrinsic_move_alloc (code
);
9415 case GFC_ISYM_ATOMIC_CAS
:
9416 res
= conv_intrinsic_atomic_cas (code
);
9419 case GFC_ISYM_ATOMIC_ADD
:
9420 case GFC_ISYM_ATOMIC_AND
:
9421 case GFC_ISYM_ATOMIC_DEF
:
9422 case GFC_ISYM_ATOMIC_OR
:
9423 case GFC_ISYM_ATOMIC_XOR
:
9424 case GFC_ISYM_ATOMIC_FETCH_ADD
:
9425 case GFC_ISYM_ATOMIC_FETCH_AND
:
9426 case GFC_ISYM_ATOMIC_FETCH_OR
:
9427 case GFC_ISYM_ATOMIC_FETCH_XOR
:
9428 res
= conv_intrinsic_atomic_op (code
);
9431 case GFC_ISYM_ATOMIC_REF
:
9432 res
= conv_intrinsic_atomic_ref (code
);
9435 case GFC_ISYM_C_F_POINTER
:
9436 case GFC_ISYM_C_F_PROCPOINTER
:
9437 res
= conv_isocbinding_subroutine (code
);
9440 case GFC_ISYM_CAF_SEND
:
9441 res
= conv_caf_send (code
);
9444 case GFC_ISYM_CO_BROADCAST
:
9445 case GFC_ISYM_CO_MIN
:
9446 case GFC_ISYM_CO_MAX
:
9447 case GFC_ISYM_CO_REDUCE
:
9448 case GFC_ISYM_CO_SUM
:
9449 res
= conv_co_collective (code
);
9452 case GFC_ISYM_SYSTEM_CLOCK
:
9453 res
= conv_intrinsic_system_clock (code
);
9464 #include "gt-fortran-trans-intrinsic.h"