1 /* Intrinsic translation
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
27 #include "tm.h" /* For UNITS_PER_WORD. */
29 #include "stringpool.h"
30 #include "tree-nested.h"
31 #include "stor-layout.h"
33 #include "diagnostic-core.h" /* For internal_error. */
34 #include "toplev.h" /* For rest_of_decl_compilation. */
38 #include "intrinsic.h"
40 #include "trans-const.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
45 #include "tree-nested.h"
48 /* This maps Fortran intrinsic math functions to external library or GCC
50 typedef struct GTY(()) gfc_intrinsic_map_t
{
51 /* The explicit enum is required to work around inadequacies in the
52 garbage collection/gengtype parsing mechanism. */
55 /* Enum value from the "language-independent", aka C-centric, part
56 of gcc, or END_BUILTINS of no such value set. */
57 enum built_in_function float_built_in
;
58 enum built_in_function double_built_in
;
59 enum built_in_function long_double_built_in
;
60 enum built_in_function complex_float_built_in
;
61 enum built_in_function complex_double_built_in
;
62 enum built_in_function complex_long_double_built_in
;
64 /* True if the naming pattern is to prepend "c" for complex and
65 append "f" for kind=4. False if the naming pattern is to
66 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
69 /* True if a complex version of the function exists. */
70 bool complex_available
;
72 /* True if the function should be marked const. */
75 /* The base library name of this function. */
78 /* Cache decls created for the various operand types. */
90 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
91 defines complex variants of all of the entries in mathbuiltins.def
93 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
94 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
95 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
96 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
97 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
100 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
101 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
102 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
103 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
105 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
106 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
109 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
111 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
112 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
113 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
114 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
115 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
117 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
119 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
120 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
121 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
122 #include "mathbuiltins.def"
124 /* Functions in libgfortran. */
125 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
128 LIB_FUNCTION (NONE
, NULL
, false)
133 #undef DEFINE_MATH_BUILTIN
134 #undef DEFINE_MATH_BUILTIN_C
137 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
140 /* Find the correct variant of a given builtin from its argument. */
142 builtin_decl_for_precision (enum built_in_function base_built_in
,
145 enum built_in_function i
= END_BUILTINS
;
147 gfc_intrinsic_map_t
*m
;
148 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
151 if (precision
== TYPE_PRECISION (float_type_node
))
152 i
= m
->float_built_in
;
153 else if (precision
== TYPE_PRECISION (double_type_node
))
154 i
= m
->double_built_in
;
155 else if (precision
== TYPE_PRECISION (long_double_type_node
))
156 i
= m
->long_double_built_in
;
157 else if (precision
== TYPE_PRECISION (float128_type_node
))
159 /* Special treatment, because it is not exactly a built-in, but
160 a library function. */
161 return m
->real16_decl
;
164 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
169 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
172 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
174 if (gfc_real_kinds
[i
].c_float128
)
176 /* For __float128, the story is a bit different, because we return
177 a decl to a library function rather than a built-in. */
178 gfc_intrinsic_map_t
*m
;
179 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
182 return m
->real16_decl
;
185 return builtin_decl_for_precision (double_built_in
,
186 gfc_real_kinds
[i
].mode_precision
);
190 /* Evaluate the arguments to an intrinsic function. The value
191 of NARGS may be less than the actual number of arguments in EXPR
192 to allow optional "KIND" arguments that are not included in the
193 generated code to be ignored. */
196 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
197 tree
*argarray
, int nargs
)
199 gfc_actual_arglist
*actual
;
201 gfc_intrinsic_arg
*formal
;
205 formal
= expr
->value
.function
.isym
->formal
;
206 actual
= expr
->value
.function
.actual
;
208 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
209 actual
= actual
->next
,
210 formal
= formal
? formal
->next
: NULL
)
214 /* Skip omitted optional arguments. */
221 /* Evaluate the parameter. This will substitute scalarized
222 references automatically. */
223 gfc_init_se (&argse
, se
);
225 if (e
->ts
.type
== BT_CHARACTER
)
227 gfc_conv_expr (&argse
, e
);
228 gfc_conv_string_parameter (&argse
);
229 argarray
[curr_arg
++] = argse
.string_length
;
230 gcc_assert (curr_arg
< nargs
);
233 gfc_conv_expr_val (&argse
, e
);
235 /* If an optional argument is itself an optional dummy argument,
236 check its presence and substitute a null if absent. */
237 if (e
->expr_type
== EXPR_VARIABLE
238 && e
->symtree
->n
.sym
->attr
.optional
241 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
243 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
244 gfc_add_block_to_block (&se
->post
, &argse
.post
);
245 argarray
[curr_arg
] = argse
.expr
;
249 /* Count the number of actual arguments to the intrinsic function EXPR
250 including any "hidden" string length arguments. */
253 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
256 gfc_actual_arglist
*actual
;
258 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
263 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
273 /* Conversions between different types are output by the frontend as
274 intrinsic functions. We implement these directly with inline code. */
277 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
283 nargs
= gfc_intrinsic_argument_list_length (expr
);
284 args
= XALLOCAVEC (tree
, nargs
);
286 /* Evaluate all the arguments passed. Whilst we're only interested in the
287 first one here, there are other parts of the front-end that assume this
288 and will trigger an ICE if it's not the case. */
289 type
= gfc_typenode_for_spec (&expr
->ts
);
290 gcc_assert (expr
->value
.function
.actual
->expr
);
291 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
293 /* Conversion between character kinds involves a call to a library
295 if (expr
->ts
.type
== BT_CHARACTER
)
297 tree fndecl
, var
, addr
, tmp
;
299 if (expr
->ts
.kind
== 1
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
301 fndecl
= gfor_fndecl_convert_char4_to_char1
;
302 else if (expr
->ts
.kind
== 4
303 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
304 fndecl
= gfor_fndecl_convert_char1_to_char4
;
308 /* Create the variable storing the converted value. */
309 type
= gfc_get_pchar_type (expr
->ts
.kind
);
310 var
= gfc_create_var (type
, "str");
311 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
313 /* Call the library function that will perform the conversion. */
314 gcc_assert (nargs
>= 2);
315 tmp
= build_call_expr_loc (input_location
,
316 fndecl
, 3, addr
, args
[0], args
[1]);
317 gfc_add_expr_to_block (&se
->pre
, tmp
);
319 /* Free the temporary afterwards. */
320 tmp
= gfc_call_free (var
);
321 gfc_add_expr_to_block (&se
->post
, tmp
);
324 se
->string_length
= args
[0];
329 /* Conversion from complex to non-complex involves taking the real
330 component of the value. */
331 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
332 && expr
->ts
.type
!= BT_COMPLEX
)
336 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
337 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
341 se
->expr
= convert (type
, args
[0]);
344 /* This is needed because the gcc backend only implements
345 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
346 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
347 Similarly for CEILING. */
350 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
357 argtype
= TREE_TYPE (arg
);
358 arg
= gfc_evaluate_now (arg
, pblock
);
360 intval
= convert (type
, arg
);
361 intval
= gfc_evaluate_now (intval
, pblock
);
363 tmp
= convert (argtype
, intval
);
364 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
365 boolean_type_node
, tmp
, arg
);
367 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
368 intval
, build_int_cst (type
, 1));
369 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
374 /* Round to nearest integer, away from zero. */
377 build_round_expr (tree arg
, tree restype
)
381 int argprec
, resprec
;
383 argtype
= TREE_TYPE (arg
);
384 argprec
= TYPE_PRECISION (argtype
);
385 resprec
= TYPE_PRECISION (restype
);
387 /* Depending on the type of the result, choose the int intrinsic
388 (iround, available only as a builtin, therefore cannot use it for
389 __float128), long int intrinsic (lround family) or long long
390 intrinsic (llround). We might also need to convert the result
392 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
393 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
394 else if (resprec
<= LONG_TYPE_SIZE
)
395 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
396 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
397 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
401 return fold_convert (restype
, build_call_expr_loc (input_location
,
406 /* Convert a real to an integer using a specific rounding mode.
407 Ideally we would just build the corresponding GENERIC node,
408 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
411 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
412 enum rounding_mode op
)
417 return build_fixbound_expr (pblock
, arg
, type
, 0);
421 return build_fixbound_expr (pblock
, arg
, type
, 1);
425 return build_round_expr (arg
, type
);
429 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
438 /* Round a real value using the specified rounding mode.
439 We use a temporary integer of that same kind size as the result.
440 Values larger than those that can be represented by this kind are
441 unchanged, as they will not be accurate enough to represent the
443 huge = HUGE (KIND (a))
444 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
448 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
460 kind
= expr
->ts
.kind
;
461 nargs
= gfc_intrinsic_argument_list_length (expr
);
464 /* We have builtin functions for some cases. */
468 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
472 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
479 /* Evaluate the argument. */
480 gcc_assert (expr
->value
.function
.actual
->expr
);
481 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
483 /* Use a builtin function if one exists. */
484 if (decl
!= NULL_TREE
)
486 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
490 /* This code is probably redundant, but we'll keep it lying around just
492 type
= gfc_typenode_for_spec (&expr
->ts
);
493 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
495 /* Test if the value is too large to handle sensibly. */
496 gfc_set_model_kind (kind
);
498 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
499 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
500 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
501 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
504 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
505 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
506 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
508 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
510 itype
= gfc_get_int_type (kind
);
512 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
513 tmp
= convert (type
, tmp
);
514 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
520 /* Convert to an integer using the specified rounding mode. */
523 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
529 nargs
= gfc_intrinsic_argument_list_length (expr
);
530 args
= XALLOCAVEC (tree
, nargs
);
532 /* Evaluate the argument, we process all arguments even though we only
533 use the first one for code generation purposes. */
534 type
= gfc_typenode_for_spec (&expr
->ts
);
535 gcc_assert (expr
->value
.function
.actual
->expr
);
536 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
538 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
540 /* Conversion to a different integer kind. */
541 se
->expr
= convert (type
, args
[0]);
545 /* Conversion from complex to non-complex involves taking the real
546 component of the value. */
547 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
548 && expr
->ts
.type
!= BT_COMPLEX
)
552 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
553 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
557 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
562 /* Get the imaginary component of a value. */
565 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
569 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
570 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
571 TREE_TYPE (TREE_TYPE (arg
)), arg
);
575 /* Get the complex conjugate of a value. */
578 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
582 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
583 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
589 define_quad_builtin (const char *name
, tree type
, bool is_const
)
592 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
595 /* Mark the decl as external. */
596 DECL_EXTERNAL (fndecl
) = 1;
597 TREE_PUBLIC (fndecl
) = 1;
599 /* Mark it __attribute__((const)). */
600 TREE_READONLY (fndecl
) = is_const
;
602 rest_of_decl_compilation (fndecl
, 1, 0);
609 /* Initialize function decls for library functions. The external functions
610 are created as required. Builtin functions are added here. */
613 gfc_build_intrinsic_lib_fndecls (void)
615 gfc_intrinsic_map_t
*m
;
616 tree quad_decls
[END_BUILTINS
+ 1];
618 if (gfc_real16_is_float128
)
620 /* If we have soft-float types, we create the decls for their
621 C99-like library functions. For now, we only handle __float128
622 q-suffixed functions. */
624 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
625 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
627 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
629 type
= float128_type_node
;
630 complex_type
= complex_float128_type_node
;
631 /* type (*) (type) */
632 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
634 func_iround
= build_function_type_list (integer_type_node
,
636 /* long (*) (type) */
637 func_lround
= build_function_type_list (long_integer_type_node
,
639 /* long long (*) (type) */
640 func_llround
= build_function_type_list (long_long_integer_type_node
,
642 /* type (*) (type, type) */
643 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
644 /* type (*) (type, &int) */
646 = build_function_type_list (type
,
648 build_pointer_type (integer_type_node
),
650 /* type (*) (type, int) */
651 func_scalbn
= build_function_type_list (type
,
652 type
, integer_type_node
, NULL_TREE
);
653 /* type (*) (complex type) */
654 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
655 /* complex type (*) (complex type, complex type) */
657 = build_function_type_list (complex_type
,
658 complex_type
, complex_type
, NULL_TREE
);
660 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
661 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
662 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
664 /* Only these built-ins are actually needed here. These are used directly
665 from the code, when calling builtin_decl_for_precision() or
666 builtin_decl_for_float_type(). The others are all constructed by
667 gfc_get_intrinsic_lib_fndecl(). */
668 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
669 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
671 #include "mathbuiltins.def"
675 #undef DEFINE_MATH_BUILTIN
676 #undef DEFINE_MATH_BUILTIN_C
680 /* Add GCC builtin functions. */
681 for (m
= gfc_intrinsic_map
;
682 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
684 if (m
->float_built_in
!= END_BUILTINS
)
685 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
686 if (m
->complex_float_built_in
!= END_BUILTINS
)
687 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
688 if (m
->double_built_in
!= END_BUILTINS
)
689 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
690 if (m
->complex_double_built_in
!= END_BUILTINS
)
691 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
693 /* If real(kind=10) exists, it is always long double. */
694 if (m
->long_double_built_in
!= END_BUILTINS
)
695 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
696 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
698 = builtin_decl_explicit (m
->complex_long_double_built_in
);
700 if (!gfc_real16_is_float128
)
702 if (m
->long_double_built_in
!= END_BUILTINS
)
703 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
704 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
706 = builtin_decl_explicit (m
->complex_long_double_built_in
);
708 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
710 /* Quad-precision function calls are constructed when first
711 needed by builtin_decl_for_precision(), except for those
712 that will be used directly (define by OTHER_BUILTIN). */
713 m
->real16_decl
= quad_decls
[m
->double_built_in
];
715 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
717 /* Same thing for the complex ones. */
718 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
724 /* Create a fndecl for a simple intrinsic library function. */
727 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
730 vec
<tree
, va_gc
> *argtypes
;
732 gfc_actual_arglist
*actual
;
735 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
738 if (ts
->type
== BT_REAL
)
743 pdecl
= &m
->real4_decl
;
746 pdecl
= &m
->real8_decl
;
749 pdecl
= &m
->real10_decl
;
752 pdecl
= &m
->real16_decl
;
758 else if (ts
->type
== BT_COMPLEX
)
760 gcc_assert (m
->complex_available
);
765 pdecl
= &m
->complex4_decl
;
768 pdecl
= &m
->complex8_decl
;
771 pdecl
= &m
->complex10_decl
;
774 pdecl
= &m
->complex16_decl
;
788 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
789 if (gfc_real_kinds
[n
].c_float
)
790 snprintf (name
, sizeof (name
), "%s%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
792 else if (gfc_real_kinds
[n
].c_double
)
793 snprintf (name
, sizeof (name
), "%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
795 else if (gfc_real_kinds
[n
].c_long_double
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
798 else if (gfc_real_kinds
[n
].c_float128
)
799 snprintf (name
, sizeof (name
), "%s%s%s",
800 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
806 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
807 ts
->type
== BT_COMPLEX
? 'c' : 'r',
812 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
814 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
815 vec_safe_push (argtypes
, type
);
817 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
818 fndecl
= build_decl (input_location
,
819 FUNCTION_DECL
, get_identifier (name
), type
);
821 /* Mark the decl as external. */
822 DECL_EXTERNAL (fndecl
) = 1;
823 TREE_PUBLIC (fndecl
) = 1;
825 /* Mark it __attribute__((const)), if possible. */
826 TREE_READONLY (fndecl
) = m
->is_constant
;
828 rest_of_decl_compilation (fndecl
, 1, 0);
835 /* Convert an intrinsic function into an external or builtin call. */
838 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
840 gfc_intrinsic_map_t
*m
;
844 unsigned int num_args
;
847 id
= expr
->value
.function
.isym
->id
;
848 /* Find the entry for this function. */
849 for (m
= gfc_intrinsic_map
;
850 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
856 if (m
->id
== GFC_ISYM_NONE
)
858 internal_error ("Intrinsic function %s(%d) not recognized",
859 expr
->value
.function
.name
, id
);
862 /* Get the decl and generate the call. */
863 num_args
= gfc_intrinsic_argument_list_length (expr
);
864 args
= XALLOCAVEC (tree
, num_args
);
866 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
867 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
868 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
870 fndecl
= build_addr (fndecl
, current_function_decl
);
871 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
875 /* If bounds-checking is enabled, create code to verify at runtime that the
876 string lengths for both expressions are the same (needed for e.g. MERGE).
877 If bounds-checking is not enabled, does nothing. */
880 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
881 tree a
, tree b
, stmtblock_t
* target
)
886 /* If bounds-checking is disabled, do nothing. */
887 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
890 /* Compare the two string lengths. */
891 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
893 /* Output the runtime-check. */
894 name
= gfc_build_cstring_const (intr_name
);
895 name
= gfc_build_addr_expr (pchar_type_node
, name
);
896 gfc_trans_runtime_check (true, false, cond
, target
, where
,
897 "Unequal character lengths (%ld/%ld) in %s",
898 fold_convert (long_integer_type_node
, a
),
899 fold_convert (long_integer_type_node
, b
), name
);
903 /* The EXPONENT(s) intrinsic function is translated into
910 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
912 tree arg
, type
, res
, tmp
, frexp
;
914 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
915 expr
->value
.function
.actual
->expr
->ts
.kind
);
917 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
919 res
= gfc_create_var (integer_type_node
, NULL
);
920 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
921 gfc_build_addr_expr (NULL_TREE
, res
));
922 gfc_add_expr_to_block (&se
->pre
, tmp
);
924 type
= gfc_typenode_for_spec (&expr
->ts
);
925 se
->expr
= fold_convert (type
, res
);
929 /* Convert the coindex of a coarray into an image index; the result is
930 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2)+1)*extent(1)
931 + (idx(3)-lcobound(3)+1)*extent(2) + ... */
934 caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
937 tree lbound
, ubound
, extent
, tmp
, img_idx
;
941 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
942 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
944 gcc_assert (ref
!= NULL
);
946 img_idx
= integer_zero_node
;
947 extent
= integer_one_node
;
948 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
949 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
951 gfc_init_se (&se
, NULL
);
952 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
953 gfc_add_block_to_block (block
, &se
.pre
);
954 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
955 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
956 integer_type_node
, se
.expr
,
957 fold_convert(integer_type_node
, lbound
));
958 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
960 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
962 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
964 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
965 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
966 extent
= fold_convert (integer_type_node
, extent
);
970 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
972 gfc_init_se (&se
, NULL
);
973 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
974 gfc_add_block_to_block (block
, &se
.pre
);
975 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
976 lbound
= fold_convert (integer_type_node
, lbound
);
977 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
978 integer_type_node
, se
.expr
, lbound
);
979 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
981 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
983 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
985 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
986 ubound
= fold_convert (integer_type_node
, ubound
);
987 extent
= fold_build2_loc (input_location
, MINUS_EXPR
,
988 integer_type_node
, ubound
, lbound
);
989 extent
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
990 extent
, integer_one_node
);
993 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
994 img_idx
, integer_one_node
);
999 /* Send data to a remove coarray. */
1002 conv_caf_send (gfc_code
*code
) {
1003 gfc_expr
*lhs_expr
, *rhs_expr
;
1004 gfc_se lhs_se
, rhs_se
;
1006 tree caf_decl
, token
, offset
, image_index
, tmp
, size
;
1008 gcc_assert (gfc_option
.coarray
== GFC_FCOARRAY_LIB
);
1010 lhs_expr
= code
->ext
.actual
->expr
;
1011 rhs_expr
= code
->ext
.actual
->next
->expr
;
1012 gfc_init_block (&block
);
1014 /* LHS: The coarray. */
1016 gfc_init_se (&lhs_se
, NULL
);
1019 gfc_conv_expr_descriptor (&lhs_se
, lhs_expr
);
1020 lhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, lhs_se
.expr
);
1024 lhs_se
.want_pointer
= 1;
1025 gfc_conv_expr_reference (&lhs_se
, lhs_expr
);
1027 gfc_add_block_to_block (&block
, &lhs_se
.pre
);
1029 caf_decl
= gfc_get_tree_for_caf_expr (lhs_expr
);
1030 if (TREE_CODE (TREE_TYPE (caf_decl
)) == REFERENCE_TYPE
)
1031 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1032 image_index
= caf_get_image_index (&block
, lhs_expr
, caf_decl
);
1034 /* Coarray token. */
1035 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1036 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
)
1037 token
= gfc_conv_descriptor_token (caf_decl
);
1038 else if (DECL_LANG_SPECIFIC (caf_decl
)
1039 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1040 token
= GFC_DECL_TOKEN (caf_decl
);
1043 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1044 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1045 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1048 /* Offset between the coarray base address and the address wanted. */
1049 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1050 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
)
1051 offset
= build_int_cst (gfc_array_index_type
, 0);
1052 else if (DECL_LANG_SPECIFIC (caf_decl
)
1053 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1054 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1055 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1056 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1058 offset
= build_int_cst (gfc_array_index_type
, 0);
1060 if (POINTER_TYPE_P (TREE_TYPE (lhs_se
.expr
))
1061 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (lhs_se
.expr
))))
1063 tmp
= build_fold_indirect_ref_loc (input_location
, lhs_se
.expr
);
1064 tmp
= gfc_conv_descriptor_data_get (tmp
);
1066 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lhs_se
.expr
)))
1067 tmp
= gfc_conv_descriptor_data_get (lhs_se
.expr
);
1070 gcc_assert (POINTER_TYPE_P (TREE_TYPE (lhs_se
.expr
)));
1074 offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1077 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1078 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1081 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1085 offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1086 fold_convert (gfc_array_index_type
, offset
),
1087 fold_convert (gfc_array_index_type
, tmp
));
1089 /* RHS - a noncoarray. */
1091 gfc_init_se (&rhs_se
, NULL
);
1094 gfc_conv_expr_descriptor (&rhs_se
, rhs_expr
);
1095 rhs_se
.expr
= gfc_build_addr_expr (NULL_TREE
, rhs_se
.expr
);
1099 rhs_se
.want_pointer
= 1;
1100 gfc_conv_expr_reference (&rhs_se
, rhs_expr
);
1102 gfc_add_block_to_block (&block
, &rhs_se
.pre
);
1106 size
= TREE_TYPE (TREE_TYPE (rhs_se
.expr
));
1107 size
= size_in_bytes (gfc_get_element_type (size
));
1110 size
= size_in_bytes (TREE_TYPE (TREE_TYPE (rhs_se
.expr
)));
1111 if (lhs_expr
->rank
&& rhs_expr
->rank
)
1112 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send_desc
, 6,
1113 token
, offset
, image_index
, lhs_se
.expr
,
1114 rhs_se
.expr
, boolean_false_node
);
1115 else if (lhs_expr
->rank
)
1116 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send_desc_scalar
,
1117 6, token
, offset
, image_index
, lhs_se
.expr
,
1118 rhs_se
.expr
, boolean_false_node
);
1120 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_send
, 6,
1121 token
, offset
, image_index
, rhs_se
.expr
, size
,
1122 boolean_false_node
);
1123 gfc_add_expr_to_block (&block
, tmp
);
1124 gfc_add_block_to_block (&block
, &lhs_se
.post
);
1125 gfc_add_block_to_block (&block
, &rhs_se
.post
);
1126 return gfc_finish_block (&block
);
1131 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
1134 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
1135 lbound
, ubound
, extent
, ml
;
1138 gfc_expr
*distance
= expr
->value
.function
.actual
->next
->next
->expr
;
1140 if (expr
->value
.function
.actual
->expr
1141 && !gfc_is_coarray (expr
->value
.function
.actual
->expr
))
1142 distance
= expr
->value
.function
.actual
->expr
;
1144 /* The case -fcoarray=single is handled elsewhere. */
1145 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
1147 /* Argument-free version: THIS_IMAGE(). */
1148 if (distance
|| expr
->value
.function
.actual
->expr
== NULL
)
1152 gfc_init_se (&argse
, NULL
);
1153 gfc_conv_expr_val (&argse
, distance
);
1154 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1155 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1156 tmp
= fold_convert (integer_type_node
, argse
.expr
);
1159 tmp
= integer_zero_node
;
1160 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1162 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1167 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1169 type
= gfc_get_int_type (gfc_default_integer_kind
);
1170 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1171 rank
= expr
->value
.function
.actual
->expr
->rank
;
1173 /* Obtain the descriptor of the COARRAY. */
1174 gfc_init_se (&argse
, NULL
);
1175 argse
.want_coarray
= 1;
1176 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1177 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1178 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1183 /* Create an implicit second parameter from the loop variable. */
1184 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
1185 gcc_assert (corank
> 0);
1186 gcc_assert (se
->loop
->dimen
== 1);
1187 gcc_assert (se
->ss
->info
->expr
== expr
);
1189 dim_arg
= se
->loop
->loopvar
[0];
1190 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
1191 gfc_array_index_type
, dim_arg
,
1192 build_int_cst (TREE_TYPE (dim_arg
), 1));
1193 gfc_advance_se_ss_chain (se
);
1197 /* Use the passed DIM= argument. */
1198 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
1199 gfc_init_se (&argse
, NULL
);
1200 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
1201 gfc_array_index_type
);
1202 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1203 dim_arg
= argse
.expr
;
1205 if (INTEGER_CST_P (dim_arg
))
1207 if (wi::ltu_p (dim_arg
, 1)
1208 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
1209 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1210 "dimension index", expr
->value
.function
.isym
->name
,
1213 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1215 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1216 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1218 build_int_cst (TREE_TYPE (dim_arg
), 1));
1219 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1220 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1222 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1223 boolean_type_node
, cond
, tmp
);
1224 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1229 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1230 one always has a dim_arg argument.
1232 m = this_image() - 1
1235 sub(1) = m + lcobound(corank)
1239 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1242 extent = gfc_extent(i)
1250 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1251 : m + lcobound(corank)
1254 /* this_image () - 1. */
1255 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1257 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
1258 fold_convert (type
, tmp
), build_int_cst (type
, 1));
1261 /* sub(1) = m + lcobound(corank). */
1262 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1263 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1265 lbound
= fold_convert (type
, lbound
);
1266 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1272 m
= gfc_create_var (type
, NULL
);
1273 ml
= gfc_create_var (type
, NULL
);
1274 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1275 min_var
= gfc_create_var (integer_type_node
, NULL
);
1277 /* m = this_image () - 1. */
1278 gfc_add_modify (&se
->pre
, m
, tmp
);
1280 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1281 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1282 fold_convert (integer_type_node
, dim_arg
),
1283 build_int_cst (integer_type_node
, rank
- 1));
1284 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1285 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1287 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1290 tmp
= build_int_cst (integer_type_node
, rank
);
1291 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1293 exit_label
= gfc_build_label_decl (NULL_TREE
);
1294 TREE_USED (exit_label
) = 1;
1297 gfc_init_block (&loop
);
1300 gfc_add_modify (&loop
, ml
, m
);
1303 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1304 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1305 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1306 extent
= fold_convert (type
, extent
);
1309 gfc_add_modify (&loop
, m
,
1310 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1313 /* Exit condition: if (i >= min_var) goto exit_label. */
1314 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1316 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1317 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1318 build_empty_stmt (input_location
));
1319 gfc_add_expr_to_block (&loop
, tmp
);
1321 /* Increment loop variable: i++. */
1322 gfc_add_modify (&loop
, loop_var
,
1323 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1325 build_int_cst (integer_type_node
, 1)));
1327 /* Making the loop... actually loop! */
1328 tmp
= gfc_finish_block (&loop
);
1329 tmp
= build1_v (LOOP_EXPR
, tmp
);
1330 gfc_add_expr_to_block (&se
->pre
, tmp
);
1332 /* The exit label. */
1333 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1334 gfc_add_expr_to_block (&se
->pre
, tmp
);
1336 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1337 : m + lcobound(corank) */
1339 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1340 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1342 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1343 fold_build2_loc (input_location
, PLUS_EXPR
,
1344 gfc_array_index_type
, dim_arg
,
1345 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1346 lbound
= fold_convert (type
, lbound
);
1348 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1349 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1351 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1353 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1354 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1360 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1362 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1364 gfc_se argse
, subse
;
1365 int rank
, corank
, codim
;
1367 type
= gfc_get_int_type (gfc_default_integer_kind
);
1368 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1369 rank
= expr
->value
.function
.actual
->expr
->rank
;
1371 /* Obtain the descriptor of the COARRAY. */
1372 gfc_init_se (&argse
, NULL
);
1373 argse
.want_coarray
= 1;
1374 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1375 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1376 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1379 /* Obtain a handle to the SUB argument. */
1380 gfc_init_se (&subse
, NULL
);
1381 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1382 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1383 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1384 subdesc
= build_fold_indirect_ref_loc (input_location
,
1385 gfc_conv_descriptor_data_get (subse
.expr
));
1387 /* Fortran 2008 does not require that the values remain in the cobounds,
1388 thus we need explicitly check this - and return 0 if they are exceeded. */
1390 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1391 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1392 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1393 fold_convert (gfc_array_index_type
, tmp
),
1396 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1398 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1399 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1400 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1401 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1402 fold_convert (gfc_array_index_type
, tmp
),
1404 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1405 boolean_type_node
, invalid_bound
, cond
);
1406 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1407 fold_convert (gfc_array_index_type
, tmp
),
1409 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1410 boolean_type_node
, invalid_bound
, cond
);
1413 invalid_bound
= gfc_unlikely (invalid_bound
, PRED_FORTRAN_INVALID_BOUND
);
1415 /* See Fortran 2008, C.10 for the following algorithm. */
1417 /* coindex = sub(corank) - lcobound(n). */
1418 coindex
= fold_convert (gfc_array_index_type
,
1419 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1421 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1422 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1423 fold_convert (gfc_array_index_type
, coindex
),
1426 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1428 tree extent
, ubound
;
1430 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1431 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1432 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1433 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1435 /* coindex *= extent. */
1436 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1437 gfc_array_index_type
, coindex
, extent
);
1439 /* coindex += sub(codim). */
1440 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1441 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1442 gfc_array_index_type
, coindex
,
1443 fold_convert (gfc_array_index_type
, tmp
));
1445 /* coindex -= lbound(codim). */
1446 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1447 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1448 gfc_array_index_type
, coindex
, lbound
);
1451 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1452 fold_convert(type
, coindex
),
1453 build_int_cst (type
, 1));
1455 /* Return 0 if "coindex" exceeds num_images(). */
1457 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1458 num_images
= build_int_cst (type
, 1);
1461 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1463 build_int_cst (integer_type_node
, -1));
1464 num_images
= fold_convert (type
, tmp
);
1467 tmp
= gfc_create_var (type
, NULL
);
1468 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1470 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1472 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1474 fold_convert (boolean_type_node
, invalid_bound
));
1475 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1476 build_int_cst (type
, 0), tmp
);
1481 trans_num_images (gfc_se
* se
, gfc_expr
*expr
)
1483 tree tmp
, distance
, failed
;
1486 if (expr
->value
.function
.actual
->expr
)
1488 gfc_init_se (&argse
, NULL
);
1489 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->expr
);
1490 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1491 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1492 distance
= fold_convert (integer_type_node
, argse
.expr
);
1495 distance
= integer_zero_node
;
1497 if (expr
->value
.function
.actual
->next
->expr
)
1499 gfc_init_se (&argse
, NULL
);
1500 gfc_conv_expr_val (&argse
, expr
->value
.function
.actual
->next
->expr
);
1501 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1502 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1503 failed
= fold_convert (integer_type_node
, argse
.expr
);
1506 failed
= build_int_cst (integer_type_node
, -1);
1508 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1510 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
1515 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1519 gfc_init_se (&argse
, NULL
);
1520 argse
.data_not_needed
= 1;
1521 argse
.descriptor_only
= 1;
1523 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1524 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1525 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1527 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1531 /* Evaluate a single upper or lower bound. */
1532 /* TODO: bound intrinsic generates way too much unnecessary code. */
1535 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1537 gfc_actual_arglist
*arg
;
1538 gfc_actual_arglist
*arg2
;
1543 tree cond
, cond1
, cond3
, cond4
, size
;
1547 gfc_array_spec
* as
;
1548 bool assumed_rank_lb_one
;
1550 arg
= expr
->value
.function
.actual
;
1555 /* Create an implicit second parameter from the loop variable. */
1556 gcc_assert (!arg2
->expr
);
1557 gcc_assert (se
->loop
->dimen
== 1);
1558 gcc_assert (se
->ss
->info
->expr
== expr
);
1559 gfc_advance_se_ss_chain (se
);
1560 bound
= se
->loop
->loopvar
[0];
1561 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1562 gfc_array_index_type
, bound
,
1567 /* use the passed argument. */
1568 gcc_assert (arg2
->expr
);
1569 gfc_init_se (&argse
, NULL
);
1570 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1571 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1573 /* Convert from one based to zero based. */
1574 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1575 gfc_array_index_type
, bound
,
1576 gfc_index_one_node
);
1579 /* TODO: don't re-evaluate the descriptor on each iteration. */
1580 /* Get a descriptor for the first parameter. */
1581 gfc_init_se (&argse
, NULL
);
1582 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1583 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1584 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1588 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1590 if (INTEGER_CST_P (bound
))
1592 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1593 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
1594 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
1595 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1596 "dimension index", upper
? "UBOUND" : "LBOUND",
1600 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1602 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1604 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1605 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1606 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1607 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1608 tmp
= gfc_conv_descriptor_rank (desc
);
1610 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1611 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1612 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1613 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1614 boolean_type_node
, cond
, tmp
);
1615 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1620 /* Take care of the lbound shift for assumed-rank arrays, which are
1621 nonallocatable and nonpointers. Those has a lbound of 1. */
1622 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1623 && ((arg
->expr
->ts
.type
!= BT_CLASS
1624 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1625 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1626 || (arg
->expr
->ts
.type
== BT_CLASS
1627 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1628 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1630 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1631 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1633 /* 13.14.53: Result value for LBOUND
1635 Case (i): For an array section or for an array expression other than a
1636 whole array or array structure component, LBOUND(ARRAY, DIM)
1637 has the value 1. For a whole array or array structure
1638 component, LBOUND(ARRAY, DIM) has the value:
1639 (a) equal to the lower bound for subscript DIM of ARRAY if
1640 dimension DIM of ARRAY does not have extent zero
1641 or if ARRAY is an assumed-size array of rank DIM,
1644 13.14.113: Result value for UBOUND
1646 Case (i): For an array section or for an array expression other than a
1647 whole array or array structure component, UBOUND(ARRAY, DIM)
1648 has the value equal to the number of elements in the given
1649 dimension; otherwise, it has a value equal to the upper bound
1650 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1651 not have size zero and has value zero if dimension DIM has
1654 if (!upper
&& assumed_rank_lb_one
)
1655 se
->expr
= gfc_index_one_node
;
1658 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1660 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1662 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1663 stride
, gfc_index_zero_node
);
1664 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1665 boolean_type_node
, cond3
, cond1
);
1666 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1667 stride
, gfc_index_zero_node
);
1672 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1673 boolean_type_node
, cond3
, cond4
);
1674 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1675 gfc_index_one_node
, lbound
);
1676 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1677 boolean_type_node
, cond4
, cond5
);
1679 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1680 boolean_type_node
, cond
, cond5
);
1682 if (assumed_rank_lb_one
)
1684 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1685 gfc_array_index_type
, ubound
, lbound
);
1686 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1687 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1692 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1693 gfc_array_index_type
, cond
,
1694 tmp
, gfc_index_zero_node
);
1698 if (as
->type
== AS_ASSUMED_SIZE
)
1699 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1700 bound
, build_int_cst (TREE_TYPE (bound
),
1701 arg
->expr
->rank
- 1));
1703 cond
= boolean_false_node
;
1705 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1706 boolean_type_node
, cond3
, cond4
);
1707 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1708 boolean_type_node
, cond
, cond1
);
1710 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1711 gfc_array_index_type
, cond
,
1712 lbound
, gfc_index_one_node
);
1719 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1720 gfc_array_index_type
, ubound
, lbound
);
1721 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1722 gfc_array_index_type
, size
,
1723 gfc_index_one_node
);
1724 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1725 gfc_array_index_type
, se
->expr
,
1726 gfc_index_zero_node
);
1729 se
->expr
= gfc_index_one_node
;
1732 type
= gfc_typenode_for_spec (&expr
->ts
);
1733 se
->expr
= convert (type
, se
->expr
);
1738 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
1740 gfc_actual_arglist
*arg
;
1741 gfc_actual_arglist
*arg2
;
1743 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
1747 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
1748 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
1749 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
1751 arg
= expr
->value
.function
.actual
;
1754 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
1755 corank
= gfc_get_corank (arg
->expr
);
1757 gfc_init_se (&argse
, NULL
);
1758 argse
.want_coarray
= 1;
1760 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1761 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1762 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1767 /* Create an implicit second parameter from the loop variable. */
1768 gcc_assert (!arg2
->expr
);
1769 gcc_assert (corank
> 0);
1770 gcc_assert (se
->loop
->dimen
== 1);
1771 gcc_assert (se
->ss
->info
->expr
== expr
);
1773 bound
= se
->loop
->loopvar
[0];
1774 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1775 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
1776 gfc_advance_se_ss_chain (se
);
1780 /* use the passed argument. */
1781 gcc_assert (arg2
->expr
);
1782 gfc_init_se (&argse
, NULL
);
1783 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1784 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1787 if (INTEGER_CST_P (bound
))
1789 if (wi::ltu_p (bound
, 1)
1790 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
1791 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1792 "dimension index", expr
->value
.function
.isym
->name
,
1795 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1797 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1798 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1799 bound
, build_int_cst (TREE_TYPE (bound
), 1));
1800 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1801 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1803 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1804 boolean_type_node
, cond
, tmp
);
1805 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1810 /* Subtract 1 to get to zero based and add dimensions. */
1811 switch (arg
->expr
->rank
)
1814 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1815 gfc_array_index_type
, bound
,
1816 gfc_index_one_node
);
1820 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1821 gfc_array_index_type
, bound
,
1822 gfc_rank_cst
[arg
->expr
->rank
- 1]);
1826 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1828 /* Handle UCOBOUND with special handling of the last codimension. */
1829 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
1831 /* Last codimension: For -fcoarray=single just return
1832 the lcobound - otherwise add
1833 ceiling (real (num_images ()) / real (size)) - 1
1834 = (num_images () + size - 1) / size - 1
1835 = (num_images - 1) / size(),
1836 where size is the product of the extent of all but the last
1839 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
1843 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
1844 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1845 2, integer_zero_node
,
1846 build_int_cst (integer_type_node
, -1));
1847 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1848 gfc_array_index_type
,
1849 fold_convert (gfc_array_index_type
, tmp
),
1850 build_int_cst (gfc_array_index_type
, 1));
1851 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1852 gfc_array_index_type
, tmp
,
1853 fold_convert (gfc_array_index_type
, cosize
));
1854 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1855 gfc_array_index_type
, resbound
, tmp
);
1857 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
1859 /* ubound = lbound + num_images() - 1. */
1860 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1861 2, integer_zero_node
,
1862 build_int_cst (integer_type_node
, -1));
1863 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1864 gfc_array_index_type
,
1865 fold_convert (gfc_array_index_type
, tmp
),
1866 build_int_cst (gfc_array_index_type
, 1));
1867 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1868 gfc_array_index_type
, resbound
, tmp
);
1873 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1875 build_int_cst (TREE_TYPE (bound
),
1876 arg
->expr
->rank
+ corank
- 1));
1878 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1879 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1880 gfc_array_index_type
, cond
,
1881 resbound
, resbound2
);
1884 se
->expr
= resbound
;
1887 se
->expr
= resbound
;
1889 type
= gfc_typenode_for_spec (&expr
->ts
);
1890 se
->expr
= convert (type
, se
->expr
);
1895 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
1897 gfc_actual_arglist
*array_arg
;
1898 gfc_actual_arglist
*dim_arg
;
1902 array_arg
= expr
->value
.function
.actual
;
1903 dim_arg
= array_arg
->next
;
1905 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
1907 gfc_init_se (&argse
, NULL
);
1908 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
1909 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1910 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1913 gcc_assert (dim_arg
->expr
);
1914 gfc_init_se (&argse
, NULL
);
1915 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
1916 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1917 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1918 argse
.expr
, gfc_index_one_node
);
1919 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
1924 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1928 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1930 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1934 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1939 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1940 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1949 /* Create a complex value from one or two real components. */
1952 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1958 unsigned int num_args
;
1960 num_args
= gfc_intrinsic_argument_list_length (expr
);
1961 args
= XALLOCAVEC (tree
, num_args
);
1963 type
= gfc_typenode_for_spec (&expr
->ts
);
1964 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1965 real
= convert (TREE_TYPE (type
), args
[0]);
1967 imag
= convert (TREE_TYPE (type
), args
[1]);
1968 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1970 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1971 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1972 imag
= convert (TREE_TYPE (type
), imag
);
1975 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1977 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1981 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1982 MODULO(A, P) = A - FLOOR (A / P) * P
1984 The obvious algorithms above are numerically instable for large
1985 arguments, hence these intrinsics are instead implemented via calls
1986 to the fmod family of functions. It is the responsibility of the
1987 user to ensure that the second argument is non-zero. */
1990 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
2000 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2002 switch (expr
->ts
.type
)
2005 /* Integer case is easy, we've got a builtin op. */
2006 type
= TREE_TYPE (args
[0]);
2009 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
2012 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
2018 /* Check if we have a builtin fmod. */
2019 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
2021 /* The builtin should always be available. */
2022 gcc_assert (fmod
!= NULL_TREE
);
2024 tmp
= build_addr (fmod
, current_function_decl
);
2025 se
->expr
= build_call_array_loc (input_location
,
2026 TREE_TYPE (TREE_TYPE (fmod
)),
2031 type
= TREE_TYPE (args
[0]);
2033 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2034 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
2037 modulo = arg - floor (arg/arg2) * arg2
2039 In order to calculate the result accurately, we use the fmod
2040 function as follows.
2042 res = fmod (arg, arg2);
2045 if ((arg < 0) xor (arg2 < 0))
2049 res = copysign (0., arg2);
2051 => As two nested ternary exprs:
2053 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2054 : copysign (0., arg2);
2058 zero
= gfc_build_const (type
, integer_zero_node
);
2059 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2060 if (!flag_signed_zeros
)
2062 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2064 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2066 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2067 boolean_type_node
, test
, test2
);
2068 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2070 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
2071 boolean_type_node
, test
, test2
);
2072 test
= gfc_evaluate_now (test
, &se
->pre
);
2073 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2074 fold_build2_loc (input_location
,
2076 type
, tmp
, args
[1]),
2081 tree expr1
, copysign
, cscall
;
2082 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
2084 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2086 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2088 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
2089 boolean_type_node
, test
, test2
);
2090 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
2091 fold_build2_loc (input_location
,
2093 type
, tmp
, args
[1]),
2095 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2097 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
2099 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
2109 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2110 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2111 where the right shifts are logical (i.e. 0's are shifted in).
2112 Because SHIFT_EXPR's want shifts strictly smaller than the integral
2113 type width, we have to special-case both S == 0 and S == BITSIZE(J):
2115 DSHIFTL(I,J,BITSIZE) = J
2117 DSHIFTR(I,J,BITSIZE) = I. */
2120 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
2122 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
2123 tree args
[3], cond
, tmp
;
2126 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
2128 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
2129 type
= TREE_TYPE (args
[0]);
2130 bitsize
= TYPE_PRECISION (type
);
2131 utype
= unsigned_type_for (type
);
2132 stype
= TREE_TYPE (args
[2]);
2134 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
2135 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
2136 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
2138 /* The generic case. */
2139 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
2140 build_int_cst (stype
, bitsize
), shift
);
2141 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
2142 arg1
, dshiftl
? shift
: tmp
);
2144 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
2145 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
2146 right
= fold_convert (type
, right
);
2148 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
2150 /* Special cases. */
2151 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2152 build_int_cst (stype
, 0));
2153 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2154 dshiftl
? arg1
: arg2
, res
);
2156 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
2157 build_int_cst (stype
, bitsize
));
2158 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
2159 dshiftl
? arg2
: arg1
, res
);
2165 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
2168 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
2176 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2177 type
= TREE_TYPE (args
[0]);
2179 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
2180 val
= gfc_evaluate_now (val
, &se
->pre
);
2182 zero
= gfc_build_const (type
, integer_zero_node
);
2183 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
2184 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
2188 /* SIGN(A, B) is absolute value of A times sign of B.
2189 The real value versions use library functions to ensure the correct
2190 handling of negative zero. Integer case implemented as:
2191 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
2195 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
2201 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2202 if (expr
->ts
.type
== BT_REAL
)
2206 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
2207 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
2209 /* We explicitly have to ignore the minus sign. We do so by using
2210 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
2211 if (!gfc_option
.flag_sign_zero
2212 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
2215 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
2216 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2218 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
2219 TREE_TYPE (args
[0]), cond
,
2220 build_call_expr_loc (input_location
, abs
, 1,
2222 build_call_expr_loc (input_location
, tmp
, 2,
2226 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
2231 /* Having excluded floating point types, we know we are now dealing
2232 with signed integer types. */
2233 type
= TREE_TYPE (args
[0]);
2235 /* Args[0] is used multiple times below. */
2236 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2238 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2239 the signs of A and B are the same, and of all ones if they differ. */
2240 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2241 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2242 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2243 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2245 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2246 is all ones (i.e. -1). */
2247 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2248 fold_build2_loc (input_location
, PLUS_EXPR
,
2249 type
, args
[0], tmp
), tmp
);
2253 /* Test for the presence of an optional argument. */
2256 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2260 arg
= expr
->value
.function
.actual
->expr
;
2261 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2262 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2263 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2267 /* Calculate the double precision product of two single precision values. */
2270 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2275 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2277 /* Convert the args to double precision before multiplying. */
2278 type
= gfc_typenode_for_spec (&expr
->ts
);
2279 args
[0] = convert (type
, args
[0]);
2280 args
[1] = convert (type
, args
[1]);
2281 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2286 /* Return a length one character string containing an ascii character. */
2289 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2294 unsigned int num_args
;
2296 num_args
= gfc_intrinsic_argument_list_length (expr
);
2297 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2299 type
= gfc_get_char_type (expr
->ts
.kind
);
2300 var
= gfc_create_var (type
, "char");
2302 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2303 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2304 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2305 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2310 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2318 unsigned int num_args
;
2320 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2321 args
= XALLOCAVEC (tree
, num_args
);
2323 var
= gfc_create_var (pchar_type_node
, "pstr");
2324 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2326 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2327 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2328 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2330 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2331 tmp
= build_call_array_loc (input_location
,
2332 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2333 fndecl
, num_args
, args
);
2334 gfc_add_expr_to_block (&se
->pre
, tmp
);
2336 /* Free the temporary afterwards, if necessary. */
2337 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2338 len
, build_int_cst (TREE_TYPE (len
), 0));
2339 tmp
= gfc_call_free (var
);
2340 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2341 gfc_add_expr_to_block (&se
->post
, tmp
);
2344 se
->string_length
= len
;
2349 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2357 unsigned int num_args
;
2359 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2360 args
= XALLOCAVEC (tree
, num_args
);
2362 var
= gfc_create_var (pchar_type_node
, "pstr");
2363 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2365 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2366 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2367 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2369 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2370 tmp
= build_call_array_loc (input_location
,
2371 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2372 fndecl
, num_args
, args
);
2373 gfc_add_expr_to_block (&se
->pre
, tmp
);
2375 /* Free the temporary afterwards, if necessary. */
2376 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2377 len
, build_int_cst (TREE_TYPE (len
), 0));
2378 tmp
= gfc_call_free (var
);
2379 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2380 gfc_add_expr_to_block (&se
->post
, tmp
);
2383 se
->string_length
= len
;
2387 /* Return a character string containing the tty name. */
2390 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2398 unsigned int num_args
;
2400 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2401 args
= XALLOCAVEC (tree
, num_args
);
2403 var
= gfc_create_var (pchar_type_node
, "pstr");
2404 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2406 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2407 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2408 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2410 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2411 tmp
= build_call_array_loc (input_location
,
2412 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2413 fndecl
, num_args
, args
);
2414 gfc_add_expr_to_block (&se
->pre
, tmp
);
2416 /* Free the temporary afterwards, if necessary. */
2417 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2418 len
, build_int_cst (TREE_TYPE (len
), 0));
2419 tmp
= gfc_call_free (var
);
2420 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2421 gfc_add_expr_to_block (&se
->post
, tmp
);
2424 se
->string_length
= len
;
2428 /* Get the minimum/maximum value of all the parameters.
2429 minmax (a1, a2, a3, ...)
2432 if (a2 .op. mvar || isnan (mvar))
2434 if (a3 .op. mvar || isnan (mvar))
2441 /* TODO: Mismatching types can occur when specific names are used.
2442 These should be handled during resolution. */
2444 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2452 gfc_actual_arglist
*argexpr
;
2453 unsigned int i
, nargs
;
2455 nargs
= gfc_intrinsic_argument_list_length (expr
);
2456 args
= XALLOCAVEC (tree
, nargs
);
2458 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2459 type
= gfc_typenode_for_spec (&expr
->ts
);
2461 argexpr
= expr
->value
.function
.actual
;
2462 if (TREE_TYPE (args
[0]) != type
)
2463 args
[0] = convert (type
, args
[0]);
2464 /* Only evaluate the argument once. */
2465 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2466 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2468 mvar
= gfc_create_var (type
, "M");
2469 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2470 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2476 /* Handle absent optional arguments by ignoring the comparison. */
2477 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2478 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2479 && TREE_CODE (val
) == INDIRECT_REF
)
2480 cond
= fold_build2_loc (input_location
,
2481 NE_EXPR
, boolean_type_node
,
2482 TREE_OPERAND (val
, 0),
2483 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2488 /* Only evaluate the argument once. */
2489 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2490 val
= gfc_evaluate_now (val
, &se
->pre
);
2493 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2495 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2496 convert (type
, val
), mvar
);
2498 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2499 __builtin_isnan might be made dependent on that module being loaded,
2500 to help performance of programs that don't rely on IEEE semantics. */
2501 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2503 isnan
= build_call_expr_loc (input_location
,
2504 builtin_decl_explicit (BUILT_IN_ISNAN
),
2506 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2507 boolean_type_node
, tmp
,
2508 fold_convert (boolean_type_node
, isnan
));
2510 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2511 build_empty_stmt (input_location
));
2513 if (cond
!= NULL_TREE
)
2514 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2515 build_empty_stmt (input_location
));
2517 gfc_add_expr_to_block (&se
->pre
, tmp
);
2518 argexpr
= argexpr
->next
;
2524 /* Generate library calls for MIN and MAX intrinsics for character
2527 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2530 tree var
, len
, fndecl
, tmp
, cond
, function
;
2533 nargs
= gfc_intrinsic_argument_list_length (expr
);
2534 args
= XALLOCAVEC (tree
, nargs
+ 4);
2535 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2537 /* Create the result variables. */
2538 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2539 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2540 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2541 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2542 args
[2] = build_int_cst (integer_type_node
, op
);
2543 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2545 if (expr
->ts
.kind
== 1)
2546 function
= gfor_fndecl_string_minmax
;
2547 else if (expr
->ts
.kind
== 4)
2548 function
= gfor_fndecl_string_minmax_char4
;
2552 /* Make the function call. */
2553 fndecl
= build_addr (function
, current_function_decl
);
2554 tmp
= build_call_array_loc (input_location
,
2555 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2557 gfc_add_expr_to_block (&se
->pre
, tmp
);
2559 /* Free the temporary afterwards, if necessary. */
2560 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2561 len
, build_int_cst (TREE_TYPE (len
), 0));
2562 tmp
= gfc_call_free (var
);
2563 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2564 gfc_add_expr_to_block (&se
->post
, tmp
);
2567 se
->string_length
= len
;
2571 /* Create a symbol node for this intrinsic. The symbol from the frontend
2572 has the generic name. */
2575 gfc_get_symbol_for_expr (gfc_expr
* expr
)
2579 /* TODO: Add symbols for intrinsic function to the global namespace. */
2580 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2581 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2584 sym
->attr
.external
= 1;
2585 sym
->attr
.function
= 1;
2586 sym
->attr
.always_explicit
= 1;
2587 sym
->attr
.proc
= PROC_INTRINSIC
;
2588 sym
->attr
.flavor
= FL_PROCEDURE
;
2592 sym
->attr
.dimension
= 1;
2593 sym
->as
= gfc_get_array_spec ();
2594 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2595 sym
->as
->rank
= expr
->rank
;
2598 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
2603 /* Generate a call to an external intrinsic function. */
2605 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2608 vec
<tree
, va_gc
> *append_args
;
2610 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2613 gcc_assert (expr
->rank
> 0);
2615 gcc_assert (expr
->rank
== 0);
2617 sym
= gfc_get_symbol_for_expr (expr
);
2619 /* Calls to libgfortran_matmul need to be appended special arguments,
2620 to be able to call the BLAS ?gemm functions if required and possible. */
2622 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2623 && sym
->ts
.type
!= BT_LOGICAL
)
2625 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2627 if (gfc_option
.flag_external_blas
2628 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2629 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
2633 if (sym
->ts
.type
== BT_REAL
)
2635 if (sym
->ts
.kind
== 4)
2636 gemm_fndecl
= gfor_fndecl_sgemm
;
2638 gemm_fndecl
= gfor_fndecl_dgemm
;
2642 if (sym
->ts
.kind
== 4)
2643 gemm_fndecl
= gfor_fndecl_cgemm
;
2645 gemm_fndecl
= gfor_fndecl_zgemm
;
2648 vec_alloc (append_args
, 3);
2649 append_args
->quick_push (build_int_cst (cint
, 1));
2650 append_args
->quick_push (build_int_cst (cint
,
2651 gfc_option
.blas_matmul_limit
));
2652 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
2657 vec_alloc (append_args
, 3);
2658 append_args
->quick_push (build_int_cst (cint
, 0));
2659 append_args
->quick_push (build_int_cst (cint
, 0));
2660 append_args
->quick_push (null_pointer_node
);
2664 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
2666 gfc_free_symbol (sym
);
2669 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2689 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2698 gfc_actual_arglist
*actual
;
2705 gfc_conv_intrinsic_funcall (se
, expr
);
2709 actual
= expr
->value
.function
.actual
;
2710 type
= gfc_typenode_for_spec (&expr
->ts
);
2711 /* Initialize the result. */
2712 resvar
= gfc_create_var (type
, "test");
2714 tmp
= convert (type
, boolean_true_node
);
2716 tmp
= convert (type
, boolean_false_node
);
2717 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2719 /* Walk the arguments. */
2720 arrayss
= gfc_walk_expr (actual
->expr
);
2721 gcc_assert (arrayss
!= gfc_ss_terminator
);
2723 /* Initialize the scalarizer. */
2724 gfc_init_loopinfo (&loop
);
2725 exit_label
= gfc_build_label_decl (NULL_TREE
);
2726 TREE_USED (exit_label
) = 1;
2727 gfc_add_ss_to_loop (&loop
, arrayss
);
2729 /* Initialize the loop. */
2730 gfc_conv_ss_startstride (&loop
);
2731 gfc_conv_loop_setup (&loop
, &expr
->where
);
2733 gfc_mark_ss_chain_used (arrayss
, 1);
2734 /* Generate the loop body. */
2735 gfc_start_scalarized_body (&loop
, &body
);
2737 /* If the condition matches then set the return value. */
2738 gfc_start_block (&block
);
2740 tmp
= convert (type
, boolean_false_node
);
2742 tmp
= convert (type
, boolean_true_node
);
2743 gfc_add_modify (&block
, resvar
, tmp
);
2745 /* And break out of the loop. */
2746 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2747 gfc_add_expr_to_block (&block
, tmp
);
2749 found
= gfc_finish_block (&block
);
2751 /* Check this element. */
2752 gfc_init_se (&arrayse
, NULL
);
2753 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2754 arrayse
.ss
= arrayss
;
2755 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2757 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2758 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
2759 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
2760 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
2761 gfc_add_expr_to_block (&body
, tmp
);
2762 gfc_add_block_to_block (&body
, &arrayse
.post
);
2764 gfc_trans_scalarizing_loops (&loop
, &body
);
2766 /* Add the exit label. */
2767 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2768 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2770 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2771 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2772 gfc_cleanup_loop (&loop
);
2777 /* COUNT(A) = Number of true elements in A. */
2779 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
2786 gfc_actual_arglist
*actual
;
2792 gfc_conv_intrinsic_funcall (se
, expr
);
2796 actual
= expr
->value
.function
.actual
;
2798 type
= gfc_typenode_for_spec (&expr
->ts
);
2799 /* Initialize the result. */
2800 resvar
= gfc_create_var (type
, "count");
2801 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
2803 /* Walk the arguments. */
2804 arrayss
= gfc_walk_expr (actual
->expr
);
2805 gcc_assert (arrayss
!= gfc_ss_terminator
);
2807 /* Initialize the scalarizer. */
2808 gfc_init_loopinfo (&loop
);
2809 gfc_add_ss_to_loop (&loop
, arrayss
);
2811 /* Initialize the loop. */
2812 gfc_conv_ss_startstride (&loop
);
2813 gfc_conv_loop_setup (&loop
, &expr
->where
);
2815 gfc_mark_ss_chain_used (arrayss
, 1);
2816 /* Generate the loop body. */
2817 gfc_start_scalarized_body (&loop
, &body
);
2819 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2820 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2821 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2823 gfc_init_se (&arrayse
, NULL
);
2824 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2825 arrayse
.ss
= arrayss
;
2826 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2827 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2828 build_empty_stmt (input_location
));
2830 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2831 gfc_add_expr_to_block (&body
, tmp
);
2832 gfc_add_block_to_block (&body
, &arrayse
.post
);
2834 gfc_trans_scalarizing_loops (&loop
, &body
);
2836 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2837 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2838 gfc_cleanup_loop (&loop
);
2844 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
2845 struct and return the corresponding loopinfo. */
2847 static gfc_loopinfo
*
2848 enter_nested_loop (gfc_se
*se
)
2850 se
->ss
= se
->ss
->nested_ss
;
2851 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
2853 return se
->ss
->loop
;
2857 /* Inline implementation of the sum and product intrinsics. */
2859 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2863 tree scale
= NULL_TREE
;
2868 gfc_loopinfo loop
, *ploop
;
2869 gfc_actual_arglist
*arg_array
, *arg_mask
;
2870 gfc_ss
*arrayss
= NULL
;
2871 gfc_ss
*maskss
= NULL
;
2875 gfc_expr
*arrayexpr
;
2880 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
2886 type
= gfc_typenode_for_spec (&expr
->ts
);
2887 /* Initialize the result. */
2888 resvar
= gfc_create_var (type
, "val");
2893 scale
= gfc_create_var (type
, "scale");
2894 gfc_add_modify (&se
->pre
, scale
,
2895 gfc_build_const (type
, integer_one_node
));
2896 tmp
= gfc_build_const (type
, integer_zero_node
);
2898 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2899 tmp
= gfc_build_const (type
, integer_zero_node
);
2900 else if (op
== NE_EXPR
)
2902 tmp
= convert (type
, boolean_false_node
);
2903 else if (op
== BIT_AND_EXPR
)
2904 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2905 type
, integer_one_node
));
2907 tmp
= gfc_build_const (type
, integer_one_node
);
2909 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2911 arg_array
= expr
->value
.function
.actual
;
2913 arrayexpr
= arg_array
->expr
;
2915 if (op
== NE_EXPR
|| norm2
)
2916 /* PARITY and NORM2. */
2920 arg_mask
= arg_array
->next
->next
;
2921 gcc_assert (arg_mask
!= NULL
);
2922 maskexpr
= arg_mask
->expr
;
2925 if (expr
->rank
== 0)
2927 /* Walk the arguments. */
2928 arrayss
= gfc_walk_expr (arrayexpr
);
2929 gcc_assert (arrayss
!= gfc_ss_terminator
);
2931 if (maskexpr
&& maskexpr
->rank
> 0)
2933 maskss
= gfc_walk_expr (maskexpr
);
2934 gcc_assert (maskss
!= gfc_ss_terminator
);
2939 /* Initialize the scalarizer. */
2940 gfc_init_loopinfo (&loop
);
2941 gfc_add_ss_to_loop (&loop
, arrayss
);
2942 if (maskexpr
&& maskexpr
->rank
> 0)
2943 gfc_add_ss_to_loop (&loop
, maskss
);
2945 /* Initialize the loop. */
2946 gfc_conv_ss_startstride (&loop
);
2947 gfc_conv_loop_setup (&loop
, &expr
->where
);
2949 gfc_mark_ss_chain_used (arrayss
, 1);
2950 if (maskexpr
&& maskexpr
->rank
> 0)
2951 gfc_mark_ss_chain_used (maskss
, 1);
2956 /* All the work has been done in the parent loops. */
2957 ploop
= enter_nested_loop (se
);
2961 /* Generate the loop body. */
2962 gfc_start_scalarized_body (ploop
, &body
);
2964 /* If we have a mask, only add this element if the mask is set. */
2965 if (maskexpr
&& maskexpr
->rank
> 0)
2967 gfc_init_se (&maskse
, parent_se
);
2968 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
2969 if (expr
->rank
== 0)
2971 gfc_conv_expr_val (&maskse
, maskexpr
);
2972 gfc_add_block_to_block (&body
, &maskse
.pre
);
2974 gfc_start_block (&block
);
2977 gfc_init_block (&block
);
2979 /* Do the actual summation/product. */
2980 gfc_init_se (&arrayse
, parent_se
);
2981 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
2982 if (expr
->rank
== 0)
2983 arrayse
.ss
= arrayss
;
2984 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2985 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2989 /* if (x (i) != 0.0)
2995 result = 1.0 + result * val * val;
3001 result += val * val;
3004 tree res1
, res2
, cond
, absX
, val
;
3005 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
3007 gfc_init_block (&ifblock1
);
3009 absX
= gfc_create_var (type
, "absX");
3010 gfc_add_modify (&ifblock1
, absX
,
3011 fold_build1_loc (input_location
, ABS_EXPR
, type
,
3013 val
= gfc_create_var (type
, "val");
3014 gfc_add_expr_to_block (&ifblock1
, val
);
3016 gfc_init_block (&ifblock2
);
3017 gfc_add_modify (&ifblock2
, val
,
3018 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
3020 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3021 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
3022 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
3023 gfc_build_const (type
, integer_one_node
));
3024 gfc_add_modify (&ifblock2
, resvar
, res1
);
3025 gfc_add_modify (&ifblock2
, scale
, absX
);
3026 res1
= gfc_finish_block (&ifblock2
);
3028 gfc_init_block (&ifblock3
);
3029 gfc_add_modify (&ifblock3
, val
,
3030 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
3032 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
3033 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
3034 gfc_add_modify (&ifblock3
, resvar
, res2
);
3035 res2
= gfc_finish_block (&ifblock3
);
3037 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
3039 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
3040 gfc_add_expr_to_block (&ifblock1
, tmp
);
3041 tmp
= gfc_finish_block (&ifblock1
);
3043 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3045 gfc_build_const (type
, integer_zero_node
));
3047 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
3048 gfc_add_expr_to_block (&block
, tmp
);
3052 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
3053 gfc_add_modify (&block
, resvar
, tmp
);
3056 gfc_add_block_to_block (&block
, &arrayse
.post
);
3058 if (maskexpr
&& maskexpr
->rank
> 0)
3060 /* We enclose the above in if (mask) {...} . */
3062 tmp
= gfc_finish_block (&block
);
3063 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3064 build_empty_stmt (input_location
));
3067 tmp
= gfc_finish_block (&block
);
3068 gfc_add_expr_to_block (&body
, tmp
);
3070 gfc_trans_scalarizing_loops (ploop
, &body
);
3072 /* For a scalar mask, enclose the loop in an if statement. */
3073 if (maskexpr
&& maskexpr
->rank
== 0)
3075 gfc_init_block (&block
);
3076 gfc_add_block_to_block (&block
, &ploop
->pre
);
3077 gfc_add_block_to_block (&block
, &ploop
->post
);
3078 tmp
= gfc_finish_block (&block
);
3082 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
3083 build_empty_stmt (input_location
));
3084 gfc_advance_se_ss_chain (se
);
3088 gcc_assert (expr
->rank
== 0);
3089 gfc_init_se (&maskse
, NULL
);
3090 gfc_conv_expr_val (&maskse
, maskexpr
);
3091 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3092 build_empty_stmt (input_location
));
3095 gfc_add_expr_to_block (&block
, tmp
);
3096 gfc_add_block_to_block (&se
->pre
, &block
);
3097 gcc_assert (se
->post
.head
== NULL
);
3101 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
3102 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
3105 if (expr
->rank
== 0)
3106 gfc_cleanup_loop (ploop
);
3110 /* result = scale * sqrt(result). */
3112 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
3113 resvar
= build_call_expr_loc (input_location
,
3115 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
3122 /* Inline implementation of the dot_product intrinsic. This function
3123 is based on gfc_conv_intrinsic_arith (the previous function). */
3125 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
3133 gfc_actual_arglist
*actual
;
3134 gfc_ss
*arrayss1
, *arrayss2
;
3135 gfc_se arrayse1
, arrayse2
;
3136 gfc_expr
*arrayexpr1
, *arrayexpr2
;
3138 type
= gfc_typenode_for_spec (&expr
->ts
);
3140 /* Initialize the result. */
3141 resvar
= gfc_create_var (type
, "val");
3142 if (expr
->ts
.type
== BT_LOGICAL
)
3143 tmp
= build_int_cst (type
, 0);
3145 tmp
= gfc_build_const (type
, integer_zero_node
);
3147 gfc_add_modify (&se
->pre
, resvar
, tmp
);
3149 /* Walk argument #1. */
3150 actual
= expr
->value
.function
.actual
;
3151 arrayexpr1
= actual
->expr
;
3152 arrayss1
= gfc_walk_expr (arrayexpr1
);
3153 gcc_assert (arrayss1
!= gfc_ss_terminator
);
3155 /* Walk argument #2. */
3156 actual
= actual
->next
;
3157 arrayexpr2
= actual
->expr
;
3158 arrayss2
= gfc_walk_expr (arrayexpr2
);
3159 gcc_assert (arrayss2
!= gfc_ss_terminator
);
3161 /* Initialize the scalarizer. */
3162 gfc_init_loopinfo (&loop
);
3163 gfc_add_ss_to_loop (&loop
, arrayss1
);
3164 gfc_add_ss_to_loop (&loop
, arrayss2
);
3166 /* Initialize the loop. */
3167 gfc_conv_ss_startstride (&loop
);
3168 gfc_conv_loop_setup (&loop
, &expr
->where
);
3170 gfc_mark_ss_chain_used (arrayss1
, 1);
3171 gfc_mark_ss_chain_used (arrayss2
, 1);
3173 /* Generate the loop body. */
3174 gfc_start_scalarized_body (&loop
, &body
);
3175 gfc_init_block (&block
);
3177 /* Make the tree expression for [conjg(]array1[)]. */
3178 gfc_init_se (&arrayse1
, NULL
);
3179 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
3180 arrayse1
.ss
= arrayss1
;
3181 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
3182 if (expr
->ts
.type
== BT_COMPLEX
)
3183 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
3185 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
3187 /* Make the tree expression for array2. */
3188 gfc_init_se (&arrayse2
, NULL
);
3189 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
3190 arrayse2
.ss
= arrayss2
;
3191 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
3192 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
3194 /* Do the actual product and sum. */
3195 if (expr
->ts
.type
== BT_LOGICAL
)
3197 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
3198 arrayse1
.expr
, arrayse2
.expr
);
3199 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
3203 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
3205 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
3207 gfc_add_modify (&block
, resvar
, tmp
);
3209 /* Finish up the loop block and the loop. */
3210 tmp
= gfc_finish_block (&block
);
3211 gfc_add_expr_to_block (&body
, tmp
);
3213 gfc_trans_scalarizing_loops (&loop
, &body
);
3214 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3215 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3216 gfc_cleanup_loop (&loop
);
3222 /* Emit code for minloc or maxloc intrinsic. There are many different cases
3223 we need to handle. For performance reasons we sometimes create two
3224 loops instead of one, where the second one is much simpler.
3225 Examples for minloc intrinsic:
3226 1) Result is an array, a call is generated
3227 2) Array mask is used and NaNs need to be supported:
3233 if (pos == 0) pos = S + (1 - from);
3234 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3241 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3245 3) NaNs need to be supported, but it is known at compile time or cheaply
3246 at runtime whether array is nonempty or not:
3251 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3254 if (from <= to) pos = 1;
3258 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3262 4) NaNs aren't supported, array mask is used:
3263 limit = infinities_supported ? Infinity : huge (limit);
3267 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3273 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3277 5) Same without array mask:
3278 limit = infinities_supported ? Infinity : huge (limit);
3279 pos = (from <= to) ? 1 : 0;
3282 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3285 For 3) and 5), if mask is scalar, this all goes into a conditional,
3286 setting pos = 0; in the else branch. */
3289 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3293 stmtblock_t ifblock
;
3294 stmtblock_t elseblock
;
3305 gfc_actual_arglist
*actual
;
3310 gfc_expr
*arrayexpr
;
3317 gfc_conv_intrinsic_funcall (se
, expr
);
3321 /* Initialize the result. */
3322 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3323 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3324 type
= gfc_typenode_for_spec (&expr
->ts
);
3326 /* Walk the arguments. */
3327 actual
= expr
->value
.function
.actual
;
3328 arrayexpr
= actual
->expr
;
3329 arrayss
= gfc_walk_expr (arrayexpr
);
3330 gcc_assert (arrayss
!= gfc_ss_terminator
);
3332 actual
= actual
->next
->next
;
3333 gcc_assert (actual
);
3334 maskexpr
= actual
->expr
;
3336 if (maskexpr
&& maskexpr
->rank
!= 0)
3338 maskss
= gfc_walk_expr (maskexpr
);
3339 gcc_assert (maskss
!= gfc_ss_terminator
);
3344 if (gfc_array_size (arrayexpr
, &asize
))
3346 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3348 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3349 boolean_type_node
, nonempty
,
3350 gfc_index_zero_node
);
3355 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3356 switch (arrayexpr
->ts
.type
)
3359 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3363 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3364 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3365 arrayexpr
->ts
.kind
);
3372 /* We start with the most negative possible value for MAXLOC, and the most
3373 positive possible value for MINLOC. The most negative possible value is
3374 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3375 possible value is HUGE in both cases. */
3377 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3378 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3379 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3380 build_int_cst (type
, 1));
3382 gfc_add_modify (&se
->pre
, limit
, tmp
);
3384 /* Initialize the scalarizer. */
3385 gfc_init_loopinfo (&loop
);
3386 gfc_add_ss_to_loop (&loop
, arrayss
);
3388 gfc_add_ss_to_loop (&loop
, maskss
);
3390 /* Initialize the loop. */
3391 gfc_conv_ss_startstride (&loop
);
3393 /* The code generated can have more than one loop in sequence (see the
3394 comment at the function header). This doesn't work well with the
3395 scalarizer, which changes arrays' offset when the scalarization loops
3396 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3397 are currently inlined in the scalar case only (for which loop is of rank
3398 one). As there is no dependency to care about in that case, there is no
3399 temporary, so that we can use the scalarizer temporary code to handle
3400 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3401 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3403 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3404 should eventually go away. We could either create two loops properly,
3405 or find another way to save/restore the array offsets between the two
3406 loops (without conflicting with temporary management), or use a single
3407 loop minmaxloc implementation. See PR 31067. */
3408 loop
.temp_dim
= loop
.dimen
;
3409 gfc_conv_loop_setup (&loop
, &expr
->where
);
3411 gcc_assert (loop
.dimen
== 1);
3412 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3413 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3414 loop
.from
[0], loop
.to
[0]);
3418 /* Initialize the position to zero, following Fortran 2003. We are free
3419 to do this because Fortran 95 allows the result of an entirely false
3420 mask to be processor dependent. If we know at compile time the array
3421 is non-empty and no MASK is used, we can initialize to 1 to simplify
3423 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3424 gfc_add_modify (&loop
.pre
, pos
,
3425 fold_build3_loc (input_location
, COND_EXPR
,
3426 gfc_array_index_type
,
3427 nonempty
, gfc_index_one_node
,
3428 gfc_index_zero_node
));
3431 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3432 lab1
= gfc_build_label_decl (NULL_TREE
);
3433 TREE_USED (lab1
) = 1;
3434 lab2
= gfc_build_label_decl (NULL_TREE
);
3435 TREE_USED (lab2
) = 1;
3438 /* An offset must be added to the loop
3439 counter to obtain the required position. */
3440 gcc_assert (loop
.from
[0]);
3442 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3443 gfc_index_one_node
, loop
.from
[0]);
3444 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3446 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3448 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3449 /* Generate the loop body. */
3450 gfc_start_scalarized_body (&loop
, &body
);
3452 /* If we have a mask, only check this element if the mask is set. */
3455 gfc_init_se (&maskse
, NULL
);
3456 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3458 gfc_conv_expr_val (&maskse
, maskexpr
);
3459 gfc_add_block_to_block (&body
, &maskse
.pre
);
3461 gfc_start_block (&block
);
3464 gfc_init_block (&block
);
3466 /* Compare with the current limit. */
3467 gfc_init_se (&arrayse
, NULL
);
3468 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3469 arrayse
.ss
= arrayss
;
3470 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3471 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3473 /* We do the following if this is a more extreme value. */
3474 gfc_start_block (&ifblock
);
3476 /* Assign the value to the limit... */
3477 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3479 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3481 stmtblock_t ifblock2
;
3484 gfc_start_block (&ifblock2
);
3485 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3486 loop
.loopvar
[0], offset
);
3487 gfc_add_modify (&ifblock2
, pos
, tmp
);
3488 ifbody2
= gfc_finish_block (&ifblock2
);
3489 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3490 gfc_index_zero_node
);
3491 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3492 build_empty_stmt (input_location
));
3493 gfc_add_expr_to_block (&block
, tmp
);
3496 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3497 loop
.loopvar
[0], offset
);
3498 gfc_add_modify (&ifblock
, pos
, tmp
);
3501 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3503 ifbody
= gfc_finish_block (&ifblock
);
3505 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3508 cond
= fold_build2_loc (input_location
,
3509 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3510 boolean_type_node
, arrayse
.expr
, limit
);
3512 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3513 arrayse
.expr
, limit
);
3515 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3516 build_empty_stmt (input_location
));
3518 gfc_add_expr_to_block (&block
, ifbody
);
3522 /* We enclose the above in if (mask) {...}. */
3523 tmp
= gfc_finish_block (&block
);
3525 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3526 build_empty_stmt (input_location
));
3529 tmp
= gfc_finish_block (&block
);
3530 gfc_add_expr_to_block (&body
, tmp
);
3534 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3536 if (HONOR_NANS (DECL_MODE (limit
)))
3538 if (nonempty
!= NULL
)
3540 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3541 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3542 build_empty_stmt (input_location
));
3543 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3547 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3548 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3550 /* If we have a mask, only check this element if the mask is set. */
3553 gfc_init_se (&maskse
, NULL
);
3554 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3556 gfc_conv_expr_val (&maskse
, maskexpr
);
3557 gfc_add_block_to_block (&body
, &maskse
.pre
);
3559 gfc_start_block (&block
);
3562 gfc_init_block (&block
);
3564 /* Compare with the current limit. */
3565 gfc_init_se (&arrayse
, NULL
);
3566 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3567 arrayse
.ss
= arrayss
;
3568 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3569 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3571 /* We do the following if this is a more extreme value. */
3572 gfc_start_block (&ifblock
);
3574 /* Assign the value to the limit... */
3575 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3577 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3578 loop
.loopvar
[0], offset
);
3579 gfc_add_modify (&ifblock
, pos
, tmp
);
3581 ifbody
= gfc_finish_block (&ifblock
);
3583 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3584 arrayse
.expr
, limit
);
3586 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3587 build_empty_stmt (input_location
));
3588 gfc_add_expr_to_block (&block
, tmp
);
3592 /* We enclose the above in if (mask) {...}. */
3593 tmp
= gfc_finish_block (&block
);
3595 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3596 build_empty_stmt (input_location
));
3599 tmp
= gfc_finish_block (&block
);
3600 gfc_add_expr_to_block (&body
, tmp
);
3601 /* Avoid initializing loopvar[0] again, it should be left where
3602 it finished by the first loop. */
3603 loop
.from
[0] = loop
.loopvar
[0];
3606 gfc_trans_scalarizing_loops (&loop
, &body
);
3609 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3611 /* For a scalar mask, enclose the loop in an if statement. */
3612 if (maskexpr
&& maskss
== NULL
)
3614 gfc_init_se (&maskse
, NULL
);
3615 gfc_conv_expr_val (&maskse
, maskexpr
);
3616 gfc_init_block (&block
);
3617 gfc_add_block_to_block (&block
, &loop
.pre
);
3618 gfc_add_block_to_block (&block
, &loop
.post
);
3619 tmp
= gfc_finish_block (&block
);
3621 /* For the else part of the scalar mask, just initialize
3622 the pos variable the same way as above. */
3624 gfc_init_block (&elseblock
);
3625 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3626 elsetmp
= gfc_finish_block (&elseblock
);
3628 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3629 gfc_add_expr_to_block (&block
, tmp
);
3630 gfc_add_block_to_block (&se
->pre
, &block
);
3634 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3635 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3637 gfc_cleanup_loop (&loop
);
3639 se
->expr
= convert (type
, pos
);
3642 /* Emit code for minval or maxval intrinsic. There are many different cases
3643 we need to handle. For performance reasons we sometimes create two
3644 loops instead of one, where the second one is much simpler.
3645 Examples for minval intrinsic:
3646 1) Result is an array, a call is generated
3647 2) Array mask is used and NaNs need to be supported, rank 1:
3652 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3655 limit = nonempty ? NaN : huge (limit);
3657 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3658 3) NaNs need to be supported, but it is known at compile time or cheaply
3659 at runtime whether array is nonempty or not, rank 1:
3662 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3663 limit = (from <= to) ? NaN : huge (limit);
3665 while (S <= to) { limit = min (a[S], limit); S++; }
3666 4) Array mask is used and NaNs need to be supported, rank > 1:
3675 if (fast) limit = min (a[S1][S2], limit);
3678 if (a[S1][S2] <= limit) {
3689 limit = nonempty ? NaN : huge (limit);
3690 5) NaNs need to be supported, but it is known at compile time or cheaply
3691 at runtime whether array is nonempty or not, rank > 1:
3698 if (fast) limit = min (a[S1][S2], limit);
3700 if (a[S1][S2] <= limit) {
3710 limit = (nonempty_array) ? NaN : huge (limit);
3711 6) NaNs aren't supported, but infinities are. Array mask is used:
3716 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3719 limit = nonempty ? limit : huge (limit);
3720 7) Same without array mask:
3723 while (S <= to) { limit = min (a[S], limit); S++; }
3724 limit = (from <= to) ? limit : huge (limit);
3725 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3726 limit = huge (limit);
3728 while (S <= to) { limit = min (a[S], limit); S++); }
3730 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3731 with array mask instead).
3732 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3733 setting limit = huge (limit); in the else branch. */
3736 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3746 tree huge_cst
= NULL
, nan_cst
= NULL
;
3748 stmtblock_t block
, block2
;
3750 gfc_actual_arglist
*actual
;
3755 gfc_expr
*arrayexpr
;
3761 gfc_conv_intrinsic_funcall (se
, expr
);
3765 type
= gfc_typenode_for_spec (&expr
->ts
);
3766 /* Initialize the result. */
3767 limit
= gfc_create_var (type
, "limit");
3768 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
3769 switch (expr
->ts
.type
)
3772 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
3774 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3776 REAL_VALUE_TYPE real
;
3778 tmp
= build_real (type
, real
);
3782 if (HONOR_NANS (DECL_MODE (limit
)))
3784 REAL_VALUE_TYPE real
;
3785 real_nan (&real
, "", 1, DECL_MODE (limit
));
3786 nan_cst
= build_real (type
, real
);
3791 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
3798 /* We start with the most negative possible value for MAXVAL, and the most
3799 positive possible value for MINVAL. The most negative possible value is
3800 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3801 possible value is HUGE in both cases. */
3804 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3806 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
3807 TREE_TYPE (huge_cst
), huge_cst
);
3810 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3811 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
3812 tmp
, build_int_cst (type
, 1));
3814 gfc_add_modify (&se
->pre
, limit
, tmp
);
3816 /* Walk the arguments. */
3817 actual
= expr
->value
.function
.actual
;
3818 arrayexpr
= actual
->expr
;
3819 arrayss
= gfc_walk_expr (arrayexpr
);
3820 gcc_assert (arrayss
!= gfc_ss_terminator
);
3822 actual
= actual
->next
->next
;
3823 gcc_assert (actual
);
3824 maskexpr
= actual
->expr
;
3826 if (maskexpr
&& maskexpr
->rank
!= 0)
3828 maskss
= gfc_walk_expr (maskexpr
);
3829 gcc_assert (maskss
!= gfc_ss_terminator
);
3834 if (gfc_array_size (arrayexpr
, &asize
))
3836 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3838 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3839 boolean_type_node
, nonempty
,
3840 gfc_index_zero_node
);
3845 /* Initialize the scalarizer. */
3846 gfc_init_loopinfo (&loop
);
3847 gfc_add_ss_to_loop (&loop
, arrayss
);
3849 gfc_add_ss_to_loop (&loop
, maskss
);
3851 /* Initialize the loop. */
3852 gfc_conv_ss_startstride (&loop
);
3854 /* The code generated can have more than one loop in sequence (see the
3855 comment at the function header). This doesn't work well with the
3856 scalarizer, which changes arrays' offset when the scalarization loops
3857 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3858 are currently inlined in the scalar case only. As there is no dependency
3859 to care about in that case, there is no temporary, so that we can use the
3860 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3861 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3862 gfc_trans_scalarized_loop_boundary even later to restore offset.
3863 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3864 should eventually go away. We could either create two loops properly,
3865 or find another way to save/restore the array offsets between the two
3866 loops (without conflicting with temporary management), or use a single
3867 loop minmaxval implementation. See PR 31067. */
3868 loop
.temp_dim
= loop
.dimen
;
3869 gfc_conv_loop_setup (&loop
, &expr
->where
);
3871 if (nonempty
== NULL
&& maskss
== NULL
3872 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
3873 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3874 loop
.from
[0], loop
.to
[0]);
3875 nonempty_var
= NULL
;
3876 if (nonempty
== NULL
3877 && (HONOR_INFINITIES (DECL_MODE (limit
))
3878 || HONOR_NANS (DECL_MODE (limit
))))
3880 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3881 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3882 nonempty
= nonempty_var
;
3886 if (HONOR_NANS (DECL_MODE (limit
)))
3888 if (loop
.dimen
== 1)
3890 lab
= gfc_build_label_decl (NULL_TREE
);
3891 TREE_USED (lab
) = 1;
3895 fast
= gfc_create_var (boolean_type_node
, "fast");
3896 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3900 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
3902 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
3903 /* Generate the loop body. */
3904 gfc_start_scalarized_body (&loop
, &body
);
3906 /* If we have a mask, only add this element if the mask is set. */
3909 gfc_init_se (&maskse
, NULL
);
3910 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3912 gfc_conv_expr_val (&maskse
, maskexpr
);
3913 gfc_add_block_to_block (&body
, &maskse
.pre
);
3915 gfc_start_block (&block
);
3918 gfc_init_block (&block
);
3920 /* Compare with the current limit. */
3921 gfc_init_se (&arrayse
, NULL
);
3922 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3923 arrayse
.ss
= arrayss
;
3924 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3925 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3927 gfc_init_block (&block2
);
3930 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3932 if (HONOR_NANS (DECL_MODE (limit
)))
3934 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3935 boolean_type_node
, arrayse
.expr
, limit
);
3937 ifbody
= build1_v (GOTO_EXPR
, lab
);
3940 stmtblock_t ifblock
;
3942 gfc_init_block (&ifblock
);
3943 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3944 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3945 ifbody
= gfc_finish_block (&ifblock
);
3947 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3948 build_empty_stmt (input_location
));
3949 gfc_add_expr_to_block (&block2
, tmp
);
3953 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3955 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3957 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3958 arrayse
.expr
, limit
);
3959 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3960 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3961 build_empty_stmt (input_location
));
3962 gfc_add_expr_to_block (&block2
, tmp
);
3966 tmp
= fold_build2_loc (input_location
,
3967 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3968 type
, arrayse
.expr
, limit
);
3969 gfc_add_modify (&block2
, limit
, tmp
);
3975 tree elsebody
= gfc_finish_block (&block2
);
3977 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3979 if (HONOR_NANS (DECL_MODE (limit
))
3980 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3982 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3983 arrayse
.expr
, limit
);
3984 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3985 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3986 build_empty_stmt (input_location
));
3990 tmp
= fold_build2_loc (input_location
,
3991 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3992 type
, arrayse
.expr
, limit
);
3993 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3995 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3996 gfc_add_expr_to_block (&block
, tmp
);
3999 gfc_add_block_to_block (&block
, &block2
);
4001 gfc_add_block_to_block (&block
, &arrayse
.post
);
4003 tmp
= gfc_finish_block (&block
);
4005 /* We enclose the above in if (mask) {...}. */
4006 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4007 build_empty_stmt (input_location
));
4008 gfc_add_expr_to_block (&body
, tmp
);
4012 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4014 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4016 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
4017 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
4019 /* If we have a mask, only add this element if the mask is set. */
4022 gfc_init_se (&maskse
, NULL
);
4023 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
4025 gfc_conv_expr_val (&maskse
, maskexpr
);
4026 gfc_add_block_to_block (&body
, &maskse
.pre
);
4028 gfc_start_block (&block
);
4031 gfc_init_block (&block
);
4033 /* Compare with the current limit. */
4034 gfc_init_se (&arrayse
, NULL
);
4035 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
4036 arrayse
.ss
= arrayss
;
4037 gfc_conv_expr_val (&arrayse
, arrayexpr
);
4038 gfc_add_block_to_block (&block
, &arrayse
.pre
);
4040 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
4042 if (HONOR_NANS (DECL_MODE (limit
))
4043 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
4045 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4046 arrayse
.expr
, limit
);
4047 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
4048 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
4049 build_empty_stmt (input_location
));
4050 gfc_add_expr_to_block (&block
, tmp
);
4054 tmp
= fold_build2_loc (input_location
,
4055 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
4056 type
, arrayse
.expr
, limit
);
4057 gfc_add_modify (&block
, limit
, tmp
);
4060 gfc_add_block_to_block (&block
, &arrayse
.post
);
4062 tmp
= gfc_finish_block (&block
);
4064 /* We enclose the above in if (mask) {...}. */
4065 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
4066 build_empty_stmt (input_location
));
4067 gfc_add_expr_to_block (&body
, tmp
);
4068 /* Avoid initializing loopvar[0] again, it should be left where
4069 it finished by the first loop. */
4070 loop
.from
[0] = loop
.loopvar
[0];
4072 gfc_trans_scalarizing_loops (&loop
, &body
);
4076 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
4078 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
4079 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
4081 gfc_add_expr_to_block (&loop
.pre
, tmp
);
4083 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
4085 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
4087 gfc_add_modify (&loop
.pre
, limit
, tmp
);
4090 /* For a scalar mask, enclose the loop in an if statement. */
4091 if (maskexpr
&& maskss
== NULL
)
4095 gfc_init_se (&maskse
, NULL
);
4096 gfc_conv_expr_val (&maskse
, maskexpr
);
4097 gfc_init_block (&block
);
4098 gfc_add_block_to_block (&block
, &loop
.pre
);
4099 gfc_add_block_to_block (&block
, &loop
.post
);
4100 tmp
= gfc_finish_block (&block
);
4102 if (HONOR_INFINITIES (DECL_MODE (limit
)))
4103 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
4105 else_stmt
= build_empty_stmt (input_location
);
4106 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
4107 gfc_add_expr_to_block (&block
, tmp
);
4108 gfc_add_block_to_block (&se
->pre
, &block
);
4112 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
4113 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
4116 gfc_cleanup_loop (&loop
);
4121 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
4123 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
4129 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4130 type
= TREE_TYPE (args
[0]);
4132 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4133 build_int_cst (type
, 1), args
[1]);
4134 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
4135 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
4136 build_int_cst (type
, 0));
4137 type
= gfc_typenode_for_spec (&expr
->ts
);
4138 se
->expr
= convert (type
, tmp
);
4142 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
4144 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4148 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4150 /* Convert both arguments to the unsigned type of the same size. */
4151 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
4152 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
4154 /* If they have unequal type size, convert to the larger one. */
4155 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
4156 > TYPE_PRECISION (TREE_TYPE (args
[1])))
4157 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
4158 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
4159 > TYPE_PRECISION (TREE_TYPE (args
[0])))
4160 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
4162 /* Now, we compare them. */
4163 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
4168 /* Generate code to perform the specified operation. */
4170 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4174 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4175 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
4181 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
4185 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4186 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4187 TREE_TYPE (arg
), arg
);
4190 /* Set or clear a single bit. */
4192 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
4199 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4200 type
= TREE_TYPE (args
[0]);
4202 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
4203 build_int_cst (type
, 1), args
[1]);
4209 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
4211 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
4214 /* Extract a sequence of bits.
4215 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
4217 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
4224 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4225 type
= TREE_TYPE (args
[0]);
4227 mask
= build_int_cst (type
, -1);
4228 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
4229 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
4231 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
4233 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4237 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4240 tree args
[2], type
, num_bits
, cond
;
4242 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4244 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4245 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4246 type
= TREE_TYPE (args
[0]);
4249 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4251 gcc_assert (right_shift
);
4253 se
->expr
= fold_build2_loc (input_location
,
4254 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4255 TREE_TYPE (args
[0]), args
[0], args
[1]);
4258 se
->expr
= fold_convert (type
, se
->expr
);
4260 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4261 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4263 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4264 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4267 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4268 build_int_cst (type
, 0), se
->expr
);
4271 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4273 : ((shift >= 0) ? i << shift : i >> -shift)
4274 where all shifts are logical shifts. */
4276 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4288 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4290 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4291 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4293 type
= TREE_TYPE (args
[0]);
4294 utype
= unsigned_type_for (type
);
4296 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4299 /* Left shift if positive. */
4300 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4302 /* Right shift if negative.
4303 We convert to an unsigned type because we want a logical shift.
4304 The standard doesn't define the case of shifting negative
4305 numbers, and we try to be compatible with other compilers, most
4306 notably g77, here. */
4307 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4308 utype
, convert (utype
, args
[0]), width
));
4310 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4311 build_int_cst (TREE_TYPE (args
[1]), 0));
4312 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4314 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4315 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4317 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4318 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4320 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4321 build_int_cst (type
, 0), tmp
);
4325 /* Circular shift. AKA rotate or barrel shift. */
4328 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4336 unsigned int num_args
;
4338 num_args
= gfc_intrinsic_argument_list_length (expr
);
4339 args
= XALLOCAVEC (tree
, num_args
);
4341 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4345 /* Use a library function for the 3 parameter version. */
4346 tree int4type
= gfc_get_int_type (4);
4348 type
= TREE_TYPE (args
[0]);
4349 /* We convert the first argument to at least 4 bytes, and
4350 convert back afterwards. This removes the need for library
4351 functions for all argument sizes, and function will be
4352 aligned to at least 32 bits, so there's no loss. */
4353 if (expr
->ts
.kind
< 4)
4354 args
[0] = convert (int4type
, args
[0]);
4356 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4357 need loads of library functions. They cannot have values >
4358 BIT_SIZE (I) so the conversion is safe. */
4359 args
[1] = convert (int4type
, args
[1]);
4360 args
[2] = convert (int4type
, args
[2]);
4362 switch (expr
->ts
.kind
)
4367 tmp
= gfor_fndecl_math_ishftc4
;
4370 tmp
= gfor_fndecl_math_ishftc8
;
4373 tmp
= gfor_fndecl_math_ishftc16
;
4378 se
->expr
= build_call_expr_loc (input_location
,
4379 tmp
, 3, args
[0], args
[1], args
[2]);
4380 /* Convert the result back to the original type, if we extended
4381 the first argument's width above. */
4382 if (expr
->ts
.kind
< 4)
4383 se
->expr
= convert (type
, se
->expr
);
4387 type
= TREE_TYPE (args
[0]);
4389 /* Evaluate arguments only once. */
4390 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4391 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4393 /* Rotate left if positive. */
4394 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4396 /* Rotate right if negative. */
4397 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4399 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4401 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4402 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4404 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4406 /* Do nothing if shift == 0. */
4407 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4409 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4414 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4415 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4417 The conditional expression is necessary because the result of LEADZ(0)
4418 is defined, but the result of __builtin_clz(0) is undefined for most
4421 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4422 difference in bit size between the argument of LEADZ and the C int. */
4425 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4437 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4438 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4440 /* Which variant of __builtin_clz* should we call? */
4441 if (argsize
<= INT_TYPE_SIZE
)
4443 arg_type
= unsigned_type_node
;
4444 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4446 else if (argsize
<= LONG_TYPE_SIZE
)
4448 arg_type
= long_unsigned_type_node
;
4449 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4451 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4453 arg_type
= long_long_unsigned_type_node
;
4454 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4458 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4459 arg_type
= gfc_build_uint_type (argsize
);
4463 /* Convert the actual argument twice: first, to the unsigned type of the
4464 same size; then, to the proper argument type for the built-in
4465 function. But the return type is of the default INTEGER kind. */
4466 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4467 arg
= fold_convert (arg_type
, arg
);
4468 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4469 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4471 /* Compute LEADZ for the case i .ne. 0. */
4474 s
= TYPE_PRECISION (arg_type
) - argsize
;
4475 tmp
= fold_convert (result_type
,
4476 build_call_expr_loc (input_location
, func
,
4478 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4479 tmp
, build_int_cst (result_type
, s
));
4483 /* We end up here if the argument type is larger than 'long long'.
4484 We generate this code:
4486 if (x & (ULL_MAX << ULL_SIZE) != 0)
4487 return clzll ((unsigned long long) (x >> ULLSIZE));
4489 return ULL_SIZE + clzll ((unsigned long long) x);
4490 where ULL_MAX is the largest value that a ULL_MAX can hold
4491 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4492 is the bit-size of the long long type (64 in this example). */
4493 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4495 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4496 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4497 long_long_unsigned_type_node
,
4498 build_int_cst (long_long_unsigned_type_node
,
4501 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4502 fold_convert (arg_type
, ullmax
), ullsize
);
4503 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4505 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4506 cond
, build_int_cst (arg_type
, 0));
4508 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4510 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4511 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4512 tmp1
= fold_convert (result_type
,
4513 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4515 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4516 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4517 tmp2
= fold_convert (result_type
,
4518 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4519 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4522 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4526 /* Build BIT_SIZE. */
4527 bit_size
= build_int_cst (result_type
, argsize
);
4529 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4530 arg
, build_int_cst (arg_type
, 0));
4531 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4536 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4538 The conditional expression is necessary because the result of TRAILZ(0)
4539 is defined, but the result of __builtin_ctz(0) is undefined for most
4543 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4554 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4555 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4557 /* Which variant of __builtin_ctz* should we call? */
4558 if (argsize
<= INT_TYPE_SIZE
)
4560 arg_type
= unsigned_type_node
;
4561 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4563 else if (argsize
<= LONG_TYPE_SIZE
)
4565 arg_type
= long_unsigned_type_node
;
4566 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4568 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4570 arg_type
= long_long_unsigned_type_node
;
4571 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4575 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4576 arg_type
= gfc_build_uint_type (argsize
);
4580 /* Convert the actual argument twice: first, to the unsigned type of the
4581 same size; then, to the proper argument type for the built-in
4582 function. But the return type is of the default INTEGER kind. */
4583 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4584 arg
= fold_convert (arg_type
, arg
);
4585 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4586 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4588 /* Compute TRAILZ for the case i .ne. 0. */
4590 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4594 /* We end up here if the argument type is larger than 'long long'.
4595 We generate this code:
4597 if ((x & ULL_MAX) == 0)
4598 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4600 return ctzll ((unsigned long long) x);
4602 where ULL_MAX is the largest value that a ULL_MAX can hold
4603 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4604 is the bit-size of the long long type (64 in this example). */
4605 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4607 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4608 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4609 long_long_unsigned_type_node
,
4610 build_int_cst (long_long_unsigned_type_node
, 0));
4612 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4613 fold_convert (arg_type
, ullmax
));
4614 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4615 build_int_cst (arg_type
, 0));
4617 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4619 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4620 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4621 tmp1
= fold_convert (result_type
,
4622 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4623 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4626 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4627 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4628 tmp2
= fold_convert (result_type
,
4629 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4631 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4635 /* Build BIT_SIZE. */
4636 bit_size
= build_int_cst (result_type
, argsize
);
4638 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4639 arg
, build_int_cst (arg_type
, 0));
4640 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4644 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4645 for types larger than "long long", we call the long long built-in for
4646 the lower and higher bits and combine the result. */
4649 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
4657 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4658 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4659 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4661 /* Which variant of the builtin should we call? */
4662 if (argsize
<= INT_TYPE_SIZE
)
4664 arg_type
= unsigned_type_node
;
4665 func
= builtin_decl_explicit (parity
4667 : BUILT_IN_POPCOUNT
);
4669 else if (argsize
<= LONG_TYPE_SIZE
)
4671 arg_type
= long_unsigned_type_node
;
4672 func
= builtin_decl_explicit (parity
4674 : BUILT_IN_POPCOUNTL
);
4676 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4678 arg_type
= long_long_unsigned_type_node
;
4679 func
= builtin_decl_explicit (parity
4681 : BUILT_IN_POPCOUNTLL
);
4685 /* Our argument type is larger than 'long long', which mean none
4686 of the POPCOUNT builtins covers it. We thus call the 'long long'
4687 variant multiple times, and add the results. */
4688 tree utype
, arg2
, call1
, call2
;
4690 /* For now, we only cover the case where argsize is twice as large
4692 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4694 func
= builtin_decl_explicit (parity
4696 : BUILT_IN_POPCOUNTLL
);
4698 /* Convert it to an integer, and store into a variable. */
4699 utype
= gfc_build_uint_type (argsize
);
4700 arg
= fold_convert (utype
, arg
);
4701 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4703 /* Call the builtin twice. */
4704 call1
= build_call_expr_loc (input_location
, func
, 1,
4705 fold_convert (long_long_unsigned_type_node
,
4708 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
4709 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
4710 call2
= build_call_expr_loc (input_location
, func
, 1,
4711 fold_convert (long_long_unsigned_type_node
,
4714 /* Combine the results. */
4716 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
4719 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4725 /* Convert the actual argument twice: first, to the unsigned type of the
4726 same size; then, to the proper argument type for the built-in
4728 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4729 arg
= fold_convert (arg_type
, arg
);
4731 se
->expr
= fold_convert (result_type
,
4732 build_call_expr_loc (input_location
, func
, 1, arg
));
4736 /* Process an intrinsic with unspecified argument-types that has an optional
4737 argument (which could be of type character), e.g. EOSHIFT. For those, we
4738 need to append the string length of the optional argument if it is not
4739 present and the type is really character.
4740 primary specifies the position (starting at 1) of the non-optional argument
4741 specifying the type and optional gives the position of the optional
4742 argument in the arglist. */
4745 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
4746 unsigned primary
, unsigned optional
)
4748 gfc_actual_arglist
* prim_arg
;
4749 gfc_actual_arglist
* opt_arg
;
4751 gfc_actual_arglist
* arg
;
4753 vec
<tree
, va_gc
> *append_args
;
4755 /* Find the two arguments given as position. */
4759 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4763 if (cur_pos
== primary
)
4765 if (cur_pos
== optional
)
4768 if (cur_pos
>= primary
&& cur_pos
>= optional
)
4771 gcc_assert (prim_arg
);
4772 gcc_assert (prim_arg
->expr
);
4773 gcc_assert (opt_arg
);
4775 /* If we do have type CHARACTER and the optional argument is really absent,
4776 append a dummy 0 as string length. */
4778 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
4782 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
4783 vec_alloc (append_args
, 1);
4784 append_args
->quick_push (dummy
);
4787 /* Build the call itself. */
4788 sym
= gfc_get_symbol_for_expr (expr
);
4789 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4791 gfc_free_symbol (sym
);
4795 /* The length of a character string. */
4797 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
4806 gcc_assert (!se
->ss
);
4808 arg
= expr
->value
.function
.actual
->expr
;
4810 type
= gfc_typenode_for_spec (&expr
->ts
);
4811 switch (arg
->expr_type
)
4814 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
4818 /* Obtain the string length from the function used by
4819 trans-array.c(gfc_trans_array_constructor). */
4821 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
4825 if (arg
->ref
== NULL
4826 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
4828 /* This doesn't catch all cases.
4829 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4830 and the surrounding thread. */
4831 sym
= arg
->symtree
->n
.sym
;
4832 decl
= gfc_get_symbol_decl (sym
);
4833 if (decl
== current_function_decl
&& sym
->attr
.function
4834 && (sym
->result
== sym
))
4835 decl
= gfc_get_fake_result_decl (sym
, 0);
4837 len
= sym
->ts
.u
.cl
->backend_decl
;
4842 /* Otherwise fall through. */
4845 /* Anybody stupid enough to do this deserves inefficient code. */
4846 gfc_init_se (&argse
, se
);
4848 gfc_conv_expr (&argse
, arg
);
4850 gfc_conv_expr_descriptor (&argse
, arg
);
4851 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4852 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4853 len
= argse
.string_length
;
4856 se
->expr
= convert (type
, len
);
4859 /* The length of a character string not including trailing blanks. */
4861 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
4863 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4864 tree args
[2], type
, fndecl
;
4866 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4867 type
= gfc_typenode_for_spec (&expr
->ts
);
4870 fndecl
= gfor_fndecl_string_len_trim
;
4872 fndecl
= gfor_fndecl_string_len_trim_char4
;
4876 se
->expr
= build_call_expr_loc (input_location
,
4877 fndecl
, 2, args
[0], args
[1]);
4878 se
->expr
= convert (type
, se
->expr
);
4882 /* Returns the starting position of a substring within a string. */
4885 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4888 tree logical4_type_node
= gfc_get_logical_type (4);
4892 unsigned int num_args
;
4894 args
= XALLOCAVEC (tree
, 5);
4896 /* Get number of arguments; characters count double due to the
4897 string length argument. Kind= is not passed to the library
4898 and thus ignored. */
4899 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4904 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4905 type
= gfc_typenode_for_spec (&expr
->ts
);
4908 args
[4] = build_int_cst (logical4_type_node
, 0);
4910 args
[4] = convert (logical4_type_node
, args
[4]);
4912 fndecl
= build_addr (function
, current_function_decl
);
4913 se
->expr
= build_call_array_loc (input_location
,
4914 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4916 se
->expr
= convert (type
, se
->expr
);
4920 /* The ascii value for a single character. */
4922 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4924 tree args
[3], type
, pchartype
;
4927 nargs
= gfc_intrinsic_argument_list_length (expr
);
4928 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
4929 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
4930 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
4931 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
4932 type
= gfc_typenode_for_spec (&expr
->ts
);
4934 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4936 se
->expr
= convert (type
, se
->expr
);
4940 /* Intrinsic ISNAN calls __builtin_isnan. */
4943 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
4947 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4948 se
->expr
= build_call_expr_loc (input_location
,
4949 builtin_decl_explicit (BUILT_IN_ISNAN
),
4951 STRIP_TYPE_NOPS (se
->expr
);
4952 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4956 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4957 their argument against a constant integer value. */
4960 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
4964 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4965 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
4966 gfc_typenode_for_spec (&expr
->ts
),
4967 arg
, build_int_cst (TREE_TYPE (arg
), value
));
4972 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4975 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
4983 unsigned int num_args
;
4985 num_args
= gfc_intrinsic_argument_list_length (expr
);
4986 args
= XALLOCAVEC (tree
, num_args
);
4988 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4989 if (expr
->ts
.type
!= BT_CHARACTER
)
4997 /* We do the same as in the non-character case, but the argument
4998 list is different because of the string length arguments. We
4999 also have to set the string length for the result. */
5006 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
5008 se
->string_length
= len
;
5010 type
= TREE_TYPE (tsource
);
5011 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
5012 fold_convert (type
, fsource
));
5016 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
5019 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
5021 tree args
[3], mask
, type
;
5023 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5024 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
5026 type
= TREE_TYPE (args
[0]);
5027 gcc_assert (TREE_TYPE (args
[1]) == type
);
5028 gcc_assert (TREE_TYPE (mask
) == type
);
5030 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
5031 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
5032 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
5034 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
5039 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
5040 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
5043 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
5045 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
5048 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5049 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5051 type
= gfc_get_int_type (expr
->ts
.kind
);
5052 utype
= unsigned_type_for (type
);
5054 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
5055 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
5057 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
5058 build_int_cst (utype
, 0));
5062 /* Left-justified mask. */
5063 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
5065 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5066 fold_convert (utype
, res
));
5068 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
5069 smaller than type width. */
5070 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5071 build_int_cst (TREE_TYPE (arg
), 0));
5072 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
5073 build_int_cst (utype
, 0), res
);
5077 /* Right-justified mask. */
5078 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
5079 fold_convert (utype
, arg
));
5080 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
5082 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
5083 strictly smaller than type width. */
5084 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5086 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
5087 cond
, allones
, res
);
5090 se
->expr
= fold_convert (type
, res
);
5094 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
5096 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
5098 tree arg
, type
, tmp
, frexp
;
5100 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5102 type
= gfc_typenode_for_spec (&expr
->ts
);
5103 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5104 tmp
= gfc_create_var (integer_type_node
, NULL
);
5105 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
5106 fold_convert (type
, arg
),
5107 gfc_build_addr_expr (NULL_TREE
, tmp
));
5108 se
->expr
= fold_convert (type
, se
->expr
);
5112 /* NEAREST (s, dir) is translated into
5113 tmp = copysign (HUGE_VAL, dir);
5114 return nextafter (s, tmp);
5117 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
5119 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
5121 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
5122 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
5124 type
= gfc_typenode_for_spec (&expr
->ts
);
5125 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5127 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
5128 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
5129 fold_convert (type
, args
[1]));
5130 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
5131 fold_convert (type
, args
[0]), tmp
);
5132 se
->expr
= fold_convert (type
, se
->expr
);
5136 /* SPACING (s) is translated into
5144 e = MAX_EXPR (e, emin);
5145 res = scalbn (1., e);
5149 where prec is the precision of s, gfc_real_kinds[k].digits,
5150 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
5151 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
5154 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
5156 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
5157 tree cond
, tmp
, frexp
, scalbn
;
5161 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5162 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
5163 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
5164 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
5166 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5167 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5169 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5170 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5172 type
= gfc_typenode_for_spec (&expr
->ts
);
5173 e
= gfc_create_var (integer_type_node
, NULL
);
5174 res
= gfc_create_var (type
, NULL
);
5177 /* Build the block for s /= 0. */
5178 gfc_start_block (&block
);
5179 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5180 gfc_build_addr_expr (NULL_TREE
, e
));
5181 gfc_add_expr_to_block (&block
, tmp
);
5183 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
5185 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
5186 integer_type_node
, tmp
, emin
));
5188 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
5189 build_real_from_int_cst (type
, integer_one_node
), e
);
5190 gfc_add_modify (&block
, res
, tmp
);
5192 /* Finish by building the IF statement. */
5193 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
5194 build_real_from_int_cst (type
, integer_zero_node
));
5195 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
5196 gfc_finish_block (&block
));
5198 gfc_add_expr_to_block (&se
->pre
, tmp
);
5203 /* RRSPACING (s) is translated into
5210 x = scalbn (x, precision - e);
5214 where precision is gfc_real_kinds[k].digits. */
5217 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
5219 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
5223 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
5224 prec
= gfc_real_kinds
[k
].digits
;
5226 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5227 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5228 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
5230 type
= gfc_typenode_for_spec (&expr
->ts
);
5231 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5232 arg
= gfc_evaluate_now (arg
, &se
->pre
);
5234 e
= gfc_create_var (integer_type_node
, NULL
);
5235 x
= gfc_create_var (type
, NULL
);
5236 gfc_add_modify (&se
->pre
, x
,
5237 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5240 gfc_start_block (&block
);
5241 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5242 gfc_build_addr_expr (NULL_TREE
, e
));
5243 gfc_add_expr_to_block (&block
, tmp
);
5245 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5246 build_int_cst (integer_type_node
, prec
), e
);
5247 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5248 gfc_add_modify (&block
, x
, tmp
);
5249 stmt
= gfc_finish_block (&block
);
5251 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5252 build_real_from_int_cst (type
, integer_zero_node
));
5253 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5254 gfc_add_expr_to_block (&se
->pre
, tmp
);
5256 se
->expr
= fold_convert (type
, x
);
5260 /* SCALE (s, i) is translated into scalbn (s, i). */
5262 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5264 tree args
[2], type
, scalbn
;
5266 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5268 type
= gfc_typenode_for_spec (&expr
->ts
);
5269 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5270 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5271 fold_convert (type
, args
[0]),
5272 fold_convert (integer_type_node
, args
[1]));
5273 se
->expr
= fold_convert (type
, se
->expr
);
5277 /* SET_EXPONENT (s, i) is translated into
5278 scalbn (frexp (s, &dummy_int), i). */
5280 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5282 tree args
[2], type
, tmp
, frexp
, scalbn
;
5284 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5285 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5287 type
= gfc_typenode_for_spec (&expr
->ts
);
5288 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5290 tmp
= gfc_create_var (integer_type_node
, NULL
);
5291 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5292 fold_convert (type
, args
[0]),
5293 gfc_build_addr_expr (NULL_TREE
, tmp
));
5294 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5295 fold_convert (integer_type_node
, args
[1]));
5296 se
->expr
= fold_convert (type
, se
->expr
);
5301 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5303 gfc_actual_arglist
*actual
;
5310 gfc_init_se (&argse
, NULL
);
5311 actual
= expr
->value
.function
.actual
;
5313 if (actual
->expr
->ts
.type
== BT_CLASS
)
5314 gfc_add_class_array_ref (actual
->expr
);
5316 argse
.want_pointer
= 1;
5317 argse
.data_not_needed
= 1;
5318 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5319 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5320 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5321 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5323 /* Build the call to size0. */
5324 fncall0
= build_call_expr_loc (input_location
,
5325 gfor_fndecl_size0
, 1, arg1
);
5327 actual
= actual
->next
;
5331 gfc_init_se (&argse
, NULL
);
5332 gfc_conv_expr_type (&argse
, actual
->expr
,
5333 gfc_array_index_type
);
5334 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5336 /* Unusually, for an intrinsic, size does not exclude
5337 an optional arg2, so we must test for it. */
5338 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5339 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5340 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5343 /* Build the call to size1. */
5344 fncall1
= build_call_expr_loc (input_location
,
5345 gfor_fndecl_size1
, 2,
5348 gfc_init_se (&argse
, NULL
);
5349 argse
.want_pointer
= 1;
5350 argse
.data_not_needed
= 1;
5351 gfc_conv_expr (&argse
, actual
->expr
);
5352 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5353 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5354 argse
.expr
, null_pointer_node
);
5355 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5356 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5357 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5361 se
->expr
= NULL_TREE
;
5362 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5363 gfc_array_index_type
,
5364 argse
.expr
, gfc_index_one_node
);
5367 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5369 argse
.expr
= gfc_index_zero_node
;
5370 se
->expr
= NULL_TREE
;
5375 if (se
->expr
== NULL_TREE
)
5377 tree ubound
, lbound
;
5379 arg1
= build_fold_indirect_ref_loc (input_location
,
5381 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5382 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5383 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5384 gfc_array_index_type
, ubound
, lbound
);
5385 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5386 gfc_array_index_type
,
5387 se
->expr
, gfc_index_one_node
);
5388 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5389 gfc_array_index_type
, se
->expr
,
5390 gfc_index_zero_node
);
5393 type
= gfc_typenode_for_spec (&expr
->ts
);
5394 se
->expr
= convert (type
, se
->expr
);
5398 /* Helper function to compute the size of a character variable,
5399 excluding the terminating null characters. The result has
5400 gfc_array_index_type type. */
5403 size_of_string_in_bytes (int kind
, tree string_length
)
5406 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5408 bytesize
= build_int_cst (gfc_array_index_type
,
5409 gfc_character_kinds
[i
].bit_size
/ 8);
5411 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5413 fold_convert (gfc_array_index_type
, string_length
));
5418 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5429 arg
= expr
->value
.function
.actual
->expr
;
5431 gfc_init_se (&argse
, NULL
);
5435 if (arg
->ts
.type
== BT_CLASS
)
5436 gfc_add_data_component (arg
);
5438 gfc_conv_expr_reference (&argse
, arg
);
5440 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5443 /* Obtain the source word length. */
5444 if (arg
->ts
.type
== BT_CHARACTER
)
5445 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
5446 argse
.string_length
);
5448 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
5452 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5453 argse
.want_pointer
= 0;
5454 gfc_conv_expr_descriptor (&argse
, arg
);
5455 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5457 /* Obtain the argument's word length. */
5458 if (arg
->ts
.type
== BT_CHARACTER
)
5459 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5461 tmp
= fold_convert (gfc_array_index_type
,
5462 size_in_bytes (type
));
5463 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5465 /* Obtain the size of the array in bytes. */
5466 for (n
= 0; n
< arg
->rank
; n
++)
5469 idx
= gfc_rank_cst
[n
];
5470 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5471 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5472 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5473 gfc_array_index_type
, upper
, lower
);
5474 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5475 gfc_array_index_type
, tmp
, gfc_index_one_node
);
5476 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5477 gfc_array_index_type
, tmp
, source_bytes
);
5478 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5480 se
->expr
= source_bytes
;
5483 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5488 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
5492 tree type
, result_type
, tmp
;
5494 arg
= expr
->value
.function
.actual
->expr
;
5496 gfc_init_se (&argse
, NULL
);
5497 result_type
= gfc_get_int_type (expr
->ts
.kind
);
5501 if (arg
->ts
.type
== BT_CLASS
)
5503 gfc_add_vptr_component (arg
);
5504 gfc_add_size_component (arg
);
5505 gfc_conv_expr (&argse
, arg
);
5506 tmp
= fold_convert (result_type
, argse
.expr
);
5510 gfc_conv_expr_reference (&argse
, arg
);
5511 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5516 argse
.want_pointer
= 0;
5517 gfc_conv_expr_descriptor (&argse
, arg
);
5518 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5521 /* Obtain the argument's word length. */
5522 if (arg
->ts
.type
== BT_CHARACTER
)
5523 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5525 tmp
= size_in_bytes (type
);
5526 tmp
= fold_convert (result_type
, tmp
);
5529 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
5530 build_int_cst (result_type
, BITS_PER_UNIT
));
5531 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5535 /* Intrinsic string comparison functions. */
5538 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5542 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
5545 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
5546 expr
->value
.function
.actual
->expr
->ts
.kind
,
5548 se
->expr
= fold_build2_loc (input_location
, op
,
5549 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
5550 build_int_cst (TREE_TYPE (se
->expr
), 0));
5553 /* Generate a call to the adjustl/adjustr library function. */
5555 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
5563 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
5566 type
= TREE_TYPE (args
[2]);
5567 var
= gfc_conv_string_tmp (se
, type
, len
);
5570 tmp
= build_call_expr_loc (input_location
,
5571 fndecl
, 3, args
[0], args
[1], args
[2]);
5572 gfc_add_expr_to_block (&se
->pre
, tmp
);
5574 se
->string_length
= len
;
5578 /* Generate code for the TRANSFER intrinsic:
5580 DEST = TRANSFER (SOURCE, MOLD)
5582 typeof<DEST> = typeof<MOLD>
5587 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5589 typeof<DEST> = typeof<MOLD>
5591 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5592 sizeof (DEST(0) * SIZE). */
5594 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
5610 gfc_actual_arglist
*arg
;
5612 gfc_array_info
*info
;
5616 gfc_expr
*source_expr
, *mold_expr
;
5620 info
= &se
->ss
->info
->data
.array
;
5622 /* Convert SOURCE. The output from this stage is:-
5623 source_bytes = length of the source in bytes
5624 source = pointer to the source data. */
5625 arg
= expr
->value
.function
.actual
;
5626 source_expr
= arg
->expr
;
5628 /* Ensure double transfer through LOGICAL preserves all
5630 if (arg
->expr
->expr_type
== EXPR_FUNCTION
5631 && arg
->expr
->value
.function
.esym
== NULL
5632 && arg
->expr
->value
.function
.isym
!= NULL
5633 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
5634 && arg
->expr
->ts
.type
== BT_LOGICAL
5635 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
5636 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
5638 gfc_init_se (&argse
, NULL
);
5640 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5642 /* Obtain the pointer to source and the length of source in bytes. */
5643 if (arg
->expr
->rank
== 0)
5645 gfc_conv_expr_reference (&argse
, arg
->expr
);
5646 if (arg
->expr
->ts
.type
== BT_CLASS
)
5647 source
= gfc_class_data_get (argse
.expr
);
5649 source
= argse
.expr
;
5651 /* Obtain the source word length. */
5652 switch (arg
->expr
->ts
.type
)
5655 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5656 argse
.string_length
);
5659 tmp
= gfc_vtable_size_get (argse
.expr
);
5662 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5664 tmp
= fold_convert (gfc_array_index_type
,
5665 size_in_bytes (source_type
));
5671 argse
.want_pointer
= 0;
5672 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5673 source
= gfc_conv_descriptor_data_get (argse
.expr
);
5674 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5676 /* Repack the source if not simply contiguous. */
5677 if (!gfc_is_simply_contiguous (arg
->expr
, false))
5679 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
5681 if (gfc_option
.warn_array_temp
)
5682 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5684 source
= build_call_expr_loc (input_location
,
5685 gfor_fndecl_in_pack
, 1, tmp
);
5686 source
= gfc_evaluate_now (source
, &argse
.pre
);
5688 /* Free the temporary. */
5689 gfc_start_block (&block
);
5690 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
5691 gfc_add_expr_to_block (&block
, tmp
);
5692 stmt
= gfc_finish_block (&block
);
5694 /* Clean up if it was repacked. */
5695 gfc_init_block (&block
);
5696 tmp
= gfc_conv_array_data (argse
.expr
);
5697 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5699 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
5700 build_empty_stmt (input_location
));
5701 gfc_add_expr_to_block (&block
, tmp
);
5702 gfc_add_block_to_block (&block
, &se
->post
);
5703 gfc_init_block (&se
->post
);
5704 gfc_add_block_to_block (&se
->post
, &block
);
5707 /* Obtain the source word length. */
5708 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5709 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5710 argse
.string_length
);
5712 tmp
= fold_convert (gfc_array_index_type
,
5713 size_in_bytes (source_type
));
5715 /* Obtain the size of the array in bytes. */
5716 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
5717 for (n
= 0; n
< arg
->expr
->rank
; n
++)
5720 idx
= gfc_rank_cst
[n
];
5721 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5722 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5723 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5724 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5725 gfc_array_index_type
, upper
, lower
);
5726 gfc_add_modify (&argse
.pre
, extent
, tmp
);
5727 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5728 gfc_array_index_type
, extent
,
5729 gfc_index_one_node
);
5730 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5731 gfc_array_index_type
, tmp
, source_bytes
);
5735 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5736 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5737 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5739 /* Now convert MOLD. The outputs are:
5740 mold_type = the TREE type of MOLD
5741 dest_word_len = destination word length in bytes. */
5743 mold_expr
= arg
->expr
;
5745 gfc_init_se (&argse
, NULL
);
5747 scalar_mold
= arg
->expr
->rank
== 0;
5749 if (arg
->expr
->rank
== 0)
5751 gfc_conv_expr_reference (&argse
, arg
->expr
);
5752 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5757 gfc_init_se (&argse
, NULL
);
5758 argse
.want_pointer
= 0;
5759 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5760 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5763 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5764 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5766 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
5768 /* If this TRANSFER is nested in another TRANSFER, use a type
5769 that preserves all bits. */
5770 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
5771 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
5774 /* Obtain the destination word length. */
5775 switch (arg
->expr
->ts
.type
)
5778 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
5779 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
5782 tmp
= gfc_vtable_size_get (argse
.expr
);
5785 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
5788 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
5789 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
5791 /* Finally convert SIZE, if it is present. */
5793 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
5797 gfc_init_se (&argse
, NULL
);
5798 gfc_conv_expr_reference (&argse
, arg
->expr
);
5799 tmp
= convert (gfc_array_index_type
,
5800 build_fold_indirect_ref_loc (input_location
,
5802 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5803 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5808 /* Separate array and scalar results. */
5809 if (scalar_mold
&& tmp
== NULL_TREE
)
5810 goto scalar_transfer
;
5812 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5813 if (tmp
!= NULL_TREE
)
5814 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5815 tmp
, dest_word_len
);
5819 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
5820 gfc_add_modify (&se
->pre
, size_words
,
5821 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
5822 gfc_array_index_type
,
5823 size_bytes
, dest_word_len
));
5825 /* Evaluate the bounds of the result. If the loop range exists, we have
5826 to check if it is too large. If so, we modify loop->to be consistent
5827 with min(size, size(source)). Otherwise, size is made consistent with
5828 the loop range, so that the right number of bytes is transferred.*/
5829 n
= se
->loop
->order
[0];
5830 if (se
->loop
->to
[n
] != NULL_TREE
)
5832 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5833 se
->loop
->to
[n
], se
->loop
->from
[n
]);
5834 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5835 tmp
, gfc_index_one_node
);
5836 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5838 gfc_add_modify (&se
->pre
, size_words
, tmp
);
5839 gfc_add_modify (&se
->pre
, size_bytes
,
5840 fold_build2_loc (input_location
, MULT_EXPR
,
5841 gfc_array_index_type
,
5842 size_words
, dest_word_len
));
5843 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5844 size_words
, se
->loop
->from
[n
]);
5845 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5846 upper
, gfc_index_one_node
);
5850 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5851 size_words
, gfc_index_one_node
);
5852 se
->loop
->from
[n
] = gfc_index_zero_node
;
5855 se
->loop
->to
[n
] = upper
;
5857 /* Build a destination descriptor, using the pointer, source, as the
5859 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
5860 NULL_TREE
, false, true, false, &expr
->where
);
5862 /* Cast the pointer to the result. */
5863 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5864 tmp
= fold_convert (pvoid_type_node
, tmp
);
5866 /* Use memcpy to do the transfer. */
5868 = build_call_expr_loc (input_location
,
5869 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
5870 fold_convert (pvoid_type_node
, source
),
5871 fold_convert (size_type_node
,
5872 fold_build2_loc (input_location
,
5874 gfc_array_index_type
,
5877 gfc_add_expr_to_block (&se
->pre
, tmp
);
5879 se
->expr
= info
->descriptor
;
5880 if (expr
->ts
.type
== BT_CHARACTER
)
5881 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5885 /* Deal with scalar results. */
5887 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5888 dest_word_len
, source_bytes
);
5889 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5890 extent
, gfc_index_zero_node
);
5892 if (expr
->ts
.type
== BT_CHARACTER
)
5894 tree direct
, indirect
, free
;
5896 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5897 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5900 /* If source is longer than the destination, use a pointer to
5901 the source directly. */
5902 gfc_init_block (&block
);
5903 gfc_add_modify (&block
, tmpdecl
, ptr
);
5904 direct
= gfc_finish_block (&block
);
5906 /* Otherwise, allocate a string with the length of the destination
5907 and copy the source into it. */
5908 gfc_init_block (&block
);
5909 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5910 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5911 gfc_add_modify (&block
, tmpdecl
,
5912 fold_convert (TREE_TYPE (ptr
), tmp
));
5913 tmp
= build_call_expr_loc (input_location
,
5914 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5915 fold_convert (pvoid_type_node
, tmpdecl
),
5916 fold_convert (pvoid_type_node
, ptr
),
5917 fold_convert (size_type_node
, extent
));
5918 gfc_add_expr_to_block (&block
, tmp
);
5919 indirect
= gfc_finish_block (&block
);
5921 /* Wrap it up with the condition. */
5922 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5923 dest_word_len
, source_bytes
);
5924 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5925 gfc_add_expr_to_block (&se
->pre
, tmp
);
5927 /* Free the temporary string, if necessary. */
5928 free
= gfc_call_free (tmpdecl
);
5929 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
5930 dest_word_len
, source_bytes
);
5931 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
5932 gfc_add_expr_to_block (&se
->post
, tmp
);
5935 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5939 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5941 ptr
= convert (build_pointer_type (mold_type
), source
);
5943 /* For CLASS results, allocate the needed memory first. */
5944 if (mold_expr
->ts
.type
== BT_CLASS
)
5947 cdata
= gfc_class_data_get (tmpdecl
);
5948 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
5949 gfc_add_modify (&se
->pre
, cdata
, tmp
);
5952 /* Use memcpy to do the transfer. */
5953 if (mold_expr
->ts
.type
== BT_CLASS
)
5954 tmp
= gfc_class_data_get (tmpdecl
);
5956 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5958 tmp
= build_call_expr_loc (input_location
,
5959 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5960 fold_convert (pvoid_type_node
, tmp
),
5961 fold_convert (pvoid_type_node
, ptr
),
5962 fold_convert (size_type_node
, extent
));
5963 gfc_add_expr_to_block (&se
->pre
, tmp
);
5965 /* For CLASS results, set the _vptr. */
5966 if (mold_expr
->ts
.type
== BT_CLASS
)
5970 vptr
= gfc_class_vptr_get (tmpdecl
);
5971 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
5973 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
5974 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
5982 /* Generate code for the ALLOCATED intrinsic.
5983 Generate inline code that directly check the address of the argument. */
5986 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5988 gfc_actual_arglist
*arg1
;
5992 gfc_init_se (&arg1se
, NULL
);
5993 arg1
= expr
->value
.function
.actual
;
5995 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5997 /* Make sure that class array expressions have both a _data
5998 component reference and an array reference.... */
5999 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
6000 gfc_add_class_array_ref (arg1
->expr
);
6001 /* .... whilst scalars only need the _data component. */
6003 gfc_add_data_component (arg1
->expr
);
6006 if (arg1
->expr
->rank
== 0)
6008 /* Allocatable scalar. */
6009 arg1se
.want_pointer
= 1;
6010 gfc_conv_expr (&arg1se
, arg1
->expr
);
6015 /* Allocatable array. */
6016 arg1se
.descriptor_only
= 1;
6017 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6018 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6021 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
6022 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6023 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6027 /* Generate code for the ASSOCIATED intrinsic.
6028 If both POINTER and TARGET are arrays, generate a call to library function
6029 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
6030 In other cases, generate inline code that directly compare the address of
6031 POINTER with the address of TARGET. */
6034 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
6036 gfc_actual_arglist
*arg1
;
6037 gfc_actual_arglist
*arg2
;
6042 tree nonzero_charlen
;
6043 tree nonzero_arraylen
;
6047 gfc_init_se (&arg1se
, NULL
);
6048 gfc_init_se (&arg2se
, NULL
);
6049 arg1
= expr
->value
.function
.actual
;
6052 /* Check whether the expression is a scalar or not; we cannot use
6053 arg1->expr->rank as it can be nonzero for proc pointers. */
6054 ss
= gfc_walk_expr (arg1
->expr
);
6055 scalar
= ss
== gfc_ss_terminator
;
6057 gfc_free_ss_chain (ss
);
6061 /* No optional target. */
6064 /* A pointer to a scalar. */
6065 arg1se
.want_pointer
= 1;
6066 gfc_conv_expr (&arg1se
, arg1
->expr
);
6067 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6068 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6069 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6071 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6072 tmp2
= gfc_class_data_get (arg1se
.expr
);
6078 /* A pointer to an array. */
6079 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6080 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
6082 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6083 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6084 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
6085 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
6090 /* An optional target. */
6091 if (arg2
->expr
->ts
.type
== BT_CLASS
)
6092 gfc_add_data_component (arg2
->expr
);
6094 nonzero_charlen
= NULL_TREE
;
6095 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
6096 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
6098 arg1
->expr
->ts
.u
.cl
->backend_decl
,
6102 /* A pointer to a scalar. */
6103 arg1se
.want_pointer
= 1;
6104 gfc_conv_expr (&arg1se
, arg1
->expr
);
6105 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6106 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
6107 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
6109 if (arg1
->expr
->ts
.type
== BT_CLASS
)
6110 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
6112 arg2se
.want_pointer
= 1;
6113 gfc_conv_expr (&arg2se
, arg2
->expr
);
6114 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6115 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
6116 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
6118 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6119 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6120 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6121 arg1se
.expr
, arg2se
.expr
);
6122 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6123 arg1se
.expr
, null_pointer_node
);
6124 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6125 boolean_type_node
, tmp
, tmp2
);
6129 /* An array pointer of zero length is not associated if target is
6131 arg1se
.descriptor_only
= 1;
6132 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
6133 if (arg1
->expr
->rank
== -1)
6135 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
6136 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6137 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
6140 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
6141 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
6142 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
6143 boolean_type_node
, tmp
,
6144 build_int_cst (TREE_TYPE (tmp
), 0));
6146 /* A pointer to an array, call library function _gfor_associated. */
6147 arg1se
.want_pointer
= 1;
6148 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
6150 arg2se
.want_pointer
= 1;
6151 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
6152 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6153 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6154 se
->expr
= build_call_expr_loc (input_location
,
6155 gfor_fndecl_associated
, 2,
6156 arg1se
.expr
, arg2se
.expr
);
6157 se
->expr
= convert (boolean_type_node
, se
->expr
);
6158 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6159 boolean_type_node
, se
->expr
,
6163 /* If target is present zero character length pointers cannot
6165 if (nonzero_charlen
!= NULL_TREE
)
6166 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6168 se
->expr
, nonzero_charlen
);
6171 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6175 /* Generate code for the SAME_TYPE_AS intrinsic.
6176 Generate inline code that directly checks the vindices. */
6179 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
6184 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
6186 gfc_init_se (&se1
, NULL
);
6187 gfc_init_se (&se2
, NULL
);
6189 a
= expr
->value
.function
.actual
->expr
;
6190 b
= expr
->value
.function
.actual
->next
->expr
;
6192 if (UNLIMITED_POLY (a
))
6194 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
6195 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6196 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6199 if (UNLIMITED_POLY (b
))
6201 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
6202 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6203 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
6206 if (a
->ts
.type
== BT_CLASS
)
6208 gfc_add_vptr_component (a
);
6209 gfc_add_hash_component (a
);
6211 else if (a
->ts
.type
== BT_DERIVED
)
6212 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6213 a
->ts
.u
.derived
->hash_value
);
6215 if (b
->ts
.type
== BT_CLASS
)
6217 gfc_add_vptr_component (b
);
6218 gfc_add_hash_component (b
);
6220 else if (b
->ts
.type
== BT_DERIVED
)
6221 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
6222 b
->ts
.u
.derived
->hash_value
);
6224 gfc_conv_expr (&se1
, a
);
6225 gfc_conv_expr (&se2
, b
);
6227 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
6228 boolean_type_node
, se1
.expr
,
6229 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
6232 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6233 boolean_type_node
, conda
, tmp
);
6236 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6237 boolean_type_node
, condb
, tmp
);
6239 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6243 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6246 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6250 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6251 se
->expr
= build_call_expr_loc (input_location
,
6252 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6253 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6257 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6260 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6264 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6266 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6267 type
= gfc_get_int_type (4);
6268 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6270 /* Convert it to the required type. */
6271 type
= gfc_typenode_for_spec (&expr
->ts
);
6272 se
->expr
= build_call_expr_loc (input_location
,
6273 gfor_fndecl_si_kind
, 1, arg
);
6274 se
->expr
= fold_convert (type
, se
->expr
);
6278 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6281 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6283 gfc_actual_arglist
*actual
;
6286 vec
<tree
, va_gc
> *args
= NULL
;
6288 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6290 gfc_init_se (&argse
, se
);
6292 /* Pass a NULL pointer for an absent arg. */
6293 if (actual
->expr
== NULL
)
6294 argse
.expr
= null_pointer_node
;
6300 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6302 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6303 ts
.type
= BT_INTEGER
;
6304 ts
.kind
= gfc_c_int_kind
;
6305 gfc_convert_type (actual
->expr
, &ts
, 2);
6307 gfc_conv_expr_reference (&argse
, actual
->expr
);
6310 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6311 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6312 vec_safe_push (args
, argse
.expr
);
6315 /* Convert it to the required type. */
6316 type
= gfc_typenode_for_spec (&expr
->ts
);
6317 se
->expr
= build_call_expr_loc_vec (input_location
,
6318 gfor_fndecl_sr_kind
, args
);
6319 se
->expr
= fold_convert (type
, se
->expr
);
6323 /* Generate code for TRIM (A) intrinsic function. */
6326 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6336 unsigned int num_args
;
6338 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6339 args
= XALLOCAVEC (tree
, num_args
);
6341 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6342 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6343 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6345 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6346 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6349 if (expr
->ts
.kind
== 1)
6350 function
= gfor_fndecl_string_trim
;
6351 else if (expr
->ts
.kind
== 4)
6352 function
= gfor_fndecl_string_trim_char4
;
6356 fndecl
= build_addr (function
, current_function_decl
);
6357 tmp
= build_call_array_loc (input_location
,
6358 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6360 gfc_add_expr_to_block (&se
->pre
, tmp
);
6362 /* Free the temporary afterwards, if necessary. */
6363 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6364 len
, build_int_cst (TREE_TYPE (len
), 0));
6365 tmp
= gfc_call_free (var
);
6366 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6367 gfc_add_expr_to_block (&se
->post
, tmp
);
6370 se
->string_length
= len
;
6374 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6377 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6379 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6380 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6382 stmtblock_t block
, body
;
6385 /* We store in charsize the size of a character. */
6386 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6387 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6389 /* Get the arguments. */
6390 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6391 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6393 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6394 ncopies_type
= TREE_TYPE (ncopies
);
6396 /* Check that NCOPIES is not negative. */
6397 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6398 build_int_cst (ncopies_type
, 0));
6399 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6400 "Argument NCOPIES of REPEAT intrinsic is negative "
6401 "(its value is %ld)",
6402 fold_convert (long_integer_type_node
, ncopies
));
6404 /* If the source length is zero, any non negative value of NCOPIES
6405 is valid, and nothing happens. */
6406 n
= gfc_create_var (ncopies_type
, "ncopies");
6407 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6408 build_int_cst (size_type_node
, 0));
6409 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6410 build_int_cst (ncopies_type
, 0), ncopies
);
6411 gfc_add_modify (&se
->pre
, n
, tmp
);
6414 /* Check that ncopies is not too large: ncopies should be less than
6415 (or equal to) MAX / slen, where MAX is the maximal integer of
6416 the gfc_charlen_type_node type. If slen == 0, we need a special
6417 case to avoid the division by zero. */
6418 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6419 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6420 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6421 fold_convert (size_type_node
, max
), slen
);
6422 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6423 ? size_type_node
: ncopies_type
;
6424 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6425 fold_convert (largest
, ncopies
),
6426 fold_convert (largest
, max
));
6427 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6428 build_int_cst (size_type_node
, 0));
6429 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6430 boolean_false_node
, cond
);
6431 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6432 "Argument NCOPIES of REPEAT intrinsic is too large");
6434 /* Compute the destination length. */
6435 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6436 fold_convert (gfc_charlen_type_node
, slen
),
6437 fold_convert (gfc_charlen_type_node
, ncopies
));
6438 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6439 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6441 /* Generate the code to do the repeat operation:
6442 for (i = 0; i < ncopies; i++)
6443 memmove (dest + (i * slen * size), src, slen*size); */
6444 gfc_start_block (&block
);
6445 count
= gfc_create_var (ncopies_type
, "count");
6446 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6447 exit_label
= gfc_build_label_decl (NULL_TREE
);
6449 /* Start the loop body. */
6450 gfc_start_block (&body
);
6452 /* Exit the loop if count >= ncopies. */
6453 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6455 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6456 TREE_USED (exit_label
) = 1;
6457 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6458 build_empty_stmt (input_location
));
6459 gfc_add_expr_to_block (&body
, tmp
);
6461 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6462 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6463 fold_convert (gfc_charlen_type_node
, slen
),
6464 fold_convert (gfc_charlen_type_node
, count
));
6465 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6466 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6467 tmp
= fold_build_pointer_plus_loc (input_location
,
6468 fold_convert (pvoid_type_node
, dest
), tmp
);
6469 tmp
= build_call_expr_loc (input_location
,
6470 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6472 fold_build2_loc (input_location
, MULT_EXPR
,
6473 size_type_node
, slen
,
6474 fold_convert (size_type_node
,
6476 gfc_add_expr_to_block (&body
, tmp
);
6478 /* Increment count. */
6479 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6480 count
, build_int_cst (TREE_TYPE (count
), 1));
6481 gfc_add_modify (&body
, count
, tmp
);
6483 /* Build the loop. */
6484 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6485 gfc_add_expr_to_block (&block
, tmp
);
6487 /* Add the exit label. */
6488 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6489 gfc_add_expr_to_block (&block
, tmp
);
6491 /* Finish the block. */
6492 tmp
= gfc_finish_block (&block
);
6493 gfc_add_expr_to_block (&se
->pre
, tmp
);
6495 /* Set the result value. */
6497 se
->string_length
= dlen
;
6501 /* Generate code for the IARGC intrinsic. */
6504 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6510 /* Call the library function. This always returns an INTEGER(4). */
6511 fndecl
= gfor_fndecl_iargc
;
6512 tmp
= build_call_expr_loc (input_location
,
6515 /* Convert it to the required type. */
6516 type
= gfc_typenode_for_spec (&expr
->ts
);
6517 tmp
= fold_convert (type
, tmp
);
6523 /* The loc intrinsic returns the address of its argument as
6524 gfc_index_integer_kind integer. */
6527 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
6532 gcc_assert (!se
->ss
);
6534 arg_expr
= expr
->value
.function
.actual
->expr
;
6535 if (arg_expr
->rank
== 0)
6536 gfc_conv_expr_reference (se
, arg_expr
);
6538 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
6539 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
6541 /* Create a temporary variable for loc return value. Without this,
6542 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6543 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
6544 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
6545 se
->expr
= temp_var
;
6549 /* The following routine generates code for the intrinsic
6550 functions from the ISO_C_BINDING module:
6556 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
6558 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
6560 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
6562 if (arg
->expr
->rank
== 0)
6563 gfc_conv_expr_reference (se
, arg
->expr
);
6564 else if (gfc_is_simply_contiguous (arg
->expr
, false))
6565 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
6568 gfc_conv_expr_descriptor (se
, arg
->expr
);
6569 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
6572 /* TODO -- the following two lines shouldn't be necessary, but if
6573 they're removed, a bug is exposed later in the code path.
6574 This workaround was thus introduced, but will have to be
6575 removed; please see PR 35150 for details about the issue. */
6576 se
->expr
= convert (pvoid_type_node
, se
->expr
);
6577 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6579 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
6580 gfc_conv_expr_reference (se
, arg
->expr
);
6581 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
6586 /* Build the addr_expr for the first argument. The argument is
6587 already an *address* so we don't need to set want_pointer in
6589 gfc_init_se (&arg1se
, NULL
);
6590 gfc_conv_expr (&arg1se
, arg
->expr
);
6591 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6592 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6594 /* See if we were given two arguments. */
6595 if (arg
->next
->expr
== NULL
)
6596 /* Only given one arg so generate a null and do a
6597 not-equal comparison against the first arg. */
6598 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6600 fold_convert (TREE_TYPE (arg1se
.expr
),
6601 null_pointer_node
));
6607 /* Given two arguments so build the arg2se from second arg. */
6608 gfc_init_se (&arg2se
, NULL
);
6609 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
6610 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6611 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6613 /* Generate test to compare that the two args are equal. */
6614 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6615 arg1se
.expr
, arg2se
.expr
);
6616 /* Generate test to ensure that the first arg is not null. */
6617 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
6619 arg1se
.expr
, null_pointer_node
);
6621 /* Finally, the generated test must check that both arg1 is not
6622 NULL and that it is equal to the second arg. */
6623 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6625 not_null_expr
, eq_expr
);
6633 /* The following routine generates code for the intrinsic
6634 subroutines from the ISO_C_BINDING module:
6636 * C_F_PROCPOINTER. */
6639 conv_isocbinding_subroutine (gfc_code
*code
)
6646 tree desc
, dim
, tmp
, stride
, offset
;
6647 stmtblock_t body
, block
;
6649 gfc_actual_arglist
*arg
= code
->ext
.actual
;
6651 gfc_init_se (&se
, NULL
);
6652 gfc_init_se (&cptrse
, NULL
);
6653 gfc_conv_expr (&cptrse
, arg
->expr
);
6654 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
6655 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
6657 gfc_init_se (&fptrse
, NULL
);
6658 if (arg
->next
->expr
->rank
== 0)
6660 fptrse
.want_pointer
= 1;
6661 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
6662 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
6663 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
6664 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6665 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
6666 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
6668 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6669 TREE_TYPE (fptrse
.expr
),
6671 fold_convert (TREE_TYPE (fptrse
.expr
),
6673 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
6674 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6675 return gfc_finish_block (&se
.pre
);
6678 gfc_start_block (&block
);
6680 /* Get the descriptor of the Fortran pointer. */
6681 fptrse
.descriptor_only
= 1;
6682 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
6683 gfc_add_block_to_block (&block
, &fptrse
.pre
);
6686 /* Set data value, dtype, and offset. */
6687 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
6688 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
6689 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
6690 gfc_get_dtype (TREE_TYPE (desc
)));
6692 /* Start scalarization of the bounds, using the shape argument. */
6694 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
6695 gcc_assert (shape_ss
!= gfc_ss_terminator
);
6696 gfc_init_se (&shapese
, NULL
);
6698 gfc_init_loopinfo (&loop
);
6699 gfc_add_ss_to_loop (&loop
, shape_ss
);
6700 gfc_conv_ss_startstride (&loop
);
6701 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
6702 gfc_mark_ss_chain_used (shape_ss
, 1);
6704 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
6705 shapese
.ss
= shape_ss
;
6707 stride
= gfc_create_var (gfc_array_index_type
, "stride");
6708 offset
= gfc_create_var (gfc_array_index_type
, "offset");
6709 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
6710 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6713 gfc_start_scalarized_body (&loop
, &body
);
6715 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6716 loop
.loopvar
[0], loop
.from
[0]);
6718 /* Set bounds and stride. */
6719 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
6720 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
6722 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
6723 gfc_add_block_to_block (&body
, &shapese
.pre
);
6724 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
6725 gfc_add_block_to_block (&body
, &shapese
.post
);
6727 /* Calculate offset. */
6728 gfc_add_modify (&body
, offset
,
6729 fold_build2_loc (input_location
, PLUS_EXPR
,
6730 gfc_array_index_type
, offset
, stride
));
6731 /* Update stride. */
6732 gfc_add_modify (&body
, stride
,
6733 fold_build2_loc (input_location
, MULT_EXPR
,
6734 gfc_array_index_type
, stride
,
6735 fold_convert (gfc_array_index_type
,
6737 /* Finish scalarization loop. */
6738 gfc_trans_scalarizing_loops (&loop
, &body
);
6739 gfc_add_block_to_block (&block
, &loop
.pre
);
6740 gfc_add_block_to_block (&block
, &loop
.post
);
6741 gfc_add_block_to_block (&block
, &fptrse
.post
);
6742 gfc_cleanup_loop (&loop
);
6744 gfc_add_modify (&block
, offset
,
6745 fold_build1_loc (input_location
, NEGATE_EXPR
,
6746 gfc_array_index_type
, offset
));
6747 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
6749 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
6750 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6751 return gfc_finish_block (&se
.pre
);
6755 /* Generate code for an intrinsic function. Some map directly to library
6756 calls, others get special handling. In some cases the name of the function
6757 used depends on the type specifiers. */
6760 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
6766 name
= &expr
->value
.function
.name
[2];
6770 lib
= gfc_is_intrinsic_libcall (expr
);
6774 se
->ignore_optional
= 1;
6776 switch (expr
->value
.function
.isym
->id
)
6778 case GFC_ISYM_EOSHIFT
:
6780 case GFC_ISYM_RESHAPE
:
6781 /* For all of those the first argument specifies the type and the
6782 third is optional. */
6783 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
6787 gfc_conv_intrinsic_funcall (se
, expr
);
6795 switch (expr
->value
.function
.isym
->id
)
6800 case GFC_ISYM_REPEAT
:
6801 gfc_conv_intrinsic_repeat (se
, expr
);
6805 gfc_conv_intrinsic_trim (se
, expr
);
6808 case GFC_ISYM_SC_KIND
:
6809 gfc_conv_intrinsic_sc_kind (se
, expr
);
6812 case GFC_ISYM_SI_KIND
:
6813 gfc_conv_intrinsic_si_kind (se
, expr
);
6816 case GFC_ISYM_SR_KIND
:
6817 gfc_conv_intrinsic_sr_kind (se
, expr
);
6820 case GFC_ISYM_EXPONENT
:
6821 gfc_conv_intrinsic_exponent (se
, expr
);
6825 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6827 fndecl
= gfor_fndecl_string_scan
;
6829 fndecl
= gfor_fndecl_string_scan_char4
;
6833 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6836 case GFC_ISYM_VERIFY
:
6837 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6839 fndecl
= gfor_fndecl_string_verify
;
6841 fndecl
= gfor_fndecl_string_verify_char4
;
6845 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6848 case GFC_ISYM_ALLOCATED
:
6849 gfc_conv_allocated (se
, expr
);
6852 case GFC_ISYM_ASSOCIATED
:
6853 gfc_conv_associated(se
, expr
);
6856 case GFC_ISYM_SAME_TYPE_AS
:
6857 gfc_conv_same_type_as (se
, expr
);
6861 gfc_conv_intrinsic_abs (se
, expr
);
6864 case GFC_ISYM_ADJUSTL
:
6865 if (expr
->ts
.kind
== 1)
6866 fndecl
= gfor_fndecl_adjustl
;
6867 else if (expr
->ts
.kind
== 4)
6868 fndecl
= gfor_fndecl_adjustl_char4
;
6872 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6875 case GFC_ISYM_ADJUSTR
:
6876 if (expr
->ts
.kind
== 1)
6877 fndecl
= gfor_fndecl_adjustr
;
6878 else if (expr
->ts
.kind
== 4)
6879 fndecl
= gfor_fndecl_adjustr_char4
;
6883 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6886 case GFC_ISYM_AIMAG
:
6887 gfc_conv_intrinsic_imagpart (se
, expr
);
6891 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
6895 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
6898 case GFC_ISYM_ANINT
:
6899 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
6903 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6907 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
6910 case GFC_ISYM_BTEST
:
6911 gfc_conv_intrinsic_btest (se
, expr
);
6915 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
6919 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
6923 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
6927 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
6930 case GFC_ISYM_C_ASSOCIATED
:
6931 case GFC_ISYM_C_FUNLOC
:
6932 case GFC_ISYM_C_LOC
:
6933 conv_isocbinding_function (se
, expr
);
6936 case GFC_ISYM_ACHAR
:
6938 gfc_conv_intrinsic_char (se
, expr
);
6941 case GFC_ISYM_CONVERSION
:
6943 case GFC_ISYM_LOGICAL
:
6945 gfc_conv_intrinsic_conversion (se
, expr
);
6948 /* Integer conversions are handled separately to make sure we get the
6949 correct rounding mode. */
6954 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
6958 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
6961 case GFC_ISYM_CEILING
:
6962 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
6965 case GFC_ISYM_FLOOR
:
6966 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
6970 gfc_conv_intrinsic_mod (se
, expr
, 0);
6973 case GFC_ISYM_MODULO
:
6974 gfc_conv_intrinsic_mod (se
, expr
, 1);
6977 case GFC_ISYM_CMPLX
:
6978 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
6981 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
6982 gfc_conv_intrinsic_iargc (se
, expr
);
6985 case GFC_ISYM_COMPLEX
:
6986 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
6989 case GFC_ISYM_CONJG
:
6990 gfc_conv_intrinsic_conjg (se
, expr
);
6993 case GFC_ISYM_COUNT
:
6994 gfc_conv_intrinsic_count (se
, expr
);
6997 case GFC_ISYM_CTIME
:
6998 gfc_conv_intrinsic_ctime (se
, expr
);
7002 gfc_conv_intrinsic_dim (se
, expr
);
7005 case GFC_ISYM_DOT_PRODUCT
:
7006 gfc_conv_intrinsic_dot_product (se
, expr
);
7009 case GFC_ISYM_DPROD
:
7010 gfc_conv_intrinsic_dprod (se
, expr
);
7013 case GFC_ISYM_DSHIFTL
:
7014 gfc_conv_intrinsic_dshift (se
, expr
, true);
7017 case GFC_ISYM_DSHIFTR
:
7018 gfc_conv_intrinsic_dshift (se
, expr
, false);
7021 case GFC_ISYM_FDATE
:
7022 gfc_conv_intrinsic_fdate (se
, expr
);
7025 case GFC_ISYM_FRACTION
:
7026 gfc_conv_intrinsic_fraction (se
, expr
);
7030 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
7034 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
7038 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
7041 case GFC_ISYM_IBCLR
:
7042 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
7045 case GFC_ISYM_IBITS
:
7046 gfc_conv_intrinsic_ibits (se
, expr
);
7049 case GFC_ISYM_IBSET
:
7050 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
7053 case GFC_ISYM_IACHAR
:
7054 case GFC_ISYM_ICHAR
:
7055 /* We assume ASCII character sequence. */
7056 gfc_conv_intrinsic_ichar (se
, expr
);
7059 case GFC_ISYM_IARGC
:
7060 gfc_conv_intrinsic_iargc (se
, expr
);
7064 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
7067 case GFC_ISYM_INDEX
:
7068 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
7070 fndecl
= gfor_fndecl_string_index
;
7072 fndecl
= gfor_fndecl_string_index_char4
;
7076 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
7080 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
7083 case GFC_ISYM_IPARITY
:
7084 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
7087 case GFC_ISYM_IS_IOSTAT_END
:
7088 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
7091 case GFC_ISYM_IS_IOSTAT_EOR
:
7092 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
7095 case GFC_ISYM_ISNAN
:
7096 gfc_conv_intrinsic_isnan (se
, expr
);
7099 case GFC_ISYM_LSHIFT
:
7100 gfc_conv_intrinsic_shift (se
, expr
, false, false);
7103 case GFC_ISYM_RSHIFT
:
7104 gfc_conv_intrinsic_shift (se
, expr
, true, true);
7107 case GFC_ISYM_SHIFTA
:
7108 gfc_conv_intrinsic_shift (se
, expr
, true, true);
7111 case GFC_ISYM_SHIFTL
:
7112 gfc_conv_intrinsic_shift (se
, expr
, false, false);
7115 case GFC_ISYM_SHIFTR
:
7116 gfc_conv_intrinsic_shift (se
, expr
, true, false);
7119 case GFC_ISYM_ISHFT
:
7120 gfc_conv_intrinsic_ishft (se
, expr
);
7123 case GFC_ISYM_ISHFTC
:
7124 gfc_conv_intrinsic_ishftc (se
, expr
);
7127 case GFC_ISYM_LEADZ
:
7128 gfc_conv_intrinsic_leadz (se
, expr
);
7131 case GFC_ISYM_TRAILZ
:
7132 gfc_conv_intrinsic_trailz (se
, expr
);
7135 case GFC_ISYM_POPCNT
:
7136 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
7139 case GFC_ISYM_POPPAR
:
7140 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
7143 case GFC_ISYM_LBOUND
:
7144 gfc_conv_intrinsic_bound (se
, expr
, 0);
7147 case GFC_ISYM_LCOBOUND
:
7148 conv_intrinsic_cobound (se
, expr
);
7151 case GFC_ISYM_TRANSPOSE
:
7152 /* The scalarizer has already been set up for reversed dimension access
7153 order ; now we just get the argument value normally. */
7154 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
7158 gfc_conv_intrinsic_len (se
, expr
);
7161 case GFC_ISYM_LEN_TRIM
:
7162 gfc_conv_intrinsic_len_trim (se
, expr
);
7166 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
7170 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
7174 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
7178 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
7181 case GFC_ISYM_MASKL
:
7182 gfc_conv_intrinsic_mask (se
, expr
, 1);
7185 case GFC_ISYM_MASKR
:
7186 gfc_conv_intrinsic_mask (se
, expr
, 0);
7190 if (expr
->ts
.type
== BT_CHARACTER
)
7191 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
7193 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
7196 case GFC_ISYM_MAXLOC
:
7197 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
7200 case GFC_ISYM_MAXVAL
:
7201 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
7204 case GFC_ISYM_MERGE
:
7205 gfc_conv_intrinsic_merge (se
, expr
);
7208 case GFC_ISYM_MERGE_BITS
:
7209 gfc_conv_intrinsic_merge_bits (se
, expr
);
7213 if (expr
->ts
.type
== BT_CHARACTER
)
7214 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
7216 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
7219 case GFC_ISYM_MINLOC
:
7220 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
7223 case GFC_ISYM_MINVAL
:
7224 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
7227 case GFC_ISYM_NEAREST
:
7228 gfc_conv_intrinsic_nearest (se
, expr
);
7231 case GFC_ISYM_NORM2
:
7232 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
7236 gfc_conv_intrinsic_not (se
, expr
);
7240 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
7243 case GFC_ISYM_PARITY
:
7244 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
7247 case GFC_ISYM_PRESENT
:
7248 gfc_conv_intrinsic_present (se
, expr
);
7251 case GFC_ISYM_PRODUCT
:
7252 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
7256 gfc_conv_intrinsic_rank (se
, expr
);
7259 case GFC_ISYM_RRSPACING
:
7260 gfc_conv_intrinsic_rrspacing (se
, expr
);
7263 case GFC_ISYM_SET_EXPONENT
:
7264 gfc_conv_intrinsic_set_exponent (se
, expr
);
7267 case GFC_ISYM_SCALE
:
7268 gfc_conv_intrinsic_scale (se
, expr
);
7272 gfc_conv_intrinsic_sign (se
, expr
);
7276 gfc_conv_intrinsic_size (se
, expr
);
7279 case GFC_ISYM_SIZEOF
:
7280 case GFC_ISYM_C_SIZEOF
:
7281 gfc_conv_intrinsic_sizeof (se
, expr
);
7284 case GFC_ISYM_STORAGE_SIZE
:
7285 gfc_conv_intrinsic_storage_size (se
, expr
);
7288 case GFC_ISYM_SPACING
:
7289 gfc_conv_intrinsic_spacing (se
, expr
);
7292 case GFC_ISYM_STRIDE
:
7293 conv_intrinsic_stride (se
, expr
);
7297 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
7300 case GFC_ISYM_TRANSFER
:
7301 if (se
->ss
&& se
->ss
->info
->useflags
)
7302 /* Access the previously obtained result. */
7303 gfc_conv_tmp_array_ref (se
);
7305 gfc_conv_intrinsic_transfer (se
, expr
);
7308 case GFC_ISYM_TTYNAM
:
7309 gfc_conv_intrinsic_ttynam (se
, expr
);
7312 case GFC_ISYM_UBOUND
:
7313 gfc_conv_intrinsic_bound (se
, expr
, 1);
7316 case GFC_ISYM_UCOBOUND
:
7317 conv_intrinsic_cobound (se
, expr
);
7321 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
7325 gfc_conv_intrinsic_loc (se
, expr
);
7328 case GFC_ISYM_THIS_IMAGE
:
7329 /* For num_images() == 1, handle as LCOBOUND. */
7330 if (expr
->value
.function
.actual
->expr
7331 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
7332 conv_intrinsic_cobound (se
, expr
);
7334 trans_this_image (se
, expr
);
7337 case GFC_ISYM_IMAGE_INDEX
:
7338 trans_image_index (se
, expr
);
7341 case GFC_ISYM_NUM_IMAGES
:
7342 trans_num_images (se
, expr
);
7345 case GFC_ISYM_ACCESS
:
7346 case GFC_ISYM_CHDIR
:
7347 case GFC_ISYM_CHMOD
:
7348 case GFC_ISYM_DTIME
:
7349 case GFC_ISYM_ETIME
:
7350 case GFC_ISYM_EXTENDS_TYPE_OF
:
7352 case GFC_ISYM_FGETC
:
7355 case GFC_ISYM_FPUTC
:
7356 case GFC_ISYM_FSTAT
:
7357 case GFC_ISYM_FTELL
:
7358 case GFC_ISYM_GETCWD
:
7359 case GFC_ISYM_GETGID
:
7360 case GFC_ISYM_GETPID
:
7361 case GFC_ISYM_GETUID
:
7362 case GFC_ISYM_HOSTNM
:
7364 case GFC_ISYM_IERRNO
:
7365 case GFC_ISYM_IRAND
:
7366 case GFC_ISYM_ISATTY
:
7369 case GFC_ISYM_LSTAT
:
7370 case GFC_ISYM_MALLOC
:
7371 case GFC_ISYM_MATMUL
:
7372 case GFC_ISYM_MCLOCK
:
7373 case GFC_ISYM_MCLOCK8
:
7375 case GFC_ISYM_RENAME
:
7376 case GFC_ISYM_SECOND
:
7377 case GFC_ISYM_SECNDS
:
7378 case GFC_ISYM_SIGNAL
:
7380 case GFC_ISYM_SYMLNK
:
7381 case GFC_ISYM_SYSTEM
:
7383 case GFC_ISYM_TIME8
:
7384 case GFC_ISYM_UMASK
:
7385 case GFC_ISYM_UNLINK
:
7387 gfc_conv_intrinsic_funcall (se
, expr
);
7390 case GFC_ISYM_EOSHIFT
:
7392 case GFC_ISYM_RESHAPE
:
7393 /* For those, expr->rank should always be >0 and thus the if above the
7394 switch should have matched. */
7399 gfc_conv_intrinsic_lib_function (se
, expr
);
7406 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
7408 gfc_ss
*arg_ss
, *tmp_ss
;
7409 gfc_actual_arglist
*arg
;
7411 arg
= expr
->value
.function
.actual
;
7413 gcc_assert (arg
->expr
);
7415 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
7416 gcc_assert (arg_ss
!= gfc_ss_terminator
);
7418 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
7420 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
7421 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
7425 gcc_assert (tmp_ss
->dimen
== 2);
7427 /* We just invert dimensions. */
7428 tmp_dim
= tmp_ss
->dim
[0];
7429 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
7430 tmp_ss
->dim
[1] = tmp_dim
;
7433 /* Stop when tmp_ss points to the last valid element of the chain... */
7434 if (tmp_ss
->next
== gfc_ss_terminator
)
7438 /* ... so that we can attach the rest of the chain to it. */
7445 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
7446 This has the side effect of reversing the nested list, so there is no
7447 need to call gfc_reverse_ss on it (the given list is assumed not to be
7451 nest_loop_dimension (gfc_ss
*ss
, int dim
)
7454 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
7455 gfc_loopinfo
*new_loop
;
7457 gcc_assert (ss
!= gfc_ss_terminator
);
7459 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
7461 new_ss
= gfc_get_ss ();
7462 new_ss
->next
= prev_ss
;
7463 new_ss
->parent
= ss
;
7464 new_ss
->info
= ss
->info
;
7465 new_ss
->info
->refcount
++;
7468 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
7469 && ss
->info
->type
!= GFC_SS_REFERENCE
);
7472 new_ss
->dim
[0] = ss
->dim
[dim
];
7474 gcc_assert (dim
< ss
->dimen
);
7476 ss_dim
= --ss
->dimen
;
7477 for (i
= dim
; i
< ss_dim
; i
++)
7478 ss
->dim
[i
] = ss
->dim
[i
+ 1];
7480 ss
->dim
[ss_dim
] = 0;
7486 ss
->nested_ss
->parent
= new_ss
;
7487 new_ss
->nested_ss
= ss
->nested_ss
;
7489 ss
->nested_ss
= new_ss
;
7492 new_loop
= gfc_get_loopinfo ();
7493 gfc_init_loopinfo (new_loop
);
7495 gcc_assert (prev_ss
!= NULL
);
7496 gcc_assert (prev_ss
!= gfc_ss_terminator
);
7497 gfc_add_ss_to_loop (new_loop
, prev_ss
);
7498 return new_ss
->parent
;
7502 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
7503 is to be inlined. */
7506 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
7508 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
7509 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
7511 bool scalar_mask
= false;
7513 /* The rank of the result will be determined later. */
7514 arg1
= expr
->value
.function
.actual
;
7517 gcc_assert (arg3
!= NULL
);
7519 if (expr
->rank
== 0)
7522 tmp_ss
= gfc_ss_terminator
;
7528 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
7529 if (mask_ss
== tmp_ss
)
7535 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
7536 gcc_assert (array_ss
!= tmp_ss
);
7538 /* Odd thing: If the mask is scalar, it is used by the frontend after
7539 the array (to make an if around the nested loop). Thus it shall
7540 be after array_ss once the gfc_ss list is reversed. */
7542 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
7546 /* "Hide" the dimension on which we will sum in the first arg's scalarization
7548 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
7549 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
7557 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
7560 switch (expr
->value
.function
.isym
->id
)
7562 case GFC_ISYM_PRODUCT
:
7564 return walk_inline_intrinsic_arith (ss
, expr
);
7566 case GFC_ISYM_TRANSPOSE
:
7567 return walk_inline_intrinsic_transpose (ss
, expr
);
7576 /* This generates code to execute before entering the scalarization loop.
7577 Currently does nothing. */
7580 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
7582 switch (ss
->info
->expr
->value
.function
.isym
->id
)
7584 case GFC_ISYM_UBOUND
:
7585 case GFC_ISYM_LBOUND
:
7586 case GFC_ISYM_UCOBOUND
:
7587 case GFC_ISYM_LCOBOUND
:
7588 case GFC_ISYM_THIS_IMAGE
:
7597 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
7598 are expanded into code inside the scalarization loop. */
7601 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
7603 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
7604 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
7606 /* The two argument version returns a scalar. */
7607 if (expr
->value
.function
.actual
->next
->expr
)
7610 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
7614 /* Walk an intrinsic array libcall. */
7617 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
7619 gcc_assert (expr
->rank
> 0);
7620 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
7624 /* Return whether the function call expression EXPR will be expanded
7625 inline by gfc_conv_intrinsic_function. */
7628 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
7630 gfc_actual_arglist
*args
;
7632 if (!expr
->value
.function
.isym
)
7635 switch (expr
->value
.function
.isym
->id
)
7637 case GFC_ISYM_PRODUCT
:
7639 /* Disable inline expansion if code size matters. */
7643 args
= expr
->value
.function
.actual
;
7644 /* We need to be able to subset the SUM argument at compile-time. */
7645 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
7650 case GFC_ISYM_TRANSPOSE
:
7659 /* Returns nonzero if the specified intrinsic function call maps directly to
7660 an external library call. Should only be used for functions that return
7664 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
7666 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
7667 gcc_assert (expr
->rank
> 0);
7669 if (gfc_inline_intrinsic_function_p (expr
))
7672 switch (expr
->value
.function
.isym
->id
)
7676 case GFC_ISYM_COUNT
:
7680 case GFC_ISYM_IPARITY
:
7681 case GFC_ISYM_MATMUL
:
7682 case GFC_ISYM_MAXLOC
:
7683 case GFC_ISYM_MAXVAL
:
7684 case GFC_ISYM_MINLOC
:
7685 case GFC_ISYM_MINVAL
:
7686 case GFC_ISYM_NORM2
:
7687 case GFC_ISYM_PARITY
:
7688 case GFC_ISYM_PRODUCT
:
7690 case GFC_ISYM_SHAPE
:
7691 case GFC_ISYM_SPREAD
:
7693 /* Ignore absent optional parameters. */
7696 case GFC_ISYM_RESHAPE
:
7697 case GFC_ISYM_CSHIFT
:
7698 case GFC_ISYM_EOSHIFT
:
7700 case GFC_ISYM_UNPACK
:
7701 /* Pass absent optional parameters. */
7709 /* Walk an intrinsic function. */
7711 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
7712 gfc_intrinsic_sym
* isym
)
7716 if (isym
->elemental
)
7717 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
7718 NULL
, GFC_SS_SCALAR
);
7720 if (expr
->rank
== 0)
7723 if (gfc_inline_intrinsic_function_p (expr
))
7724 return walk_inline_intrinsic_function (ss
, expr
);
7726 if (gfc_is_intrinsic_libcall (expr
))
7727 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7729 /* Special cases. */
7732 case GFC_ISYM_LBOUND
:
7733 case GFC_ISYM_LCOBOUND
:
7734 case GFC_ISYM_UBOUND
:
7735 case GFC_ISYM_UCOBOUND
:
7736 case GFC_ISYM_THIS_IMAGE
:
7737 return gfc_walk_intrinsic_bound (ss
, expr
);
7739 case GFC_ISYM_TRANSFER
:
7740 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7743 /* This probably meant someone forgot to add an intrinsic to the above
7744 list(s) when they implemented it, or something's gone horribly
7752 conv_co_minmaxsum (gfc_code
*code
)
7755 stmtblock_t block
, post_block
;
7756 tree fndecl
, array
, vec
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
7758 gfc_start_block (&block
);
7759 gfc_init_block (&post_block
);
7762 if (code
->ext
.actual
->next
->next
->expr
)
7764 gfc_init_se (&argse
, NULL
);
7765 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
7766 gfc_add_block_to_block (&block
, &argse
.pre
);
7767 gfc_add_block_to_block (&post_block
, &argse
.post
);
7769 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
7770 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
7772 else if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
7775 stat
= null_pointer_node
;
7777 /* Early exit for GFC_FCOARRAY_SINGLE. */
7778 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
7780 if (stat
!= NULL_TREE
)
7781 gfc_add_modify (&block
, stat
,
7782 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
7783 return gfc_finish_block (&block
);
7786 /* Handle the array. */
7787 gfc_init_se (&argse
, NULL
);
7788 if (code
->ext
.actual
->expr
->rank
== 0)
7790 symbol_attribute attr
;
7791 gfc_clear_attr (&attr
);
7792 gfc_init_se (&argse
, NULL
);
7793 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
7794 gfc_add_block_to_block (&block
, &argse
.pre
);
7795 gfc_add_block_to_block (&post_block
, &argse
.post
);
7796 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
7797 array
= gfc_build_addr_expr (NULL_TREE
, array
);
7801 argse
.want_pointer
= 1;
7802 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
7805 gfc_add_block_to_block (&block
, &argse
.pre
);
7806 gfc_add_block_to_block (&post_block
, &argse
.post
);
7808 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
7809 strlen
= argse
.string_length
;
7811 strlen
= integer_zero_node
;
7813 vec
= null_pointer_node
;
7816 if (code
->ext
.actual
->next
->expr
)
7818 gfc_init_se (&argse
, NULL
);
7819 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
7820 gfc_add_block_to_block (&block
, &argse
.pre
);
7821 gfc_add_block_to_block (&post_block
, &argse
.post
);
7822 image_index
= fold_convert (integer_type_node
, argse
.expr
);
7825 image_index
= integer_zero_node
;
7828 if (code
->ext
.actual
->next
->next
->next
->expr
)
7830 gfc_init_se (&argse
, NULL
);
7831 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
7832 gfc_add_block_to_block (&block
, &argse
.pre
);
7833 gfc_add_block_to_block (&post_block
, &argse
.post
);
7834 errmsg
= argse
.expr
;
7835 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
7839 errmsg
= null_pointer_node
;
7840 errmsg_len
= integer_zero_node
;
7843 /* Generate the function call. */
7844 if (code
->resolved_isym
->id
== GFC_ISYM_CO_MAX
)
7845 fndecl
= gfor_fndecl_co_max
;
7846 else if (code
->resolved_isym
->id
== GFC_ISYM_CO_MIN
)
7847 fndecl
= gfor_fndecl_co_min
;
7848 else if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
)
7849 fndecl
= gfor_fndecl_co_sum
;
7853 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
)
7854 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, vec
,
7855 image_index
, stat
, errmsg
, errmsg_len
);
7857 fndecl
= build_call_expr_loc (input_location
, fndecl
, 7, array
, vec
,
7858 image_index
, stat
, errmsg
, strlen
,
7860 gfc_add_expr_to_block (&block
, fndecl
);
7861 gfc_add_block_to_block (&block
, &post_block
);
7863 /* Add CALL to CO_SUM/MIN/MAX: array descriptor, vector descriptor, stat, errmsg, strlen, errmsglen */
7864 return gfc_finish_block (&block
);
7869 conv_intrinsic_atomic_def (gfc_code
*code
)
7874 gfc_init_se (&atom
, NULL
);
7875 gfc_init_se (&value
, NULL
);
7876 gfc_conv_expr (&atom
, code
->ext
.actual
->expr
);
7877 gfc_conv_expr (&value
, code
->ext
.actual
->next
->expr
);
7879 gfc_init_block (&block
);
7880 gfc_add_modify (&block
, atom
.expr
,
7881 fold_convert (TREE_TYPE (atom
.expr
), value
.expr
));
7882 return gfc_finish_block (&block
);
7887 conv_intrinsic_atomic_ref (gfc_code
*code
)
7892 gfc_init_se (&atom
, NULL
);
7893 gfc_init_se (&value
, NULL
);
7894 gfc_conv_expr (&value
, code
->ext
.actual
->expr
);
7895 gfc_conv_expr (&atom
, code
->ext
.actual
->next
->expr
);
7897 gfc_init_block (&block
);
7898 gfc_add_modify (&block
, value
.expr
,
7899 fold_convert (TREE_TYPE (value
.expr
), atom
.expr
));
7900 return gfc_finish_block (&block
);
7905 conv_intrinsic_move_alloc (gfc_code
*code
)
7908 gfc_expr
*from_expr
, *to_expr
;
7909 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
7910 gfc_se from_se
, to_se
;
7914 gfc_start_block (&block
);
7916 from_expr
= code
->ext
.actual
->expr
;
7917 to_expr
= code
->ext
.actual
->next
->expr
;
7919 gfc_init_se (&from_se
, NULL
);
7920 gfc_init_se (&to_se
, NULL
);
7922 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
7923 || to_expr
->ts
.type
== BT_CLASS
);
7924 coarray
= gfc_get_corank (from_expr
) != 0;
7926 if (from_expr
->rank
== 0 && !coarray
)
7928 if (from_expr
->ts
.type
!= BT_CLASS
)
7929 from_expr2
= from_expr
;
7932 from_expr2
= gfc_copy_expr (from_expr
);
7933 gfc_add_data_component (from_expr2
);
7936 if (to_expr
->ts
.type
!= BT_CLASS
)
7940 to_expr2
= gfc_copy_expr (to_expr
);
7941 gfc_add_data_component (to_expr2
);
7944 from_se
.want_pointer
= 1;
7945 to_se
.want_pointer
= 1;
7946 gfc_conv_expr (&from_se
, from_expr2
);
7947 gfc_conv_expr (&to_se
, to_expr2
);
7948 gfc_add_block_to_block (&block
, &from_se
.pre
);
7949 gfc_add_block_to_block (&block
, &to_se
.pre
);
7951 /* Deallocate "to". */
7952 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
7953 to_expr
, to_expr
->ts
);
7954 gfc_add_expr_to_block (&block
, tmp
);
7956 /* Assign (_data) pointers. */
7957 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7958 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
7960 /* Set "from" to NULL. */
7961 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7962 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
7964 gfc_add_block_to_block (&block
, &from_se
.post
);
7965 gfc_add_block_to_block (&block
, &to_se
.post
);
7968 if (to_expr
->ts
.type
== BT_CLASS
)
7972 gfc_free_expr (to_expr2
);
7973 gfc_init_se (&to_se
, NULL
);
7974 to_se
.want_pointer
= 1;
7975 gfc_add_vptr_component (to_expr
);
7976 gfc_conv_expr (&to_se
, to_expr
);
7978 if (from_expr
->ts
.type
== BT_CLASS
)
7980 if (UNLIMITED_POLY (from_expr
))
7984 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7988 gfc_free_expr (from_expr2
);
7989 gfc_init_se (&from_se
, NULL
);
7990 from_se
.want_pointer
= 1;
7991 gfc_add_vptr_component (from_expr
);
7992 gfc_conv_expr (&from_se
, from_expr
);
7993 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7994 fold_convert (TREE_TYPE (to_se
.expr
),
7997 /* Reset _vptr component to declared type. */
7999 /* Unlimited polymorphic. */
8000 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
8001 fold_convert (TREE_TYPE (from_se
.expr
),
8002 null_pointer_node
));
8005 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
8006 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
8007 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
8012 vtab
= gfc_find_vtab (&from_expr
->ts
);
8014 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
8015 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
8016 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
8020 return gfc_finish_block (&block
);
8023 /* Update _vptr component. */
8024 if (to_expr
->ts
.type
== BT_CLASS
)
8028 to_se
.want_pointer
= 1;
8029 to_expr2
= gfc_copy_expr (to_expr
);
8030 gfc_add_vptr_component (to_expr2
);
8031 gfc_conv_expr (&to_se
, to_expr2
);
8033 if (from_expr
->ts
.type
== BT_CLASS
)
8035 if (UNLIMITED_POLY (from_expr
))
8039 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
8043 from_se
.want_pointer
= 1;
8044 from_expr2
= gfc_copy_expr (from_expr
);
8045 gfc_add_vptr_component (from_expr2
);
8046 gfc_conv_expr (&from_se
, from_expr2
);
8047 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
8048 fold_convert (TREE_TYPE (to_se
.expr
),
8051 /* Reset _vptr component to declared type. */
8053 /* Unlimited polymorphic. */
8054 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
8055 fold_convert (TREE_TYPE (from_se
.expr
),
8056 null_pointer_node
));
8059 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
8060 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
8061 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
8066 vtab
= gfc_find_vtab (&from_expr
->ts
);
8068 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
8069 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
8070 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
8073 gfc_free_expr (to_expr2
);
8074 gfc_init_se (&to_se
, NULL
);
8076 if (from_expr
->ts
.type
== BT_CLASS
)
8078 gfc_free_expr (from_expr2
);
8079 gfc_init_se (&from_se
, NULL
);
8084 /* Deallocate "to". */
8085 if (from_expr
->rank
== 0)
8087 to_se
.want_coarray
= 1;
8088 from_se
.want_coarray
= 1;
8090 gfc_conv_expr_descriptor (&to_se
, to_expr
);
8091 gfc_conv_expr_descriptor (&from_se
, from_expr
);
8093 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
8094 is an image control "statement", cf. IR F08/0040 in 12-006A. */
8095 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
8099 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
8100 NULL_TREE
, NULL_TREE
, true, to_expr
,
8102 gfc_add_expr_to_block (&block
, tmp
);
8104 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
8105 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8106 boolean_type_node
, tmp
,
8107 fold_convert (TREE_TYPE (tmp
),
8108 null_pointer_node
));
8109 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
8110 3, null_pointer_node
, null_pointer_node
,
8111 build_int_cst (integer_type_node
, 0));
8113 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
8114 tmp
, build_empty_stmt (input_location
));
8115 gfc_add_expr_to_block (&block
, tmp
);
8119 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
8120 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
8121 NULL_TREE
, true, to_expr
, false);
8122 gfc_add_expr_to_block (&block
, tmp
);
8125 /* Move the pointer and update the array descriptor data. */
8126 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
8128 /* Set "from" to NULL. */
8129 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
8130 gfc_add_modify_loc (input_location
, &block
, tmp
,
8131 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
8133 return gfc_finish_block (&block
);
8138 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
8142 gcc_assert (code
->resolved_isym
);
8144 switch (code
->resolved_isym
->id
)
8146 case GFC_ISYM_MOVE_ALLOC
:
8147 res
= conv_intrinsic_move_alloc (code
);
8150 case GFC_ISYM_ATOMIC_DEF
:
8151 res
= conv_intrinsic_atomic_def (code
);
8154 case GFC_ISYM_ATOMIC_REF
:
8155 res
= conv_intrinsic_atomic_ref (code
);
8158 case GFC_ISYM_C_F_POINTER
:
8159 case GFC_ISYM_C_F_PROCPOINTER
:
8160 res
= conv_isocbinding_subroutine (code
);
8163 case GFC_ISYM_CAF_SEND
:
8164 res
= conv_caf_send (code
);
8167 case GFC_ISYM_CO_MIN
:
8168 case GFC_ISYM_CO_MAX
:
8169 case GFC_ISYM_CO_SUM
:
8170 res
= conv_co_minmaxsum (code
);
8181 #include "gt-fortran-trans-intrinsic.h"