1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
28 #include "coretypes.h"
29 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "diagnostic-core.h" /* For internal_error. */
33 #include "toplev.h" /* For rest_of_decl_compilation. */
37 #include "intrinsic.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps Fortran intrinsic math functions to external library or GCC
47 typedef struct GTY(()) gfc_intrinsic_map_t
{
48 /* The explicit enum is required to work around inadequacies in the
49 garbage collection/gengtype parsing mechanism. */
52 /* Enum value from the "language-independent", aka C-centric, part
53 of gcc, or END_BUILTINS of no such value set. */
54 enum built_in_function float_built_in
;
55 enum built_in_function double_built_in
;
56 enum built_in_function long_double_built_in
;
57 enum built_in_function complex_float_built_in
;
58 enum built_in_function complex_double_built_in
;
59 enum built_in_function complex_long_double_built_in
;
61 /* True if the naming pattern is to prepend "c" for complex and
62 append "f" for kind=4. False if the naming pattern is to
63 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 /* True if a complex version of the function exists. */
67 bool complex_available
;
69 /* True if the function should be marked const. */
72 /* The base library name of this function. */
75 /* Cache decls created for the various operand types. */
87 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
88 defines complex variants of all of the entries in mathbuiltins.def
90 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
91 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
92 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
93 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
94 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
96 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
97 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
98 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
99 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
100 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
102 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
108 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
109 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
110 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
116 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
117 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
118 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
119 #include "mathbuiltins.def"
121 /* Functions in libgfortran. */
122 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
125 LIB_FUNCTION (NONE
, NULL
, false)
130 #undef DEFINE_MATH_BUILTIN
131 #undef DEFINE_MATH_BUILTIN_C
134 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
137 /* Find the correct variant of a given builtin from its argument. */
139 builtin_decl_for_precision (enum built_in_function base_built_in
,
142 enum built_in_function i
= END_BUILTINS
;
144 gfc_intrinsic_map_t
*m
;
145 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
148 if (precision
== TYPE_PRECISION (float_type_node
))
149 i
= m
->float_built_in
;
150 else if (precision
== TYPE_PRECISION (double_type_node
))
151 i
= m
->double_built_in
;
152 else if (precision
== TYPE_PRECISION (long_double_type_node
))
153 i
= m
->long_double_built_in
;
154 else if (precision
== TYPE_PRECISION (float128_type_node
))
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m
->real16_decl
;
161 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
169 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
171 if (gfc_real_kinds
[i
].c_float128
)
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t
*m
;
176 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
179 return m
->real16_decl
;
182 return builtin_decl_for_precision (double_built_in
,
183 gfc_real_kinds
[i
].mode_precision
);
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
193 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
194 tree
*argarray
, int nargs
)
196 gfc_actual_arglist
*actual
;
198 gfc_intrinsic_arg
*formal
;
202 formal
= expr
->value
.function
.isym
->formal
;
203 actual
= expr
->value
.function
.actual
;
205 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
206 actual
= actual
->next
,
207 formal
= formal
? formal
->next
: NULL
)
211 /* Skip omitted optional arguments. */
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse
, se
);
222 if (e
->ts
.type
== BT_CHARACTER
)
224 gfc_conv_expr (&argse
, e
);
225 gfc_conv_string_parameter (&argse
);
226 argarray
[curr_arg
++] = argse
.string_length
;
227 gcc_assert (curr_arg
< nargs
);
230 gfc_conv_expr_val (&argse
, e
);
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e
->expr_type
== EXPR_VARIABLE
235 && e
->symtree
->n
.sym
->attr
.optional
238 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
240 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
241 gfc_add_block_to_block (&se
->post
, &argse
.post
);
242 argarray
[curr_arg
] = argse
.expr
;
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
250 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
253 gfc_actual_arglist
*actual
;
255 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
260 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
274 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
280 nargs
= gfc_intrinsic_argument_list_length (expr
);
281 args
= XALLOCAVEC (tree
, nargs
);
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type
= gfc_typenode_for_spec (&expr
->ts
);
287 gcc_assert (expr
->value
.function
.actual
->expr
);
288 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
290 /* Conversion between character kinds involves a call to a library
292 if (expr
->ts
.type
== BT_CHARACTER
)
294 tree fndecl
, var
, addr
, tmp
;
296 if (expr
->ts
.kind
== 1
297 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
298 fndecl
= gfor_fndecl_convert_char4_to_char1
;
299 else if (expr
->ts
.kind
== 4
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
301 fndecl
= gfor_fndecl_convert_char1_to_char4
;
305 /* Create the variable storing the converted value. */
306 type
= gfc_get_pchar_type (expr
->ts
.kind
);
307 var
= gfc_create_var (type
, "str");
308 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs
>= 2);
312 tmp
= build_call_expr_loc (input_location
,
313 fndecl
, 3, addr
, args
[0], args
[1]);
314 gfc_add_expr_to_block (&se
->pre
, tmp
);
316 /* Free the temporary afterwards. */
317 tmp
= gfc_call_free (var
);
318 gfc_add_expr_to_block (&se
->post
, tmp
);
321 se
->string_length
= args
[0];
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
329 && expr
->ts
.type
!= BT_COMPLEX
)
333 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
334 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
338 se
->expr
= convert (type
, args
[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
354 argtype
= TREE_TYPE (arg
);
355 arg
= gfc_evaluate_now (arg
, pblock
);
357 intval
= convert (type
, arg
);
358 intval
= gfc_evaluate_now (intval
, pblock
);
360 tmp
= convert (argtype
, intval
);
361 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
362 boolean_type_node
, tmp
, arg
);
364 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
365 intval
, build_int_cst (type
, 1));
366 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg
, tree restype
)
378 int argprec
, resprec
;
380 argtype
= TREE_TYPE (arg
);
381 argprec
= TYPE_PRECISION (argtype
);
382 resprec
= TYPE_PRECISION (restype
);
384 /* Depending on the type of the result, choose the int intrinsic
385 (iround, available only as a builtin, therefore cannot use it for
386 __float128), long int intrinsic (lround family) or long long
387 intrinsic (llround). We might also need to convert the result
389 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
390 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
391 else if (resprec
<= LONG_TYPE_SIZE
)
392 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
393 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
394 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
398 return fold_convert (restype
, build_call_expr_loc (input_location
,
403 /* Convert a real to an integer using a specific rounding mode.
404 Ideally we would just build the corresponding GENERIC node,
405 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
408 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
409 enum rounding_mode op
)
414 return build_fixbound_expr (pblock
, arg
, type
, 0);
418 return build_fixbound_expr (pblock
, arg
, type
, 1);
422 return build_round_expr (arg
, type
);
426 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
435 /* Round a real value using the specified rounding mode.
436 We use a temporary integer of that same kind size as the result.
437 Values larger than those that can be represented by this kind are
438 unchanged, as they will not be accurate enough to represent the
440 huge = HUGE (KIND (a))
441 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
445 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
457 kind
= expr
->ts
.kind
;
458 nargs
= gfc_intrinsic_argument_list_length (expr
);
461 /* We have builtin functions for some cases. */
465 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
469 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
476 /* Evaluate the argument. */
477 gcc_assert (expr
->value
.function
.actual
->expr
);
478 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
480 /* Use a builtin function if one exists. */
481 if (decl
!= NULL_TREE
)
483 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
487 /* This code is probably redundant, but we'll keep it lying around just
489 type
= gfc_typenode_for_spec (&expr
->ts
);
490 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
492 /* Test if the value is too large to handle sensibly. */
493 gfc_set_model_kind (kind
);
495 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
496 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
497 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
498 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
501 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
502 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
503 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
505 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
507 itype
= gfc_get_int_type (kind
);
509 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
510 tmp
= convert (type
, tmp
);
511 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
517 /* Convert to an integer using the specified rounding mode. */
520 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
526 nargs
= gfc_intrinsic_argument_list_length (expr
);
527 args
= XALLOCAVEC (tree
, nargs
);
529 /* Evaluate the argument, we process all arguments even though we only
530 use the first one for code generation purposes. */
531 type
= gfc_typenode_for_spec (&expr
->ts
);
532 gcc_assert (expr
->value
.function
.actual
->expr
);
533 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
535 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
537 /* Conversion to a different integer kind. */
538 se
->expr
= convert (type
, args
[0]);
542 /* Conversion from complex to non-complex involves taking the real
543 component of the value. */
544 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
545 && expr
->ts
.type
!= BT_COMPLEX
)
549 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
550 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
554 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
559 /* Get the imaginary component of a value. */
562 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
566 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
567 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
568 TREE_TYPE (TREE_TYPE (arg
)), arg
);
572 /* Get the complex conjugate of a value. */
575 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
579 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
580 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
586 define_quad_builtin (const char *name
, tree type
, bool is_const
)
589 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
592 /* Mark the decl as external. */
593 DECL_EXTERNAL (fndecl
) = 1;
594 TREE_PUBLIC (fndecl
) = 1;
596 /* Mark it __attribute__((const)). */
597 TREE_READONLY (fndecl
) = is_const
;
599 rest_of_decl_compilation (fndecl
, 1, 0);
606 /* Initialize function decls for library functions. The external functions
607 are created as required. Builtin functions are added here. */
610 gfc_build_intrinsic_lib_fndecls (void)
612 gfc_intrinsic_map_t
*m
;
613 tree quad_decls
[END_BUILTINS
+ 1];
615 if (gfc_real16_is_float128
)
617 /* If we have soft-float types, we create the decls for their
618 C99-like library functions. For now, we only handle __float128
619 q-suffixed functions. */
621 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
622 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
624 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
626 type
= float128_type_node
;
627 complex_type
= complex_float128_type_node
;
628 /* type (*) (type) */
629 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
631 func_iround
= build_function_type_list (integer_type_node
,
633 /* long (*) (type) */
634 func_lround
= build_function_type_list (long_integer_type_node
,
636 /* long long (*) (type) */
637 func_llround
= build_function_type_list (long_long_integer_type_node
,
639 /* type (*) (type, type) */
640 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
641 /* type (*) (type, &int) */
643 = build_function_type_list (type
,
645 build_pointer_type (integer_type_node
),
647 /* type (*) (type, int) */
648 func_scalbn
= build_function_type_list (type
,
649 type
, integer_type_node
, NULL_TREE
);
650 /* type (*) (complex type) */
651 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
652 /* complex type (*) (complex type, complex type) */
654 = build_function_type_list (complex_type
,
655 complex_type
, complex_type
, NULL_TREE
);
657 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
658 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
659 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
661 /* Only these built-ins are actually needed here. These are used directly
662 from the code, when calling builtin_decl_for_precision() or
663 builtin_decl_for_float_type(). The others are all constructed by
664 gfc_get_intrinsic_lib_fndecl(). */
665 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
666 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
668 #include "mathbuiltins.def"
672 #undef DEFINE_MATH_BUILTIN
673 #undef DEFINE_MATH_BUILTIN_C
677 /* Add GCC builtin functions. */
678 for (m
= gfc_intrinsic_map
;
679 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
681 if (m
->float_built_in
!= END_BUILTINS
)
682 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
683 if (m
->complex_float_built_in
!= END_BUILTINS
)
684 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
685 if (m
->double_built_in
!= END_BUILTINS
)
686 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
687 if (m
->complex_double_built_in
!= END_BUILTINS
)
688 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
690 /* If real(kind=10) exists, it is always long double. */
691 if (m
->long_double_built_in
!= END_BUILTINS
)
692 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
693 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
695 = builtin_decl_explicit (m
->complex_long_double_built_in
);
697 if (!gfc_real16_is_float128
)
699 if (m
->long_double_built_in
!= END_BUILTINS
)
700 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
701 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
703 = builtin_decl_explicit (m
->complex_long_double_built_in
);
705 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m
->real16_decl
= quad_decls
[m
->double_built_in
];
712 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
714 /* Same thing for the complex ones. */
715 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
721 /* Create a fndecl for a simple intrinsic library function. */
724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
727 vec
<tree
, va_gc
> *argtypes
;
729 gfc_actual_arglist
*actual
;
732 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
735 if (ts
->type
== BT_REAL
)
740 pdecl
= &m
->real4_decl
;
743 pdecl
= &m
->real8_decl
;
746 pdecl
= &m
->real10_decl
;
749 pdecl
= &m
->real16_decl
;
755 else if (ts
->type
== BT_COMPLEX
)
757 gcc_assert (m
->complex_available
);
762 pdecl
= &m
->complex4_decl
;
765 pdecl
= &m
->complex8_decl
;
768 pdecl
= &m
->complex10_decl
;
771 pdecl
= &m
->complex16_decl
;
785 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
786 if (gfc_real_kinds
[n
].c_float
)
787 snprintf (name
, sizeof (name
), "%s%s%s",
788 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
789 else if (gfc_real_kinds
[n
].c_double
)
790 snprintf (name
, sizeof (name
), "%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
792 else if (gfc_real_kinds
[n
].c_long_double
)
793 snprintf (name
, sizeof (name
), "%s%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
795 else if (gfc_real_kinds
[n
].c_float128
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
803 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
804 ts
->type
== BT_COMPLEX
? 'c' : 'r',
809 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
811 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
812 vec_safe_push (argtypes
, type
);
814 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
815 fndecl
= build_decl (input_location
,
816 FUNCTION_DECL
, get_identifier (name
), type
);
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl
) = 1;
820 TREE_PUBLIC (fndecl
) = 1;
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl
) = m
->is_constant
;
825 rest_of_decl_compilation (fndecl
, 1, 0);
832 /* Convert an intrinsic function into an external or builtin call. */
835 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
837 gfc_intrinsic_map_t
*m
;
841 unsigned int num_args
;
844 id
= expr
->value
.function
.isym
->id
;
845 /* Find the entry for this function. */
846 for (m
= gfc_intrinsic_map
;
847 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
853 if (m
->id
== GFC_ISYM_NONE
)
855 internal_error ("Intrinsic function %s(%d) not recognized",
856 expr
->value
.function
.name
, id
);
859 /* Get the decl and generate the call. */
860 num_args
= gfc_intrinsic_argument_list_length (expr
);
861 args
= XALLOCAVEC (tree
, num_args
);
863 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
864 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
865 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
867 fndecl
= build_addr (fndecl
, current_function_decl
);
868 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
877 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
878 tree a
, tree b
, stmtblock_t
* target
)
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
887 /* Compare the two string lengths. */
888 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
890 /* Output the runtime-check. */
891 name
= gfc_build_cstring_const (intr_name
);
892 name
= gfc_build_addr_expr (pchar_type_node
, name
);
893 gfc_trans_runtime_check (true, false, cond
, target
, where
,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node
, a
),
896 fold_convert (long_integer_type_node
, b
), name
);
900 /* The EXPONENT(s) intrinsic function is translated into
907 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
909 tree arg
, type
, res
, tmp
, frexp
;
911 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
912 expr
->value
.function
.actual
->expr
->ts
.kind
);
914 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
916 res
= gfc_create_var (integer_type_node
, NULL
);
917 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
918 gfc_build_addr_expr (NULL_TREE
, res
));
919 gfc_add_expr_to_block (&se
->pre
, tmp
);
921 type
= gfc_typenode_for_spec (&expr
->ts
);
922 se
->expr
= fold_convert (type
, res
);
927 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
930 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
931 lbound
, ubound
, extent
, ml
;
935 /* The case -fcoarray=single is handled elsewhere. */
936 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
938 gfc_init_coarray_decl (false);
940 /* Argument-free version: THIS_IMAGE(). */
941 if (expr
->value
.function
.actual
->expr
== NULL
)
943 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
944 gfort_gvar_caf_this_image
);
948 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
950 type
= gfc_get_int_type (gfc_default_integer_kind
);
951 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
952 rank
= expr
->value
.function
.actual
->expr
->rank
;
954 /* Obtain the descriptor of the COARRAY. */
955 gfc_init_se (&argse
, NULL
);
956 argse
.want_coarray
= 1;
957 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
958 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
959 gfc_add_block_to_block (&se
->post
, &argse
.post
);
964 /* Create an implicit second parameter from the loop variable. */
965 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
966 gcc_assert (corank
> 0);
967 gcc_assert (se
->loop
->dimen
== 1);
968 gcc_assert (se
->ss
->info
->expr
== expr
);
970 dim_arg
= se
->loop
->loopvar
[0];
971 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
972 gfc_array_index_type
, dim_arg
,
973 build_int_cst (TREE_TYPE (dim_arg
), 1));
974 gfc_advance_se_ss_chain (se
);
978 /* Use the passed DIM= argument. */
979 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
980 gfc_init_se (&argse
, NULL
);
981 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
982 gfc_array_index_type
);
983 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
984 dim_arg
= argse
.expr
;
986 if (INTEGER_CST_P (dim_arg
))
990 hi
= TREE_INT_CST_HIGH (dim_arg
);
991 co_dim
= TREE_INT_CST_LOW (dim_arg
);
993 || co_dim
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
994 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
995 "dimension index", expr
->value
.function
.isym
->name
,
998 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1000 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1001 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1003 build_int_cst (TREE_TYPE (dim_arg
), 1));
1004 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1005 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1007 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1008 boolean_type_node
, cond
, tmp
);
1009 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1014 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1015 one always has a dim_arg argument.
1017 m = this_image() - 1
1020 sub(1) = m + lcobound(corank)
1024 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1027 extent = gfc_extent(i)
1035 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1036 : m + lcobound(corank)
1039 /* this_image () - 1. */
1040 tmp
= fold_convert (type
, gfort_gvar_caf_this_image
);
1041 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, tmp
,
1042 build_int_cst (type
, 1));
1045 /* sub(1) = m + lcobound(corank). */
1046 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1047 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1049 lbound
= fold_convert (type
, lbound
);
1050 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1056 m
= gfc_create_var (type
, NULL
);
1057 ml
= gfc_create_var (type
, NULL
);
1058 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1059 min_var
= gfc_create_var (integer_type_node
, NULL
);
1061 /* m = this_image () - 1. */
1062 gfc_add_modify (&se
->pre
, m
, tmp
);
1064 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1065 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1066 fold_convert (integer_type_node
, dim_arg
),
1067 build_int_cst (integer_type_node
, rank
- 1));
1068 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1069 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1071 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1074 tmp
= build_int_cst (integer_type_node
, rank
);
1075 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1077 exit_label
= gfc_build_label_decl (NULL_TREE
);
1078 TREE_USED (exit_label
) = 1;
1081 gfc_init_block (&loop
);
1084 gfc_add_modify (&loop
, ml
, m
);
1087 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1088 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1089 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1090 extent
= fold_convert (type
, extent
);
1093 gfc_add_modify (&loop
, m
,
1094 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1097 /* Exit condition: if (i >= min_var) goto exit_label. */
1098 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1100 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1101 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1102 build_empty_stmt (input_location
));
1103 gfc_add_expr_to_block (&loop
, tmp
);
1105 /* Increment loop variable: i++. */
1106 gfc_add_modify (&loop
, loop_var
,
1107 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1109 build_int_cst (integer_type_node
, 1)));
1111 /* Making the loop... actually loop! */
1112 tmp
= gfc_finish_block (&loop
);
1113 tmp
= build1_v (LOOP_EXPR
, tmp
);
1114 gfc_add_expr_to_block (&se
->pre
, tmp
);
1116 /* The exit label. */
1117 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1118 gfc_add_expr_to_block (&se
->pre
, tmp
);
1120 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1121 : m + lcobound(corank) */
1123 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1124 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1126 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1127 fold_build2_loc (input_location
, PLUS_EXPR
,
1128 gfc_array_index_type
, dim_arg
,
1129 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1130 lbound
= fold_convert (type
, lbound
);
1132 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1133 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1135 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1137 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1138 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1144 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1146 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1148 gfc_se argse
, subse
;
1149 int rank
, corank
, codim
;
1151 type
= gfc_get_int_type (gfc_default_integer_kind
);
1152 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1153 rank
= expr
->value
.function
.actual
->expr
->rank
;
1155 /* Obtain the descriptor of the COARRAY. */
1156 gfc_init_se (&argse
, NULL
);
1157 argse
.want_coarray
= 1;
1158 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1159 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1160 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1163 /* Obtain a handle to the SUB argument. */
1164 gfc_init_se (&subse
, NULL
);
1165 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1166 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1167 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1168 subdesc
= build_fold_indirect_ref_loc (input_location
,
1169 gfc_conv_descriptor_data_get (subse
.expr
));
1171 /* Fortran 2008 does not require that the values remain in the cobounds,
1172 thus we need explicitly check this - and return 0 if they are exceeded. */
1174 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1175 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1176 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1177 fold_convert (gfc_array_index_type
, tmp
),
1180 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1182 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1183 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1184 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1185 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1186 fold_convert (gfc_array_index_type
, tmp
),
1188 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1189 boolean_type_node
, invalid_bound
, cond
);
1190 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1191 fold_convert (gfc_array_index_type
, tmp
),
1193 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1194 boolean_type_node
, invalid_bound
, cond
);
1197 invalid_bound
= gfc_unlikely (invalid_bound
);
1200 /* See Fortran 2008, C.10 for the following algorithm. */
1202 /* coindex = sub(corank) - lcobound(n). */
1203 coindex
= fold_convert (gfc_array_index_type
,
1204 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1206 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1207 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1208 fold_convert (gfc_array_index_type
, coindex
),
1211 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1213 tree extent
, ubound
;
1215 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1216 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1217 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1218 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1220 /* coindex *= extent. */
1221 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1222 gfc_array_index_type
, coindex
, extent
);
1224 /* coindex += sub(codim). */
1225 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1226 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1227 gfc_array_index_type
, coindex
,
1228 fold_convert (gfc_array_index_type
, tmp
));
1230 /* coindex -= lbound(codim). */
1231 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1232 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1233 gfc_array_index_type
, coindex
, lbound
);
1236 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1237 fold_convert(type
, coindex
),
1238 build_int_cst (type
, 1));
1240 /* Return 0 if "coindex" exceeds num_images(). */
1242 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1243 num_images
= build_int_cst (type
, 1);
1246 gfc_init_coarray_decl (false);
1247 num_images
= fold_convert (type
, gfort_gvar_caf_num_images
);
1250 tmp
= gfc_create_var (type
, NULL
);
1251 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1253 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1255 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1257 fold_convert (boolean_type_node
, invalid_bound
));
1258 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1259 build_int_cst (type
, 0), tmp
);
1264 trans_num_images (gfc_se
* se
)
1266 gfc_init_coarray_decl (false);
1267 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1268 gfort_gvar_caf_num_images
);
1273 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1277 gfc_init_se (&argse
, NULL
);
1278 argse
.data_not_needed
= 1;
1279 argse
.descriptor_only
= 1;
1281 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1282 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1283 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1285 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1289 /* Evaluate a single upper or lower bound. */
1290 /* TODO: bound intrinsic generates way too much unnecessary code. */
1293 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1295 gfc_actual_arglist
*arg
;
1296 gfc_actual_arglist
*arg2
;
1301 tree cond
, cond1
, cond3
, cond4
, size
;
1305 gfc_array_spec
* as
;
1306 bool assumed_rank_lb_one
;
1308 arg
= expr
->value
.function
.actual
;
1313 /* Create an implicit second parameter from the loop variable. */
1314 gcc_assert (!arg2
->expr
);
1315 gcc_assert (se
->loop
->dimen
== 1);
1316 gcc_assert (se
->ss
->info
->expr
== expr
);
1317 gfc_advance_se_ss_chain (se
);
1318 bound
= se
->loop
->loopvar
[0];
1319 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1320 gfc_array_index_type
, bound
,
1325 /* use the passed argument. */
1326 gcc_assert (arg2
->expr
);
1327 gfc_init_se (&argse
, NULL
);
1328 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1329 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1331 /* Convert from one based to zero based. */
1332 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1333 gfc_array_index_type
, bound
,
1334 gfc_index_one_node
);
1337 /* TODO: don't re-evaluate the descriptor on each iteration. */
1338 /* Get a descriptor for the first parameter. */
1339 gfc_init_se (&argse
, NULL
);
1340 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1341 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1342 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1346 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1348 if (INTEGER_CST_P (bound
))
1352 hi
= TREE_INT_CST_HIGH (bound
);
1353 low
= TREE_INT_CST_LOW (bound
);
1355 || ((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1356 && low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
1357 || low
> GFC_MAX_DIMENSIONS
)
1358 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1359 "dimension index", upper
? "UBOUND" : "LBOUND",
1363 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1365 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1367 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1368 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1369 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1370 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1371 tmp
= gfc_conv_descriptor_rank (desc
);
1373 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1374 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1375 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1376 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1377 boolean_type_node
, cond
, tmp
);
1378 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1383 /* Take care of the lbound shift for assumed-rank arrays, which are
1384 nonallocatable and nonpointers. Those has a lbound of 1. */
1385 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1386 && ((arg
->expr
->ts
.type
!= BT_CLASS
1387 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1388 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1389 || (arg
->expr
->ts
.type
== BT_CLASS
1390 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1391 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1393 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1394 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1396 /* 13.14.53: Result value for LBOUND
1398 Case (i): For an array section or for an array expression other than a
1399 whole array or array structure component, LBOUND(ARRAY, DIM)
1400 has the value 1. For a whole array or array structure
1401 component, LBOUND(ARRAY, DIM) has the value:
1402 (a) equal to the lower bound for subscript DIM of ARRAY if
1403 dimension DIM of ARRAY does not have extent zero
1404 or if ARRAY is an assumed-size array of rank DIM,
1407 13.14.113: Result value for UBOUND
1409 Case (i): For an array section or for an array expression other than a
1410 whole array or array structure component, UBOUND(ARRAY, DIM)
1411 has the value equal to the number of elements in the given
1412 dimension; otherwise, it has a value equal to the upper bound
1413 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1414 not have size zero and has value zero if dimension DIM has
1417 if (!upper
&& assumed_rank_lb_one
)
1418 se
->expr
= gfc_index_one_node
;
1421 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1423 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1425 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1426 stride
, gfc_index_zero_node
);
1427 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1428 boolean_type_node
, cond3
, cond1
);
1429 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1430 stride
, gfc_index_zero_node
);
1435 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1436 boolean_type_node
, cond3
, cond4
);
1437 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1438 gfc_index_one_node
, lbound
);
1439 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1440 boolean_type_node
, cond4
, cond5
);
1442 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1443 boolean_type_node
, cond
, cond5
);
1445 if (assumed_rank_lb_one
)
1447 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1448 gfc_array_index_type
, ubound
, lbound
);
1449 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1450 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1455 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1456 gfc_array_index_type
, cond
,
1457 tmp
, gfc_index_zero_node
);
1461 if (as
->type
== AS_ASSUMED_SIZE
)
1462 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1463 bound
, build_int_cst (TREE_TYPE (bound
),
1464 arg
->expr
->rank
- 1));
1466 cond
= boolean_false_node
;
1468 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1469 boolean_type_node
, cond3
, cond4
);
1470 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1471 boolean_type_node
, cond
, cond1
);
1473 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1474 gfc_array_index_type
, cond
,
1475 lbound
, gfc_index_one_node
);
1482 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1483 gfc_array_index_type
, ubound
, lbound
);
1484 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1485 gfc_array_index_type
, size
,
1486 gfc_index_one_node
);
1487 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1488 gfc_array_index_type
, se
->expr
,
1489 gfc_index_zero_node
);
1492 se
->expr
= gfc_index_one_node
;
1495 type
= gfc_typenode_for_spec (&expr
->ts
);
1496 se
->expr
= convert (type
, se
->expr
);
1501 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
1503 gfc_actual_arglist
*arg
;
1504 gfc_actual_arglist
*arg2
;
1506 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
1510 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
1511 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
1512 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
1514 arg
= expr
->value
.function
.actual
;
1517 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
1518 corank
= gfc_get_corank (arg
->expr
);
1520 gfc_init_se (&argse
, NULL
);
1521 argse
.want_coarray
= 1;
1523 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1524 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1525 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1530 /* Create an implicit second parameter from the loop variable. */
1531 gcc_assert (!arg2
->expr
);
1532 gcc_assert (corank
> 0);
1533 gcc_assert (se
->loop
->dimen
== 1);
1534 gcc_assert (se
->ss
->info
->expr
== expr
);
1536 bound
= se
->loop
->loopvar
[0];
1537 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1538 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
1539 gfc_advance_se_ss_chain (se
);
1543 /* use the passed argument. */
1544 gcc_assert (arg2
->expr
);
1545 gfc_init_se (&argse
, NULL
);
1546 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1547 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1550 if (INTEGER_CST_P (bound
))
1554 hi
= TREE_INT_CST_HIGH (bound
);
1555 low
= TREE_INT_CST_LOW (bound
);
1556 if (hi
|| low
< 1 || low
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
1557 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1558 "dimension index", expr
->value
.function
.isym
->name
,
1561 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1563 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1564 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1565 bound
, build_int_cst (TREE_TYPE (bound
), 1));
1566 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1567 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1569 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1570 boolean_type_node
, cond
, tmp
);
1571 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1576 /* Subtract 1 to get to zero based and add dimensions. */
1577 switch (arg
->expr
->rank
)
1580 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1581 gfc_array_index_type
, bound
,
1582 gfc_index_one_node
);
1586 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1587 gfc_array_index_type
, bound
,
1588 gfc_rank_cst
[arg
->expr
->rank
- 1]);
1592 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1594 /* Handle UCOBOUND with special handling of the last codimension. */
1595 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
1597 /* Last codimension: For -fcoarray=single just return
1598 the lcobound - otherwise add
1599 ceiling (real (num_images ()) / real (size)) - 1
1600 = (num_images () + size - 1) / size - 1
1601 = (num_images - 1) / size(),
1602 where size is the product of the extent of all but the last
1605 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
1609 gfc_init_coarray_decl (false);
1610 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
1612 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1613 gfc_array_index_type
,
1614 fold_convert (gfc_array_index_type
,
1615 gfort_gvar_caf_num_images
),
1616 build_int_cst (gfc_array_index_type
, 1));
1617 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1618 gfc_array_index_type
, tmp
,
1619 fold_convert (gfc_array_index_type
, cosize
));
1620 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1621 gfc_array_index_type
, resbound
, tmp
);
1623 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
1625 /* ubound = lbound + num_images() - 1. */
1626 gfc_init_coarray_decl (false);
1627 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1628 gfc_array_index_type
,
1629 fold_convert (gfc_array_index_type
,
1630 gfort_gvar_caf_num_images
),
1631 build_int_cst (gfc_array_index_type
, 1));
1632 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1633 gfc_array_index_type
, resbound
, tmp
);
1638 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1640 build_int_cst (TREE_TYPE (bound
),
1641 arg
->expr
->rank
+ corank
- 1));
1643 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1644 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1645 gfc_array_index_type
, cond
,
1646 resbound
, resbound2
);
1649 se
->expr
= resbound
;
1652 se
->expr
= resbound
;
1654 type
= gfc_typenode_for_spec (&expr
->ts
);
1655 se
->expr
= convert (type
, se
->expr
);
1660 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
1662 gfc_actual_arglist
*array_arg
;
1663 gfc_actual_arglist
*dim_arg
;
1667 array_arg
= expr
->value
.function
.actual
;
1668 dim_arg
= array_arg
->next
;
1670 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
1672 gfc_init_se (&argse
, NULL
);
1673 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
1674 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1675 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1678 gcc_assert (dim_arg
->expr
);
1679 gfc_init_se (&argse
, NULL
);
1680 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
1681 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1682 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1683 argse
.expr
, gfc_index_one_node
);
1684 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
1689 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1693 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1695 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1699 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1704 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1705 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1714 /* Create a complex value from one or two real components. */
1717 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1723 unsigned int num_args
;
1725 num_args
= gfc_intrinsic_argument_list_length (expr
);
1726 args
= XALLOCAVEC (tree
, num_args
);
1728 type
= gfc_typenode_for_spec (&expr
->ts
);
1729 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1730 real
= convert (TREE_TYPE (type
), args
[0]);
1732 imag
= convert (TREE_TYPE (type
), args
[1]);
1733 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1735 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1736 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1737 imag
= convert (TREE_TYPE (type
), imag
);
1740 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1742 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1746 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1747 MODULO(A, P) = A - FLOOR (A / P) * P
1749 The obvious algorithms above are numerically instable for large
1750 arguments, hence these intrinsics are instead implemented via calls
1751 to the fmod family of functions. It is the responsibility of the
1752 user to ensure that the second argument is non-zero. */
1755 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1765 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1767 switch (expr
->ts
.type
)
1770 /* Integer case is easy, we've got a builtin op. */
1771 type
= TREE_TYPE (args
[0]);
1774 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
1777 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
1783 /* Check if we have a builtin fmod. */
1784 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1786 /* The builtin should always be available. */
1787 gcc_assert (fmod
!= NULL_TREE
);
1789 tmp
= build_addr (fmod
, current_function_decl
);
1790 se
->expr
= build_call_array_loc (input_location
,
1791 TREE_TYPE (TREE_TYPE (fmod
)),
1796 type
= TREE_TYPE (args
[0]);
1798 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1799 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1802 modulo = arg - floor (arg/arg2) * arg2
1804 In order to calculate the result accurately, we use the fmod
1805 function as follows.
1807 res = fmod (arg, arg2);
1810 if ((arg < 0) xor (arg2 < 0))
1814 res = copysign (0., arg2);
1816 => As two nested ternary exprs:
1818 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
1819 : copysign (0., arg2);
1823 zero
= gfc_build_const (type
, integer_zero_node
);
1824 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1825 if (!flag_signed_zeros
)
1827 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1829 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1831 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1832 boolean_type_node
, test
, test2
);
1833 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1835 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1836 boolean_type_node
, test
, test2
);
1837 test
= gfc_evaluate_now (test
, &se
->pre
);
1838 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1839 fold_build2_loc (input_location
,
1841 type
, tmp
, args
[1]),
1846 tree expr1
, copysign
, cscall
;
1847 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
1849 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1851 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1853 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1854 boolean_type_node
, test
, test2
);
1855 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
1856 fold_build2_loc (input_location
,
1858 type
, tmp
, args
[1]),
1860 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1862 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
1864 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1874 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1875 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1876 where the right shifts are logical (i.e. 0's are shifted in).
1877 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1878 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1880 DSHIFTL(I,J,BITSIZE) = J
1882 DSHIFTR(I,J,BITSIZE) = I. */
1885 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
1887 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
1888 tree args
[3], cond
, tmp
;
1891 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
1893 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
1894 type
= TREE_TYPE (args
[0]);
1895 bitsize
= TYPE_PRECISION (type
);
1896 utype
= unsigned_type_for (type
);
1897 stype
= TREE_TYPE (args
[2]);
1899 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
1900 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
1901 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
1903 /* The generic case. */
1904 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
1905 build_int_cst (stype
, bitsize
), shift
);
1906 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
1907 arg1
, dshiftl
? shift
: tmp
);
1909 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
1910 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
1911 right
= fold_convert (type
, right
);
1913 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
1915 /* Special cases. */
1916 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1917 build_int_cst (stype
, 0));
1918 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1919 dshiftl
? arg1
: arg2
, res
);
1921 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1922 build_int_cst (stype
, bitsize
));
1923 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1924 dshiftl
? arg2
: arg1
, res
);
1930 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1933 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1941 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1942 type
= TREE_TYPE (args
[0]);
1944 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
1945 val
= gfc_evaluate_now (val
, &se
->pre
);
1947 zero
= gfc_build_const (type
, integer_zero_node
);
1948 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
1949 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
1953 /* SIGN(A, B) is absolute value of A times sign of B.
1954 The real value versions use library functions to ensure the correct
1955 handling of negative zero. Integer case implemented as:
1956 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1960 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1966 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1967 if (expr
->ts
.type
== BT_REAL
)
1971 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1972 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1974 /* We explicitly have to ignore the minus sign. We do so by using
1975 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1976 if (!gfc_option
.flag_sign_zero
1977 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1980 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1981 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1983 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1984 TREE_TYPE (args
[0]), cond
,
1985 build_call_expr_loc (input_location
, abs
, 1,
1987 build_call_expr_loc (input_location
, tmp
, 2,
1991 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1996 /* Having excluded floating point types, we know we are now dealing
1997 with signed integer types. */
1998 type
= TREE_TYPE (args
[0]);
2000 /* Args[0] is used multiple times below. */
2001 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2003 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2004 the signs of A and B are the same, and of all ones if they differ. */
2005 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2006 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2007 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2008 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2010 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2011 is all ones (i.e. -1). */
2012 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2013 fold_build2_loc (input_location
, PLUS_EXPR
,
2014 type
, args
[0], tmp
), tmp
);
2018 /* Test for the presence of an optional argument. */
2021 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2025 arg
= expr
->value
.function
.actual
->expr
;
2026 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2027 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2028 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2032 /* Calculate the double precision product of two single precision values. */
2035 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2040 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2042 /* Convert the args to double precision before multiplying. */
2043 type
= gfc_typenode_for_spec (&expr
->ts
);
2044 args
[0] = convert (type
, args
[0]);
2045 args
[1] = convert (type
, args
[1]);
2046 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2051 /* Return a length one character string containing an ascii character. */
2054 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2059 unsigned int num_args
;
2061 num_args
= gfc_intrinsic_argument_list_length (expr
);
2062 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2064 type
= gfc_get_char_type (expr
->ts
.kind
);
2065 var
= gfc_create_var (type
, "char");
2067 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2068 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2069 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2070 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2075 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2083 unsigned int num_args
;
2085 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2086 args
= XALLOCAVEC (tree
, num_args
);
2088 var
= gfc_create_var (pchar_type_node
, "pstr");
2089 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2091 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2092 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2093 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2095 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2096 tmp
= build_call_array_loc (input_location
,
2097 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2098 fndecl
, num_args
, args
);
2099 gfc_add_expr_to_block (&se
->pre
, tmp
);
2101 /* Free the temporary afterwards, if necessary. */
2102 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2103 len
, build_int_cst (TREE_TYPE (len
), 0));
2104 tmp
= gfc_call_free (var
);
2105 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2106 gfc_add_expr_to_block (&se
->post
, tmp
);
2109 se
->string_length
= len
;
2114 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2122 unsigned int num_args
;
2124 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2125 args
= XALLOCAVEC (tree
, num_args
);
2127 var
= gfc_create_var (pchar_type_node
, "pstr");
2128 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2130 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2131 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2132 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2134 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2135 tmp
= build_call_array_loc (input_location
,
2136 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2137 fndecl
, num_args
, args
);
2138 gfc_add_expr_to_block (&se
->pre
, tmp
);
2140 /* Free the temporary afterwards, if necessary. */
2141 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2142 len
, build_int_cst (TREE_TYPE (len
), 0));
2143 tmp
= gfc_call_free (var
);
2144 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2145 gfc_add_expr_to_block (&se
->post
, tmp
);
2148 se
->string_length
= len
;
2152 /* Return a character string containing the tty name. */
2155 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2163 unsigned int num_args
;
2165 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2166 args
= XALLOCAVEC (tree
, num_args
);
2168 var
= gfc_create_var (pchar_type_node
, "pstr");
2169 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2171 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2172 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2173 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2175 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2176 tmp
= build_call_array_loc (input_location
,
2177 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2178 fndecl
, num_args
, args
);
2179 gfc_add_expr_to_block (&se
->pre
, tmp
);
2181 /* Free the temporary afterwards, if necessary. */
2182 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2183 len
, build_int_cst (TREE_TYPE (len
), 0));
2184 tmp
= gfc_call_free (var
);
2185 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2186 gfc_add_expr_to_block (&se
->post
, tmp
);
2189 se
->string_length
= len
;
2193 /* Get the minimum/maximum value of all the parameters.
2194 minmax (a1, a2, a3, ...)
2197 if (a2 .op. mvar || isnan(mvar))
2199 if (a3 .op. mvar || isnan(mvar))
2206 /* TODO: Mismatching types can occur when specific names are used.
2207 These should be handled during resolution. */
2209 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2217 gfc_actual_arglist
*argexpr
;
2218 unsigned int i
, nargs
;
2220 nargs
= gfc_intrinsic_argument_list_length (expr
);
2221 args
= XALLOCAVEC (tree
, nargs
);
2223 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2224 type
= gfc_typenode_for_spec (&expr
->ts
);
2226 argexpr
= expr
->value
.function
.actual
;
2227 if (TREE_TYPE (args
[0]) != type
)
2228 args
[0] = convert (type
, args
[0]);
2229 /* Only evaluate the argument once. */
2230 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2231 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2233 mvar
= gfc_create_var (type
, "M");
2234 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2235 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2241 /* Handle absent optional arguments by ignoring the comparison. */
2242 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2243 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2244 && TREE_CODE (val
) == INDIRECT_REF
)
2245 cond
= fold_build2_loc (input_location
,
2246 NE_EXPR
, boolean_type_node
,
2247 TREE_OPERAND (val
, 0),
2248 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2253 /* Only evaluate the argument once. */
2254 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2255 val
= gfc_evaluate_now (val
, &se
->pre
);
2258 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2260 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2261 convert (type
, val
), mvar
);
2263 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2264 __builtin_isnan might be made dependent on that module being loaded,
2265 to help performance of programs that don't rely on IEEE semantics. */
2266 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2268 isnan
= build_call_expr_loc (input_location
,
2269 builtin_decl_explicit (BUILT_IN_ISNAN
),
2271 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2272 boolean_type_node
, tmp
,
2273 fold_convert (boolean_type_node
, isnan
));
2275 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2276 build_empty_stmt (input_location
));
2278 if (cond
!= NULL_TREE
)
2279 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2280 build_empty_stmt (input_location
));
2282 gfc_add_expr_to_block (&se
->pre
, tmp
);
2283 argexpr
= argexpr
->next
;
2289 /* Generate library calls for MIN and MAX intrinsics for character
2292 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2295 tree var
, len
, fndecl
, tmp
, cond
, function
;
2298 nargs
= gfc_intrinsic_argument_list_length (expr
);
2299 args
= XALLOCAVEC (tree
, nargs
+ 4);
2300 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2302 /* Create the result variables. */
2303 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2304 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2305 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2306 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2307 args
[2] = build_int_cst (integer_type_node
, op
);
2308 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2310 if (expr
->ts
.kind
== 1)
2311 function
= gfor_fndecl_string_minmax
;
2312 else if (expr
->ts
.kind
== 4)
2313 function
= gfor_fndecl_string_minmax_char4
;
2317 /* Make the function call. */
2318 fndecl
= build_addr (function
, current_function_decl
);
2319 tmp
= build_call_array_loc (input_location
,
2320 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2322 gfc_add_expr_to_block (&se
->pre
, tmp
);
2324 /* Free the temporary afterwards, if necessary. */
2325 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2326 len
, build_int_cst (TREE_TYPE (len
), 0));
2327 tmp
= gfc_call_free (var
);
2328 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2329 gfc_add_expr_to_block (&se
->post
, tmp
);
2332 se
->string_length
= len
;
2336 /* Create a symbol node for this intrinsic. The symbol from the frontend
2337 has the generic name. */
2340 gfc_get_symbol_for_expr (gfc_expr
* expr
)
2344 /* TODO: Add symbols for intrinsic function to the global namespace. */
2345 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2346 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2349 sym
->attr
.external
= 1;
2350 sym
->attr
.function
= 1;
2351 sym
->attr
.always_explicit
= 1;
2352 sym
->attr
.proc
= PROC_INTRINSIC
;
2353 sym
->attr
.flavor
= FL_PROCEDURE
;
2357 sym
->attr
.dimension
= 1;
2358 sym
->as
= gfc_get_array_spec ();
2359 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2360 sym
->as
->rank
= expr
->rank
;
2363 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
2368 /* Generate a call to an external intrinsic function. */
2370 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2373 vec
<tree
, va_gc
> *append_args
;
2375 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2378 gcc_assert (expr
->rank
> 0);
2380 gcc_assert (expr
->rank
== 0);
2382 sym
= gfc_get_symbol_for_expr (expr
);
2384 /* Calls to libgfortran_matmul need to be appended special arguments,
2385 to be able to call the BLAS ?gemm functions if required and possible. */
2387 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2388 && sym
->ts
.type
!= BT_LOGICAL
)
2390 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2392 if (gfc_option
.flag_external_blas
2393 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2394 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
2398 if (sym
->ts
.type
== BT_REAL
)
2400 if (sym
->ts
.kind
== 4)
2401 gemm_fndecl
= gfor_fndecl_sgemm
;
2403 gemm_fndecl
= gfor_fndecl_dgemm
;
2407 if (sym
->ts
.kind
== 4)
2408 gemm_fndecl
= gfor_fndecl_cgemm
;
2410 gemm_fndecl
= gfor_fndecl_zgemm
;
2413 vec_alloc (append_args
, 3);
2414 append_args
->quick_push (build_int_cst (cint
, 1));
2415 append_args
->quick_push (build_int_cst (cint
,
2416 gfc_option
.blas_matmul_limit
));
2417 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
2422 vec_alloc (append_args
, 3);
2423 append_args
->quick_push (build_int_cst (cint
, 0));
2424 append_args
->quick_push (build_int_cst (cint
, 0));
2425 append_args
->quick_push (null_pointer_node
);
2429 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
2431 gfc_free_symbol (sym
);
2434 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2454 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2463 gfc_actual_arglist
*actual
;
2470 gfc_conv_intrinsic_funcall (se
, expr
);
2474 actual
= expr
->value
.function
.actual
;
2475 type
= gfc_typenode_for_spec (&expr
->ts
);
2476 /* Initialize the result. */
2477 resvar
= gfc_create_var (type
, "test");
2479 tmp
= convert (type
, boolean_true_node
);
2481 tmp
= convert (type
, boolean_false_node
);
2482 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2484 /* Walk the arguments. */
2485 arrayss
= gfc_walk_expr (actual
->expr
);
2486 gcc_assert (arrayss
!= gfc_ss_terminator
);
2488 /* Initialize the scalarizer. */
2489 gfc_init_loopinfo (&loop
);
2490 exit_label
= gfc_build_label_decl (NULL_TREE
);
2491 TREE_USED (exit_label
) = 1;
2492 gfc_add_ss_to_loop (&loop
, arrayss
);
2494 /* Initialize the loop. */
2495 gfc_conv_ss_startstride (&loop
);
2496 gfc_conv_loop_setup (&loop
, &expr
->where
);
2498 gfc_mark_ss_chain_used (arrayss
, 1);
2499 /* Generate the loop body. */
2500 gfc_start_scalarized_body (&loop
, &body
);
2502 /* If the condition matches then set the return value. */
2503 gfc_start_block (&block
);
2505 tmp
= convert (type
, boolean_false_node
);
2507 tmp
= convert (type
, boolean_true_node
);
2508 gfc_add_modify (&block
, resvar
, tmp
);
2510 /* And break out of the loop. */
2511 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2512 gfc_add_expr_to_block (&block
, tmp
);
2514 found
= gfc_finish_block (&block
);
2516 /* Check this element. */
2517 gfc_init_se (&arrayse
, NULL
);
2518 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2519 arrayse
.ss
= arrayss
;
2520 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2522 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2523 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
2524 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
2525 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
2526 gfc_add_expr_to_block (&body
, tmp
);
2527 gfc_add_block_to_block (&body
, &arrayse
.post
);
2529 gfc_trans_scalarizing_loops (&loop
, &body
);
2531 /* Add the exit label. */
2532 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2533 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2535 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2536 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2537 gfc_cleanup_loop (&loop
);
2542 /* COUNT(A) = Number of true elements in A. */
2544 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
2551 gfc_actual_arglist
*actual
;
2557 gfc_conv_intrinsic_funcall (se
, expr
);
2561 actual
= expr
->value
.function
.actual
;
2563 type
= gfc_typenode_for_spec (&expr
->ts
);
2564 /* Initialize the result. */
2565 resvar
= gfc_create_var (type
, "count");
2566 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
2568 /* Walk the arguments. */
2569 arrayss
= gfc_walk_expr (actual
->expr
);
2570 gcc_assert (arrayss
!= gfc_ss_terminator
);
2572 /* Initialize the scalarizer. */
2573 gfc_init_loopinfo (&loop
);
2574 gfc_add_ss_to_loop (&loop
, arrayss
);
2576 /* Initialize the loop. */
2577 gfc_conv_ss_startstride (&loop
);
2578 gfc_conv_loop_setup (&loop
, &expr
->where
);
2580 gfc_mark_ss_chain_used (arrayss
, 1);
2581 /* Generate the loop body. */
2582 gfc_start_scalarized_body (&loop
, &body
);
2584 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2585 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2586 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2588 gfc_init_se (&arrayse
, NULL
);
2589 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2590 arrayse
.ss
= arrayss
;
2591 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2592 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2593 build_empty_stmt (input_location
));
2595 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2596 gfc_add_expr_to_block (&body
, tmp
);
2597 gfc_add_block_to_block (&body
, &arrayse
.post
);
2599 gfc_trans_scalarizing_loops (&loop
, &body
);
2601 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2602 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2603 gfc_cleanup_loop (&loop
);
2609 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
2610 struct and return the corresponding loopinfo. */
2612 static gfc_loopinfo
*
2613 enter_nested_loop (gfc_se
*se
)
2615 se
->ss
= se
->ss
->nested_ss
;
2616 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
2618 return se
->ss
->loop
;
2622 /* Inline implementation of the sum and product intrinsics. */
2624 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2628 tree scale
= NULL_TREE
;
2633 gfc_loopinfo loop
, *ploop
;
2634 gfc_actual_arglist
*arg_array
, *arg_mask
;
2635 gfc_ss
*arrayss
= NULL
;
2636 gfc_ss
*maskss
= NULL
;
2640 gfc_expr
*arrayexpr
;
2645 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
2651 type
= gfc_typenode_for_spec (&expr
->ts
);
2652 /* Initialize the result. */
2653 resvar
= gfc_create_var (type
, "val");
2658 scale
= gfc_create_var (type
, "scale");
2659 gfc_add_modify (&se
->pre
, scale
,
2660 gfc_build_const (type
, integer_one_node
));
2661 tmp
= gfc_build_const (type
, integer_zero_node
);
2663 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2664 tmp
= gfc_build_const (type
, integer_zero_node
);
2665 else if (op
== NE_EXPR
)
2667 tmp
= convert (type
, boolean_false_node
);
2668 else if (op
== BIT_AND_EXPR
)
2669 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2670 type
, integer_one_node
));
2672 tmp
= gfc_build_const (type
, integer_one_node
);
2674 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2676 arg_array
= expr
->value
.function
.actual
;
2678 arrayexpr
= arg_array
->expr
;
2680 if (op
== NE_EXPR
|| norm2
)
2681 /* PARITY and NORM2. */
2685 arg_mask
= arg_array
->next
->next
;
2686 gcc_assert (arg_mask
!= NULL
);
2687 maskexpr
= arg_mask
->expr
;
2690 if (expr
->rank
== 0)
2692 /* Walk the arguments. */
2693 arrayss
= gfc_walk_expr (arrayexpr
);
2694 gcc_assert (arrayss
!= gfc_ss_terminator
);
2696 if (maskexpr
&& maskexpr
->rank
> 0)
2698 maskss
= gfc_walk_expr (maskexpr
);
2699 gcc_assert (maskss
!= gfc_ss_terminator
);
2704 /* Initialize the scalarizer. */
2705 gfc_init_loopinfo (&loop
);
2706 gfc_add_ss_to_loop (&loop
, arrayss
);
2707 if (maskexpr
&& maskexpr
->rank
> 0)
2708 gfc_add_ss_to_loop (&loop
, maskss
);
2710 /* Initialize the loop. */
2711 gfc_conv_ss_startstride (&loop
);
2712 gfc_conv_loop_setup (&loop
, &expr
->where
);
2714 gfc_mark_ss_chain_used (arrayss
, 1);
2715 if (maskexpr
&& maskexpr
->rank
> 0)
2716 gfc_mark_ss_chain_used (maskss
, 1);
2721 /* All the work has been done in the parent loops. */
2722 ploop
= enter_nested_loop (se
);
2726 /* Generate the loop body. */
2727 gfc_start_scalarized_body (ploop
, &body
);
2729 /* If we have a mask, only add this element if the mask is set. */
2730 if (maskexpr
&& maskexpr
->rank
> 0)
2732 gfc_init_se (&maskse
, parent_se
);
2733 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
2734 if (expr
->rank
== 0)
2736 gfc_conv_expr_val (&maskse
, maskexpr
);
2737 gfc_add_block_to_block (&body
, &maskse
.pre
);
2739 gfc_start_block (&block
);
2742 gfc_init_block (&block
);
2744 /* Do the actual summation/product. */
2745 gfc_init_se (&arrayse
, parent_se
);
2746 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
2747 if (expr
->rank
== 0)
2748 arrayse
.ss
= arrayss
;
2749 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2750 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2760 result = 1.0 + result * val * val;
2766 result += val * val;
2769 tree res1
, res2
, cond
, absX
, val
;
2770 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
2772 gfc_init_block (&ifblock1
);
2774 absX
= gfc_create_var (type
, "absX");
2775 gfc_add_modify (&ifblock1
, absX
,
2776 fold_build1_loc (input_location
, ABS_EXPR
, type
,
2778 val
= gfc_create_var (type
, "val");
2779 gfc_add_expr_to_block (&ifblock1
, val
);
2781 gfc_init_block (&ifblock2
);
2782 gfc_add_modify (&ifblock2
, val
,
2783 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
2785 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2786 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
2787 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
2788 gfc_build_const (type
, integer_one_node
));
2789 gfc_add_modify (&ifblock2
, resvar
, res1
);
2790 gfc_add_modify (&ifblock2
, scale
, absX
);
2791 res1
= gfc_finish_block (&ifblock2
);
2793 gfc_init_block (&ifblock3
);
2794 gfc_add_modify (&ifblock3
, val
,
2795 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
2797 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2798 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
2799 gfc_add_modify (&ifblock3
, resvar
, res2
);
2800 res2
= gfc_finish_block (&ifblock3
);
2802 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2804 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
2805 gfc_add_expr_to_block (&ifblock1
, tmp
);
2806 tmp
= gfc_finish_block (&ifblock1
);
2808 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2810 gfc_build_const (type
, integer_zero_node
));
2812 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2813 gfc_add_expr_to_block (&block
, tmp
);
2817 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
2818 gfc_add_modify (&block
, resvar
, tmp
);
2821 gfc_add_block_to_block (&block
, &arrayse
.post
);
2823 if (maskexpr
&& maskexpr
->rank
> 0)
2825 /* We enclose the above in if (mask) {...} . */
2827 tmp
= gfc_finish_block (&block
);
2828 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2829 build_empty_stmt (input_location
));
2832 tmp
= gfc_finish_block (&block
);
2833 gfc_add_expr_to_block (&body
, tmp
);
2835 gfc_trans_scalarizing_loops (ploop
, &body
);
2837 /* For a scalar mask, enclose the loop in an if statement. */
2838 if (maskexpr
&& maskexpr
->rank
== 0)
2840 gfc_init_block (&block
);
2841 gfc_add_block_to_block (&block
, &ploop
->pre
);
2842 gfc_add_block_to_block (&block
, &ploop
->post
);
2843 tmp
= gfc_finish_block (&block
);
2847 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
2848 build_empty_stmt (input_location
));
2849 gfc_advance_se_ss_chain (se
);
2853 gcc_assert (expr
->rank
== 0);
2854 gfc_init_se (&maskse
, NULL
);
2855 gfc_conv_expr_val (&maskse
, maskexpr
);
2856 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2857 build_empty_stmt (input_location
));
2860 gfc_add_expr_to_block (&block
, tmp
);
2861 gfc_add_block_to_block (&se
->pre
, &block
);
2862 gcc_assert (se
->post
.head
== NULL
);
2866 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
2867 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
2870 if (expr
->rank
== 0)
2871 gfc_cleanup_loop (ploop
);
2875 /* result = scale * sqrt(result). */
2877 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
2878 resvar
= build_call_expr_loc (input_location
,
2880 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
2887 /* Inline implementation of the dot_product intrinsic. This function
2888 is based on gfc_conv_intrinsic_arith (the previous function). */
2890 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2898 gfc_actual_arglist
*actual
;
2899 gfc_ss
*arrayss1
, *arrayss2
;
2900 gfc_se arrayse1
, arrayse2
;
2901 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2903 type
= gfc_typenode_for_spec (&expr
->ts
);
2905 /* Initialize the result. */
2906 resvar
= gfc_create_var (type
, "val");
2907 if (expr
->ts
.type
== BT_LOGICAL
)
2908 tmp
= build_int_cst (type
, 0);
2910 tmp
= gfc_build_const (type
, integer_zero_node
);
2912 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2914 /* Walk argument #1. */
2915 actual
= expr
->value
.function
.actual
;
2916 arrayexpr1
= actual
->expr
;
2917 arrayss1
= gfc_walk_expr (arrayexpr1
);
2918 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2920 /* Walk argument #2. */
2921 actual
= actual
->next
;
2922 arrayexpr2
= actual
->expr
;
2923 arrayss2
= gfc_walk_expr (arrayexpr2
);
2924 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2926 /* Initialize the scalarizer. */
2927 gfc_init_loopinfo (&loop
);
2928 gfc_add_ss_to_loop (&loop
, arrayss1
);
2929 gfc_add_ss_to_loop (&loop
, arrayss2
);
2931 /* Initialize the loop. */
2932 gfc_conv_ss_startstride (&loop
);
2933 gfc_conv_loop_setup (&loop
, &expr
->where
);
2935 gfc_mark_ss_chain_used (arrayss1
, 1);
2936 gfc_mark_ss_chain_used (arrayss2
, 1);
2938 /* Generate the loop body. */
2939 gfc_start_scalarized_body (&loop
, &body
);
2940 gfc_init_block (&block
);
2942 /* Make the tree expression for [conjg(]array1[)]. */
2943 gfc_init_se (&arrayse1
, NULL
);
2944 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2945 arrayse1
.ss
= arrayss1
;
2946 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2947 if (expr
->ts
.type
== BT_COMPLEX
)
2948 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
2950 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2952 /* Make the tree expression for array2. */
2953 gfc_init_se (&arrayse2
, NULL
);
2954 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2955 arrayse2
.ss
= arrayss2
;
2956 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2957 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2959 /* Do the actual product and sum. */
2960 if (expr
->ts
.type
== BT_LOGICAL
)
2962 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
2963 arrayse1
.expr
, arrayse2
.expr
);
2964 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2968 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
2970 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
2972 gfc_add_modify (&block
, resvar
, tmp
);
2974 /* Finish up the loop block and the loop. */
2975 tmp
= gfc_finish_block (&block
);
2976 gfc_add_expr_to_block (&body
, tmp
);
2978 gfc_trans_scalarizing_loops (&loop
, &body
);
2979 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2980 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2981 gfc_cleanup_loop (&loop
);
2987 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2988 we need to handle. For performance reasons we sometimes create two
2989 loops instead of one, where the second one is much simpler.
2990 Examples for minloc intrinsic:
2991 1) Result is an array, a call is generated
2992 2) Array mask is used and NaNs need to be supported:
2998 if (pos == 0) pos = S + (1 - from);
2999 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3006 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3010 3) NaNs need to be supported, but it is known at compile time or cheaply
3011 at runtime whether array is nonempty or not:
3016 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3019 if (from <= to) pos = 1;
3023 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3027 4) NaNs aren't supported, array mask is used:
3028 limit = infinities_supported ? Infinity : huge (limit);
3032 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3038 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3042 5) Same without array mask:
3043 limit = infinities_supported ? Infinity : huge (limit);
3044 pos = (from <= to) ? 1 : 0;
3047 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3050 For 3) and 5), if mask is scalar, this all goes into a conditional,
3051 setting pos = 0; in the else branch. */
3054 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3058 stmtblock_t ifblock
;
3059 stmtblock_t elseblock
;
3070 gfc_actual_arglist
*actual
;
3075 gfc_expr
*arrayexpr
;
3082 gfc_conv_intrinsic_funcall (se
, expr
);
3086 /* Initialize the result. */
3087 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3088 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3089 type
= gfc_typenode_for_spec (&expr
->ts
);
3091 /* Walk the arguments. */
3092 actual
= expr
->value
.function
.actual
;
3093 arrayexpr
= actual
->expr
;
3094 arrayss
= gfc_walk_expr (arrayexpr
);
3095 gcc_assert (arrayss
!= gfc_ss_terminator
);
3097 actual
= actual
->next
->next
;
3098 gcc_assert (actual
);
3099 maskexpr
= actual
->expr
;
3101 if (maskexpr
&& maskexpr
->rank
!= 0)
3103 maskss
= gfc_walk_expr (maskexpr
);
3104 gcc_assert (maskss
!= gfc_ss_terminator
);
3109 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3111 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3113 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3114 boolean_type_node
, nonempty
,
3115 gfc_index_zero_node
);
3120 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3121 switch (arrayexpr
->ts
.type
)
3124 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3128 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3129 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3130 arrayexpr
->ts
.kind
);
3137 /* We start with the most negative possible value for MAXLOC, and the most
3138 positive possible value for MINLOC. The most negative possible value is
3139 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3140 possible value is HUGE in both cases. */
3142 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3143 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3144 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3145 build_int_cst (type
, 1));
3147 gfc_add_modify (&se
->pre
, limit
, tmp
);
3149 /* Initialize the scalarizer. */
3150 gfc_init_loopinfo (&loop
);
3151 gfc_add_ss_to_loop (&loop
, arrayss
);
3153 gfc_add_ss_to_loop (&loop
, maskss
);
3155 /* Initialize the loop. */
3156 gfc_conv_ss_startstride (&loop
);
3158 /* The code generated can have more than one loop in sequence (see the
3159 comment at the function header). This doesn't work well with the
3160 scalarizer, which changes arrays' offset when the scalarization loops
3161 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3162 are currently inlined in the scalar case only (for which loop is of rank
3163 one). As there is no dependency to care about in that case, there is no
3164 temporary, so that we can use the scalarizer temporary code to handle
3165 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3166 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3168 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3169 should eventually go away. We could either create two loops properly,
3170 or find another way to save/restore the array offsets between the two
3171 loops (without conflicting with temporary management), or use a single
3172 loop minmaxloc implementation. See PR 31067. */
3173 loop
.temp_dim
= loop
.dimen
;
3174 gfc_conv_loop_setup (&loop
, &expr
->where
);
3176 gcc_assert (loop
.dimen
== 1);
3177 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3178 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3179 loop
.from
[0], loop
.to
[0]);
3183 /* Initialize the position to zero, following Fortran 2003. We are free
3184 to do this because Fortran 95 allows the result of an entirely false
3185 mask to be processor dependent. If we know at compile time the array
3186 is non-empty and no MASK is used, we can initialize to 1 to simplify
3188 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3189 gfc_add_modify (&loop
.pre
, pos
,
3190 fold_build3_loc (input_location
, COND_EXPR
,
3191 gfc_array_index_type
,
3192 nonempty
, gfc_index_one_node
,
3193 gfc_index_zero_node
));
3196 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3197 lab1
= gfc_build_label_decl (NULL_TREE
);
3198 TREE_USED (lab1
) = 1;
3199 lab2
= gfc_build_label_decl (NULL_TREE
);
3200 TREE_USED (lab2
) = 1;
3203 /* An offset must be added to the loop
3204 counter to obtain the required position. */
3205 gcc_assert (loop
.from
[0]);
3207 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3208 gfc_index_one_node
, loop
.from
[0]);
3209 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3211 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3213 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3214 /* Generate the loop body. */
3215 gfc_start_scalarized_body (&loop
, &body
);
3217 /* If we have a mask, only check this element if the mask is set. */
3220 gfc_init_se (&maskse
, NULL
);
3221 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3223 gfc_conv_expr_val (&maskse
, maskexpr
);
3224 gfc_add_block_to_block (&body
, &maskse
.pre
);
3226 gfc_start_block (&block
);
3229 gfc_init_block (&block
);
3231 /* Compare with the current limit. */
3232 gfc_init_se (&arrayse
, NULL
);
3233 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3234 arrayse
.ss
= arrayss
;
3235 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3236 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3238 /* We do the following if this is a more extreme value. */
3239 gfc_start_block (&ifblock
);
3241 /* Assign the value to the limit... */
3242 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3244 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3246 stmtblock_t ifblock2
;
3249 gfc_start_block (&ifblock2
);
3250 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3251 loop
.loopvar
[0], offset
);
3252 gfc_add_modify (&ifblock2
, pos
, tmp
);
3253 ifbody2
= gfc_finish_block (&ifblock2
);
3254 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3255 gfc_index_zero_node
);
3256 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3257 build_empty_stmt (input_location
));
3258 gfc_add_expr_to_block (&block
, tmp
);
3261 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3262 loop
.loopvar
[0], offset
);
3263 gfc_add_modify (&ifblock
, pos
, tmp
);
3266 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3268 ifbody
= gfc_finish_block (&ifblock
);
3270 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3273 cond
= fold_build2_loc (input_location
,
3274 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3275 boolean_type_node
, arrayse
.expr
, limit
);
3277 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3278 arrayse
.expr
, limit
);
3280 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3281 build_empty_stmt (input_location
));
3283 gfc_add_expr_to_block (&block
, ifbody
);
3287 /* We enclose the above in if (mask) {...}. */
3288 tmp
= gfc_finish_block (&block
);
3290 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3291 build_empty_stmt (input_location
));
3294 tmp
= gfc_finish_block (&block
);
3295 gfc_add_expr_to_block (&body
, tmp
);
3299 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3301 if (HONOR_NANS (DECL_MODE (limit
)))
3303 if (nonempty
!= NULL
)
3305 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3306 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3307 build_empty_stmt (input_location
));
3308 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3312 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3313 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3315 /* If we have a mask, only check this element if the mask is set. */
3318 gfc_init_se (&maskse
, NULL
);
3319 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3321 gfc_conv_expr_val (&maskse
, maskexpr
);
3322 gfc_add_block_to_block (&body
, &maskse
.pre
);
3324 gfc_start_block (&block
);
3327 gfc_init_block (&block
);
3329 /* Compare with the current limit. */
3330 gfc_init_se (&arrayse
, NULL
);
3331 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3332 arrayse
.ss
= arrayss
;
3333 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3334 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3336 /* We do the following if this is a more extreme value. */
3337 gfc_start_block (&ifblock
);
3339 /* Assign the value to the limit... */
3340 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3342 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3343 loop
.loopvar
[0], offset
);
3344 gfc_add_modify (&ifblock
, pos
, tmp
);
3346 ifbody
= gfc_finish_block (&ifblock
);
3348 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3349 arrayse
.expr
, limit
);
3351 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3352 build_empty_stmt (input_location
));
3353 gfc_add_expr_to_block (&block
, tmp
);
3357 /* We enclose the above in if (mask) {...}. */
3358 tmp
= gfc_finish_block (&block
);
3360 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3361 build_empty_stmt (input_location
));
3364 tmp
= gfc_finish_block (&block
);
3365 gfc_add_expr_to_block (&body
, tmp
);
3366 /* Avoid initializing loopvar[0] again, it should be left where
3367 it finished by the first loop. */
3368 loop
.from
[0] = loop
.loopvar
[0];
3371 gfc_trans_scalarizing_loops (&loop
, &body
);
3374 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3376 /* For a scalar mask, enclose the loop in an if statement. */
3377 if (maskexpr
&& maskss
== NULL
)
3379 gfc_init_se (&maskse
, NULL
);
3380 gfc_conv_expr_val (&maskse
, maskexpr
);
3381 gfc_init_block (&block
);
3382 gfc_add_block_to_block (&block
, &loop
.pre
);
3383 gfc_add_block_to_block (&block
, &loop
.post
);
3384 tmp
= gfc_finish_block (&block
);
3386 /* For the else part of the scalar mask, just initialize
3387 the pos variable the same way as above. */
3389 gfc_init_block (&elseblock
);
3390 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3391 elsetmp
= gfc_finish_block (&elseblock
);
3393 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3394 gfc_add_expr_to_block (&block
, tmp
);
3395 gfc_add_block_to_block (&se
->pre
, &block
);
3399 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3400 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3402 gfc_cleanup_loop (&loop
);
3404 se
->expr
= convert (type
, pos
);
3407 /* Emit code for minval or maxval intrinsic. There are many different cases
3408 we need to handle. For performance reasons we sometimes create two
3409 loops instead of one, where the second one is much simpler.
3410 Examples for minval intrinsic:
3411 1) Result is an array, a call is generated
3412 2) Array mask is used and NaNs need to be supported, rank 1:
3417 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3420 limit = nonempty ? NaN : huge (limit);
3422 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3423 3) NaNs need to be supported, but it is known at compile time or cheaply
3424 at runtime whether array is nonempty or not, rank 1:
3427 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3428 limit = (from <= to) ? NaN : huge (limit);
3430 while (S <= to) { limit = min (a[S], limit); S++; }
3431 4) Array mask is used and NaNs need to be supported, rank > 1:
3440 if (fast) limit = min (a[S1][S2], limit);
3443 if (a[S1][S2] <= limit) {
3454 limit = nonempty ? NaN : huge (limit);
3455 5) NaNs need to be supported, but it is known at compile time or cheaply
3456 at runtime whether array is nonempty or not, rank > 1:
3463 if (fast) limit = min (a[S1][S2], limit);
3465 if (a[S1][S2] <= limit) {
3475 limit = (nonempty_array) ? NaN : huge (limit);
3476 6) NaNs aren't supported, but infinities are. Array mask is used:
3481 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3484 limit = nonempty ? limit : huge (limit);
3485 7) Same without array mask:
3488 while (S <= to) { limit = min (a[S], limit); S++; }
3489 limit = (from <= to) ? limit : huge (limit);
3490 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3491 limit = huge (limit);
3493 while (S <= to) { limit = min (a[S], limit); S++); }
3495 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3496 with array mask instead).
3497 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3498 setting limit = huge (limit); in the else branch. */
3501 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3511 tree huge_cst
= NULL
, nan_cst
= NULL
;
3513 stmtblock_t block
, block2
;
3515 gfc_actual_arglist
*actual
;
3520 gfc_expr
*arrayexpr
;
3526 gfc_conv_intrinsic_funcall (se
, expr
);
3530 type
= gfc_typenode_for_spec (&expr
->ts
);
3531 /* Initialize the result. */
3532 limit
= gfc_create_var (type
, "limit");
3533 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
3534 switch (expr
->ts
.type
)
3537 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
3539 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3541 REAL_VALUE_TYPE real
;
3543 tmp
= build_real (type
, real
);
3547 if (HONOR_NANS (DECL_MODE (limit
)))
3549 REAL_VALUE_TYPE real
;
3550 real_nan (&real
, "", 1, DECL_MODE (limit
));
3551 nan_cst
= build_real (type
, real
);
3556 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
3563 /* We start with the most negative possible value for MAXVAL, and the most
3564 positive possible value for MINVAL. The most negative possible value is
3565 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3566 possible value is HUGE in both cases. */
3569 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3571 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
3572 TREE_TYPE (huge_cst
), huge_cst
);
3575 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3576 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
3577 tmp
, build_int_cst (type
, 1));
3579 gfc_add_modify (&se
->pre
, limit
, tmp
);
3581 /* Walk the arguments. */
3582 actual
= expr
->value
.function
.actual
;
3583 arrayexpr
= actual
->expr
;
3584 arrayss
= gfc_walk_expr (arrayexpr
);
3585 gcc_assert (arrayss
!= gfc_ss_terminator
);
3587 actual
= actual
->next
->next
;
3588 gcc_assert (actual
);
3589 maskexpr
= actual
->expr
;
3591 if (maskexpr
&& maskexpr
->rank
!= 0)
3593 maskss
= gfc_walk_expr (maskexpr
);
3594 gcc_assert (maskss
!= gfc_ss_terminator
);
3599 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3601 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3603 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3604 boolean_type_node
, nonempty
,
3605 gfc_index_zero_node
);
3610 /* Initialize the scalarizer. */
3611 gfc_init_loopinfo (&loop
);
3612 gfc_add_ss_to_loop (&loop
, arrayss
);
3614 gfc_add_ss_to_loop (&loop
, maskss
);
3616 /* Initialize the loop. */
3617 gfc_conv_ss_startstride (&loop
);
3619 /* The code generated can have more than one loop in sequence (see the
3620 comment at the function header). This doesn't work well with the
3621 scalarizer, which changes arrays' offset when the scalarization loops
3622 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3623 are currently inlined in the scalar case only. As there is no dependency
3624 to care about in that case, there is no temporary, so that we can use the
3625 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3626 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3627 gfc_trans_scalarized_loop_boundary even later to restore offset.
3628 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3629 should eventually go away. We could either create two loops properly,
3630 or find another way to save/restore the array offsets between the two
3631 loops (without conflicting with temporary management), or use a single
3632 loop minmaxval implementation. See PR 31067. */
3633 loop
.temp_dim
= loop
.dimen
;
3634 gfc_conv_loop_setup (&loop
, &expr
->where
);
3636 if (nonempty
== NULL
&& maskss
== NULL
3637 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
3638 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3639 loop
.from
[0], loop
.to
[0]);
3640 nonempty_var
= NULL
;
3641 if (nonempty
== NULL
3642 && (HONOR_INFINITIES (DECL_MODE (limit
))
3643 || HONOR_NANS (DECL_MODE (limit
))))
3645 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3646 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3647 nonempty
= nonempty_var
;
3651 if (HONOR_NANS (DECL_MODE (limit
)))
3653 if (loop
.dimen
== 1)
3655 lab
= gfc_build_label_decl (NULL_TREE
);
3656 TREE_USED (lab
) = 1;
3660 fast
= gfc_create_var (boolean_type_node
, "fast");
3661 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3665 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
3667 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
3668 /* Generate the loop body. */
3669 gfc_start_scalarized_body (&loop
, &body
);
3671 /* If we have a mask, only add this element if the mask is set. */
3674 gfc_init_se (&maskse
, NULL
);
3675 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3677 gfc_conv_expr_val (&maskse
, maskexpr
);
3678 gfc_add_block_to_block (&body
, &maskse
.pre
);
3680 gfc_start_block (&block
);
3683 gfc_init_block (&block
);
3685 /* Compare with the current limit. */
3686 gfc_init_se (&arrayse
, NULL
);
3687 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3688 arrayse
.ss
= arrayss
;
3689 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3690 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3692 gfc_init_block (&block2
);
3695 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3697 if (HONOR_NANS (DECL_MODE (limit
)))
3699 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3700 boolean_type_node
, arrayse
.expr
, limit
);
3702 ifbody
= build1_v (GOTO_EXPR
, lab
);
3705 stmtblock_t ifblock
;
3707 gfc_init_block (&ifblock
);
3708 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3709 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3710 ifbody
= gfc_finish_block (&ifblock
);
3712 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3713 build_empty_stmt (input_location
));
3714 gfc_add_expr_to_block (&block2
, tmp
);
3718 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3720 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3722 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3723 arrayse
.expr
, limit
);
3724 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3725 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3726 build_empty_stmt (input_location
));
3727 gfc_add_expr_to_block (&block2
, tmp
);
3731 tmp
= fold_build2_loc (input_location
,
3732 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3733 type
, arrayse
.expr
, limit
);
3734 gfc_add_modify (&block2
, limit
, tmp
);
3740 tree elsebody
= gfc_finish_block (&block2
);
3742 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3744 if (HONOR_NANS (DECL_MODE (limit
))
3745 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3747 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3748 arrayse
.expr
, limit
);
3749 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3750 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3751 build_empty_stmt (input_location
));
3755 tmp
= fold_build2_loc (input_location
,
3756 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3757 type
, arrayse
.expr
, limit
);
3758 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3760 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3761 gfc_add_expr_to_block (&block
, tmp
);
3764 gfc_add_block_to_block (&block
, &block2
);
3766 gfc_add_block_to_block (&block
, &arrayse
.post
);
3768 tmp
= gfc_finish_block (&block
);
3770 /* We enclose the above in if (mask) {...}. */
3771 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3772 build_empty_stmt (input_location
));
3773 gfc_add_expr_to_block (&body
, tmp
);
3777 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3779 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3781 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
3782 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
3784 /* If we have a mask, only add this element if the mask is set. */
3787 gfc_init_se (&maskse
, NULL
);
3788 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3790 gfc_conv_expr_val (&maskse
, maskexpr
);
3791 gfc_add_block_to_block (&body
, &maskse
.pre
);
3793 gfc_start_block (&block
);
3796 gfc_init_block (&block
);
3798 /* Compare with the current limit. */
3799 gfc_init_se (&arrayse
, NULL
);
3800 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3801 arrayse
.ss
= arrayss
;
3802 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3803 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3805 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3807 if (HONOR_NANS (DECL_MODE (limit
))
3808 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3810 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3811 arrayse
.expr
, limit
);
3812 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3813 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3814 build_empty_stmt (input_location
));
3815 gfc_add_expr_to_block (&block
, tmp
);
3819 tmp
= fold_build2_loc (input_location
,
3820 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3821 type
, arrayse
.expr
, limit
);
3822 gfc_add_modify (&block
, limit
, tmp
);
3825 gfc_add_block_to_block (&block
, &arrayse
.post
);
3827 tmp
= gfc_finish_block (&block
);
3829 /* We enclose the above in if (mask) {...}. */
3830 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3831 build_empty_stmt (input_location
));
3832 gfc_add_expr_to_block (&body
, tmp
);
3833 /* Avoid initializing loopvar[0] again, it should be left where
3834 it finished by the first loop. */
3835 loop
.from
[0] = loop
.loopvar
[0];
3837 gfc_trans_scalarizing_loops (&loop
, &body
);
3841 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3843 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3844 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
3846 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3848 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
3850 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
3852 gfc_add_modify (&loop
.pre
, limit
, tmp
);
3855 /* For a scalar mask, enclose the loop in an if statement. */
3856 if (maskexpr
&& maskss
== NULL
)
3860 gfc_init_se (&maskse
, NULL
);
3861 gfc_conv_expr_val (&maskse
, maskexpr
);
3862 gfc_init_block (&block
);
3863 gfc_add_block_to_block (&block
, &loop
.pre
);
3864 gfc_add_block_to_block (&block
, &loop
.post
);
3865 tmp
= gfc_finish_block (&block
);
3867 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3868 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
3870 else_stmt
= build_empty_stmt (input_location
);
3871 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
3872 gfc_add_expr_to_block (&block
, tmp
);
3873 gfc_add_block_to_block (&se
->pre
, &block
);
3877 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3878 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3881 gfc_cleanup_loop (&loop
);
3886 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3888 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
3894 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3895 type
= TREE_TYPE (args
[0]);
3897 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3898 build_int_cst (type
, 1), args
[1]);
3899 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
3900 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
3901 build_int_cst (type
, 0));
3902 type
= gfc_typenode_for_spec (&expr
->ts
);
3903 se
->expr
= convert (type
, tmp
);
3907 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3909 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3913 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3915 /* Convert both arguments to the unsigned type of the same size. */
3916 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
3917 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
3919 /* If they have unequal type size, convert to the larger one. */
3920 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
3921 > TYPE_PRECISION (TREE_TYPE (args
[1])))
3922 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
3923 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
3924 > TYPE_PRECISION (TREE_TYPE (args
[0])))
3925 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
3927 /* Now, we compare them. */
3928 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3933 /* Generate code to perform the specified operation. */
3935 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3939 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3940 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
3946 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
3950 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3951 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3952 TREE_TYPE (arg
), arg
);
3955 /* Set or clear a single bit. */
3957 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
3964 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3965 type
= TREE_TYPE (args
[0]);
3967 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3968 build_int_cst (type
, 1), args
[1]);
3974 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
3976 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
3979 /* Extract a sequence of bits.
3980 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3982 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
3989 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3990 type
= TREE_TYPE (args
[0]);
3992 mask
= build_int_cst (type
, -1);
3993 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
3994 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
3996 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
3998 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4002 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4005 tree args
[2], type
, num_bits
, cond
;
4007 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4009 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4010 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4011 type
= TREE_TYPE (args
[0]);
4014 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4016 gcc_assert (right_shift
);
4018 se
->expr
= fold_build2_loc (input_location
,
4019 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4020 TREE_TYPE (args
[0]), args
[0], args
[1]);
4023 se
->expr
= fold_convert (type
, se
->expr
);
4025 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4026 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4028 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4029 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4032 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4033 build_int_cst (type
, 0), se
->expr
);
4036 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4038 : ((shift >= 0) ? i << shift : i >> -shift)
4039 where all shifts are logical shifts. */
4041 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4053 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4055 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4056 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4058 type
= TREE_TYPE (args
[0]);
4059 utype
= unsigned_type_for (type
);
4061 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4064 /* Left shift if positive. */
4065 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4067 /* Right shift if negative.
4068 We convert to an unsigned type because we want a logical shift.
4069 The standard doesn't define the case of shifting negative
4070 numbers, and we try to be compatible with other compilers, most
4071 notably g77, here. */
4072 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4073 utype
, convert (utype
, args
[0]), width
));
4075 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4076 build_int_cst (TREE_TYPE (args
[1]), 0));
4077 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4079 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4080 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4082 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4083 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4085 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4086 build_int_cst (type
, 0), tmp
);
4090 /* Circular shift. AKA rotate or barrel shift. */
4093 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4101 unsigned int num_args
;
4103 num_args
= gfc_intrinsic_argument_list_length (expr
);
4104 args
= XALLOCAVEC (tree
, num_args
);
4106 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4110 /* Use a library function for the 3 parameter version. */
4111 tree int4type
= gfc_get_int_type (4);
4113 type
= TREE_TYPE (args
[0]);
4114 /* We convert the first argument to at least 4 bytes, and
4115 convert back afterwards. This removes the need for library
4116 functions for all argument sizes, and function will be
4117 aligned to at least 32 bits, so there's no loss. */
4118 if (expr
->ts
.kind
< 4)
4119 args
[0] = convert (int4type
, args
[0]);
4121 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4122 need loads of library functions. They cannot have values >
4123 BIT_SIZE (I) so the conversion is safe. */
4124 args
[1] = convert (int4type
, args
[1]);
4125 args
[2] = convert (int4type
, args
[2]);
4127 switch (expr
->ts
.kind
)
4132 tmp
= gfor_fndecl_math_ishftc4
;
4135 tmp
= gfor_fndecl_math_ishftc8
;
4138 tmp
= gfor_fndecl_math_ishftc16
;
4143 se
->expr
= build_call_expr_loc (input_location
,
4144 tmp
, 3, args
[0], args
[1], args
[2]);
4145 /* Convert the result back to the original type, if we extended
4146 the first argument's width above. */
4147 if (expr
->ts
.kind
< 4)
4148 se
->expr
= convert (type
, se
->expr
);
4152 type
= TREE_TYPE (args
[0]);
4154 /* Evaluate arguments only once. */
4155 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4156 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4158 /* Rotate left if positive. */
4159 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4161 /* Rotate right if negative. */
4162 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4164 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4166 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4167 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4169 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4171 /* Do nothing if shift == 0. */
4172 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4174 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4179 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4180 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4182 The conditional expression is necessary because the result of LEADZ(0)
4183 is defined, but the result of __builtin_clz(0) is undefined for most
4186 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4187 difference in bit size between the argument of LEADZ and the C int. */
4190 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4202 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4203 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4205 /* Which variant of __builtin_clz* should we call? */
4206 if (argsize
<= INT_TYPE_SIZE
)
4208 arg_type
= unsigned_type_node
;
4209 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4211 else if (argsize
<= LONG_TYPE_SIZE
)
4213 arg_type
= long_unsigned_type_node
;
4214 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4216 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4218 arg_type
= long_long_unsigned_type_node
;
4219 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4223 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4224 arg_type
= gfc_build_uint_type (argsize
);
4228 /* Convert the actual argument twice: first, to the unsigned type of the
4229 same size; then, to the proper argument type for the built-in
4230 function. But the return type is of the default INTEGER kind. */
4231 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4232 arg
= fold_convert (arg_type
, arg
);
4233 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4234 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4236 /* Compute LEADZ for the case i .ne. 0. */
4239 s
= TYPE_PRECISION (arg_type
) - argsize
;
4240 tmp
= fold_convert (result_type
,
4241 build_call_expr_loc (input_location
, func
,
4243 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4244 tmp
, build_int_cst (result_type
, s
));
4248 /* We end up here if the argument type is larger than 'long long'.
4249 We generate this code:
4251 if (x & (ULL_MAX << ULL_SIZE) != 0)
4252 return clzll ((unsigned long long) (x >> ULLSIZE));
4254 return ULL_SIZE + clzll ((unsigned long long) x);
4255 where ULL_MAX is the largest value that a ULL_MAX can hold
4256 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4257 is the bit-size of the long long type (64 in this example). */
4258 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4260 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4261 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4262 long_long_unsigned_type_node
,
4263 build_int_cst (long_long_unsigned_type_node
,
4266 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4267 fold_convert (arg_type
, ullmax
), ullsize
);
4268 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4270 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4271 cond
, build_int_cst (arg_type
, 0));
4273 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4275 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4276 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4277 tmp1
= fold_convert (result_type
,
4278 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4280 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4281 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4282 tmp2
= fold_convert (result_type
,
4283 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4284 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4287 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4291 /* Build BIT_SIZE. */
4292 bit_size
= build_int_cst (result_type
, argsize
);
4294 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4295 arg
, build_int_cst (arg_type
, 0));
4296 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4301 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4303 The conditional expression is necessary because the result of TRAILZ(0)
4304 is defined, but the result of __builtin_ctz(0) is undefined for most
4308 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4319 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4320 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4322 /* Which variant of __builtin_ctz* should we call? */
4323 if (argsize
<= INT_TYPE_SIZE
)
4325 arg_type
= unsigned_type_node
;
4326 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4328 else if (argsize
<= LONG_TYPE_SIZE
)
4330 arg_type
= long_unsigned_type_node
;
4331 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4333 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4335 arg_type
= long_long_unsigned_type_node
;
4336 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4340 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4341 arg_type
= gfc_build_uint_type (argsize
);
4345 /* Convert the actual argument twice: first, to the unsigned type of the
4346 same size; then, to the proper argument type for the built-in
4347 function. But the return type is of the default INTEGER kind. */
4348 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4349 arg
= fold_convert (arg_type
, arg
);
4350 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4351 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4353 /* Compute TRAILZ for the case i .ne. 0. */
4355 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4359 /* We end up here if the argument type is larger than 'long long'.
4360 We generate this code:
4362 if ((x & ULL_MAX) == 0)
4363 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4365 return ctzll ((unsigned long long) x);
4367 where ULL_MAX is the largest value that a ULL_MAX can hold
4368 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4369 is the bit-size of the long long type (64 in this example). */
4370 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4372 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4373 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4374 long_long_unsigned_type_node
,
4375 build_int_cst (long_long_unsigned_type_node
, 0));
4377 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4378 fold_convert (arg_type
, ullmax
));
4379 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4380 build_int_cst (arg_type
, 0));
4382 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4384 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4385 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4386 tmp1
= fold_convert (result_type
,
4387 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4388 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4391 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4392 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4393 tmp2
= fold_convert (result_type
,
4394 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4396 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4400 /* Build BIT_SIZE. */
4401 bit_size
= build_int_cst (result_type
, argsize
);
4403 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4404 arg
, build_int_cst (arg_type
, 0));
4405 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4409 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4410 for types larger than "long long", we call the long long built-in for
4411 the lower and higher bits and combine the result. */
4414 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
4422 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4423 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4424 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4426 /* Which variant of the builtin should we call? */
4427 if (argsize
<= INT_TYPE_SIZE
)
4429 arg_type
= unsigned_type_node
;
4430 func
= builtin_decl_explicit (parity
4432 : BUILT_IN_POPCOUNT
);
4434 else if (argsize
<= LONG_TYPE_SIZE
)
4436 arg_type
= long_unsigned_type_node
;
4437 func
= builtin_decl_explicit (parity
4439 : BUILT_IN_POPCOUNTL
);
4441 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4443 arg_type
= long_long_unsigned_type_node
;
4444 func
= builtin_decl_explicit (parity
4446 : BUILT_IN_POPCOUNTLL
);
4450 /* Our argument type is larger than 'long long', which mean none
4451 of the POPCOUNT builtins covers it. We thus call the 'long long'
4452 variant multiple times, and add the results. */
4453 tree utype
, arg2
, call1
, call2
;
4455 /* For now, we only cover the case where argsize is twice as large
4457 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4459 func
= builtin_decl_explicit (parity
4461 : BUILT_IN_POPCOUNTLL
);
4463 /* Convert it to an integer, and store into a variable. */
4464 utype
= gfc_build_uint_type (argsize
);
4465 arg
= fold_convert (utype
, arg
);
4466 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4468 /* Call the builtin twice. */
4469 call1
= build_call_expr_loc (input_location
, func
, 1,
4470 fold_convert (long_long_unsigned_type_node
,
4473 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
4474 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
4475 call2
= build_call_expr_loc (input_location
, func
, 1,
4476 fold_convert (long_long_unsigned_type_node
,
4479 /* Combine the results. */
4481 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
4484 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4490 /* Convert the actual argument twice: first, to the unsigned type of the
4491 same size; then, to the proper argument type for the built-in
4493 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4494 arg
= fold_convert (arg_type
, arg
);
4496 se
->expr
= fold_convert (result_type
,
4497 build_call_expr_loc (input_location
, func
, 1, arg
));
4501 /* Process an intrinsic with unspecified argument-types that has an optional
4502 argument (which could be of type character), e.g. EOSHIFT. For those, we
4503 need to append the string length of the optional argument if it is not
4504 present and the type is really character.
4505 primary specifies the position (starting at 1) of the non-optional argument
4506 specifying the type and optional gives the position of the optional
4507 argument in the arglist. */
4510 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
4511 unsigned primary
, unsigned optional
)
4513 gfc_actual_arglist
* prim_arg
;
4514 gfc_actual_arglist
* opt_arg
;
4516 gfc_actual_arglist
* arg
;
4518 vec
<tree
, va_gc
> *append_args
;
4520 /* Find the two arguments given as position. */
4524 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4528 if (cur_pos
== primary
)
4530 if (cur_pos
== optional
)
4533 if (cur_pos
>= primary
&& cur_pos
>= optional
)
4536 gcc_assert (prim_arg
);
4537 gcc_assert (prim_arg
->expr
);
4538 gcc_assert (opt_arg
);
4540 /* If we do have type CHARACTER and the optional argument is really absent,
4541 append a dummy 0 as string length. */
4543 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
4547 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
4548 vec_alloc (append_args
, 1);
4549 append_args
->quick_push (dummy
);
4552 /* Build the call itself. */
4553 sym
= gfc_get_symbol_for_expr (expr
);
4554 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4556 gfc_free_symbol (sym
);
4560 /* The length of a character string. */
4562 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
4571 gcc_assert (!se
->ss
);
4573 arg
= expr
->value
.function
.actual
->expr
;
4575 type
= gfc_typenode_for_spec (&expr
->ts
);
4576 switch (arg
->expr_type
)
4579 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
4583 /* Obtain the string length from the function used by
4584 trans-array.c(gfc_trans_array_constructor). */
4586 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
4590 if (arg
->ref
== NULL
4591 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
4593 /* This doesn't catch all cases.
4594 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4595 and the surrounding thread. */
4596 sym
= arg
->symtree
->n
.sym
;
4597 decl
= gfc_get_symbol_decl (sym
);
4598 if (decl
== current_function_decl
&& sym
->attr
.function
4599 && (sym
->result
== sym
))
4600 decl
= gfc_get_fake_result_decl (sym
, 0);
4602 len
= sym
->ts
.u
.cl
->backend_decl
;
4607 /* Otherwise fall through. */
4610 /* Anybody stupid enough to do this deserves inefficient code. */
4611 gfc_init_se (&argse
, se
);
4613 gfc_conv_expr (&argse
, arg
);
4615 gfc_conv_expr_descriptor (&argse
, arg
);
4616 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4617 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4618 len
= argse
.string_length
;
4621 se
->expr
= convert (type
, len
);
4624 /* The length of a character string not including trailing blanks. */
4626 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
4628 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4629 tree args
[2], type
, fndecl
;
4631 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4632 type
= gfc_typenode_for_spec (&expr
->ts
);
4635 fndecl
= gfor_fndecl_string_len_trim
;
4637 fndecl
= gfor_fndecl_string_len_trim_char4
;
4641 se
->expr
= build_call_expr_loc (input_location
,
4642 fndecl
, 2, args
[0], args
[1]);
4643 se
->expr
= convert (type
, se
->expr
);
4647 /* Returns the starting position of a substring within a string. */
4650 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4653 tree logical4_type_node
= gfc_get_logical_type (4);
4657 unsigned int num_args
;
4659 args
= XALLOCAVEC (tree
, 5);
4661 /* Get number of arguments; characters count double due to the
4662 string length argument. Kind= is not passed to the library
4663 and thus ignored. */
4664 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4669 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4670 type
= gfc_typenode_for_spec (&expr
->ts
);
4673 args
[4] = build_int_cst (logical4_type_node
, 0);
4675 args
[4] = convert (logical4_type_node
, args
[4]);
4677 fndecl
= build_addr (function
, current_function_decl
);
4678 se
->expr
= build_call_array_loc (input_location
,
4679 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4681 se
->expr
= convert (type
, se
->expr
);
4685 /* The ascii value for a single character. */
4687 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4689 tree args
[2], type
, pchartype
;
4691 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4692 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
4693 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
4694 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
4695 type
= gfc_typenode_for_spec (&expr
->ts
);
4697 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4699 se
->expr
= convert (type
, se
->expr
);
4703 /* Intrinsic ISNAN calls __builtin_isnan. */
4706 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
4710 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4711 se
->expr
= build_call_expr_loc (input_location
,
4712 builtin_decl_explicit (BUILT_IN_ISNAN
),
4714 STRIP_TYPE_NOPS (se
->expr
);
4715 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4719 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4720 their argument against a constant integer value. */
4723 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
4727 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4728 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
4729 gfc_typenode_for_spec (&expr
->ts
),
4730 arg
, build_int_cst (TREE_TYPE (arg
), value
));
4735 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4738 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
4746 unsigned int num_args
;
4748 num_args
= gfc_intrinsic_argument_list_length (expr
);
4749 args
= XALLOCAVEC (tree
, num_args
);
4751 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4752 if (expr
->ts
.type
!= BT_CHARACTER
)
4760 /* We do the same as in the non-character case, but the argument
4761 list is different because of the string length arguments. We
4762 also have to set the string length for the result. */
4769 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
4771 se
->string_length
= len
;
4773 type
= TREE_TYPE (tsource
);
4774 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
4775 fold_convert (type
, fsource
));
4779 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4782 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
4784 tree args
[3], mask
, type
;
4786 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4787 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
4789 type
= TREE_TYPE (args
[0]);
4790 gcc_assert (TREE_TYPE (args
[1]) == type
);
4791 gcc_assert (TREE_TYPE (mask
) == type
);
4793 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
4794 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
4795 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4797 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
4802 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4803 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4806 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
4808 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
4811 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4812 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4814 type
= gfc_get_int_type (expr
->ts
.kind
);
4815 utype
= unsigned_type_for (type
);
4817 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
4818 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
4820 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
4821 build_int_cst (utype
, 0));
4825 /* Left-justified mask. */
4826 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
4828 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4829 fold_convert (utype
, res
));
4831 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4832 smaller than type width. */
4833 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4834 build_int_cst (TREE_TYPE (arg
), 0));
4835 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
4836 build_int_cst (utype
, 0), res
);
4840 /* Right-justified mask. */
4841 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4842 fold_convert (utype
, arg
));
4843 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
4845 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4846 strictly smaller than type width. */
4847 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4849 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
4850 cond
, allones
, res
);
4853 se
->expr
= fold_convert (type
, res
);
4857 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4859 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
4861 tree arg
, type
, tmp
, frexp
;
4863 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4865 type
= gfc_typenode_for_spec (&expr
->ts
);
4866 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4867 tmp
= gfc_create_var (integer_type_node
, NULL
);
4868 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
4869 fold_convert (type
, arg
),
4870 gfc_build_addr_expr (NULL_TREE
, tmp
));
4871 se
->expr
= fold_convert (type
, se
->expr
);
4875 /* NEAREST (s, dir) is translated into
4876 tmp = copysign (HUGE_VAL, dir);
4877 return nextafter (s, tmp);
4880 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
4882 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
4884 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
4885 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
4887 type
= gfc_typenode_for_spec (&expr
->ts
);
4888 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4890 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
4891 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
4892 fold_convert (type
, args
[1]));
4893 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
4894 fold_convert (type
, args
[0]), tmp
);
4895 se
->expr
= fold_convert (type
, se
->expr
);
4899 /* SPACING (s) is translated into
4907 e = MAX_EXPR (e, emin);
4908 res = scalbn (1., e);
4912 where prec is the precision of s, gfc_real_kinds[k].digits,
4913 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4914 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4917 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
4919 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
4920 tree cond
, tmp
, frexp
, scalbn
;
4924 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4925 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
4926 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
4927 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
4929 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4930 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4932 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4933 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4935 type
= gfc_typenode_for_spec (&expr
->ts
);
4936 e
= gfc_create_var (integer_type_node
, NULL
);
4937 res
= gfc_create_var (type
, NULL
);
4940 /* Build the block for s /= 0. */
4941 gfc_start_block (&block
);
4942 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4943 gfc_build_addr_expr (NULL_TREE
, e
));
4944 gfc_add_expr_to_block (&block
, tmp
);
4946 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
4948 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
4949 integer_type_node
, tmp
, emin
));
4951 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
4952 build_real_from_int_cst (type
, integer_one_node
), e
);
4953 gfc_add_modify (&block
, res
, tmp
);
4955 /* Finish by building the IF statement. */
4956 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4957 build_real_from_int_cst (type
, integer_zero_node
));
4958 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
4959 gfc_finish_block (&block
));
4961 gfc_add_expr_to_block (&se
->pre
, tmp
);
4966 /* RRSPACING (s) is translated into
4973 x = scalbn (x, precision - e);
4977 where precision is gfc_real_kinds[k].digits. */
4980 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
4982 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
4986 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4987 prec
= gfc_real_kinds
[k
].digits
;
4989 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4990 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4991 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
4993 type
= gfc_typenode_for_spec (&expr
->ts
);
4994 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4995 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4997 e
= gfc_create_var (integer_type_node
, NULL
);
4998 x
= gfc_create_var (type
, NULL
);
4999 gfc_add_modify (&se
->pre
, x
,
5000 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5003 gfc_start_block (&block
);
5004 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5005 gfc_build_addr_expr (NULL_TREE
, e
));
5006 gfc_add_expr_to_block (&block
, tmp
);
5008 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5009 build_int_cst (integer_type_node
, prec
), e
);
5010 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5011 gfc_add_modify (&block
, x
, tmp
);
5012 stmt
= gfc_finish_block (&block
);
5014 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5015 build_real_from_int_cst (type
, integer_zero_node
));
5016 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5017 gfc_add_expr_to_block (&se
->pre
, tmp
);
5019 se
->expr
= fold_convert (type
, x
);
5023 /* SCALE (s, i) is translated into scalbn (s, i). */
5025 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5027 tree args
[2], type
, scalbn
;
5029 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5031 type
= gfc_typenode_for_spec (&expr
->ts
);
5032 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5033 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5034 fold_convert (type
, args
[0]),
5035 fold_convert (integer_type_node
, args
[1]));
5036 se
->expr
= fold_convert (type
, se
->expr
);
5040 /* SET_EXPONENT (s, i) is translated into
5041 scalbn (frexp (s, &dummy_int), i). */
5043 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5045 tree args
[2], type
, tmp
, frexp
, scalbn
;
5047 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5048 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5050 type
= gfc_typenode_for_spec (&expr
->ts
);
5051 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5053 tmp
= gfc_create_var (integer_type_node
, NULL
);
5054 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5055 fold_convert (type
, args
[0]),
5056 gfc_build_addr_expr (NULL_TREE
, tmp
));
5057 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5058 fold_convert (integer_type_node
, args
[1]));
5059 se
->expr
= fold_convert (type
, se
->expr
);
5064 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5066 gfc_actual_arglist
*actual
;
5073 gfc_init_se (&argse
, NULL
);
5074 actual
= expr
->value
.function
.actual
;
5076 if (actual
->expr
->ts
.type
== BT_CLASS
)
5077 gfc_add_class_array_ref (actual
->expr
);
5079 argse
.want_pointer
= 1;
5080 argse
.data_not_needed
= 1;
5081 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5082 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5083 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5084 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5086 /* Build the call to size0. */
5087 fncall0
= build_call_expr_loc (input_location
,
5088 gfor_fndecl_size0
, 1, arg1
);
5090 actual
= actual
->next
;
5094 gfc_init_se (&argse
, NULL
);
5095 gfc_conv_expr_type (&argse
, actual
->expr
,
5096 gfc_array_index_type
);
5097 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5099 /* Unusually, for an intrinsic, size does not exclude
5100 an optional arg2, so we must test for it. */
5101 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5102 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5103 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5106 /* Build the call to size1. */
5107 fncall1
= build_call_expr_loc (input_location
,
5108 gfor_fndecl_size1
, 2,
5111 gfc_init_se (&argse
, NULL
);
5112 argse
.want_pointer
= 1;
5113 argse
.data_not_needed
= 1;
5114 gfc_conv_expr (&argse
, actual
->expr
);
5115 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5116 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5117 argse
.expr
, null_pointer_node
);
5118 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5119 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5120 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5124 se
->expr
= NULL_TREE
;
5125 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5126 gfc_array_index_type
,
5127 argse
.expr
, gfc_index_one_node
);
5130 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5132 argse
.expr
= gfc_index_zero_node
;
5133 se
->expr
= NULL_TREE
;
5138 if (se
->expr
== NULL_TREE
)
5140 tree ubound
, lbound
;
5142 arg1
= build_fold_indirect_ref_loc (input_location
,
5144 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5145 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5146 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5147 gfc_array_index_type
, ubound
, lbound
);
5148 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5149 gfc_array_index_type
,
5150 se
->expr
, gfc_index_one_node
);
5151 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5152 gfc_array_index_type
, se
->expr
,
5153 gfc_index_zero_node
);
5156 type
= gfc_typenode_for_spec (&expr
->ts
);
5157 se
->expr
= convert (type
, se
->expr
);
5161 /* Helper function to compute the size of a character variable,
5162 excluding the terminating null characters. The result has
5163 gfc_array_index_type type. */
5166 size_of_string_in_bytes (int kind
, tree string_length
)
5169 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5171 bytesize
= build_int_cst (gfc_array_index_type
,
5172 gfc_character_kinds
[i
].bit_size
/ 8);
5174 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5176 fold_convert (gfc_array_index_type
, string_length
));
5181 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5192 arg
= expr
->value
.function
.actual
->expr
;
5194 gfc_init_se (&argse
, NULL
);
5198 if (arg
->ts
.type
== BT_CLASS
)
5199 gfc_add_data_component (arg
);
5201 gfc_conv_expr_reference (&argse
, arg
);
5203 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5206 /* Obtain the source word length. */
5207 if (arg
->ts
.type
== BT_CHARACTER
)
5208 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
5209 argse
.string_length
);
5211 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
5215 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5216 argse
.want_pointer
= 0;
5217 gfc_conv_expr_descriptor (&argse
, arg
);
5218 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5220 /* Obtain the argument's word length. */
5221 if (arg
->ts
.type
== BT_CHARACTER
)
5222 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5224 tmp
= fold_convert (gfc_array_index_type
,
5225 size_in_bytes (type
));
5226 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5228 /* Obtain the size of the array in bytes. */
5229 for (n
= 0; n
< arg
->rank
; n
++)
5232 idx
= gfc_rank_cst
[n
];
5233 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5234 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5235 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5236 gfc_array_index_type
, upper
, lower
);
5237 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5238 gfc_array_index_type
, tmp
, gfc_index_one_node
);
5239 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5240 gfc_array_index_type
, tmp
, source_bytes
);
5241 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5243 se
->expr
= source_bytes
;
5246 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5251 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
5255 tree type
, result_type
, tmp
;
5257 arg
= expr
->value
.function
.actual
->expr
;
5258 gfc_init_se (&eight
, NULL
);
5259 gfc_conv_expr (&eight
, gfc_get_int_expr (expr
->ts
.kind
, NULL
, 8));
5261 gfc_init_se (&argse
, NULL
);
5262 result_type
= gfc_get_int_type (expr
->ts
.kind
);
5266 if (arg
->ts
.type
== BT_CLASS
)
5268 gfc_add_vptr_component (arg
);
5269 gfc_add_size_component (arg
);
5270 gfc_conv_expr (&argse
, arg
);
5271 tmp
= fold_convert (result_type
, argse
.expr
);
5275 gfc_conv_expr_reference (&argse
, arg
);
5276 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5281 argse
.want_pointer
= 0;
5282 gfc_conv_expr_descriptor (&argse
, arg
);
5283 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5286 /* Obtain the argument's word length. */
5287 if (arg
->ts
.type
== BT_CHARACTER
)
5288 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5290 tmp
= fold_convert (result_type
, size_in_bytes (type
));
5293 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
5295 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5299 /* Intrinsic string comparison functions. */
5302 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5306 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
5309 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
5310 expr
->value
.function
.actual
->expr
->ts
.kind
,
5312 se
->expr
= fold_build2_loc (input_location
, op
,
5313 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
5314 build_int_cst (TREE_TYPE (se
->expr
), 0));
5317 /* Generate a call to the adjustl/adjustr library function. */
5319 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
5327 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
5330 type
= TREE_TYPE (args
[2]);
5331 var
= gfc_conv_string_tmp (se
, type
, len
);
5334 tmp
= build_call_expr_loc (input_location
,
5335 fndecl
, 3, args
[0], args
[1], args
[2]);
5336 gfc_add_expr_to_block (&se
->pre
, tmp
);
5338 se
->string_length
= len
;
5342 /* Generate code for the TRANSFER intrinsic:
5344 DEST = TRANSFER (SOURCE, MOLD)
5346 typeof<DEST> = typeof<MOLD>
5351 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5353 typeof<DEST> = typeof<MOLD>
5355 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5356 sizeof (DEST(0) * SIZE). */
5358 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
5374 gfc_actual_arglist
*arg
;
5376 gfc_array_info
*info
;
5380 gfc_expr
*source_expr
, *mold_expr
;
5384 info
= &se
->ss
->info
->data
.array
;
5386 /* Convert SOURCE. The output from this stage is:-
5387 source_bytes = length of the source in bytes
5388 source = pointer to the source data. */
5389 arg
= expr
->value
.function
.actual
;
5390 source_expr
= arg
->expr
;
5392 /* Ensure double transfer through LOGICAL preserves all
5394 if (arg
->expr
->expr_type
== EXPR_FUNCTION
5395 && arg
->expr
->value
.function
.esym
== NULL
5396 && arg
->expr
->value
.function
.isym
!= NULL
5397 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
5398 && arg
->expr
->ts
.type
== BT_LOGICAL
5399 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
5400 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
5402 gfc_init_se (&argse
, NULL
);
5404 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5406 /* Obtain the pointer to source and the length of source in bytes. */
5407 if (arg
->expr
->rank
== 0)
5409 gfc_conv_expr_reference (&argse
, arg
->expr
);
5410 if (arg
->expr
->ts
.type
== BT_CLASS
)
5411 source
= gfc_class_data_get (argse
.expr
);
5413 source
= argse
.expr
;
5415 /* Obtain the source word length. */
5416 switch (arg
->expr
->ts
.type
)
5419 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5420 argse
.string_length
);
5423 tmp
= gfc_vtable_size_get (argse
.expr
);
5426 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5428 tmp
= fold_convert (gfc_array_index_type
,
5429 size_in_bytes (source_type
));
5435 argse
.want_pointer
= 0;
5436 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5437 source
= gfc_conv_descriptor_data_get (argse
.expr
);
5438 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5440 /* Repack the source if not a full variable array. */
5441 if (arg
->expr
->expr_type
== EXPR_VARIABLE
5442 && arg
->expr
->ref
->u
.ar
.type
!= AR_FULL
)
5444 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
5446 if (gfc_option
.warn_array_temp
)
5447 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5449 source
= build_call_expr_loc (input_location
,
5450 gfor_fndecl_in_pack
, 1, tmp
);
5451 source
= gfc_evaluate_now (source
, &argse
.pre
);
5453 /* Free the temporary. */
5454 gfc_start_block (&block
);
5455 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
5456 gfc_add_expr_to_block (&block
, tmp
);
5457 stmt
= gfc_finish_block (&block
);
5459 /* Clean up if it was repacked. */
5460 gfc_init_block (&block
);
5461 tmp
= gfc_conv_array_data (argse
.expr
);
5462 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5464 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
5465 build_empty_stmt (input_location
));
5466 gfc_add_expr_to_block (&block
, tmp
);
5467 gfc_add_block_to_block (&block
, &se
->post
);
5468 gfc_init_block (&se
->post
);
5469 gfc_add_block_to_block (&se
->post
, &block
);
5472 /* Obtain the source word length. */
5473 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5474 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5475 argse
.string_length
);
5477 tmp
= fold_convert (gfc_array_index_type
,
5478 size_in_bytes (source_type
));
5480 /* Obtain the size of the array in bytes. */
5481 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
5482 for (n
= 0; n
< arg
->expr
->rank
; n
++)
5485 idx
= gfc_rank_cst
[n
];
5486 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5487 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5488 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5489 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5490 gfc_array_index_type
, upper
, lower
);
5491 gfc_add_modify (&argse
.pre
, extent
, tmp
);
5492 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5493 gfc_array_index_type
, extent
,
5494 gfc_index_one_node
);
5495 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5496 gfc_array_index_type
, tmp
, source_bytes
);
5500 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5501 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5502 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5504 /* Now convert MOLD. The outputs are:
5505 mold_type = the TREE type of MOLD
5506 dest_word_len = destination word length in bytes. */
5508 mold_expr
= arg
->expr
;
5510 gfc_init_se (&argse
, NULL
);
5512 scalar_mold
= arg
->expr
->rank
== 0;
5514 if (arg
->expr
->rank
== 0)
5516 gfc_conv_expr_reference (&argse
, arg
->expr
);
5517 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5522 gfc_init_se (&argse
, NULL
);
5523 argse
.want_pointer
= 0;
5524 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5525 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5528 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5529 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5531 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
5533 /* If this TRANSFER is nested in another TRANSFER, use a type
5534 that preserves all bits. */
5535 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
5536 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
5539 /* Obtain the destination word length. */
5540 switch (arg
->expr
->ts
.type
)
5543 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
5544 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
5547 tmp
= gfc_vtable_size_get (argse
.expr
);
5550 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
5553 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
5554 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
5556 /* Finally convert SIZE, if it is present. */
5558 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
5562 gfc_init_se (&argse
, NULL
);
5563 gfc_conv_expr_reference (&argse
, arg
->expr
);
5564 tmp
= convert (gfc_array_index_type
,
5565 build_fold_indirect_ref_loc (input_location
,
5567 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5568 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5573 /* Separate array and scalar results. */
5574 if (scalar_mold
&& tmp
== NULL_TREE
)
5575 goto scalar_transfer
;
5577 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5578 if (tmp
!= NULL_TREE
)
5579 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5580 tmp
, dest_word_len
);
5584 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
5585 gfc_add_modify (&se
->pre
, size_words
,
5586 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
5587 gfc_array_index_type
,
5588 size_bytes
, dest_word_len
));
5590 /* Evaluate the bounds of the result. If the loop range exists, we have
5591 to check if it is too large. If so, we modify loop->to be consistent
5592 with min(size, size(source)). Otherwise, size is made consistent with
5593 the loop range, so that the right number of bytes is transferred.*/
5594 n
= se
->loop
->order
[0];
5595 if (se
->loop
->to
[n
] != NULL_TREE
)
5597 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5598 se
->loop
->to
[n
], se
->loop
->from
[n
]);
5599 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5600 tmp
, gfc_index_one_node
);
5601 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5603 gfc_add_modify (&se
->pre
, size_words
, tmp
);
5604 gfc_add_modify (&se
->pre
, size_bytes
,
5605 fold_build2_loc (input_location
, MULT_EXPR
,
5606 gfc_array_index_type
,
5607 size_words
, dest_word_len
));
5608 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5609 size_words
, se
->loop
->from
[n
]);
5610 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5611 upper
, gfc_index_one_node
);
5615 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5616 size_words
, gfc_index_one_node
);
5617 se
->loop
->from
[n
] = gfc_index_zero_node
;
5620 se
->loop
->to
[n
] = upper
;
5622 /* Build a destination descriptor, using the pointer, source, as the
5624 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
5625 NULL_TREE
, false, true, false, &expr
->where
);
5627 /* Cast the pointer to the result. */
5628 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5629 tmp
= fold_convert (pvoid_type_node
, tmp
);
5631 /* Use memcpy to do the transfer. */
5633 = build_call_expr_loc (input_location
,
5634 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
5635 fold_convert (pvoid_type_node
, source
),
5636 fold_convert (size_type_node
,
5637 fold_build2_loc (input_location
,
5639 gfc_array_index_type
,
5642 gfc_add_expr_to_block (&se
->pre
, tmp
);
5644 se
->expr
= info
->descriptor
;
5645 if (expr
->ts
.type
== BT_CHARACTER
)
5646 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5650 /* Deal with scalar results. */
5652 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5653 dest_word_len
, source_bytes
);
5654 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5655 extent
, gfc_index_zero_node
);
5657 if (expr
->ts
.type
== BT_CHARACTER
)
5662 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5663 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5666 /* If source is longer than the destination, use a pointer to
5667 the source directly. */
5668 gfc_init_block (&block
);
5669 gfc_add_modify (&block
, tmpdecl
, ptr
);
5670 direct
= gfc_finish_block (&block
);
5672 /* Otherwise, allocate a string with the length of the destination
5673 and copy the source into it. */
5674 gfc_init_block (&block
);
5675 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5676 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5677 gfc_add_modify (&block
, tmpdecl
,
5678 fold_convert (TREE_TYPE (ptr
), tmp
));
5679 tmp
= build_call_expr_loc (input_location
,
5680 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5681 fold_convert (pvoid_type_node
, tmpdecl
),
5682 fold_convert (pvoid_type_node
, ptr
),
5683 fold_convert (size_type_node
, extent
));
5684 gfc_add_expr_to_block (&block
, tmp
);
5685 indirect
= gfc_finish_block (&block
);
5687 /* Wrap it up with the condition. */
5688 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5689 dest_word_len
, source_bytes
);
5690 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5691 gfc_add_expr_to_block (&se
->pre
, tmp
);
5694 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5698 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5700 ptr
= convert (build_pointer_type (mold_type
), source
);
5702 /* For CLASS results, allocate the needed memory first. */
5703 if (mold_expr
->ts
.type
== BT_CLASS
)
5706 cdata
= gfc_class_data_get (tmpdecl
);
5707 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
5708 gfc_add_modify (&se
->pre
, cdata
, tmp
);
5711 /* Use memcpy to do the transfer. */
5712 if (mold_expr
->ts
.type
== BT_CLASS
)
5713 tmp
= gfc_class_data_get (tmpdecl
);
5715 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5717 tmp
= build_call_expr_loc (input_location
,
5718 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5719 fold_convert (pvoid_type_node
, tmp
),
5720 fold_convert (pvoid_type_node
, ptr
),
5721 fold_convert (size_type_node
, extent
));
5722 gfc_add_expr_to_block (&se
->pre
, tmp
);
5724 /* For CLASS results, set the _vptr. */
5725 if (mold_expr
->ts
.type
== BT_CLASS
)
5729 vptr
= gfc_class_vptr_get (tmpdecl
);
5730 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
5732 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
5733 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
5741 /* Generate code for the ALLOCATED intrinsic.
5742 Generate inline code that directly check the address of the argument. */
5745 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5747 gfc_actual_arglist
*arg1
;
5751 gfc_init_se (&arg1se
, NULL
);
5752 arg1
= expr
->value
.function
.actual
;
5754 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5756 /* Make sure that class array expressions have both a _data
5757 component reference and an array reference.... */
5758 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
5759 gfc_add_class_array_ref (arg1
->expr
);
5760 /* .... whilst scalars only need the _data component. */
5762 gfc_add_data_component (arg1
->expr
);
5765 if (arg1
->expr
->rank
== 0)
5767 /* Allocatable scalar. */
5768 arg1se
.want_pointer
= 1;
5769 gfc_conv_expr (&arg1se
, arg1
->expr
);
5774 /* Allocatable array. */
5775 arg1se
.descriptor_only
= 1;
5776 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5777 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5780 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5781 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5782 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5786 /* Generate code for the ASSOCIATED intrinsic.
5787 If both POINTER and TARGET are arrays, generate a call to library function
5788 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5789 In other cases, generate inline code that directly compare the address of
5790 POINTER with the address of TARGET. */
5793 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
5795 gfc_actual_arglist
*arg1
;
5796 gfc_actual_arglist
*arg2
;
5801 tree nonzero_charlen
;
5802 tree nonzero_arraylen
;
5806 gfc_init_se (&arg1se
, NULL
);
5807 gfc_init_se (&arg2se
, NULL
);
5808 arg1
= expr
->value
.function
.actual
;
5811 /* Check whether the expression is a scalar or not; we cannot use
5812 arg1->expr->rank as it can be nonzero for proc pointers. */
5813 ss
= gfc_walk_expr (arg1
->expr
);
5814 scalar
= ss
== gfc_ss_terminator
;
5816 gfc_free_ss_chain (ss
);
5820 /* No optional target. */
5823 /* A pointer to a scalar. */
5824 arg1se
.want_pointer
= 1;
5825 gfc_conv_expr (&arg1se
, arg1
->expr
);
5826 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5827 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5828 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5830 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5831 tmp2
= gfc_class_data_get (arg1se
.expr
);
5837 /* A pointer to an array. */
5838 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5839 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5841 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5842 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5843 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
5844 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
5849 /* An optional target. */
5850 if (arg2
->expr
->ts
.type
== BT_CLASS
)
5851 gfc_add_data_component (arg2
->expr
);
5853 nonzero_charlen
= NULL_TREE
;
5854 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
5855 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
5857 arg1
->expr
->ts
.u
.cl
->backend_decl
,
5861 /* A pointer to a scalar. */
5862 arg1se
.want_pointer
= 1;
5863 gfc_conv_expr (&arg1se
, arg1
->expr
);
5864 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5865 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5866 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5868 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5869 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
5871 arg2se
.want_pointer
= 1;
5872 gfc_conv_expr (&arg2se
, arg2
->expr
);
5873 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5874 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
5875 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
5877 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5878 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5879 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5880 arg1se
.expr
, arg2se
.expr
);
5881 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5882 arg1se
.expr
, null_pointer_node
);
5883 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5884 boolean_type_node
, tmp
, tmp2
);
5888 /* An array pointer of zero length is not associated if target is
5890 arg1se
.descriptor_only
= 1;
5891 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
5892 if (arg1
->expr
->rank
== -1)
5894 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
5895 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5896 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
5899 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
5900 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
5901 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
5902 boolean_type_node
, tmp
,
5903 build_int_cst (TREE_TYPE (tmp
), 0));
5905 /* A pointer to an array, call library function _gfor_associated. */
5906 arg1se
.want_pointer
= 1;
5907 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5909 arg2se
.want_pointer
= 1;
5910 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
5911 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
5912 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
5913 se
->expr
= build_call_expr_loc (input_location
,
5914 gfor_fndecl_associated
, 2,
5915 arg1se
.expr
, arg2se
.expr
);
5916 se
->expr
= convert (boolean_type_node
, se
->expr
);
5917 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5918 boolean_type_node
, se
->expr
,
5922 /* If target is present zero character length pointers cannot
5924 if (nonzero_charlen
!= NULL_TREE
)
5925 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5927 se
->expr
, nonzero_charlen
);
5930 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5934 /* Generate code for the SAME_TYPE_AS intrinsic.
5935 Generate inline code that directly checks the vindices. */
5938 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
5943 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
5945 gfc_init_se (&se1
, NULL
);
5946 gfc_init_se (&se2
, NULL
);
5948 a
= expr
->value
.function
.actual
->expr
;
5949 b
= expr
->value
.function
.actual
->next
->expr
;
5951 if (UNLIMITED_POLY (a
))
5953 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
5954 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5955 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
5958 if (UNLIMITED_POLY (b
))
5960 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
5961 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5962 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
5965 if (a
->ts
.type
== BT_CLASS
)
5967 gfc_add_vptr_component (a
);
5968 gfc_add_hash_component (a
);
5970 else if (a
->ts
.type
== BT_DERIVED
)
5971 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5972 a
->ts
.u
.derived
->hash_value
);
5974 if (b
->ts
.type
== BT_CLASS
)
5976 gfc_add_vptr_component (b
);
5977 gfc_add_hash_component (b
);
5979 else if (b
->ts
.type
== BT_DERIVED
)
5980 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5981 b
->ts
.u
.derived
->hash_value
);
5983 gfc_conv_expr (&se1
, a
);
5984 gfc_conv_expr (&se2
, b
);
5986 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
5987 boolean_type_node
, se1
.expr
,
5988 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
5991 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5992 boolean_type_node
, conda
, tmp
);
5995 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5996 boolean_type_node
, condb
, tmp
);
5998 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6002 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6005 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6009 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6010 se
->expr
= build_call_expr_loc (input_location
,
6011 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6012 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6016 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6019 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6023 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6025 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6026 type
= gfc_get_int_type (4);
6027 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6029 /* Convert it to the required type. */
6030 type
= gfc_typenode_for_spec (&expr
->ts
);
6031 se
->expr
= build_call_expr_loc (input_location
,
6032 gfor_fndecl_si_kind
, 1, arg
);
6033 se
->expr
= fold_convert (type
, se
->expr
);
6037 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6040 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6042 gfc_actual_arglist
*actual
;
6045 vec
<tree
, va_gc
> *args
= NULL
;
6047 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6049 gfc_init_se (&argse
, se
);
6051 /* Pass a NULL pointer for an absent arg. */
6052 if (actual
->expr
== NULL
)
6053 argse
.expr
= null_pointer_node
;
6059 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6061 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6062 ts
.type
= BT_INTEGER
;
6063 ts
.kind
= gfc_c_int_kind
;
6064 gfc_convert_type (actual
->expr
, &ts
, 2);
6066 gfc_conv_expr_reference (&argse
, actual
->expr
);
6069 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6070 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6071 vec_safe_push (args
, argse
.expr
);
6074 /* Convert it to the required type. */
6075 type
= gfc_typenode_for_spec (&expr
->ts
);
6076 se
->expr
= build_call_expr_loc_vec (input_location
,
6077 gfor_fndecl_sr_kind
, args
);
6078 se
->expr
= fold_convert (type
, se
->expr
);
6082 /* Generate code for TRIM (A) intrinsic function. */
6085 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6095 unsigned int num_args
;
6097 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6098 args
= XALLOCAVEC (tree
, num_args
);
6100 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6101 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6102 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6104 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6105 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6108 if (expr
->ts
.kind
== 1)
6109 function
= gfor_fndecl_string_trim
;
6110 else if (expr
->ts
.kind
== 4)
6111 function
= gfor_fndecl_string_trim_char4
;
6115 fndecl
= build_addr (function
, current_function_decl
);
6116 tmp
= build_call_array_loc (input_location
,
6117 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6119 gfc_add_expr_to_block (&se
->pre
, tmp
);
6121 /* Free the temporary afterwards, if necessary. */
6122 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6123 len
, build_int_cst (TREE_TYPE (len
), 0));
6124 tmp
= gfc_call_free (var
);
6125 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6126 gfc_add_expr_to_block (&se
->post
, tmp
);
6129 se
->string_length
= len
;
6133 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6136 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6138 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6139 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6141 stmtblock_t block
, body
;
6144 /* We store in charsize the size of a character. */
6145 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6146 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6148 /* Get the arguments. */
6149 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6150 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6152 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6153 ncopies_type
= TREE_TYPE (ncopies
);
6155 /* Check that NCOPIES is not negative. */
6156 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6157 build_int_cst (ncopies_type
, 0));
6158 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6159 "Argument NCOPIES of REPEAT intrinsic is negative "
6160 "(its value is %ld)",
6161 fold_convert (long_integer_type_node
, ncopies
));
6163 /* If the source length is zero, any non negative value of NCOPIES
6164 is valid, and nothing happens. */
6165 n
= gfc_create_var (ncopies_type
, "ncopies");
6166 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6167 build_int_cst (size_type_node
, 0));
6168 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6169 build_int_cst (ncopies_type
, 0), ncopies
);
6170 gfc_add_modify (&se
->pre
, n
, tmp
);
6173 /* Check that ncopies is not too large: ncopies should be less than
6174 (or equal to) MAX / slen, where MAX is the maximal integer of
6175 the gfc_charlen_type_node type. If slen == 0, we need a special
6176 case to avoid the division by zero. */
6177 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6178 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6179 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6180 fold_convert (size_type_node
, max
), slen
);
6181 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6182 ? size_type_node
: ncopies_type
;
6183 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6184 fold_convert (largest
, ncopies
),
6185 fold_convert (largest
, max
));
6186 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6187 build_int_cst (size_type_node
, 0));
6188 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6189 boolean_false_node
, cond
);
6190 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6191 "Argument NCOPIES of REPEAT intrinsic is too large");
6193 /* Compute the destination length. */
6194 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6195 fold_convert (gfc_charlen_type_node
, slen
),
6196 fold_convert (gfc_charlen_type_node
, ncopies
));
6197 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6198 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6200 /* Generate the code to do the repeat operation:
6201 for (i = 0; i < ncopies; i++)
6202 memmove (dest + (i * slen * size), src, slen*size); */
6203 gfc_start_block (&block
);
6204 count
= gfc_create_var (ncopies_type
, "count");
6205 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6206 exit_label
= gfc_build_label_decl (NULL_TREE
);
6208 /* Start the loop body. */
6209 gfc_start_block (&body
);
6211 /* Exit the loop if count >= ncopies. */
6212 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6214 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6215 TREE_USED (exit_label
) = 1;
6216 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6217 build_empty_stmt (input_location
));
6218 gfc_add_expr_to_block (&body
, tmp
);
6220 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6221 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6222 fold_convert (gfc_charlen_type_node
, slen
),
6223 fold_convert (gfc_charlen_type_node
, count
));
6224 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6225 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6226 tmp
= fold_build_pointer_plus_loc (input_location
,
6227 fold_convert (pvoid_type_node
, dest
), tmp
);
6228 tmp
= build_call_expr_loc (input_location
,
6229 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6231 fold_build2_loc (input_location
, MULT_EXPR
,
6232 size_type_node
, slen
,
6233 fold_convert (size_type_node
,
6235 gfc_add_expr_to_block (&body
, tmp
);
6237 /* Increment count. */
6238 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6239 count
, build_int_cst (TREE_TYPE (count
), 1));
6240 gfc_add_modify (&body
, count
, tmp
);
6242 /* Build the loop. */
6243 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6244 gfc_add_expr_to_block (&block
, tmp
);
6246 /* Add the exit label. */
6247 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6248 gfc_add_expr_to_block (&block
, tmp
);
6250 /* Finish the block. */
6251 tmp
= gfc_finish_block (&block
);
6252 gfc_add_expr_to_block (&se
->pre
, tmp
);
6254 /* Set the result value. */
6256 se
->string_length
= dlen
;
6260 /* Generate code for the IARGC intrinsic. */
6263 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6269 /* Call the library function. This always returns an INTEGER(4). */
6270 fndecl
= gfor_fndecl_iargc
;
6271 tmp
= build_call_expr_loc (input_location
,
6274 /* Convert it to the required type. */
6275 type
= gfc_typenode_for_spec (&expr
->ts
);
6276 tmp
= fold_convert (type
, tmp
);
6282 /* The loc intrinsic returns the address of its argument as
6283 gfc_index_integer_kind integer. */
6286 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
6291 gcc_assert (!se
->ss
);
6293 arg_expr
= expr
->value
.function
.actual
->expr
;
6294 if (arg_expr
->rank
== 0)
6295 gfc_conv_expr_reference (se
, arg_expr
);
6297 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
6298 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
6300 /* Create a temporary variable for loc return value. Without this,
6301 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6302 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
6303 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
6304 se
->expr
= temp_var
;
6307 /* Generate code for an intrinsic function. Some map directly to library
6308 calls, others get special handling. In some cases the name of the function
6309 used depends on the type specifiers. */
6312 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
6318 name
= &expr
->value
.function
.name
[2];
6322 lib
= gfc_is_intrinsic_libcall (expr
);
6326 se
->ignore_optional
= 1;
6328 switch (expr
->value
.function
.isym
->id
)
6330 case GFC_ISYM_EOSHIFT
:
6332 case GFC_ISYM_RESHAPE
:
6333 /* For all of those the first argument specifies the type and the
6334 third is optional. */
6335 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
6339 gfc_conv_intrinsic_funcall (se
, expr
);
6347 switch (expr
->value
.function
.isym
->id
)
6352 case GFC_ISYM_REPEAT
:
6353 gfc_conv_intrinsic_repeat (se
, expr
);
6357 gfc_conv_intrinsic_trim (se
, expr
);
6360 case GFC_ISYM_SC_KIND
:
6361 gfc_conv_intrinsic_sc_kind (se
, expr
);
6364 case GFC_ISYM_SI_KIND
:
6365 gfc_conv_intrinsic_si_kind (se
, expr
);
6368 case GFC_ISYM_SR_KIND
:
6369 gfc_conv_intrinsic_sr_kind (se
, expr
);
6372 case GFC_ISYM_EXPONENT
:
6373 gfc_conv_intrinsic_exponent (se
, expr
);
6377 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6379 fndecl
= gfor_fndecl_string_scan
;
6381 fndecl
= gfor_fndecl_string_scan_char4
;
6385 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6388 case GFC_ISYM_VERIFY
:
6389 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6391 fndecl
= gfor_fndecl_string_verify
;
6393 fndecl
= gfor_fndecl_string_verify_char4
;
6397 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6400 case GFC_ISYM_ALLOCATED
:
6401 gfc_conv_allocated (se
, expr
);
6404 case GFC_ISYM_ASSOCIATED
:
6405 gfc_conv_associated(se
, expr
);
6408 case GFC_ISYM_SAME_TYPE_AS
:
6409 gfc_conv_same_type_as (se
, expr
);
6413 gfc_conv_intrinsic_abs (se
, expr
);
6416 case GFC_ISYM_ADJUSTL
:
6417 if (expr
->ts
.kind
== 1)
6418 fndecl
= gfor_fndecl_adjustl
;
6419 else if (expr
->ts
.kind
== 4)
6420 fndecl
= gfor_fndecl_adjustl_char4
;
6424 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6427 case GFC_ISYM_ADJUSTR
:
6428 if (expr
->ts
.kind
== 1)
6429 fndecl
= gfor_fndecl_adjustr
;
6430 else if (expr
->ts
.kind
== 4)
6431 fndecl
= gfor_fndecl_adjustr_char4
;
6435 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6438 case GFC_ISYM_AIMAG
:
6439 gfc_conv_intrinsic_imagpart (se
, expr
);
6443 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
6447 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
6450 case GFC_ISYM_ANINT
:
6451 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
6455 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6459 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
6462 case GFC_ISYM_BTEST
:
6463 gfc_conv_intrinsic_btest (se
, expr
);
6467 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
6471 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
6475 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
6479 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
6482 case GFC_ISYM_ACHAR
:
6484 gfc_conv_intrinsic_char (se
, expr
);
6487 case GFC_ISYM_CONVERSION
:
6489 case GFC_ISYM_LOGICAL
:
6491 gfc_conv_intrinsic_conversion (se
, expr
);
6494 /* Integer conversions are handled separately to make sure we get the
6495 correct rounding mode. */
6500 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
6504 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
6507 case GFC_ISYM_CEILING
:
6508 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
6511 case GFC_ISYM_FLOOR
:
6512 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
6516 gfc_conv_intrinsic_mod (se
, expr
, 0);
6519 case GFC_ISYM_MODULO
:
6520 gfc_conv_intrinsic_mod (se
, expr
, 1);
6523 case GFC_ISYM_CMPLX
:
6524 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
6527 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
6528 gfc_conv_intrinsic_iargc (se
, expr
);
6531 case GFC_ISYM_COMPLEX
:
6532 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
6535 case GFC_ISYM_CONJG
:
6536 gfc_conv_intrinsic_conjg (se
, expr
);
6539 case GFC_ISYM_COUNT
:
6540 gfc_conv_intrinsic_count (se
, expr
);
6543 case GFC_ISYM_CTIME
:
6544 gfc_conv_intrinsic_ctime (se
, expr
);
6548 gfc_conv_intrinsic_dim (se
, expr
);
6551 case GFC_ISYM_DOT_PRODUCT
:
6552 gfc_conv_intrinsic_dot_product (se
, expr
);
6555 case GFC_ISYM_DPROD
:
6556 gfc_conv_intrinsic_dprod (se
, expr
);
6559 case GFC_ISYM_DSHIFTL
:
6560 gfc_conv_intrinsic_dshift (se
, expr
, true);
6563 case GFC_ISYM_DSHIFTR
:
6564 gfc_conv_intrinsic_dshift (se
, expr
, false);
6567 case GFC_ISYM_FDATE
:
6568 gfc_conv_intrinsic_fdate (se
, expr
);
6571 case GFC_ISYM_FRACTION
:
6572 gfc_conv_intrinsic_fraction (se
, expr
);
6576 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
6580 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6584 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
6587 case GFC_ISYM_IBCLR
:
6588 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
6591 case GFC_ISYM_IBITS
:
6592 gfc_conv_intrinsic_ibits (se
, expr
);
6595 case GFC_ISYM_IBSET
:
6596 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
6599 case GFC_ISYM_IACHAR
:
6600 case GFC_ISYM_ICHAR
:
6601 /* We assume ASCII character sequence. */
6602 gfc_conv_intrinsic_ichar (se
, expr
);
6605 case GFC_ISYM_IARGC
:
6606 gfc_conv_intrinsic_iargc (se
, expr
);
6610 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6613 case GFC_ISYM_INDEX
:
6614 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6616 fndecl
= gfor_fndecl_string_index
;
6618 fndecl
= gfor_fndecl_string_index_char4
;
6622 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6626 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6629 case GFC_ISYM_IPARITY
:
6630 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
6633 case GFC_ISYM_IS_IOSTAT_END
:
6634 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
6637 case GFC_ISYM_IS_IOSTAT_EOR
:
6638 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
6641 case GFC_ISYM_ISNAN
:
6642 gfc_conv_intrinsic_isnan (se
, expr
);
6645 case GFC_ISYM_LSHIFT
:
6646 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6649 case GFC_ISYM_RSHIFT
:
6650 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6653 case GFC_ISYM_SHIFTA
:
6654 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6657 case GFC_ISYM_SHIFTL
:
6658 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6661 case GFC_ISYM_SHIFTR
:
6662 gfc_conv_intrinsic_shift (se
, expr
, true, false);
6665 case GFC_ISYM_ISHFT
:
6666 gfc_conv_intrinsic_ishft (se
, expr
);
6669 case GFC_ISYM_ISHFTC
:
6670 gfc_conv_intrinsic_ishftc (se
, expr
);
6673 case GFC_ISYM_LEADZ
:
6674 gfc_conv_intrinsic_leadz (se
, expr
);
6677 case GFC_ISYM_TRAILZ
:
6678 gfc_conv_intrinsic_trailz (se
, expr
);
6681 case GFC_ISYM_POPCNT
:
6682 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
6685 case GFC_ISYM_POPPAR
:
6686 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
6689 case GFC_ISYM_LBOUND
:
6690 gfc_conv_intrinsic_bound (se
, expr
, 0);
6693 case GFC_ISYM_LCOBOUND
:
6694 conv_intrinsic_cobound (se
, expr
);
6697 case GFC_ISYM_TRANSPOSE
:
6698 /* The scalarizer has already been set up for reversed dimension access
6699 order ; now we just get the argument value normally. */
6700 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
6704 gfc_conv_intrinsic_len (se
, expr
);
6707 case GFC_ISYM_LEN_TRIM
:
6708 gfc_conv_intrinsic_len_trim (se
, expr
);
6712 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
6716 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
6720 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
6724 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
6727 case GFC_ISYM_MASKL
:
6728 gfc_conv_intrinsic_mask (se
, expr
, 1);
6731 case GFC_ISYM_MASKR
:
6732 gfc_conv_intrinsic_mask (se
, expr
, 0);
6736 if (expr
->ts
.type
== BT_CHARACTER
)
6737 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
6739 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
6742 case GFC_ISYM_MAXLOC
:
6743 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
6746 case GFC_ISYM_MAXVAL
:
6747 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
6750 case GFC_ISYM_MERGE
:
6751 gfc_conv_intrinsic_merge (se
, expr
);
6754 case GFC_ISYM_MERGE_BITS
:
6755 gfc_conv_intrinsic_merge_bits (se
, expr
);
6759 if (expr
->ts
.type
== BT_CHARACTER
)
6760 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
6762 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
6765 case GFC_ISYM_MINLOC
:
6766 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
6769 case GFC_ISYM_MINVAL
:
6770 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
6773 case GFC_ISYM_NEAREST
:
6774 gfc_conv_intrinsic_nearest (se
, expr
);
6777 case GFC_ISYM_NORM2
:
6778 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
6782 gfc_conv_intrinsic_not (se
, expr
);
6786 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6789 case GFC_ISYM_PARITY
:
6790 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
6793 case GFC_ISYM_PRESENT
:
6794 gfc_conv_intrinsic_present (se
, expr
);
6797 case GFC_ISYM_PRODUCT
:
6798 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
6802 gfc_conv_intrinsic_rank (se
, expr
);
6805 case GFC_ISYM_RRSPACING
:
6806 gfc_conv_intrinsic_rrspacing (se
, expr
);
6809 case GFC_ISYM_SET_EXPONENT
:
6810 gfc_conv_intrinsic_set_exponent (se
, expr
);
6813 case GFC_ISYM_SCALE
:
6814 gfc_conv_intrinsic_scale (se
, expr
);
6818 gfc_conv_intrinsic_sign (se
, expr
);
6822 gfc_conv_intrinsic_size (se
, expr
);
6825 case GFC_ISYM_SIZEOF
:
6826 case GFC_ISYM_C_SIZEOF
:
6827 gfc_conv_intrinsic_sizeof (se
, expr
);
6830 case GFC_ISYM_STORAGE_SIZE
:
6831 gfc_conv_intrinsic_storage_size (se
, expr
);
6834 case GFC_ISYM_SPACING
:
6835 gfc_conv_intrinsic_spacing (se
, expr
);
6838 case GFC_ISYM_STRIDE
:
6839 conv_intrinsic_stride (se
, expr
);
6843 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
6846 case GFC_ISYM_TRANSFER
:
6847 if (se
->ss
&& se
->ss
->info
->useflags
)
6848 /* Access the previously obtained result. */
6849 gfc_conv_tmp_array_ref (se
);
6851 gfc_conv_intrinsic_transfer (se
, expr
);
6854 case GFC_ISYM_TTYNAM
:
6855 gfc_conv_intrinsic_ttynam (se
, expr
);
6858 case GFC_ISYM_UBOUND
:
6859 gfc_conv_intrinsic_bound (se
, expr
, 1);
6862 case GFC_ISYM_UCOBOUND
:
6863 conv_intrinsic_cobound (se
, expr
);
6867 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6871 gfc_conv_intrinsic_loc (se
, expr
);
6874 case GFC_ISYM_THIS_IMAGE
:
6875 /* For num_images() == 1, handle as LCOBOUND. */
6876 if (expr
->value
.function
.actual
->expr
6877 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
6878 conv_intrinsic_cobound (se
, expr
);
6880 trans_this_image (se
, expr
);
6883 case GFC_ISYM_IMAGE_INDEX
:
6884 trans_image_index (se
, expr
);
6887 case GFC_ISYM_NUM_IMAGES
:
6888 trans_num_images (se
);
6891 case GFC_ISYM_ACCESS
:
6892 case GFC_ISYM_CHDIR
:
6893 case GFC_ISYM_CHMOD
:
6894 case GFC_ISYM_DTIME
:
6895 case GFC_ISYM_ETIME
:
6896 case GFC_ISYM_EXTENDS_TYPE_OF
:
6898 case GFC_ISYM_FGETC
:
6901 case GFC_ISYM_FPUTC
:
6902 case GFC_ISYM_FSTAT
:
6903 case GFC_ISYM_FTELL
:
6904 case GFC_ISYM_GETCWD
:
6905 case GFC_ISYM_GETGID
:
6906 case GFC_ISYM_GETPID
:
6907 case GFC_ISYM_GETUID
:
6908 case GFC_ISYM_HOSTNM
:
6910 case GFC_ISYM_IERRNO
:
6911 case GFC_ISYM_IRAND
:
6912 case GFC_ISYM_ISATTY
:
6915 case GFC_ISYM_LSTAT
:
6916 case GFC_ISYM_MALLOC
:
6917 case GFC_ISYM_MATMUL
:
6918 case GFC_ISYM_MCLOCK
:
6919 case GFC_ISYM_MCLOCK8
:
6921 case GFC_ISYM_RENAME
:
6922 case GFC_ISYM_SECOND
:
6923 case GFC_ISYM_SECNDS
:
6924 case GFC_ISYM_SIGNAL
:
6926 case GFC_ISYM_SYMLNK
:
6927 case GFC_ISYM_SYSTEM
:
6929 case GFC_ISYM_TIME8
:
6930 case GFC_ISYM_UMASK
:
6931 case GFC_ISYM_UNLINK
:
6933 gfc_conv_intrinsic_funcall (se
, expr
);
6936 case GFC_ISYM_EOSHIFT
:
6938 case GFC_ISYM_RESHAPE
:
6939 /* For those, expr->rank should always be >0 and thus the if above the
6940 switch should have matched. */
6945 gfc_conv_intrinsic_lib_function (se
, expr
);
6952 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
6954 gfc_ss
*arg_ss
, *tmp_ss
;
6955 gfc_actual_arglist
*arg
;
6957 arg
= expr
->value
.function
.actual
;
6959 gcc_assert (arg
->expr
);
6961 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
6962 gcc_assert (arg_ss
!= gfc_ss_terminator
);
6964 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
6966 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
6967 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
6971 gcc_assert (tmp_ss
->dimen
== 2);
6973 /* We just invert dimensions. */
6974 tmp_dim
= tmp_ss
->dim
[0];
6975 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
6976 tmp_ss
->dim
[1] = tmp_dim
;
6979 /* Stop when tmp_ss points to the last valid element of the chain... */
6980 if (tmp_ss
->next
== gfc_ss_terminator
)
6984 /* ... so that we can attach the rest of the chain to it. */
6991 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
6992 This has the side effect of reversing the nested list, so there is no
6993 need to call gfc_reverse_ss on it (the given list is assumed not to be
6997 nest_loop_dimension (gfc_ss
*ss
, int dim
)
7000 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
7001 gfc_loopinfo
*new_loop
;
7003 gcc_assert (ss
!= gfc_ss_terminator
);
7005 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
7007 new_ss
= gfc_get_ss ();
7008 new_ss
->next
= prev_ss
;
7009 new_ss
->parent
= ss
;
7010 new_ss
->info
= ss
->info
;
7011 new_ss
->info
->refcount
++;
7014 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
7015 && ss
->info
->type
!= GFC_SS_REFERENCE
);
7018 new_ss
->dim
[0] = ss
->dim
[dim
];
7020 gcc_assert (dim
< ss
->dimen
);
7022 ss_dim
= --ss
->dimen
;
7023 for (i
= dim
; i
< ss_dim
; i
++)
7024 ss
->dim
[i
] = ss
->dim
[i
+ 1];
7026 ss
->dim
[ss_dim
] = 0;
7032 ss
->nested_ss
->parent
= new_ss
;
7033 new_ss
->nested_ss
= ss
->nested_ss
;
7035 ss
->nested_ss
= new_ss
;
7038 new_loop
= gfc_get_loopinfo ();
7039 gfc_init_loopinfo (new_loop
);
7041 gcc_assert (prev_ss
!= NULL
);
7042 gcc_assert (prev_ss
!= gfc_ss_terminator
);
7043 gfc_add_ss_to_loop (new_loop
, prev_ss
);
7044 return new_ss
->parent
;
7048 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
7049 is to be inlined. */
7052 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
7054 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
7055 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
7057 bool scalar_mask
= false;
7059 /* The rank of the result will be determined later. */
7060 arg1
= expr
->value
.function
.actual
;
7063 gcc_assert (arg3
!= NULL
);
7065 if (expr
->rank
== 0)
7068 tmp_ss
= gfc_ss_terminator
;
7074 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
7075 if (mask_ss
== tmp_ss
)
7081 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
7082 gcc_assert (array_ss
!= tmp_ss
);
7084 /* Odd thing: If the mask is scalar, it is used by the frontend after
7085 the array (to make an if around the nested loop). Thus it shall
7086 be after array_ss once the gfc_ss list is reversed. */
7088 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
7092 /* "Hide" the dimension on which we will sum in the first arg's scalarization
7094 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
7095 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
7103 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
7106 switch (expr
->value
.function
.isym
->id
)
7108 case GFC_ISYM_PRODUCT
:
7110 return walk_inline_intrinsic_arith (ss
, expr
);
7112 case GFC_ISYM_TRANSPOSE
:
7113 return walk_inline_intrinsic_transpose (ss
, expr
);
7122 /* This generates code to execute before entering the scalarization loop.
7123 Currently does nothing. */
7126 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
7128 switch (ss
->info
->expr
->value
.function
.isym
->id
)
7130 case GFC_ISYM_UBOUND
:
7131 case GFC_ISYM_LBOUND
:
7132 case GFC_ISYM_UCOBOUND
:
7133 case GFC_ISYM_LCOBOUND
:
7134 case GFC_ISYM_THIS_IMAGE
:
7143 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
7144 are expanded into code inside the scalarization loop. */
7147 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
7149 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
7150 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
7152 /* The two argument version returns a scalar. */
7153 if (expr
->value
.function
.actual
->next
->expr
)
7156 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
7160 /* Walk an intrinsic array libcall. */
7163 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
7165 gcc_assert (expr
->rank
> 0);
7166 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
7170 /* Return whether the function call expression EXPR will be expanded
7171 inline by gfc_conv_intrinsic_function. */
7174 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
7176 gfc_actual_arglist
*args
;
7178 if (!expr
->value
.function
.isym
)
7181 switch (expr
->value
.function
.isym
->id
)
7183 case GFC_ISYM_PRODUCT
:
7185 /* Disable inline expansion if code size matters. */
7189 args
= expr
->value
.function
.actual
;
7190 /* We need to be able to subset the SUM argument at compile-time. */
7191 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
7196 case GFC_ISYM_TRANSPOSE
:
7205 /* Returns nonzero if the specified intrinsic function call maps directly to
7206 an external library call. Should only be used for functions that return
7210 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
7212 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
7213 gcc_assert (expr
->rank
> 0);
7215 if (gfc_inline_intrinsic_function_p (expr
))
7218 switch (expr
->value
.function
.isym
->id
)
7222 case GFC_ISYM_COUNT
:
7226 case GFC_ISYM_IPARITY
:
7227 case GFC_ISYM_MATMUL
:
7228 case GFC_ISYM_MAXLOC
:
7229 case GFC_ISYM_MAXVAL
:
7230 case GFC_ISYM_MINLOC
:
7231 case GFC_ISYM_MINVAL
:
7232 case GFC_ISYM_NORM2
:
7233 case GFC_ISYM_PARITY
:
7234 case GFC_ISYM_PRODUCT
:
7236 case GFC_ISYM_SHAPE
:
7237 case GFC_ISYM_SPREAD
:
7239 /* Ignore absent optional parameters. */
7242 case GFC_ISYM_RESHAPE
:
7243 case GFC_ISYM_CSHIFT
:
7244 case GFC_ISYM_EOSHIFT
:
7246 case GFC_ISYM_UNPACK
:
7247 /* Pass absent optional parameters. */
7255 /* Walk an intrinsic function. */
7257 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
7258 gfc_intrinsic_sym
* isym
)
7262 if (isym
->elemental
)
7263 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
7264 NULL
, GFC_SS_SCALAR
);
7266 if (expr
->rank
== 0)
7269 if (gfc_inline_intrinsic_function_p (expr
))
7270 return walk_inline_intrinsic_function (ss
, expr
);
7272 if (gfc_is_intrinsic_libcall (expr
))
7273 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7275 /* Special cases. */
7278 case GFC_ISYM_LBOUND
:
7279 case GFC_ISYM_LCOBOUND
:
7280 case GFC_ISYM_UBOUND
:
7281 case GFC_ISYM_UCOBOUND
:
7282 case GFC_ISYM_THIS_IMAGE
:
7283 return gfc_walk_intrinsic_bound (ss
, expr
);
7285 case GFC_ISYM_TRANSFER
:
7286 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7289 /* This probably meant someone forgot to add an intrinsic to the above
7290 list(s) when they implemented it, or something's gone horribly
7298 conv_intrinsic_atomic_def (gfc_code
*code
)
7303 gfc_init_se (&atom
, NULL
);
7304 gfc_init_se (&value
, NULL
);
7305 gfc_conv_expr (&atom
, code
->ext
.actual
->expr
);
7306 gfc_conv_expr (&value
, code
->ext
.actual
->next
->expr
);
7308 gfc_init_block (&block
);
7309 gfc_add_modify (&block
, atom
.expr
,
7310 fold_convert (TREE_TYPE (atom
.expr
), value
.expr
));
7311 return gfc_finish_block (&block
);
7316 conv_intrinsic_atomic_ref (gfc_code
*code
)
7321 gfc_init_se (&atom
, NULL
);
7322 gfc_init_se (&value
, NULL
);
7323 gfc_conv_expr (&value
, code
->ext
.actual
->expr
);
7324 gfc_conv_expr (&atom
, code
->ext
.actual
->next
->expr
);
7326 gfc_init_block (&block
);
7327 gfc_add_modify (&block
, value
.expr
,
7328 fold_convert (TREE_TYPE (value
.expr
), atom
.expr
));
7329 return gfc_finish_block (&block
);
7334 conv_intrinsic_move_alloc (gfc_code
*code
)
7337 gfc_expr
*from_expr
, *to_expr
;
7338 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
7339 gfc_se from_se
, to_se
;
7343 gfc_start_block (&block
);
7345 from_expr
= code
->ext
.actual
->expr
;
7346 to_expr
= code
->ext
.actual
->next
->expr
;
7348 gfc_init_se (&from_se
, NULL
);
7349 gfc_init_se (&to_se
, NULL
);
7351 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
7352 || to_expr
->ts
.type
== BT_CLASS
);
7353 coarray
= gfc_get_corank (from_expr
) != 0;
7355 if (from_expr
->rank
== 0 && !coarray
)
7357 if (from_expr
->ts
.type
!= BT_CLASS
)
7358 from_expr2
= from_expr
;
7361 from_expr2
= gfc_copy_expr (from_expr
);
7362 gfc_add_data_component (from_expr2
);
7365 if (to_expr
->ts
.type
!= BT_CLASS
)
7369 to_expr2
= gfc_copy_expr (to_expr
);
7370 gfc_add_data_component (to_expr2
);
7373 from_se
.want_pointer
= 1;
7374 to_se
.want_pointer
= 1;
7375 gfc_conv_expr (&from_se
, from_expr2
);
7376 gfc_conv_expr (&to_se
, to_expr2
);
7377 gfc_add_block_to_block (&block
, &from_se
.pre
);
7378 gfc_add_block_to_block (&block
, &to_se
.pre
);
7380 /* Deallocate "to". */
7381 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
7382 to_expr
, to_expr
->ts
);
7383 gfc_add_expr_to_block (&block
, tmp
);
7385 /* Assign (_data) pointers. */
7386 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7387 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
7389 /* Set "from" to NULL. */
7390 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7391 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
7393 gfc_add_block_to_block (&block
, &from_se
.post
);
7394 gfc_add_block_to_block (&block
, &to_se
.post
);
7397 if (to_expr
->ts
.type
== BT_CLASS
)
7401 gfc_free_expr (to_expr2
);
7402 gfc_init_se (&to_se
, NULL
);
7403 to_se
.want_pointer
= 1;
7404 gfc_add_vptr_component (to_expr
);
7405 gfc_conv_expr (&to_se
, to_expr
);
7407 if (from_expr
->ts
.type
== BT_CLASS
)
7409 if (UNLIMITED_POLY (from_expr
))
7413 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7417 gfc_free_expr (from_expr2
);
7418 gfc_init_se (&from_se
, NULL
);
7419 from_se
.want_pointer
= 1;
7420 gfc_add_vptr_component (from_expr
);
7421 gfc_conv_expr (&from_se
, from_expr
);
7422 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7423 fold_convert (TREE_TYPE (to_se
.expr
),
7426 /* Reset _vptr component to declared type. */
7427 if (UNLIMITED_POLY (from_expr
))
7428 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7429 fold_convert (TREE_TYPE (from_se
.expr
),
7430 null_pointer_node
));
7433 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7434 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7435 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
7440 if (from_expr
->ts
.type
!= BT_DERIVED
)
7441 vtab
= gfc_find_intrinsic_vtab (&from_expr
->ts
);
7443 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7445 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7446 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7447 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7451 return gfc_finish_block (&block
);
7454 /* Update _vptr component. */
7455 if (to_expr
->ts
.type
== BT_CLASS
)
7459 to_se
.want_pointer
= 1;
7460 to_expr2
= gfc_copy_expr (to_expr
);
7461 gfc_add_vptr_component (to_expr2
);
7462 gfc_conv_expr (&to_se
, to_expr2
);
7464 if (from_expr
->ts
.type
== BT_CLASS
)
7466 if (UNLIMITED_POLY (from_expr
))
7470 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7474 from_se
.want_pointer
= 1;
7475 from_expr2
= gfc_copy_expr (from_expr
);
7476 gfc_add_vptr_component (from_expr2
);
7477 gfc_conv_expr (&from_se
, from_expr2
);
7478 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7479 fold_convert (TREE_TYPE (to_se
.expr
),
7482 /* Reset _vptr component to declared type. */
7483 if (UNLIMITED_POLY (from_expr
))
7484 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7485 fold_convert (TREE_TYPE (from_se
.expr
),
7486 null_pointer_node
));
7489 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7490 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7491 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
7496 if (from_expr
->ts
.type
!= BT_DERIVED
)
7497 vtab
= gfc_find_intrinsic_vtab (&from_expr
->ts
);
7499 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7501 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7502 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7503 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7506 gfc_free_expr (to_expr2
);
7507 gfc_init_se (&to_se
, NULL
);
7509 if (from_expr
->ts
.type
== BT_CLASS
)
7511 gfc_free_expr (from_expr2
);
7512 gfc_init_se (&from_se
, NULL
);
7517 /* Deallocate "to". */
7518 if (from_expr
->rank
== 0)
7520 to_se
.want_coarray
= 1;
7521 from_se
.want_coarray
= 1;
7523 gfc_conv_expr_descriptor (&to_se
, to_expr
);
7524 gfc_conv_expr_descriptor (&from_se
, from_expr
);
7526 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
7527 is an image control "statement", cf. IR F08/0040 in 12-006A. */
7528 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
7532 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
7533 NULL_TREE
, NULL_TREE
, true, to_expr
,
7535 gfc_add_expr_to_block (&block
, tmp
);
7537 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7538 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7539 boolean_type_node
, tmp
,
7540 fold_convert (TREE_TYPE (tmp
),
7541 null_pointer_node
));
7542 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
7543 3, null_pointer_node
, null_pointer_node
,
7544 build_int_cst (integer_type_node
, 0));
7546 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
7547 tmp
, build_empty_stmt (input_location
));
7548 gfc_add_expr_to_block (&block
, tmp
);
7552 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7553 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
7554 NULL_TREE
, true, to_expr
, false);
7555 gfc_add_expr_to_block (&block
, tmp
);
7558 /* Move the pointer and update the array descriptor data. */
7559 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
7561 /* Set "from" to NULL. */
7562 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
7563 gfc_add_modify_loc (input_location
, &block
, tmp
,
7564 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7566 return gfc_finish_block (&block
);
7571 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
7575 gcc_assert (code
->resolved_isym
);
7577 switch (code
->resolved_isym
->id
)
7579 case GFC_ISYM_MOVE_ALLOC
:
7580 res
= conv_intrinsic_move_alloc (code
);
7583 case GFC_ISYM_ATOMIC_DEF
:
7584 res
= conv_intrinsic_atomic_def (code
);
7587 case GFC_ISYM_ATOMIC_REF
:
7588 res
= conv_intrinsic_atomic_ref (code
);
7599 #include "gt-fortran-trans-intrinsic.h"