1 /* Intrinsic translation
2 Copyright (C) 2002-2013 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
27 #include "tm.h" /* For UNITS_PER_WORD. */
30 #include "diagnostic-core.h" /* For internal_error. */
31 #include "toplev.h" /* For rest_of_decl_compilation. */
35 #include "intrinsic.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
43 /* This maps Fortran intrinsic math functions to external library or GCC
45 typedef struct GTY(()) gfc_intrinsic_map_t
{
46 /* The explicit enum is required to work around inadequacies in the
47 garbage collection/gengtype parsing mechanism. */
50 /* Enum value from the "language-independent", aka C-centric, part
51 of gcc, or END_BUILTINS of no such value set. */
52 enum built_in_function float_built_in
;
53 enum built_in_function double_built_in
;
54 enum built_in_function long_double_built_in
;
55 enum built_in_function complex_float_built_in
;
56 enum built_in_function complex_double_built_in
;
57 enum built_in_function complex_long_double_built_in
;
59 /* True if the naming pattern is to prepend "c" for complex and
60 append "f" for kind=4. False if the naming pattern is to
61 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
64 /* True if a complex version of the function exists. */
65 bool complex_available
;
67 /* True if the function should be marked const. */
70 /* The base library name of this function. */
73 /* Cache decls created for the various operand types. */
85 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
86 defines complex variants of all of the entries in mathbuiltins.def
88 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
89 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
90 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
91 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
92 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
94 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
97 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
101 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
102 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
104 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
106 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
107 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
108 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
110 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
112 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
114 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
115 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
116 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
117 #include "mathbuiltins.def"
119 /* Functions in libgfortran. */
120 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
123 LIB_FUNCTION (NONE
, NULL
, false)
128 #undef DEFINE_MATH_BUILTIN
129 #undef DEFINE_MATH_BUILTIN_C
132 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
135 /* Find the correct variant of a given builtin from its argument. */
137 builtin_decl_for_precision (enum built_in_function base_built_in
,
140 enum built_in_function i
= END_BUILTINS
;
142 gfc_intrinsic_map_t
*m
;
143 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
146 if (precision
== TYPE_PRECISION (float_type_node
))
147 i
= m
->float_built_in
;
148 else if (precision
== TYPE_PRECISION (double_type_node
))
149 i
= m
->double_built_in
;
150 else if (precision
== TYPE_PRECISION (long_double_type_node
))
151 i
= m
->long_double_built_in
;
152 else if (precision
== TYPE_PRECISION (float128_type_node
))
154 /* Special treatment, because it is not exactly a built-in, but
155 a library function. */
156 return m
->real16_decl
;
159 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
164 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
167 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
169 if (gfc_real_kinds
[i
].c_float128
)
171 /* For __float128, the story is a bit different, because we return
172 a decl to a library function rather than a built-in. */
173 gfc_intrinsic_map_t
*m
;
174 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
177 return m
->real16_decl
;
180 return builtin_decl_for_precision (double_built_in
,
181 gfc_real_kinds
[i
].mode_precision
);
185 /* Evaluate the arguments to an intrinsic function. The value
186 of NARGS may be less than the actual number of arguments in EXPR
187 to allow optional "KIND" arguments that are not included in the
188 generated code to be ignored. */
191 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
192 tree
*argarray
, int nargs
)
194 gfc_actual_arglist
*actual
;
196 gfc_intrinsic_arg
*formal
;
200 formal
= expr
->value
.function
.isym
->formal
;
201 actual
= expr
->value
.function
.actual
;
203 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
204 actual
= actual
->next
,
205 formal
= formal
? formal
->next
: NULL
)
209 /* Skip omitted optional arguments. */
216 /* Evaluate the parameter. This will substitute scalarized
217 references automatically. */
218 gfc_init_se (&argse
, se
);
220 if (e
->ts
.type
== BT_CHARACTER
)
222 gfc_conv_expr (&argse
, e
);
223 gfc_conv_string_parameter (&argse
);
224 argarray
[curr_arg
++] = argse
.string_length
;
225 gcc_assert (curr_arg
< nargs
);
228 gfc_conv_expr_val (&argse
, e
);
230 /* If an optional argument is itself an optional dummy argument,
231 check its presence and substitute a null if absent. */
232 if (e
->expr_type
== EXPR_VARIABLE
233 && e
->symtree
->n
.sym
->attr
.optional
236 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
238 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
239 gfc_add_block_to_block (&se
->post
, &argse
.post
);
240 argarray
[curr_arg
] = argse
.expr
;
244 /* Count the number of actual arguments to the intrinsic function EXPR
245 including any "hidden" string length arguments. */
248 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
251 gfc_actual_arglist
*actual
;
253 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
258 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
268 /* Conversions between different types are output by the frontend as
269 intrinsic functions. We implement these directly with inline code. */
272 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
278 nargs
= gfc_intrinsic_argument_list_length (expr
);
279 args
= XALLOCAVEC (tree
, nargs
);
281 /* Evaluate all the arguments passed. Whilst we're only interested in the
282 first one here, there are other parts of the front-end that assume this
283 and will trigger an ICE if it's not the case. */
284 type
= gfc_typenode_for_spec (&expr
->ts
);
285 gcc_assert (expr
->value
.function
.actual
->expr
);
286 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
288 /* Conversion between character kinds involves a call to a library
290 if (expr
->ts
.type
== BT_CHARACTER
)
292 tree fndecl
, var
, addr
, tmp
;
294 if (expr
->ts
.kind
== 1
295 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
296 fndecl
= gfor_fndecl_convert_char4_to_char1
;
297 else if (expr
->ts
.kind
== 4
298 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
299 fndecl
= gfor_fndecl_convert_char1_to_char4
;
303 /* Create the variable storing the converted value. */
304 type
= gfc_get_pchar_type (expr
->ts
.kind
);
305 var
= gfc_create_var (type
, "str");
306 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
308 /* Call the library function that will perform the conversion. */
309 gcc_assert (nargs
>= 2);
310 tmp
= build_call_expr_loc (input_location
,
311 fndecl
, 3, addr
, args
[0], args
[1]);
312 gfc_add_expr_to_block (&se
->pre
, tmp
);
314 /* Free the temporary afterwards. */
315 tmp
= gfc_call_free (var
);
316 gfc_add_expr_to_block (&se
->post
, tmp
);
319 se
->string_length
= args
[0];
324 /* Conversion from complex to non-complex involves taking the real
325 component of the value. */
326 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
327 && expr
->ts
.type
!= BT_COMPLEX
)
331 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
332 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
336 se
->expr
= convert (type
, args
[0]);
339 /* This is needed because the gcc backend only implements
340 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
341 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
342 Similarly for CEILING. */
345 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
352 argtype
= TREE_TYPE (arg
);
353 arg
= gfc_evaluate_now (arg
, pblock
);
355 intval
= convert (type
, arg
);
356 intval
= gfc_evaluate_now (intval
, pblock
);
358 tmp
= convert (argtype
, intval
);
359 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
360 boolean_type_node
, tmp
, arg
);
362 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
363 intval
, build_int_cst (type
, 1));
364 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
369 /* Round to nearest integer, away from zero. */
372 build_round_expr (tree arg
, tree restype
)
376 int argprec
, resprec
;
378 argtype
= TREE_TYPE (arg
);
379 argprec
= TYPE_PRECISION (argtype
);
380 resprec
= TYPE_PRECISION (restype
);
382 /* Depending on the type of the result, choose the int intrinsic
383 (iround, available only as a builtin, therefore cannot use it for
384 __float128), long int intrinsic (lround family) or long long
385 intrinsic (llround). We might also need to convert the result
387 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
388 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
389 else if (resprec
<= LONG_TYPE_SIZE
)
390 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
391 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
392 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
396 return fold_convert (restype
, build_call_expr_loc (input_location
,
401 /* Convert a real to an integer using a specific rounding mode.
402 Ideally we would just build the corresponding GENERIC node,
403 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
406 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
407 enum rounding_mode op
)
412 return build_fixbound_expr (pblock
, arg
, type
, 0);
416 return build_fixbound_expr (pblock
, arg
, type
, 1);
420 return build_round_expr (arg
, type
);
424 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
433 /* Round a real value using the specified rounding mode.
434 We use a temporary integer of that same kind size as the result.
435 Values larger than those that can be represented by this kind are
436 unchanged, as they will not be accurate enough to represent the
438 huge = HUGE (KIND (a))
439 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
443 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
455 kind
= expr
->ts
.kind
;
456 nargs
= gfc_intrinsic_argument_list_length (expr
);
459 /* We have builtin functions for some cases. */
463 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
467 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
474 /* Evaluate the argument. */
475 gcc_assert (expr
->value
.function
.actual
->expr
);
476 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
478 /* Use a builtin function if one exists. */
479 if (decl
!= NULL_TREE
)
481 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
485 /* This code is probably redundant, but we'll keep it lying around just
487 type
= gfc_typenode_for_spec (&expr
->ts
);
488 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
490 /* Test if the value is too large to handle sensibly. */
491 gfc_set_model_kind (kind
);
493 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
494 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
495 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
496 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
499 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
500 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
501 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
503 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
505 itype
= gfc_get_int_type (kind
);
507 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
508 tmp
= convert (type
, tmp
);
509 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
515 /* Convert to an integer using the specified rounding mode. */
518 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
524 nargs
= gfc_intrinsic_argument_list_length (expr
);
525 args
= XALLOCAVEC (tree
, nargs
);
527 /* Evaluate the argument, we process all arguments even though we only
528 use the first one for code generation purposes. */
529 type
= gfc_typenode_for_spec (&expr
->ts
);
530 gcc_assert (expr
->value
.function
.actual
->expr
);
531 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
533 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
535 /* Conversion to a different integer kind. */
536 se
->expr
= convert (type
, args
[0]);
540 /* Conversion from complex to non-complex involves taking the real
541 component of the value. */
542 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
543 && expr
->ts
.type
!= BT_COMPLEX
)
547 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
548 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
552 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
557 /* Get the imaginary component of a value. */
560 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
564 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
565 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
566 TREE_TYPE (TREE_TYPE (arg
)), arg
);
570 /* Get the complex conjugate of a value. */
573 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
577 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
578 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
584 define_quad_builtin (const char *name
, tree type
, bool is_const
)
587 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
590 /* Mark the decl as external. */
591 DECL_EXTERNAL (fndecl
) = 1;
592 TREE_PUBLIC (fndecl
) = 1;
594 /* Mark it __attribute__((const)). */
595 TREE_READONLY (fndecl
) = is_const
;
597 rest_of_decl_compilation (fndecl
, 1, 0);
604 /* Initialize function decls for library functions. The external functions
605 are created as required. Builtin functions are added here. */
608 gfc_build_intrinsic_lib_fndecls (void)
610 gfc_intrinsic_map_t
*m
;
611 tree quad_decls
[END_BUILTINS
+ 1];
613 if (gfc_real16_is_float128
)
615 /* If we have soft-float types, we create the decls for their
616 C99-like library functions. For now, we only handle __float128
617 q-suffixed functions. */
619 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
620 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
622 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
624 type
= float128_type_node
;
625 complex_type
= complex_float128_type_node
;
626 /* type (*) (type) */
627 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
629 func_iround
= build_function_type_list (integer_type_node
,
631 /* long (*) (type) */
632 func_lround
= build_function_type_list (long_integer_type_node
,
634 /* long long (*) (type) */
635 func_llround
= build_function_type_list (long_long_integer_type_node
,
637 /* type (*) (type, type) */
638 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
639 /* type (*) (type, &int) */
641 = build_function_type_list (type
,
643 build_pointer_type (integer_type_node
),
645 /* type (*) (type, int) */
646 func_scalbn
= build_function_type_list (type
,
647 type
, integer_type_node
, NULL_TREE
);
648 /* type (*) (complex type) */
649 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
650 /* complex type (*) (complex type, complex type) */
652 = build_function_type_list (complex_type
,
653 complex_type
, complex_type
, NULL_TREE
);
655 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
656 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
657 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
659 /* Only these built-ins are actually needed here. These are used directly
660 from the code, when calling builtin_decl_for_precision() or
661 builtin_decl_for_float_type(). The others are all constructed by
662 gfc_get_intrinsic_lib_fndecl(). */
663 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
664 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
666 #include "mathbuiltins.def"
670 #undef DEFINE_MATH_BUILTIN
671 #undef DEFINE_MATH_BUILTIN_C
675 /* Add GCC builtin functions. */
676 for (m
= gfc_intrinsic_map
;
677 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
679 if (m
->float_built_in
!= END_BUILTINS
)
680 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
681 if (m
->complex_float_built_in
!= END_BUILTINS
)
682 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
683 if (m
->double_built_in
!= END_BUILTINS
)
684 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
685 if (m
->complex_double_built_in
!= END_BUILTINS
)
686 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
688 /* If real(kind=10) exists, it is always long double. */
689 if (m
->long_double_built_in
!= END_BUILTINS
)
690 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
691 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
693 = builtin_decl_explicit (m
->complex_long_double_built_in
);
695 if (!gfc_real16_is_float128
)
697 if (m
->long_double_built_in
!= END_BUILTINS
)
698 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
699 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
701 = builtin_decl_explicit (m
->complex_long_double_built_in
);
703 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
705 /* Quad-precision function calls are constructed when first
706 needed by builtin_decl_for_precision(), except for those
707 that will be used directly (define by OTHER_BUILTIN). */
708 m
->real16_decl
= quad_decls
[m
->double_built_in
];
710 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
712 /* Same thing for the complex ones. */
713 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
719 /* Create a fndecl for a simple intrinsic library function. */
722 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
725 vec
<tree
, va_gc
> *argtypes
;
727 gfc_actual_arglist
*actual
;
730 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
733 if (ts
->type
== BT_REAL
)
738 pdecl
= &m
->real4_decl
;
741 pdecl
= &m
->real8_decl
;
744 pdecl
= &m
->real10_decl
;
747 pdecl
= &m
->real16_decl
;
753 else if (ts
->type
== BT_COMPLEX
)
755 gcc_assert (m
->complex_available
);
760 pdecl
= &m
->complex4_decl
;
763 pdecl
= &m
->complex8_decl
;
766 pdecl
= &m
->complex10_decl
;
769 pdecl
= &m
->complex16_decl
;
783 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
784 if (gfc_real_kinds
[n
].c_float
)
785 snprintf (name
, sizeof (name
), "%s%s%s",
786 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
787 else if (gfc_real_kinds
[n
].c_double
)
788 snprintf (name
, sizeof (name
), "%s%s",
789 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
790 else if (gfc_real_kinds
[n
].c_long_double
)
791 snprintf (name
, sizeof (name
), "%s%s%s",
792 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
793 else if (gfc_real_kinds
[n
].c_float128
)
794 snprintf (name
, sizeof (name
), "%s%s%s",
795 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
801 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
802 ts
->type
== BT_COMPLEX
? 'c' : 'r',
807 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
809 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
810 vec_safe_push (argtypes
, type
);
812 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
813 fndecl
= build_decl (input_location
,
814 FUNCTION_DECL
, get_identifier (name
), type
);
816 /* Mark the decl as external. */
817 DECL_EXTERNAL (fndecl
) = 1;
818 TREE_PUBLIC (fndecl
) = 1;
820 /* Mark it __attribute__((const)), if possible. */
821 TREE_READONLY (fndecl
) = m
->is_constant
;
823 rest_of_decl_compilation (fndecl
, 1, 0);
830 /* Convert an intrinsic function into an external or builtin call. */
833 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
835 gfc_intrinsic_map_t
*m
;
839 unsigned int num_args
;
842 id
= expr
->value
.function
.isym
->id
;
843 /* Find the entry for this function. */
844 for (m
= gfc_intrinsic_map
;
845 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
851 if (m
->id
== GFC_ISYM_NONE
)
853 internal_error ("Intrinsic function %s(%d) not recognized",
854 expr
->value
.function
.name
, id
);
857 /* Get the decl and generate the call. */
858 num_args
= gfc_intrinsic_argument_list_length (expr
);
859 args
= XALLOCAVEC (tree
, num_args
);
861 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
862 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
863 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
865 fndecl
= build_addr (fndecl
, current_function_decl
);
866 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
870 /* If bounds-checking is enabled, create code to verify at runtime that the
871 string lengths for both expressions are the same (needed for e.g. MERGE).
872 If bounds-checking is not enabled, does nothing. */
875 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
876 tree a
, tree b
, stmtblock_t
* target
)
881 /* If bounds-checking is disabled, do nothing. */
882 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
885 /* Compare the two string lengths. */
886 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
888 /* Output the runtime-check. */
889 name
= gfc_build_cstring_const (intr_name
);
890 name
= gfc_build_addr_expr (pchar_type_node
, name
);
891 gfc_trans_runtime_check (true, false, cond
, target
, where
,
892 "Unequal character lengths (%ld/%ld) in %s",
893 fold_convert (long_integer_type_node
, a
),
894 fold_convert (long_integer_type_node
, b
), name
);
898 /* The EXPONENT(s) intrinsic function is translated into
905 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
907 tree arg
, type
, res
, tmp
, frexp
;
909 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
910 expr
->value
.function
.actual
->expr
->ts
.kind
);
912 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
914 res
= gfc_create_var (integer_type_node
, NULL
);
915 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
916 gfc_build_addr_expr (NULL_TREE
, res
));
917 gfc_add_expr_to_block (&se
->pre
, tmp
);
919 type
= gfc_typenode_for_spec (&expr
->ts
);
920 se
->expr
= fold_convert (type
, res
);
925 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
928 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
929 lbound
, ubound
, extent
, ml
;
933 /* The case -fcoarray=single is handled elsewhere. */
934 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
936 gfc_init_coarray_decl (false);
938 /* Argument-free version: THIS_IMAGE(). */
939 if (expr
->value
.function
.actual
->expr
== NULL
)
941 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
942 gfort_gvar_caf_this_image
);
946 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
948 type
= gfc_get_int_type (gfc_default_integer_kind
);
949 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
950 rank
= expr
->value
.function
.actual
->expr
->rank
;
952 /* Obtain the descriptor of the COARRAY. */
953 gfc_init_se (&argse
, NULL
);
954 argse
.want_coarray
= 1;
955 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
956 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
957 gfc_add_block_to_block (&se
->post
, &argse
.post
);
962 /* Create an implicit second parameter from the loop variable. */
963 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
964 gcc_assert (corank
> 0);
965 gcc_assert (se
->loop
->dimen
== 1);
966 gcc_assert (se
->ss
->info
->expr
== expr
);
968 dim_arg
= se
->loop
->loopvar
[0];
969 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
970 gfc_array_index_type
, dim_arg
,
971 build_int_cst (TREE_TYPE (dim_arg
), 1));
972 gfc_advance_se_ss_chain (se
);
976 /* Use the passed DIM= argument. */
977 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
978 gfc_init_se (&argse
, NULL
);
979 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
980 gfc_array_index_type
);
981 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
982 dim_arg
= argse
.expr
;
984 if (INTEGER_CST_P (dim_arg
))
988 hi
= TREE_INT_CST_HIGH (dim_arg
);
989 co_dim
= TREE_INT_CST_LOW (dim_arg
);
991 || co_dim
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
992 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
993 "dimension index", expr
->value
.function
.isym
->name
,
996 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
998 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
999 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1001 build_int_cst (TREE_TYPE (dim_arg
), 1));
1002 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1003 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1005 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1006 boolean_type_node
, cond
, tmp
);
1007 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1012 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1013 one always has a dim_arg argument.
1015 m = this_image() - 1
1018 sub(1) = m + lcobound(corank)
1022 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1025 extent = gfc_extent(i)
1033 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1034 : m + lcobound(corank)
1037 /* this_image () - 1. */
1038 tmp
= fold_convert (type
, gfort_gvar_caf_this_image
);
1039 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, tmp
,
1040 build_int_cst (type
, 1));
1043 /* sub(1) = m + lcobound(corank). */
1044 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1045 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1047 lbound
= fold_convert (type
, lbound
);
1048 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1054 m
= gfc_create_var (type
, NULL
);
1055 ml
= gfc_create_var (type
, NULL
);
1056 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1057 min_var
= gfc_create_var (integer_type_node
, NULL
);
1059 /* m = this_image () - 1. */
1060 gfc_add_modify (&se
->pre
, m
, tmp
);
1062 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1063 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1064 fold_convert (integer_type_node
, dim_arg
),
1065 build_int_cst (integer_type_node
, rank
- 1));
1066 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1067 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1069 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1072 tmp
= build_int_cst (integer_type_node
, rank
);
1073 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1075 exit_label
= gfc_build_label_decl (NULL_TREE
);
1076 TREE_USED (exit_label
) = 1;
1079 gfc_init_block (&loop
);
1082 gfc_add_modify (&loop
, ml
, m
);
1085 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1086 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1087 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1088 extent
= fold_convert (type
, extent
);
1091 gfc_add_modify (&loop
, m
,
1092 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1095 /* Exit condition: if (i >= min_var) goto exit_label. */
1096 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1098 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1099 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1100 build_empty_stmt (input_location
));
1101 gfc_add_expr_to_block (&loop
, tmp
);
1103 /* Increment loop variable: i++. */
1104 gfc_add_modify (&loop
, loop_var
,
1105 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1107 build_int_cst (integer_type_node
, 1)));
1109 /* Making the loop... actually loop! */
1110 tmp
= gfc_finish_block (&loop
);
1111 tmp
= build1_v (LOOP_EXPR
, tmp
);
1112 gfc_add_expr_to_block (&se
->pre
, tmp
);
1114 /* The exit label. */
1115 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1116 gfc_add_expr_to_block (&se
->pre
, tmp
);
1118 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1119 : m + lcobound(corank) */
1121 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1122 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1124 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1125 fold_build2_loc (input_location
, PLUS_EXPR
,
1126 gfc_array_index_type
, dim_arg
,
1127 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1128 lbound
= fold_convert (type
, lbound
);
1130 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1131 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1133 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1135 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1136 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1142 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1144 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1146 gfc_se argse
, subse
;
1147 int rank
, corank
, codim
;
1149 type
= gfc_get_int_type (gfc_default_integer_kind
);
1150 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1151 rank
= expr
->value
.function
.actual
->expr
->rank
;
1153 /* Obtain the descriptor of the COARRAY. */
1154 gfc_init_se (&argse
, NULL
);
1155 argse
.want_coarray
= 1;
1156 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1157 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1158 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1161 /* Obtain a handle to the SUB argument. */
1162 gfc_init_se (&subse
, NULL
);
1163 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1164 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1165 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1166 subdesc
= build_fold_indirect_ref_loc (input_location
,
1167 gfc_conv_descriptor_data_get (subse
.expr
));
1169 /* Fortran 2008 does not require that the values remain in the cobounds,
1170 thus we need explicitly check this - and return 0 if they are exceeded. */
1172 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1173 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1174 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1175 fold_convert (gfc_array_index_type
, tmp
),
1178 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1180 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1181 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1182 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1183 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1184 fold_convert (gfc_array_index_type
, tmp
),
1186 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1187 boolean_type_node
, invalid_bound
, cond
);
1188 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1189 fold_convert (gfc_array_index_type
, tmp
),
1191 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1192 boolean_type_node
, invalid_bound
, cond
);
1195 invalid_bound
= gfc_unlikely (invalid_bound
);
1198 /* See Fortran 2008, C.10 for the following algorithm. */
1200 /* coindex = sub(corank) - lcobound(n). */
1201 coindex
= fold_convert (gfc_array_index_type
,
1202 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1204 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1205 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1206 fold_convert (gfc_array_index_type
, coindex
),
1209 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1211 tree extent
, ubound
;
1213 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1214 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1215 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1216 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1218 /* coindex *= extent. */
1219 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1220 gfc_array_index_type
, coindex
, extent
);
1222 /* coindex += sub(codim). */
1223 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1224 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1225 gfc_array_index_type
, coindex
,
1226 fold_convert (gfc_array_index_type
, tmp
));
1228 /* coindex -= lbound(codim). */
1229 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1230 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1231 gfc_array_index_type
, coindex
, lbound
);
1234 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1235 fold_convert(type
, coindex
),
1236 build_int_cst (type
, 1));
1238 /* Return 0 if "coindex" exceeds num_images(). */
1240 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1241 num_images
= build_int_cst (type
, 1);
1244 gfc_init_coarray_decl (false);
1245 num_images
= fold_convert (type
, gfort_gvar_caf_num_images
);
1248 tmp
= gfc_create_var (type
, NULL
);
1249 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1251 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1253 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1255 fold_convert (boolean_type_node
, invalid_bound
));
1256 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1257 build_int_cst (type
, 0), tmp
);
1262 trans_num_images (gfc_se
* se
)
1264 gfc_init_coarray_decl (false);
1265 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1266 gfort_gvar_caf_num_images
);
1271 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1275 gfc_init_se (&argse
, NULL
);
1276 argse
.data_not_needed
= 1;
1277 argse
.descriptor_only
= 1;
1279 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1280 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1281 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1283 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1287 /* Evaluate a single upper or lower bound. */
1288 /* TODO: bound intrinsic generates way too much unnecessary code. */
1291 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1293 gfc_actual_arglist
*arg
;
1294 gfc_actual_arglist
*arg2
;
1299 tree cond
, cond1
, cond3
, cond4
, size
;
1303 gfc_array_spec
* as
;
1304 bool assumed_rank_lb_one
;
1306 arg
= expr
->value
.function
.actual
;
1311 /* Create an implicit second parameter from the loop variable. */
1312 gcc_assert (!arg2
->expr
);
1313 gcc_assert (se
->loop
->dimen
== 1);
1314 gcc_assert (se
->ss
->info
->expr
== expr
);
1315 gfc_advance_se_ss_chain (se
);
1316 bound
= se
->loop
->loopvar
[0];
1317 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1318 gfc_array_index_type
, bound
,
1323 /* use the passed argument. */
1324 gcc_assert (arg2
->expr
);
1325 gfc_init_se (&argse
, NULL
);
1326 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1327 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1329 /* Convert from one based to zero based. */
1330 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1331 gfc_array_index_type
, bound
,
1332 gfc_index_one_node
);
1335 /* TODO: don't re-evaluate the descriptor on each iteration. */
1336 /* Get a descriptor for the first parameter. */
1337 gfc_init_se (&argse
, NULL
);
1338 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1339 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1340 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1344 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1346 if (INTEGER_CST_P (bound
))
1350 hi
= TREE_INT_CST_HIGH (bound
);
1351 low
= TREE_INT_CST_LOW (bound
);
1353 || ((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1354 && low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
1355 || low
> GFC_MAX_DIMENSIONS
)
1356 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1357 "dimension index", upper
? "UBOUND" : "LBOUND",
1361 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1363 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1365 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1366 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1367 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1368 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1369 tmp
= gfc_conv_descriptor_rank (desc
);
1371 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1372 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1373 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1374 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1375 boolean_type_node
, cond
, tmp
);
1376 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1381 /* Take care of the lbound shift for assumed-rank arrays, which are
1382 nonallocatable and nonpointers. Those has a lbound of 1. */
1383 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1384 && ((arg
->expr
->ts
.type
!= BT_CLASS
1385 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1386 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1387 || (arg
->expr
->ts
.type
== BT_CLASS
1388 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1389 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1391 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1392 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1394 /* 13.14.53: Result value for LBOUND
1396 Case (i): For an array section or for an array expression other than a
1397 whole array or array structure component, LBOUND(ARRAY, DIM)
1398 has the value 1. For a whole array or array structure
1399 component, LBOUND(ARRAY, DIM) has the value:
1400 (a) equal to the lower bound for subscript DIM of ARRAY if
1401 dimension DIM of ARRAY does not have extent zero
1402 or if ARRAY is an assumed-size array of rank DIM,
1405 13.14.113: Result value for UBOUND
1407 Case (i): For an array section or for an array expression other than a
1408 whole array or array structure component, UBOUND(ARRAY, DIM)
1409 has the value equal to the number of elements in the given
1410 dimension; otherwise, it has a value equal to the upper bound
1411 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1412 not have size zero and has value zero if dimension DIM has
1415 if (!upper
&& assumed_rank_lb_one
)
1416 se
->expr
= gfc_index_one_node
;
1419 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1421 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1423 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1424 stride
, gfc_index_zero_node
);
1425 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1426 boolean_type_node
, cond3
, cond1
);
1427 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1428 stride
, gfc_index_zero_node
);
1433 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1434 boolean_type_node
, cond3
, cond4
);
1435 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1436 gfc_index_one_node
, lbound
);
1437 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1438 boolean_type_node
, cond4
, cond5
);
1440 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1441 boolean_type_node
, cond
, cond5
);
1443 if (assumed_rank_lb_one
)
1445 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1446 gfc_array_index_type
, ubound
, lbound
);
1447 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1448 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1453 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1454 gfc_array_index_type
, cond
,
1455 tmp
, gfc_index_zero_node
);
1459 if (as
->type
== AS_ASSUMED_SIZE
)
1460 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1461 bound
, build_int_cst (TREE_TYPE (bound
),
1462 arg
->expr
->rank
- 1));
1464 cond
= boolean_false_node
;
1466 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1467 boolean_type_node
, cond3
, cond4
);
1468 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1469 boolean_type_node
, cond
, cond1
);
1471 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1472 gfc_array_index_type
, cond
,
1473 lbound
, gfc_index_one_node
);
1480 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1481 gfc_array_index_type
, ubound
, lbound
);
1482 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1483 gfc_array_index_type
, size
,
1484 gfc_index_one_node
);
1485 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1486 gfc_array_index_type
, se
->expr
,
1487 gfc_index_zero_node
);
1490 se
->expr
= gfc_index_one_node
;
1493 type
= gfc_typenode_for_spec (&expr
->ts
);
1494 se
->expr
= convert (type
, se
->expr
);
1499 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
1501 gfc_actual_arglist
*arg
;
1502 gfc_actual_arglist
*arg2
;
1504 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
1508 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
1509 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
1510 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
1512 arg
= expr
->value
.function
.actual
;
1515 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
1516 corank
= gfc_get_corank (arg
->expr
);
1518 gfc_init_se (&argse
, NULL
);
1519 argse
.want_coarray
= 1;
1521 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1522 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1523 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1528 /* Create an implicit second parameter from the loop variable. */
1529 gcc_assert (!arg2
->expr
);
1530 gcc_assert (corank
> 0);
1531 gcc_assert (se
->loop
->dimen
== 1);
1532 gcc_assert (se
->ss
->info
->expr
== expr
);
1534 bound
= se
->loop
->loopvar
[0];
1535 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1536 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
1537 gfc_advance_se_ss_chain (se
);
1541 /* use the passed argument. */
1542 gcc_assert (arg2
->expr
);
1543 gfc_init_se (&argse
, NULL
);
1544 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1545 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1548 if (INTEGER_CST_P (bound
))
1552 hi
= TREE_INT_CST_HIGH (bound
);
1553 low
= TREE_INT_CST_LOW (bound
);
1554 if (hi
|| low
< 1 || low
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
1555 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1556 "dimension index", expr
->value
.function
.isym
->name
,
1559 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1561 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1562 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1563 bound
, build_int_cst (TREE_TYPE (bound
), 1));
1564 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1565 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1567 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1568 boolean_type_node
, cond
, tmp
);
1569 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1574 /* Subtract 1 to get to zero based and add dimensions. */
1575 switch (arg
->expr
->rank
)
1578 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1579 gfc_array_index_type
, bound
,
1580 gfc_index_one_node
);
1584 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1585 gfc_array_index_type
, bound
,
1586 gfc_rank_cst
[arg
->expr
->rank
- 1]);
1590 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1592 /* Handle UCOBOUND with special handling of the last codimension. */
1593 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
1595 /* Last codimension: For -fcoarray=single just return
1596 the lcobound - otherwise add
1597 ceiling (real (num_images ()) / real (size)) - 1
1598 = (num_images () + size - 1) / size - 1
1599 = (num_images - 1) / size(),
1600 where size is the product of the extent of all but the last
1603 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
1607 gfc_init_coarray_decl (false);
1608 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
1610 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1611 gfc_array_index_type
,
1612 fold_convert (gfc_array_index_type
,
1613 gfort_gvar_caf_num_images
),
1614 build_int_cst (gfc_array_index_type
, 1));
1615 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1616 gfc_array_index_type
, tmp
,
1617 fold_convert (gfc_array_index_type
, cosize
));
1618 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1619 gfc_array_index_type
, resbound
, tmp
);
1621 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
1623 /* ubound = lbound + num_images() - 1. */
1624 gfc_init_coarray_decl (false);
1625 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1626 gfc_array_index_type
,
1627 fold_convert (gfc_array_index_type
,
1628 gfort_gvar_caf_num_images
),
1629 build_int_cst (gfc_array_index_type
, 1));
1630 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1631 gfc_array_index_type
, resbound
, tmp
);
1636 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1638 build_int_cst (TREE_TYPE (bound
),
1639 arg
->expr
->rank
+ corank
- 1));
1641 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1642 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1643 gfc_array_index_type
, cond
,
1644 resbound
, resbound2
);
1647 se
->expr
= resbound
;
1650 se
->expr
= resbound
;
1652 type
= gfc_typenode_for_spec (&expr
->ts
);
1653 se
->expr
= convert (type
, se
->expr
);
1658 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
1660 gfc_actual_arglist
*array_arg
;
1661 gfc_actual_arglist
*dim_arg
;
1665 array_arg
= expr
->value
.function
.actual
;
1666 dim_arg
= array_arg
->next
;
1668 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
1670 gfc_init_se (&argse
, NULL
);
1671 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
1672 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1673 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1676 gcc_assert (dim_arg
->expr
);
1677 gfc_init_se (&argse
, NULL
);
1678 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
1679 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1680 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1681 argse
.expr
, gfc_index_one_node
);
1682 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
1687 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1691 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1693 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1697 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1702 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1703 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1712 /* Create a complex value from one or two real components. */
1715 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1721 unsigned int num_args
;
1723 num_args
= gfc_intrinsic_argument_list_length (expr
);
1724 args
= XALLOCAVEC (tree
, num_args
);
1726 type
= gfc_typenode_for_spec (&expr
->ts
);
1727 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1728 real
= convert (TREE_TYPE (type
), args
[0]);
1730 imag
= convert (TREE_TYPE (type
), args
[1]);
1731 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1733 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1734 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1735 imag
= convert (TREE_TYPE (type
), imag
);
1738 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1740 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1744 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1745 MODULO(A, P) = A - FLOOR (A / P) * P
1747 The obvious algorithms above are numerically instable for large
1748 arguments, hence these intrinsics are instead implemented via calls
1749 to the fmod family of functions. It is the responsibility of the
1750 user to ensure that the second argument is non-zero. */
1753 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1763 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1765 switch (expr
->ts
.type
)
1768 /* Integer case is easy, we've got a builtin op. */
1769 type
= TREE_TYPE (args
[0]);
1772 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
1775 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
1781 /* Check if we have a builtin fmod. */
1782 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1784 /* The builtin should always be available. */
1785 gcc_assert (fmod
!= NULL_TREE
);
1787 tmp
= build_addr (fmod
, current_function_decl
);
1788 se
->expr
= build_call_array_loc (input_location
,
1789 TREE_TYPE (TREE_TYPE (fmod
)),
1794 type
= TREE_TYPE (args
[0]);
1796 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1797 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1800 modulo = arg - floor (arg/arg2) * arg2
1802 In order to calculate the result accurately, we use the fmod
1803 function as follows.
1805 res = fmod (arg, arg2);
1808 if ((arg < 0) xor (arg2 < 0))
1812 res = copysign (0., arg2);
1814 => As two nested ternary exprs:
1816 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
1817 : copysign (0., arg2);
1821 zero
= gfc_build_const (type
, integer_zero_node
);
1822 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1823 if (!flag_signed_zeros
)
1825 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1827 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1829 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1830 boolean_type_node
, test
, test2
);
1831 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1833 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1834 boolean_type_node
, test
, test2
);
1835 test
= gfc_evaluate_now (test
, &se
->pre
);
1836 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1837 fold_build2_loc (input_location
,
1839 type
, tmp
, args
[1]),
1844 tree expr1
, copysign
, cscall
;
1845 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
1847 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1849 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1851 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1852 boolean_type_node
, test
, test2
);
1853 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
1854 fold_build2_loc (input_location
,
1856 type
, tmp
, args
[1]),
1858 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1860 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
1862 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1872 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1873 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1874 where the right shifts are logical (i.e. 0's are shifted in).
1875 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1876 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1878 DSHIFTL(I,J,BITSIZE) = J
1880 DSHIFTR(I,J,BITSIZE) = I. */
1883 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
1885 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
1886 tree args
[3], cond
, tmp
;
1889 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
1891 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
1892 type
= TREE_TYPE (args
[0]);
1893 bitsize
= TYPE_PRECISION (type
);
1894 utype
= unsigned_type_for (type
);
1895 stype
= TREE_TYPE (args
[2]);
1897 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
1898 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
1899 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
1901 /* The generic case. */
1902 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
1903 build_int_cst (stype
, bitsize
), shift
);
1904 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
1905 arg1
, dshiftl
? shift
: tmp
);
1907 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
1908 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
1909 right
= fold_convert (type
, right
);
1911 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
1913 /* Special cases. */
1914 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1915 build_int_cst (stype
, 0));
1916 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1917 dshiftl
? arg1
: arg2
, res
);
1919 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1920 build_int_cst (stype
, bitsize
));
1921 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1922 dshiftl
? arg2
: arg1
, res
);
1928 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1931 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1939 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1940 type
= TREE_TYPE (args
[0]);
1942 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
1943 val
= gfc_evaluate_now (val
, &se
->pre
);
1945 zero
= gfc_build_const (type
, integer_zero_node
);
1946 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
1947 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
1951 /* SIGN(A, B) is absolute value of A times sign of B.
1952 The real value versions use library functions to ensure the correct
1953 handling of negative zero. Integer case implemented as:
1954 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1958 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1964 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1965 if (expr
->ts
.type
== BT_REAL
)
1969 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1970 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1972 /* We explicitly have to ignore the minus sign. We do so by using
1973 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1974 if (!gfc_option
.flag_sign_zero
1975 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1978 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1979 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1981 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1982 TREE_TYPE (args
[0]), cond
,
1983 build_call_expr_loc (input_location
, abs
, 1,
1985 build_call_expr_loc (input_location
, tmp
, 2,
1989 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1994 /* Having excluded floating point types, we know we are now dealing
1995 with signed integer types. */
1996 type
= TREE_TYPE (args
[0]);
1998 /* Args[0] is used multiple times below. */
1999 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2001 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
2002 the signs of A and B are the same, and of all ones if they differ. */
2003 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2004 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2005 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2006 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2008 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2009 is all ones (i.e. -1). */
2010 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2011 fold_build2_loc (input_location
, PLUS_EXPR
,
2012 type
, args
[0], tmp
), tmp
);
2016 /* Test for the presence of an optional argument. */
2019 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2023 arg
= expr
->value
.function
.actual
->expr
;
2024 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2025 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2026 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2030 /* Calculate the double precision product of two single precision values. */
2033 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2038 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2040 /* Convert the args to double precision before multiplying. */
2041 type
= gfc_typenode_for_spec (&expr
->ts
);
2042 args
[0] = convert (type
, args
[0]);
2043 args
[1] = convert (type
, args
[1]);
2044 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2049 /* Return a length one character string containing an ascii character. */
2052 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2057 unsigned int num_args
;
2059 num_args
= gfc_intrinsic_argument_list_length (expr
);
2060 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2062 type
= gfc_get_char_type (expr
->ts
.kind
);
2063 var
= gfc_create_var (type
, "char");
2065 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2066 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2067 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2068 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2073 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2081 unsigned int num_args
;
2083 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2084 args
= XALLOCAVEC (tree
, num_args
);
2086 var
= gfc_create_var (pchar_type_node
, "pstr");
2087 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2089 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2090 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2091 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2093 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2094 tmp
= build_call_array_loc (input_location
,
2095 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2096 fndecl
, num_args
, args
);
2097 gfc_add_expr_to_block (&se
->pre
, tmp
);
2099 /* Free the temporary afterwards, if necessary. */
2100 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2101 len
, build_int_cst (TREE_TYPE (len
), 0));
2102 tmp
= gfc_call_free (var
);
2103 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2104 gfc_add_expr_to_block (&se
->post
, tmp
);
2107 se
->string_length
= len
;
2112 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2120 unsigned int num_args
;
2122 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2123 args
= XALLOCAVEC (tree
, num_args
);
2125 var
= gfc_create_var (pchar_type_node
, "pstr");
2126 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2128 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2129 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2130 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2132 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2133 tmp
= build_call_array_loc (input_location
,
2134 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2135 fndecl
, num_args
, args
);
2136 gfc_add_expr_to_block (&se
->pre
, tmp
);
2138 /* Free the temporary afterwards, if necessary. */
2139 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2140 len
, build_int_cst (TREE_TYPE (len
), 0));
2141 tmp
= gfc_call_free (var
);
2142 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2143 gfc_add_expr_to_block (&se
->post
, tmp
);
2146 se
->string_length
= len
;
2150 /* Return a character string containing the tty name. */
2153 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2161 unsigned int num_args
;
2163 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2164 args
= XALLOCAVEC (tree
, num_args
);
2166 var
= gfc_create_var (pchar_type_node
, "pstr");
2167 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2169 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2170 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2171 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2173 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2174 tmp
= build_call_array_loc (input_location
,
2175 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2176 fndecl
, num_args
, args
);
2177 gfc_add_expr_to_block (&se
->pre
, tmp
);
2179 /* Free the temporary afterwards, if necessary. */
2180 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2181 len
, build_int_cst (TREE_TYPE (len
), 0));
2182 tmp
= gfc_call_free (var
);
2183 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2184 gfc_add_expr_to_block (&se
->post
, tmp
);
2187 se
->string_length
= len
;
2191 /* Get the minimum/maximum value of all the parameters.
2192 minmax (a1, a2, a3, ...)
2195 if (a2 .op. mvar || isnan(mvar))
2197 if (a3 .op. mvar || isnan(mvar))
2204 /* TODO: Mismatching types can occur when specific names are used.
2205 These should be handled during resolution. */
2207 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2215 gfc_actual_arglist
*argexpr
;
2216 unsigned int i
, nargs
;
2218 nargs
= gfc_intrinsic_argument_list_length (expr
);
2219 args
= XALLOCAVEC (tree
, nargs
);
2221 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2222 type
= gfc_typenode_for_spec (&expr
->ts
);
2224 argexpr
= expr
->value
.function
.actual
;
2225 if (TREE_TYPE (args
[0]) != type
)
2226 args
[0] = convert (type
, args
[0]);
2227 /* Only evaluate the argument once. */
2228 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2229 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2231 mvar
= gfc_create_var (type
, "M");
2232 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2233 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2239 /* Handle absent optional arguments by ignoring the comparison. */
2240 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2241 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2242 && TREE_CODE (val
) == INDIRECT_REF
)
2243 cond
= fold_build2_loc (input_location
,
2244 NE_EXPR
, boolean_type_node
,
2245 TREE_OPERAND (val
, 0),
2246 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2251 /* Only evaluate the argument once. */
2252 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2253 val
= gfc_evaluate_now (val
, &se
->pre
);
2256 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2258 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2259 convert (type
, val
), mvar
);
2261 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2262 __builtin_isnan might be made dependent on that module being loaded,
2263 to help performance of programs that don't rely on IEEE semantics. */
2264 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2266 isnan
= build_call_expr_loc (input_location
,
2267 builtin_decl_explicit (BUILT_IN_ISNAN
),
2269 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2270 boolean_type_node
, tmp
,
2271 fold_convert (boolean_type_node
, isnan
));
2273 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2274 build_empty_stmt (input_location
));
2276 if (cond
!= NULL_TREE
)
2277 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2278 build_empty_stmt (input_location
));
2280 gfc_add_expr_to_block (&se
->pre
, tmp
);
2281 argexpr
= argexpr
->next
;
2287 /* Generate library calls for MIN and MAX intrinsics for character
2290 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2293 tree var
, len
, fndecl
, tmp
, cond
, function
;
2296 nargs
= gfc_intrinsic_argument_list_length (expr
);
2297 args
= XALLOCAVEC (tree
, nargs
+ 4);
2298 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2300 /* Create the result variables. */
2301 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2302 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2303 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2304 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2305 args
[2] = build_int_cst (integer_type_node
, op
);
2306 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2308 if (expr
->ts
.kind
== 1)
2309 function
= gfor_fndecl_string_minmax
;
2310 else if (expr
->ts
.kind
== 4)
2311 function
= gfor_fndecl_string_minmax_char4
;
2315 /* Make the function call. */
2316 fndecl
= build_addr (function
, current_function_decl
);
2317 tmp
= build_call_array_loc (input_location
,
2318 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2320 gfc_add_expr_to_block (&se
->pre
, tmp
);
2322 /* Free the temporary afterwards, if necessary. */
2323 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2324 len
, build_int_cst (TREE_TYPE (len
), 0));
2325 tmp
= gfc_call_free (var
);
2326 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2327 gfc_add_expr_to_block (&se
->post
, tmp
);
2330 se
->string_length
= len
;
2334 /* Create a symbol node for this intrinsic. The symbol from the frontend
2335 has the generic name. */
2338 gfc_get_symbol_for_expr (gfc_expr
* expr
)
2342 /* TODO: Add symbols for intrinsic function to the global namespace. */
2343 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2344 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2347 sym
->attr
.external
= 1;
2348 sym
->attr
.function
= 1;
2349 sym
->attr
.always_explicit
= 1;
2350 sym
->attr
.proc
= PROC_INTRINSIC
;
2351 sym
->attr
.flavor
= FL_PROCEDURE
;
2355 sym
->attr
.dimension
= 1;
2356 sym
->as
= gfc_get_array_spec ();
2357 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2358 sym
->as
->rank
= expr
->rank
;
2361 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
2366 /* Generate a call to an external intrinsic function. */
2368 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2371 vec
<tree
, va_gc
> *append_args
;
2373 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2376 gcc_assert (expr
->rank
> 0);
2378 gcc_assert (expr
->rank
== 0);
2380 sym
= gfc_get_symbol_for_expr (expr
);
2382 /* Calls to libgfortran_matmul need to be appended special arguments,
2383 to be able to call the BLAS ?gemm functions if required and possible. */
2385 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2386 && sym
->ts
.type
!= BT_LOGICAL
)
2388 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2390 if (gfc_option
.flag_external_blas
2391 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2392 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
2396 if (sym
->ts
.type
== BT_REAL
)
2398 if (sym
->ts
.kind
== 4)
2399 gemm_fndecl
= gfor_fndecl_sgemm
;
2401 gemm_fndecl
= gfor_fndecl_dgemm
;
2405 if (sym
->ts
.kind
== 4)
2406 gemm_fndecl
= gfor_fndecl_cgemm
;
2408 gemm_fndecl
= gfor_fndecl_zgemm
;
2411 vec_alloc (append_args
, 3);
2412 append_args
->quick_push (build_int_cst (cint
, 1));
2413 append_args
->quick_push (build_int_cst (cint
,
2414 gfc_option
.blas_matmul_limit
));
2415 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
2420 vec_alloc (append_args
, 3);
2421 append_args
->quick_push (build_int_cst (cint
, 0));
2422 append_args
->quick_push (build_int_cst (cint
, 0));
2423 append_args
->quick_push (null_pointer_node
);
2427 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
2429 gfc_free_symbol (sym
);
2432 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2452 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2461 gfc_actual_arglist
*actual
;
2468 gfc_conv_intrinsic_funcall (se
, expr
);
2472 actual
= expr
->value
.function
.actual
;
2473 type
= gfc_typenode_for_spec (&expr
->ts
);
2474 /* Initialize the result. */
2475 resvar
= gfc_create_var (type
, "test");
2477 tmp
= convert (type
, boolean_true_node
);
2479 tmp
= convert (type
, boolean_false_node
);
2480 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2482 /* Walk the arguments. */
2483 arrayss
= gfc_walk_expr (actual
->expr
);
2484 gcc_assert (arrayss
!= gfc_ss_terminator
);
2486 /* Initialize the scalarizer. */
2487 gfc_init_loopinfo (&loop
);
2488 exit_label
= gfc_build_label_decl (NULL_TREE
);
2489 TREE_USED (exit_label
) = 1;
2490 gfc_add_ss_to_loop (&loop
, arrayss
);
2492 /* Initialize the loop. */
2493 gfc_conv_ss_startstride (&loop
);
2494 gfc_conv_loop_setup (&loop
, &expr
->where
);
2496 gfc_mark_ss_chain_used (arrayss
, 1);
2497 /* Generate the loop body. */
2498 gfc_start_scalarized_body (&loop
, &body
);
2500 /* If the condition matches then set the return value. */
2501 gfc_start_block (&block
);
2503 tmp
= convert (type
, boolean_false_node
);
2505 tmp
= convert (type
, boolean_true_node
);
2506 gfc_add_modify (&block
, resvar
, tmp
);
2508 /* And break out of the loop. */
2509 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2510 gfc_add_expr_to_block (&block
, tmp
);
2512 found
= gfc_finish_block (&block
);
2514 /* Check this element. */
2515 gfc_init_se (&arrayse
, NULL
);
2516 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2517 arrayse
.ss
= arrayss
;
2518 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2520 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2521 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
2522 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
2523 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
2524 gfc_add_expr_to_block (&body
, tmp
);
2525 gfc_add_block_to_block (&body
, &arrayse
.post
);
2527 gfc_trans_scalarizing_loops (&loop
, &body
);
2529 /* Add the exit label. */
2530 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2531 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2533 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2534 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2535 gfc_cleanup_loop (&loop
);
2540 /* COUNT(A) = Number of true elements in A. */
2542 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
2549 gfc_actual_arglist
*actual
;
2555 gfc_conv_intrinsic_funcall (se
, expr
);
2559 actual
= expr
->value
.function
.actual
;
2561 type
= gfc_typenode_for_spec (&expr
->ts
);
2562 /* Initialize the result. */
2563 resvar
= gfc_create_var (type
, "count");
2564 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
2566 /* Walk the arguments. */
2567 arrayss
= gfc_walk_expr (actual
->expr
);
2568 gcc_assert (arrayss
!= gfc_ss_terminator
);
2570 /* Initialize the scalarizer. */
2571 gfc_init_loopinfo (&loop
);
2572 gfc_add_ss_to_loop (&loop
, arrayss
);
2574 /* Initialize the loop. */
2575 gfc_conv_ss_startstride (&loop
);
2576 gfc_conv_loop_setup (&loop
, &expr
->where
);
2578 gfc_mark_ss_chain_used (arrayss
, 1);
2579 /* Generate the loop body. */
2580 gfc_start_scalarized_body (&loop
, &body
);
2582 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2583 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2584 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2586 gfc_init_se (&arrayse
, NULL
);
2587 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2588 arrayse
.ss
= arrayss
;
2589 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2590 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2591 build_empty_stmt (input_location
));
2593 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2594 gfc_add_expr_to_block (&body
, tmp
);
2595 gfc_add_block_to_block (&body
, &arrayse
.post
);
2597 gfc_trans_scalarizing_loops (&loop
, &body
);
2599 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2600 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2601 gfc_cleanup_loop (&loop
);
2607 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
2608 struct and return the corresponding loopinfo. */
2610 static gfc_loopinfo
*
2611 enter_nested_loop (gfc_se
*se
)
2613 se
->ss
= se
->ss
->nested_ss
;
2614 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
2616 return se
->ss
->loop
;
2620 /* Inline implementation of the sum and product intrinsics. */
2622 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2626 tree scale
= NULL_TREE
;
2631 gfc_loopinfo loop
, *ploop
;
2632 gfc_actual_arglist
*arg_array
, *arg_mask
;
2633 gfc_ss
*arrayss
= NULL
;
2634 gfc_ss
*maskss
= NULL
;
2638 gfc_expr
*arrayexpr
;
2643 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
2649 type
= gfc_typenode_for_spec (&expr
->ts
);
2650 /* Initialize the result. */
2651 resvar
= gfc_create_var (type
, "val");
2656 scale
= gfc_create_var (type
, "scale");
2657 gfc_add_modify (&se
->pre
, scale
,
2658 gfc_build_const (type
, integer_one_node
));
2659 tmp
= gfc_build_const (type
, integer_zero_node
);
2661 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2662 tmp
= gfc_build_const (type
, integer_zero_node
);
2663 else if (op
== NE_EXPR
)
2665 tmp
= convert (type
, boolean_false_node
);
2666 else if (op
== BIT_AND_EXPR
)
2667 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2668 type
, integer_one_node
));
2670 tmp
= gfc_build_const (type
, integer_one_node
);
2672 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2674 arg_array
= expr
->value
.function
.actual
;
2676 arrayexpr
= arg_array
->expr
;
2678 if (op
== NE_EXPR
|| norm2
)
2679 /* PARITY and NORM2. */
2683 arg_mask
= arg_array
->next
->next
;
2684 gcc_assert (arg_mask
!= NULL
);
2685 maskexpr
= arg_mask
->expr
;
2688 if (expr
->rank
== 0)
2690 /* Walk the arguments. */
2691 arrayss
= gfc_walk_expr (arrayexpr
);
2692 gcc_assert (arrayss
!= gfc_ss_terminator
);
2694 if (maskexpr
&& maskexpr
->rank
> 0)
2696 maskss
= gfc_walk_expr (maskexpr
);
2697 gcc_assert (maskss
!= gfc_ss_terminator
);
2702 /* Initialize the scalarizer. */
2703 gfc_init_loopinfo (&loop
);
2704 gfc_add_ss_to_loop (&loop
, arrayss
);
2705 if (maskexpr
&& maskexpr
->rank
> 0)
2706 gfc_add_ss_to_loop (&loop
, maskss
);
2708 /* Initialize the loop. */
2709 gfc_conv_ss_startstride (&loop
);
2710 gfc_conv_loop_setup (&loop
, &expr
->where
);
2712 gfc_mark_ss_chain_used (arrayss
, 1);
2713 if (maskexpr
&& maskexpr
->rank
> 0)
2714 gfc_mark_ss_chain_used (maskss
, 1);
2719 /* All the work has been done in the parent loops. */
2720 ploop
= enter_nested_loop (se
);
2724 /* Generate the loop body. */
2725 gfc_start_scalarized_body (ploop
, &body
);
2727 /* If we have a mask, only add this element if the mask is set. */
2728 if (maskexpr
&& maskexpr
->rank
> 0)
2730 gfc_init_se (&maskse
, parent_se
);
2731 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
2732 if (expr
->rank
== 0)
2734 gfc_conv_expr_val (&maskse
, maskexpr
);
2735 gfc_add_block_to_block (&body
, &maskse
.pre
);
2737 gfc_start_block (&block
);
2740 gfc_init_block (&block
);
2742 /* Do the actual summation/product. */
2743 gfc_init_se (&arrayse
, parent_se
);
2744 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
2745 if (expr
->rank
== 0)
2746 arrayse
.ss
= arrayss
;
2747 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2748 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2758 result = 1.0 + result * val * val;
2764 result += val * val;
2767 tree res1
, res2
, cond
, absX
, val
;
2768 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
2770 gfc_init_block (&ifblock1
);
2772 absX
= gfc_create_var (type
, "absX");
2773 gfc_add_modify (&ifblock1
, absX
,
2774 fold_build1_loc (input_location
, ABS_EXPR
, type
,
2776 val
= gfc_create_var (type
, "val");
2777 gfc_add_expr_to_block (&ifblock1
, val
);
2779 gfc_init_block (&ifblock2
);
2780 gfc_add_modify (&ifblock2
, val
,
2781 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
2783 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2784 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
2785 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
2786 gfc_build_const (type
, integer_one_node
));
2787 gfc_add_modify (&ifblock2
, resvar
, res1
);
2788 gfc_add_modify (&ifblock2
, scale
, absX
);
2789 res1
= gfc_finish_block (&ifblock2
);
2791 gfc_init_block (&ifblock3
);
2792 gfc_add_modify (&ifblock3
, val
,
2793 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
2795 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2796 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
2797 gfc_add_modify (&ifblock3
, resvar
, res2
);
2798 res2
= gfc_finish_block (&ifblock3
);
2800 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2802 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
2803 gfc_add_expr_to_block (&ifblock1
, tmp
);
2804 tmp
= gfc_finish_block (&ifblock1
);
2806 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2808 gfc_build_const (type
, integer_zero_node
));
2810 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2811 gfc_add_expr_to_block (&block
, tmp
);
2815 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
2816 gfc_add_modify (&block
, resvar
, tmp
);
2819 gfc_add_block_to_block (&block
, &arrayse
.post
);
2821 if (maskexpr
&& maskexpr
->rank
> 0)
2823 /* We enclose the above in if (mask) {...} . */
2825 tmp
= gfc_finish_block (&block
);
2826 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2827 build_empty_stmt (input_location
));
2830 tmp
= gfc_finish_block (&block
);
2831 gfc_add_expr_to_block (&body
, tmp
);
2833 gfc_trans_scalarizing_loops (ploop
, &body
);
2835 /* For a scalar mask, enclose the loop in an if statement. */
2836 if (maskexpr
&& maskexpr
->rank
== 0)
2838 gfc_init_block (&block
);
2839 gfc_add_block_to_block (&block
, &ploop
->pre
);
2840 gfc_add_block_to_block (&block
, &ploop
->post
);
2841 tmp
= gfc_finish_block (&block
);
2845 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
2846 build_empty_stmt (input_location
));
2847 gfc_advance_se_ss_chain (se
);
2851 gcc_assert (expr
->rank
== 0);
2852 gfc_init_se (&maskse
, NULL
);
2853 gfc_conv_expr_val (&maskse
, maskexpr
);
2854 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2855 build_empty_stmt (input_location
));
2858 gfc_add_expr_to_block (&block
, tmp
);
2859 gfc_add_block_to_block (&se
->pre
, &block
);
2860 gcc_assert (se
->post
.head
== NULL
);
2864 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
2865 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
2868 if (expr
->rank
== 0)
2869 gfc_cleanup_loop (ploop
);
2873 /* result = scale * sqrt(result). */
2875 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
2876 resvar
= build_call_expr_loc (input_location
,
2878 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
2885 /* Inline implementation of the dot_product intrinsic. This function
2886 is based on gfc_conv_intrinsic_arith (the previous function). */
2888 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2896 gfc_actual_arglist
*actual
;
2897 gfc_ss
*arrayss1
, *arrayss2
;
2898 gfc_se arrayse1
, arrayse2
;
2899 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2901 type
= gfc_typenode_for_spec (&expr
->ts
);
2903 /* Initialize the result. */
2904 resvar
= gfc_create_var (type
, "val");
2905 if (expr
->ts
.type
== BT_LOGICAL
)
2906 tmp
= build_int_cst (type
, 0);
2908 tmp
= gfc_build_const (type
, integer_zero_node
);
2910 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2912 /* Walk argument #1. */
2913 actual
= expr
->value
.function
.actual
;
2914 arrayexpr1
= actual
->expr
;
2915 arrayss1
= gfc_walk_expr (arrayexpr1
);
2916 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2918 /* Walk argument #2. */
2919 actual
= actual
->next
;
2920 arrayexpr2
= actual
->expr
;
2921 arrayss2
= gfc_walk_expr (arrayexpr2
);
2922 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2924 /* Initialize the scalarizer. */
2925 gfc_init_loopinfo (&loop
);
2926 gfc_add_ss_to_loop (&loop
, arrayss1
);
2927 gfc_add_ss_to_loop (&loop
, arrayss2
);
2929 /* Initialize the loop. */
2930 gfc_conv_ss_startstride (&loop
);
2931 gfc_conv_loop_setup (&loop
, &expr
->where
);
2933 gfc_mark_ss_chain_used (arrayss1
, 1);
2934 gfc_mark_ss_chain_used (arrayss2
, 1);
2936 /* Generate the loop body. */
2937 gfc_start_scalarized_body (&loop
, &body
);
2938 gfc_init_block (&block
);
2940 /* Make the tree expression for [conjg(]array1[)]. */
2941 gfc_init_se (&arrayse1
, NULL
);
2942 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2943 arrayse1
.ss
= arrayss1
;
2944 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2945 if (expr
->ts
.type
== BT_COMPLEX
)
2946 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
2948 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2950 /* Make the tree expression for array2. */
2951 gfc_init_se (&arrayse2
, NULL
);
2952 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2953 arrayse2
.ss
= arrayss2
;
2954 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2955 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2957 /* Do the actual product and sum. */
2958 if (expr
->ts
.type
== BT_LOGICAL
)
2960 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
2961 arrayse1
.expr
, arrayse2
.expr
);
2962 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2966 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
2968 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
2970 gfc_add_modify (&block
, resvar
, tmp
);
2972 /* Finish up the loop block and the loop. */
2973 tmp
= gfc_finish_block (&block
);
2974 gfc_add_expr_to_block (&body
, tmp
);
2976 gfc_trans_scalarizing_loops (&loop
, &body
);
2977 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2978 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2979 gfc_cleanup_loop (&loop
);
2985 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2986 we need to handle. For performance reasons we sometimes create two
2987 loops instead of one, where the second one is much simpler.
2988 Examples for minloc intrinsic:
2989 1) Result is an array, a call is generated
2990 2) Array mask is used and NaNs need to be supported:
2996 if (pos == 0) pos = S + (1 - from);
2997 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3004 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3008 3) NaNs need to be supported, but it is known at compile time or cheaply
3009 at runtime whether array is nonempty or not:
3014 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3017 if (from <= to) pos = 1;
3021 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3025 4) NaNs aren't supported, array mask is used:
3026 limit = infinities_supported ? Infinity : huge (limit);
3030 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3036 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3040 5) Same without array mask:
3041 limit = infinities_supported ? Infinity : huge (limit);
3042 pos = (from <= to) ? 1 : 0;
3045 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3048 For 3) and 5), if mask is scalar, this all goes into a conditional,
3049 setting pos = 0; in the else branch. */
3052 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3056 stmtblock_t ifblock
;
3057 stmtblock_t elseblock
;
3068 gfc_actual_arglist
*actual
;
3073 gfc_expr
*arrayexpr
;
3080 gfc_conv_intrinsic_funcall (se
, expr
);
3084 /* Initialize the result. */
3085 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3086 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3087 type
= gfc_typenode_for_spec (&expr
->ts
);
3089 /* Walk the arguments. */
3090 actual
= expr
->value
.function
.actual
;
3091 arrayexpr
= actual
->expr
;
3092 arrayss
= gfc_walk_expr (arrayexpr
);
3093 gcc_assert (arrayss
!= gfc_ss_terminator
);
3095 actual
= actual
->next
->next
;
3096 gcc_assert (actual
);
3097 maskexpr
= actual
->expr
;
3099 if (maskexpr
&& maskexpr
->rank
!= 0)
3101 maskss
= gfc_walk_expr (maskexpr
);
3102 gcc_assert (maskss
!= gfc_ss_terminator
);
3107 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3109 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3111 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3112 boolean_type_node
, nonempty
,
3113 gfc_index_zero_node
);
3118 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3119 switch (arrayexpr
->ts
.type
)
3122 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3126 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3127 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3128 arrayexpr
->ts
.kind
);
3135 /* We start with the most negative possible value for MAXLOC, and the most
3136 positive possible value for MINLOC. The most negative possible value is
3137 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3138 possible value is HUGE in both cases. */
3140 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3141 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3142 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3143 build_int_cst (type
, 1));
3145 gfc_add_modify (&se
->pre
, limit
, tmp
);
3147 /* Initialize the scalarizer. */
3148 gfc_init_loopinfo (&loop
);
3149 gfc_add_ss_to_loop (&loop
, arrayss
);
3151 gfc_add_ss_to_loop (&loop
, maskss
);
3153 /* Initialize the loop. */
3154 gfc_conv_ss_startstride (&loop
);
3156 /* The code generated can have more than one loop in sequence (see the
3157 comment at the function header). This doesn't work well with the
3158 scalarizer, which changes arrays' offset when the scalarization loops
3159 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3160 are currently inlined in the scalar case only (for which loop is of rank
3161 one). As there is no dependency to care about in that case, there is no
3162 temporary, so that we can use the scalarizer temporary code to handle
3163 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3164 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3166 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3167 should eventually go away. We could either create two loops properly,
3168 or find another way to save/restore the array offsets between the two
3169 loops (without conflicting with temporary management), or use a single
3170 loop minmaxloc implementation. See PR 31067. */
3171 loop
.temp_dim
= loop
.dimen
;
3172 gfc_conv_loop_setup (&loop
, &expr
->where
);
3174 gcc_assert (loop
.dimen
== 1);
3175 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3176 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3177 loop
.from
[0], loop
.to
[0]);
3181 /* Initialize the position to zero, following Fortran 2003. We are free
3182 to do this because Fortran 95 allows the result of an entirely false
3183 mask to be processor dependent. If we know at compile time the array
3184 is non-empty and no MASK is used, we can initialize to 1 to simplify
3186 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3187 gfc_add_modify (&loop
.pre
, pos
,
3188 fold_build3_loc (input_location
, COND_EXPR
,
3189 gfc_array_index_type
,
3190 nonempty
, gfc_index_one_node
,
3191 gfc_index_zero_node
));
3194 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3195 lab1
= gfc_build_label_decl (NULL_TREE
);
3196 TREE_USED (lab1
) = 1;
3197 lab2
= gfc_build_label_decl (NULL_TREE
);
3198 TREE_USED (lab2
) = 1;
3201 /* An offset must be added to the loop
3202 counter to obtain the required position. */
3203 gcc_assert (loop
.from
[0]);
3205 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3206 gfc_index_one_node
, loop
.from
[0]);
3207 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3209 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3211 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3212 /* Generate the loop body. */
3213 gfc_start_scalarized_body (&loop
, &body
);
3215 /* If we have a mask, only check this element if the mask is set. */
3218 gfc_init_se (&maskse
, NULL
);
3219 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3221 gfc_conv_expr_val (&maskse
, maskexpr
);
3222 gfc_add_block_to_block (&body
, &maskse
.pre
);
3224 gfc_start_block (&block
);
3227 gfc_init_block (&block
);
3229 /* Compare with the current limit. */
3230 gfc_init_se (&arrayse
, NULL
);
3231 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3232 arrayse
.ss
= arrayss
;
3233 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3234 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3236 /* We do the following if this is a more extreme value. */
3237 gfc_start_block (&ifblock
);
3239 /* Assign the value to the limit... */
3240 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3242 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3244 stmtblock_t ifblock2
;
3247 gfc_start_block (&ifblock2
);
3248 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3249 loop
.loopvar
[0], offset
);
3250 gfc_add_modify (&ifblock2
, pos
, tmp
);
3251 ifbody2
= gfc_finish_block (&ifblock2
);
3252 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3253 gfc_index_zero_node
);
3254 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3255 build_empty_stmt (input_location
));
3256 gfc_add_expr_to_block (&block
, tmp
);
3259 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3260 loop
.loopvar
[0], offset
);
3261 gfc_add_modify (&ifblock
, pos
, tmp
);
3264 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3266 ifbody
= gfc_finish_block (&ifblock
);
3268 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3271 cond
= fold_build2_loc (input_location
,
3272 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3273 boolean_type_node
, arrayse
.expr
, limit
);
3275 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3276 arrayse
.expr
, limit
);
3278 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3279 build_empty_stmt (input_location
));
3281 gfc_add_expr_to_block (&block
, ifbody
);
3285 /* We enclose the above in if (mask) {...}. */
3286 tmp
= gfc_finish_block (&block
);
3288 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3289 build_empty_stmt (input_location
));
3292 tmp
= gfc_finish_block (&block
);
3293 gfc_add_expr_to_block (&body
, tmp
);
3297 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3299 if (HONOR_NANS (DECL_MODE (limit
)))
3301 if (nonempty
!= NULL
)
3303 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3304 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3305 build_empty_stmt (input_location
));
3306 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3310 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3311 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3313 /* If we have a mask, only check this element if the mask is set. */
3316 gfc_init_se (&maskse
, NULL
);
3317 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3319 gfc_conv_expr_val (&maskse
, maskexpr
);
3320 gfc_add_block_to_block (&body
, &maskse
.pre
);
3322 gfc_start_block (&block
);
3325 gfc_init_block (&block
);
3327 /* Compare with the current limit. */
3328 gfc_init_se (&arrayse
, NULL
);
3329 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3330 arrayse
.ss
= arrayss
;
3331 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3332 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3334 /* We do the following if this is a more extreme value. */
3335 gfc_start_block (&ifblock
);
3337 /* Assign the value to the limit... */
3338 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3340 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3341 loop
.loopvar
[0], offset
);
3342 gfc_add_modify (&ifblock
, pos
, tmp
);
3344 ifbody
= gfc_finish_block (&ifblock
);
3346 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3347 arrayse
.expr
, limit
);
3349 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3350 build_empty_stmt (input_location
));
3351 gfc_add_expr_to_block (&block
, tmp
);
3355 /* We enclose the above in if (mask) {...}. */
3356 tmp
= gfc_finish_block (&block
);
3358 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3359 build_empty_stmt (input_location
));
3362 tmp
= gfc_finish_block (&block
);
3363 gfc_add_expr_to_block (&body
, tmp
);
3364 /* Avoid initializing loopvar[0] again, it should be left where
3365 it finished by the first loop. */
3366 loop
.from
[0] = loop
.loopvar
[0];
3369 gfc_trans_scalarizing_loops (&loop
, &body
);
3372 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3374 /* For a scalar mask, enclose the loop in an if statement. */
3375 if (maskexpr
&& maskss
== NULL
)
3377 gfc_init_se (&maskse
, NULL
);
3378 gfc_conv_expr_val (&maskse
, maskexpr
);
3379 gfc_init_block (&block
);
3380 gfc_add_block_to_block (&block
, &loop
.pre
);
3381 gfc_add_block_to_block (&block
, &loop
.post
);
3382 tmp
= gfc_finish_block (&block
);
3384 /* For the else part of the scalar mask, just initialize
3385 the pos variable the same way as above. */
3387 gfc_init_block (&elseblock
);
3388 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3389 elsetmp
= gfc_finish_block (&elseblock
);
3391 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3392 gfc_add_expr_to_block (&block
, tmp
);
3393 gfc_add_block_to_block (&se
->pre
, &block
);
3397 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3398 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3400 gfc_cleanup_loop (&loop
);
3402 se
->expr
= convert (type
, pos
);
3405 /* Emit code for minval or maxval intrinsic. There are many different cases
3406 we need to handle. For performance reasons we sometimes create two
3407 loops instead of one, where the second one is much simpler.
3408 Examples for minval intrinsic:
3409 1) Result is an array, a call is generated
3410 2) Array mask is used and NaNs need to be supported, rank 1:
3415 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3418 limit = nonempty ? NaN : huge (limit);
3420 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3421 3) NaNs need to be supported, but it is known at compile time or cheaply
3422 at runtime whether array is nonempty or not, rank 1:
3425 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3426 limit = (from <= to) ? NaN : huge (limit);
3428 while (S <= to) { limit = min (a[S], limit); S++; }
3429 4) Array mask is used and NaNs need to be supported, rank > 1:
3438 if (fast) limit = min (a[S1][S2], limit);
3441 if (a[S1][S2] <= limit) {
3452 limit = nonempty ? NaN : huge (limit);
3453 5) NaNs need to be supported, but it is known at compile time or cheaply
3454 at runtime whether array is nonempty or not, rank > 1:
3461 if (fast) limit = min (a[S1][S2], limit);
3463 if (a[S1][S2] <= limit) {
3473 limit = (nonempty_array) ? NaN : huge (limit);
3474 6) NaNs aren't supported, but infinities are. Array mask is used:
3479 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3482 limit = nonempty ? limit : huge (limit);
3483 7) Same without array mask:
3486 while (S <= to) { limit = min (a[S], limit); S++; }
3487 limit = (from <= to) ? limit : huge (limit);
3488 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3489 limit = huge (limit);
3491 while (S <= to) { limit = min (a[S], limit); S++); }
3493 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3494 with array mask instead).
3495 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3496 setting limit = huge (limit); in the else branch. */
3499 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3509 tree huge_cst
= NULL
, nan_cst
= NULL
;
3511 stmtblock_t block
, block2
;
3513 gfc_actual_arglist
*actual
;
3518 gfc_expr
*arrayexpr
;
3524 gfc_conv_intrinsic_funcall (se
, expr
);
3528 type
= gfc_typenode_for_spec (&expr
->ts
);
3529 /* Initialize the result. */
3530 limit
= gfc_create_var (type
, "limit");
3531 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
3532 switch (expr
->ts
.type
)
3535 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
3537 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3539 REAL_VALUE_TYPE real
;
3541 tmp
= build_real (type
, real
);
3545 if (HONOR_NANS (DECL_MODE (limit
)))
3547 REAL_VALUE_TYPE real
;
3548 real_nan (&real
, "", 1, DECL_MODE (limit
));
3549 nan_cst
= build_real (type
, real
);
3554 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
3561 /* We start with the most negative possible value for MAXVAL, and the most
3562 positive possible value for MINVAL. The most negative possible value is
3563 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3564 possible value is HUGE in both cases. */
3567 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3569 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
3570 TREE_TYPE (huge_cst
), huge_cst
);
3573 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3574 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
3575 tmp
, build_int_cst (type
, 1));
3577 gfc_add_modify (&se
->pre
, limit
, tmp
);
3579 /* Walk the arguments. */
3580 actual
= expr
->value
.function
.actual
;
3581 arrayexpr
= actual
->expr
;
3582 arrayss
= gfc_walk_expr (arrayexpr
);
3583 gcc_assert (arrayss
!= gfc_ss_terminator
);
3585 actual
= actual
->next
->next
;
3586 gcc_assert (actual
);
3587 maskexpr
= actual
->expr
;
3589 if (maskexpr
&& maskexpr
->rank
!= 0)
3591 maskss
= gfc_walk_expr (maskexpr
);
3592 gcc_assert (maskss
!= gfc_ss_terminator
);
3597 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3599 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3601 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3602 boolean_type_node
, nonempty
,
3603 gfc_index_zero_node
);
3608 /* Initialize the scalarizer. */
3609 gfc_init_loopinfo (&loop
);
3610 gfc_add_ss_to_loop (&loop
, arrayss
);
3612 gfc_add_ss_to_loop (&loop
, maskss
);
3614 /* Initialize the loop. */
3615 gfc_conv_ss_startstride (&loop
);
3617 /* The code generated can have more than one loop in sequence (see the
3618 comment at the function header). This doesn't work well with the
3619 scalarizer, which changes arrays' offset when the scalarization loops
3620 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3621 are currently inlined in the scalar case only. As there is no dependency
3622 to care about in that case, there is no temporary, so that we can use the
3623 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3624 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3625 gfc_trans_scalarized_loop_boundary even later to restore offset.
3626 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3627 should eventually go away. We could either create two loops properly,
3628 or find another way to save/restore the array offsets between the two
3629 loops (without conflicting with temporary management), or use a single
3630 loop minmaxval implementation. See PR 31067. */
3631 loop
.temp_dim
= loop
.dimen
;
3632 gfc_conv_loop_setup (&loop
, &expr
->where
);
3634 if (nonempty
== NULL
&& maskss
== NULL
3635 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
3636 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3637 loop
.from
[0], loop
.to
[0]);
3638 nonempty_var
= NULL
;
3639 if (nonempty
== NULL
3640 && (HONOR_INFINITIES (DECL_MODE (limit
))
3641 || HONOR_NANS (DECL_MODE (limit
))))
3643 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3644 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3645 nonempty
= nonempty_var
;
3649 if (HONOR_NANS (DECL_MODE (limit
)))
3651 if (loop
.dimen
== 1)
3653 lab
= gfc_build_label_decl (NULL_TREE
);
3654 TREE_USED (lab
) = 1;
3658 fast
= gfc_create_var (boolean_type_node
, "fast");
3659 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3663 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
3665 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
3666 /* Generate the loop body. */
3667 gfc_start_scalarized_body (&loop
, &body
);
3669 /* If we have a mask, only add this element if the mask is set. */
3672 gfc_init_se (&maskse
, NULL
);
3673 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3675 gfc_conv_expr_val (&maskse
, maskexpr
);
3676 gfc_add_block_to_block (&body
, &maskse
.pre
);
3678 gfc_start_block (&block
);
3681 gfc_init_block (&block
);
3683 /* Compare with the current limit. */
3684 gfc_init_se (&arrayse
, NULL
);
3685 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3686 arrayse
.ss
= arrayss
;
3687 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3688 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3690 gfc_init_block (&block2
);
3693 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3695 if (HONOR_NANS (DECL_MODE (limit
)))
3697 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3698 boolean_type_node
, arrayse
.expr
, limit
);
3700 ifbody
= build1_v (GOTO_EXPR
, lab
);
3703 stmtblock_t ifblock
;
3705 gfc_init_block (&ifblock
);
3706 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3707 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3708 ifbody
= gfc_finish_block (&ifblock
);
3710 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3711 build_empty_stmt (input_location
));
3712 gfc_add_expr_to_block (&block2
, tmp
);
3716 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3718 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3720 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3721 arrayse
.expr
, limit
);
3722 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3723 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3724 build_empty_stmt (input_location
));
3725 gfc_add_expr_to_block (&block2
, tmp
);
3729 tmp
= fold_build2_loc (input_location
,
3730 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3731 type
, arrayse
.expr
, limit
);
3732 gfc_add_modify (&block2
, limit
, tmp
);
3738 tree elsebody
= gfc_finish_block (&block2
);
3740 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3742 if (HONOR_NANS (DECL_MODE (limit
))
3743 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3745 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3746 arrayse
.expr
, limit
);
3747 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3748 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3749 build_empty_stmt (input_location
));
3753 tmp
= fold_build2_loc (input_location
,
3754 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3755 type
, arrayse
.expr
, limit
);
3756 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3758 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3759 gfc_add_expr_to_block (&block
, tmp
);
3762 gfc_add_block_to_block (&block
, &block2
);
3764 gfc_add_block_to_block (&block
, &arrayse
.post
);
3766 tmp
= gfc_finish_block (&block
);
3768 /* We enclose the above in if (mask) {...}. */
3769 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3770 build_empty_stmt (input_location
));
3771 gfc_add_expr_to_block (&body
, tmp
);
3775 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3777 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3779 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
3780 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
3782 /* If we have a mask, only add this element if the mask is set. */
3785 gfc_init_se (&maskse
, NULL
);
3786 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3788 gfc_conv_expr_val (&maskse
, maskexpr
);
3789 gfc_add_block_to_block (&body
, &maskse
.pre
);
3791 gfc_start_block (&block
);
3794 gfc_init_block (&block
);
3796 /* Compare with the current limit. */
3797 gfc_init_se (&arrayse
, NULL
);
3798 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3799 arrayse
.ss
= arrayss
;
3800 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3801 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3803 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3805 if (HONOR_NANS (DECL_MODE (limit
))
3806 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3808 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3809 arrayse
.expr
, limit
);
3810 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3811 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3812 build_empty_stmt (input_location
));
3813 gfc_add_expr_to_block (&block
, tmp
);
3817 tmp
= fold_build2_loc (input_location
,
3818 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3819 type
, arrayse
.expr
, limit
);
3820 gfc_add_modify (&block
, limit
, tmp
);
3823 gfc_add_block_to_block (&block
, &arrayse
.post
);
3825 tmp
= gfc_finish_block (&block
);
3827 /* We enclose the above in if (mask) {...}. */
3828 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3829 build_empty_stmt (input_location
));
3830 gfc_add_expr_to_block (&body
, tmp
);
3831 /* Avoid initializing loopvar[0] again, it should be left where
3832 it finished by the first loop. */
3833 loop
.from
[0] = loop
.loopvar
[0];
3835 gfc_trans_scalarizing_loops (&loop
, &body
);
3839 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3841 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3842 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
3844 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3846 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
3848 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
3850 gfc_add_modify (&loop
.pre
, limit
, tmp
);
3853 /* For a scalar mask, enclose the loop in an if statement. */
3854 if (maskexpr
&& maskss
== NULL
)
3858 gfc_init_se (&maskse
, NULL
);
3859 gfc_conv_expr_val (&maskse
, maskexpr
);
3860 gfc_init_block (&block
);
3861 gfc_add_block_to_block (&block
, &loop
.pre
);
3862 gfc_add_block_to_block (&block
, &loop
.post
);
3863 tmp
= gfc_finish_block (&block
);
3865 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3866 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
3868 else_stmt
= build_empty_stmt (input_location
);
3869 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
3870 gfc_add_expr_to_block (&block
, tmp
);
3871 gfc_add_block_to_block (&se
->pre
, &block
);
3875 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3876 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3879 gfc_cleanup_loop (&loop
);
3884 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3886 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
3892 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3893 type
= TREE_TYPE (args
[0]);
3895 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3896 build_int_cst (type
, 1), args
[1]);
3897 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
3898 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
3899 build_int_cst (type
, 0));
3900 type
= gfc_typenode_for_spec (&expr
->ts
);
3901 se
->expr
= convert (type
, tmp
);
3905 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3907 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3911 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3913 /* Convert both arguments to the unsigned type of the same size. */
3914 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
3915 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
3917 /* If they have unequal type size, convert to the larger one. */
3918 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
3919 > TYPE_PRECISION (TREE_TYPE (args
[1])))
3920 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
3921 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
3922 > TYPE_PRECISION (TREE_TYPE (args
[0])))
3923 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
3925 /* Now, we compare them. */
3926 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3931 /* Generate code to perform the specified operation. */
3933 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3937 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3938 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
3944 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
3948 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3949 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3950 TREE_TYPE (arg
), arg
);
3953 /* Set or clear a single bit. */
3955 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
3962 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3963 type
= TREE_TYPE (args
[0]);
3965 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3966 build_int_cst (type
, 1), args
[1]);
3972 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
3974 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
3977 /* Extract a sequence of bits.
3978 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3980 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
3987 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3988 type
= TREE_TYPE (args
[0]);
3990 mask
= build_int_cst (type
, -1);
3991 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
3992 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
3994 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
3996 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
4000 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4003 tree args
[2], type
, num_bits
, cond
;
4005 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4007 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4008 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4009 type
= TREE_TYPE (args
[0]);
4012 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4014 gcc_assert (right_shift
);
4016 se
->expr
= fold_build2_loc (input_location
,
4017 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4018 TREE_TYPE (args
[0]), args
[0], args
[1]);
4021 se
->expr
= fold_convert (type
, se
->expr
);
4023 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4024 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4026 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4027 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4030 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4031 build_int_cst (type
, 0), se
->expr
);
4034 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4036 : ((shift >= 0) ? i << shift : i >> -shift)
4037 where all shifts are logical shifts. */
4039 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4051 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4053 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4054 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4056 type
= TREE_TYPE (args
[0]);
4057 utype
= unsigned_type_for (type
);
4059 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4062 /* Left shift if positive. */
4063 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4065 /* Right shift if negative.
4066 We convert to an unsigned type because we want a logical shift.
4067 The standard doesn't define the case of shifting negative
4068 numbers, and we try to be compatible with other compilers, most
4069 notably g77, here. */
4070 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4071 utype
, convert (utype
, args
[0]), width
));
4073 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4074 build_int_cst (TREE_TYPE (args
[1]), 0));
4075 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4077 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4078 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4080 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4081 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4083 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4084 build_int_cst (type
, 0), tmp
);
4088 /* Circular shift. AKA rotate or barrel shift. */
4091 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4099 unsigned int num_args
;
4101 num_args
= gfc_intrinsic_argument_list_length (expr
);
4102 args
= XALLOCAVEC (tree
, num_args
);
4104 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4108 /* Use a library function for the 3 parameter version. */
4109 tree int4type
= gfc_get_int_type (4);
4111 type
= TREE_TYPE (args
[0]);
4112 /* We convert the first argument to at least 4 bytes, and
4113 convert back afterwards. This removes the need for library
4114 functions for all argument sizes, and function will be
4115 aligned to at least 32 bits, so there's no loss. */
4116 if (expr
->ts
.kind
< 4)
4117 args
[0] = convert (int4type
, args
[0]);
4119 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4120 need loads of library functions. They cannot have values >
4121 BIT_SIZE (I) so the conversion is safe. */
4122 args
[1] = convert (int4type
, args
[1]);
4123 args
[2] = convert (int4type
, args
[2]);
4125 switch (expr
->ts
.kind
)
4130 tmp
= gfor_fndecl_math_ishftc4
;
4133 tmp
= gfor_fndecl_math_ishftc8
;
4136 tmp
= gfor_fndecl_math_ishftc16
;
4141 se
->expr
= build_call_expr_loc (input_location
,
4142 tmp
, 3, args
[0], args
[1], args
[2]);
4143 /* Convert the result back to the original type, if we extended
4144 the first argument's width above. */
4145 if (expr
->ts
.kind
< 4)
4146 se
->expr
= convert (type
, se
->expr
);
4150 type
= TREE_TYPE (args
[0]);
4152 /* Evaluate arguments only once. */
4153 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4154 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4156 /* Rotate left if positive. */
4157 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4159 /* Rotate right if negative. */
4160 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4162 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4164 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4165 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4167 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4169 /* Do nothing if shift == 0. */
4170 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4172 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4177 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4178 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4180 The conditional expression is necessary because the result of LEADZ(0)
4181 is defined, but the result of __builtin_clz(0) is undefined for most
4184 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4185 difference in bit size between the argument of LEADZ and the C int. */
4188 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4200 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4201 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4203 /* Which variant of __builtin_clz* should we call? */
4204 if (argsize
<= INT_TYPE_SIZE
)
4206 arg_type
= unsigned_type_node
;
4207 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4209 else if (argsize
<= LONG_TYPE_SIZE
)
4211 arg_type
= long_unsigned_type_node
;
4212 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4214 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4216 arg_type
= long_long_unsigned_type_node
;
4217 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4221 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4222 arg_type
= gfc_build_uint_type (argsize
);
4226 /* Convert the actual argument twice: first, to the unsigned type of the
4227 same size; then, to the proper argument type for the built-in
4228 function. But the return type is of the default INTEGER kind. */
4229 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4230 arg
= fold_convert (arg_type
, arg
);
4231 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4232 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4234 /* Compute LEADZ for the case i .ne. 0. */
4237 s
= TYPE_PRECISION (arg_type
) - argsize
;
4238 tmp
= fold_convert (result_type
,
4239 build_call_expr_loc (input_location
, func
,
4241 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4242 tmp
, build_int_cst (result_type
, s
));
4246 /* We end up here if the argument type is larger than 'long long'.
4247 We generate this code:
4249 if (x & (ULL_MAX << ULL_SIZE) != 0)
4250 return clzll ((unsigned long long) (x >> ULLSIZE));
4252 return ULL_SIZE + clzll ((unsigned long long) x);
4253 where ULL_MAX is the largest value that a ULL_MAX can hold
4254 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4255 is the bit-size of the long long type (64 in this example). */
4256 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4258 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4259 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4260 long_long_unsigned_type_node
,
4261 build_int_cst (long_long_unsigned_type_node
,
4264 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4265 fold_convert (arg_type
, ullmax
), ullsize
);
4266 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4268 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4269 cond
, build_int_cst (arg_type
, 0));
4271 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4273 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4274 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4275 tmp1
= fold_convert (result_type
,
4276 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4278 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4279 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4280 tmp2
= fold_convert (result_type
,
4281 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4282 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4285 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4289 /* Build BIT_SIZE. */
4290 bit_size
= build_int_cst (result_type
, argsize
);
4292 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4293 arg
, build_int_cst (arg_type
, 0));
4294 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4299 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4301 The conditional expression is necessary because the result of TRAILZ(0)
4302 is defined, but the result of __builtin_ctz(0) is undefined for most
4306 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4317 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4318 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4320 /* Which variant of __builtin_ctz* should we call? */
4321 if (argsize
<= INT_TYPE_SIZE
)
4323 arg_type
= unsigned_type_node
;
4324 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4326 else if (argsize
<= LONG_TYPE_SIZE
)
4328 arg_type
= long_unsigned_type_node
;
4329 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4331 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4333 arg_type
= long_long_unsigned_type_node
;
4334 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4338 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4339 arg_type
= gfc_build_uint_type (argsize
);
4343 /* Convert the actual argument twice: first, to the unsigned type of the
4344 same size; then, to the proper argument type for the built-in
4345 function. But the return type is of the default INTEGER kind. */
4346 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4347 arg
= fold_convert (arg_type
, arg
);
4348 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4349 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4351 /* Compute TRAILZ for the case i .ne. 0. */
4353 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4357 /* We end up here if the argument type is larger than 'long long'.
4358 We generate this code:
4360 if ((x & ULL_MAX) == 0)
4361 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4363 return ctzll ((unsigned long long) x);
4365 where ULL_MAX is the largest value that a ULL_MAX can hold
4366 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4367 is the bit-size of the long long type (64 in this example). */
4368 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4370 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4371 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4372 long_long_unsigned_type_node
,
4373 build_int_cst (long_long_unsigned_type_node
, 0));
4375 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4376 fold_convert (arg_type
, ullmax
));
4377 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4378 build_int_cst (arg_type
, 0));
4380 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4382 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4383 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4384 tmp1
= fold_convert (result_type
,
4385 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4386 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4389 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4390 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4391 tmp2
= fold_convert (result_type
,
4392 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4394 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4398 /* Build BIT_SIZE. */
4399 bit_size
= build_int_cst (result_type
, argsize
);
4401 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4402 arg
, build_int_cst (arg_type
, 0));
4403 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4407 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4408 for types larger than "long long", we call the long long built-in for
4409 the lower and higher bits and combine the result. */
4412 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
4420 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4421 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4422 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4424 /* Which variant of the builtin should we call? */
4425 if (argsize
<= INT_TYPE_SIZE
)
4427 arg_type
= unsigned_type_node
;
4428 func
= builtin_decl_explicit (parity
4430 : BUILT_IN_POPCOUNT
);
4432 else if (argsize
<= LONG_TYPE_SIZE
)
4434 arg_type
= long_unsigned_type_node
;
4435 func
= builtin_decl_explicit (parity
4437 : BUILT_IN_POPCOUNTL
);
4439 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4441 arg_type
= long_long_unsigned_type_node
;
4442 func
= builtin_decl_explicit (parity
4444 : BUILT_IN_POPCOUNTLL
);
4448 /* Our argument type is larger than 'long long', which mean none
4449 of the POPCOUNT builtins covers it. We thus call the 'long long'
4450 variant multiple times, and add the results. */
4451 tree utype
, arg2
, call1
, call2
;
4453 /* For now, we only cover the case where argsize is twice as large
4455 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4457 func
= builtin_decl_explicit (parity
4459 : BUILT_IN_POPCOUNTLL
);
4461 /* Convert it to an integer, and store into a variable. */
4462 utype
= gfc_build_uint_type (argsize
);
4463 arg
= fold_convert (utype
, arg
);
4464 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4466 /* Call the builtin twice. */
4467 call1
= build_call_expr_loc (input_location
, func
, 1,
4468 fold_convert (long_long_unsigned_type_node
,
4471 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
4472 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
4473 call2
= build_call_expr_loc (input_location
, func
, 1,
4474 fold_convert (long_long_unsigned_type_node
,
4477 /* Combine the results. */
4479 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
4482 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4488 /* Convert the actual argument twice: first, to the unsigned type of the
4489 same size; then, to the proper argument type for the built-in
4491 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4492 arg
= fold_convert (arg_type
, arg
);
4494 se
->expr
= fold_convert (result_type
,
4495 build_call_expr_loc (input_location
, func
, 1, arg
));
4499 /* Process an intrinsic with unspecified argument-types that has an optional
4500 argument (which could be of type character), e.g. EOSHIFT. For those, we
4501 need to append the string length of the optional argument if it is not
4502 present and the type is really character.
4503 primary specifies the position (starting at 1) of the non-optional argument
4504 specifying the type and optional gives the position of the optional
4505 argument in the arglist. */
4508 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
4509 unsigned primary
, unsigned optional
)
4511 gfc_actual_arglist
* prim_arg
;
4512 gfc_actual_arglist
* opt_arg
;
4514 gfc_actual_arglist
* arg
;
4516 vec
<tree
, va_gc
> *append_args
;
4518 /* Find the two arguments given as position. */
4522 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4526 if (cur_pos
== primary
)
4528 if (cur_pos
== optional
)
4531 if (cur_pos
>= primary
&& cur_pos
>= optional
)
4534 gcc_assert (prim_arg
);
4535 gcc_assert (prim_arg
->expr
);
4536 gcc_assert (opt_arg
);
4538 /* If we do have type CHARACTER and the optional argument is really absent,
4539 append a dummy 0 as string length. */
4541 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
4545 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
4546 vec_alloc (append_args
, 1);
4547 append_args
->quick_push (dummy
);
4550 /* Build the call itself. */
4551 sym
= gfc_get_symbol_for_expr (expr
);
4552 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4554 gfc_free_symbol (sym
);
4558 /* The length of a character string. */
4560 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
4569 gcc_assert (!se
->ss
);
4571 arg
= expr
->value
.function
.actual
->expr
;
4573 type
= gfc_typenode_for_spec (&expr
->ts
);
4574 switch (arg
->expr_type
)
4577 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
4581 /* Obtain the string length from the function used by
4582 trans-array.c(gfc_trans_array_constructor). */
4584 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
4588 if (arg
->ref
== NULL
4589 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
4591 /* This doesn't catch all cases.
4592 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4593 and the surrounding thread. */
4594 sym
= arg
->symtree
->n
.sym
;
4595 decl
= gfc_get_symbol_decl (sym
);
4596 if (decl
== current_function_decl
&& sym
->attr
.function
4597 && (sym
->result
== sym
))
4598 decl
= gfc_get_fake_result_decl (sym
, 0);
4600 len
= sym
->ts
.u
.cl
->backend_decl
;
4605 /* Otherwise fall through. */
4608 /* Anybody stupid enough to do this deserves inefficient code. */
4609 gfc_init_se (&argse
, se
);
4611 gfc_conv_expr (&argse
, arg
);
4613 gfc_conv_expr_descriptor (&argse
, arg
);
4614 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4615 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4616 len
= argse
.string_length
;
4619 se
->expr
= convert (type
, len
);
4622 /* The length of a character string not including trailing blanks. */
4624 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
4626 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4627 tree args
[2], type
, fndecl
;
4629 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4630 type
= gfc_typenode_for_spec (&expr
->ts
);
4633 fndecl
= gfor_fndecl_string_len_trim
;
4635 fndecl
= gfor_fndecl_string_len_trim_char4
;
4639 se
->expr
= build_call_expr_loc (input_location
,
4640 fndecl
, 2, args
[0], args
[1]);
4641 se
->expr
= convert (type
, se
->expr
);
4645 /* Returns the starting position of a substring within a string. */
4648 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4651 tree logical4_type_node
= gfc_get_logical_type (4);
4655 unsigned int num_args
;
4657 args
= XALLOCAVEC (tree
, 5);
4659 /* Get number of arguments; characters count double due to the
4660 string length argument. Kind= is not passed to the library
4661 and thus ignored. */
4662 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4667 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4668 type
= gfc_typenode_for_spec (&expr
->ts
);
4671 args
[4] = build_int_cst (logical4_type_node
, 0);
4673 args
[4] = convert (logical4_type_node
, args
[4]);
4675 fndecl
= build_addr (function
, current_function_decl
);
4676 se
->expr
= build_call_array_loc (input_location
,
4677 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4679 se
->expr
= convert (type
, se
->expr
);
4683 /* The ascii value for a single character. */
4685 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4687 tree args
[3], type
, pchartype
;
4690 nargs
= gfc_intrinsic_argument_list_length (expr
);
4691 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
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 simply contiguous. */
5441 if (!gfc_is_simply_contiguous (arg
->expr
, false))
5443 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
5445 if (gfc_option
.warn_array_temp
)
5446 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5448 source
= build_call_expr_loc (input_location
,
5449 gfor_fndecl_in_pack
, 1, tmp
);
5450 source
= gfc_evaluate_now (source
, &argse
.pre
);
5452 /* Free the temporary. */
5453 gfc_start_block (&block
);
5454 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
5455 gfc_add_expr_to_block (&block
, tmp
);
5456 stmt
= gfc_finish_block (&block
);
5458 /* Clean up if it was repacked. */
5459 gfc_init_block (&block
);
5460 tmp
= gfc_conv_array_data (argse
.expr
);
5461 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5463 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
5464 build_empty_stmt (input_location
));
5465 gfc_add_expr_to_block (&block
, tmp
);
5466 gfc_add_block_to_block (&block
, &se
->post
);
5467 gfc_init_block (&se
->post
);
5468 gfc_add_block_to_block (&se
->post
, &block
);
5471 /* Obtain the source word length. */
5472 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5473 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5474 argse
.string_length
);
5476 tmp
= fold_convert (gfc_array_index_type
,
5477 size_in_bytes (source_type
));
5479 /* Obtain the size of the array in bytes. */
5480 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
5481 for (n
= 0; n
< arg
->expr
->rank
; n
++)
5484 idx
= gfc_rank_cst
[n
];
5485 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5486 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5487 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5488 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5489 gfc_array_index_type
, upper
, lower
);
5490 gfc_add_modify (&argse
.pre
, extent
, tmp
);
5491 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5492 gfc_array_index_type
, extent
,
5493 gfc_index_one_node
);
5494 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5495 gfc_array_index_type
, tmp
, source_bytes
);
5499 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5500 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5501 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5503 /* Now convert MOLD. The outputs are:
5504 mold_type = the TREE type of MOLD
5505 dest_word_len = destination word length in bytes. */
5507 mold_expr
= arg
->expr
;
5509 gfc_init_se (&argse
, NULL
);
5511 scalar_mold
= arg
->expr
->rank
== 0;
5513 if (arg
->expr
->rank
== 0)
5515 gfc_conv_expr_reference (&argse
, arg
->expr
);
5516 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5521 gfc_init_se (&argse
, NULL
);
5522 argse
.want_pointer
= 0;
5523 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5524 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5527 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5528 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5530 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
5532 /* If this TRANSFER is nested in another TRANSFER, use a type
5533 that preserves all bits. */
5534 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
5535 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
5538 /* Obtain the destination word length. */
5539 switch (arg
->expr
->ts
.type
)
5542 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
5543 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
5546 tmp
= gfc_vtable_size_get (argse
.expr
);
5549 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
5552 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
5553 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
5555 /* Finally convert SIZE, if it is present. */
5557 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
5561 gfc_init_se (&argse
, NULL
);
5562 gfc_conv_expr_reference (&argse
, arg
->expr
);
5563 tmp
= convert (gfc_array_index_type
,
5564 build_fold_indirect_ref_loc (input_location
,
5566 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5567 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5572 /* Separate array and scalar results. */
5573 if (scalar_mold
&& tmp
== NULL_TREE
)
5574 goto scalar_transfer
;
5576 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5577 if (tmp
!= NULL_TREE
)
5578 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5579 tmp
, dest_word_len
);
5583 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
5584 gfc_add_modify (&se
->pre
, size_words
,
5585 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
5586 gfc_array_index_type
,
5587 size_bytes
, dest_word_len
));
5589 /* Evaluate the bounds of the result. If the loop range exists, we have
5590 to check if it is too large. If so, we modify loop->to be consistent
5591 with min(size, size(source)). Otherwise, size is made consistent with
5592 the loop range, so that the right number of bytes is transferred.*/
5593 n
= se
->loop
->order
[0];
5594 if (se
->loop
->to
[n
] != NULL_TREE
)
5596 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5597 se
->loop
->to
[n
], se
->loop
->from
[n
]);
5598 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5599 tmp
, gfc_index_one_node
);
5600 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5602 gfc_add_modify (&se
->pre
, size_words
, tmp
);
5603 gfc_add_modify (&se
->pre
, size_bytes
,
5604 fold_build2_loc (input_location
, MULT_EXPR
,
5605 gfc_array_index_type
,
5606 size_words
, dest_word_len
));
5607 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5608 size_words
, se
->loop
->from
[n
]);
5609 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5610 upper
, gfc_index_one_node
);
5614 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5615 size_words
, gfc_index_one_node
);
5616 se
->loop
->from
[n
] = gfc_index_zero_node
;
5619 se
->loop
->to
[n
] = upper
;
5621 /* Build a destination descriptor, using the pointer, source, as the
5623 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
5624 NULL_TREE
, false, true, false, &expr
->where
);
5626 /* Cast the pointer to the result. */
5627 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5628 tmp
= fold_convert (pvoid_type_node
, tmp
);
5630 /* Use memcpy to do the transfer. */
5632 = build_call_expr_loc (input_location
,
5633 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
5634 fold_convert (pvoid_type_node
, source
),
5635 fold_convert (size_type_node
,
5636 fold_build2_loc (input_location
,
5638 gfc_array_index_type
,
5641 gfc_add_expr_to_block (&se
->pre
, tmp
);
5643 se
->expr
= info
->descriptor
;
5644 if (expr
->ts
.type
== BT_CHARACTER
)
5645 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5649 /* Deal with scalar results. */
5651 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5652 dest_word_len
, source_bytes
);
5653 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5654 extent
, gfc_index_zero_node
);
5656 if (expr
->ts
.type
== BT_CHARACTER
)
5658 tree direct
, indirect
, free
;
5660 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5661 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5664 /* If source is longer than the destination, use a pointer to
5665 the source directly. */
5666 gfc_init_block (&block
);
5667 gfc_add_modify (&block
, tmpdecl
, ptr
);
5668 direct
= gfc_finish_block (&block
);
5670 /* Otherwise, allocate a string with the length of the destination
5671 and copy the source into it. */
5672 gfc_init_block (&block
);
5673 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5674 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5675 gfc_add_modify (&block
, tmpdecl
,
5676 fold_convert (TREE_TYPE (ptr
), tmp
));
5677 tmp
= build_call_expr_loc (input_location
,
5678 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5679 fold_convert (pvoid_type_node
, tmpdecl
),
5680 fold_convert (pvoid_type_node
, ptr
),
5681 fold_convert (size_type_node
, extent
));
5682 gfc_add_expr_to_block (&block
, tmp
);
5683 indirect
= gfc_finish_block (&block
);
5685 /* Wrap it up with the condition. */
5686 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5687 dest_word_len
, source_bytes
);
5688 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5689 gfc_add_expr_to_block (&se
->pre
, tmp
);
5691 /* Free the temporary string, if necessary. */
5692 free
= gfc_call_free (tmpdecl
);
5693 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
5694 dest_word_len
, source_bytes
);
5695 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
5696 gfc_add_expr_to_block (&se
->post
, tmp
);
5699 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5703 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5705 ptr
= convert (build_pointer_type (mold_type
), source
);
5707 /* For CLASS results, allocate the needed memory first. */
5708 if (mold_expr
->ts
.type
== BT_CLASS
)
5711 cdata
= gfc_class_data_get (tmpdecl
);
5712 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
5713 gfc_add_modify (&se
->pre
, cdata
, tmp
);
5716 /* Use memcpy to do the transfer. */
5717 if (mold_expr
->ts
.type
== BT_CLASS
)
5718 tmp
= gfc_class_data_get (tmpdecl
);
5720 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5722 tmp
= build_call_expr_loc (input_location
,
5723 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5724 fold_convert (pvoid_type_node
, tmp
),
5725 fold_convert (pvoid_type_node
, ptr
),
5726 fold_convert (size_type_node
, extent
));
5727 gfc_add_expr_to_block (&se
->pre
, tmp
);
5729 /* For CLASS results, set the _vptr. */
5730 if (mold_expr
->ts
.type
== BT_CLASS
)
5734 vptr
= gfc_class_vptr_get (tmpdecl
);
5735 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
5737 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
5738 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
5746 /* Generate code for the ALLOCATED intrinsic.
5747 Generate inline code that directly check the address of the argument. */
5750 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5752 gfc_actual_arglist
*arg1
;
5756 gfc_init_se (&arg1se
, NULL
);
5757 arg1
= expr
->value
.function
.actual
;
5759 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5761 /* Make sure that class array expressions have both a _data
5762 component reference and an array reference.... */
5763 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
5764 gfc_add_class_array_ref (arg1
->expr
);
5765 /* .... whilst scalars only need the _data component. */
5767 gfc_add_data_component (arg1
->expr
);
5770 if (arg1
->expr
->rank
== 0)
5772 /* Allocatable scalar. */
5773 arg1se
.want_pointer
= 1;
5774 gfc_conv_expr (&arg1se
, arg1
->expr
);
5779 /* Allocatable array. */
5780 arg1se
.descriptor_only
= 1;
5781 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5782 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5785 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5786 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5787 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5791 /* Generate code for the ASSOCIATED intrinsic.
5792 If both POINTER and TARGET are arrays, generate a call to library function
5793 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5794 In other cases, generate inline code that directly compare the address of
5795 POINTER with the address of TARGET. */
5798 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
5800 gfc_actual_arglist
*arg1
;
5801 gfc_actual_arglist
*arg2
;
5806 tree nonzero_charlen
;
5807 tree nonzero_arraylen
;
5811 gfc_init_se (&arg1se
, NULL
);
5812 gfc_init_se (&arg2se
, NULL
);
5813 arg1
= expr
->value
.function
.actual
;
5816 /* Check whether the expression is a scalar or not; we cannot use
5817 arg1->expr->rank as it can be nonzero for proc pointers. */
5818 ss
= gfc_walk_expr (arg1
->expr
);
5819 scalar
= ss
== gfc_ss_terminator
;
5821 gfc_free_ss_chain (ss
);
5825 /* No optional target. */
5828 /* A pointer to a scalar. */
5829 arg1se
.want_pointer
= 1;
5830 gfc_conv_expr (&arg1se
, arg1
->expr
);
5831 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5832 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5833 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5835 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5836 tmp2
= gfc_class_data_get (arg1se
.expr
);
5842 /* A pointer to an array. */
5843 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5844 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5846 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5847 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5848 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
5849 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
5854 /* An optional target. */
5855 if (arg2
->expr
->ts
.type
== BT_CLASS
)
5856 gfc_add_data_component (arg2
->expr
);
5858 nonzero_charlen
= NULL_TREE
;
5859 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
5860 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
5862 arg1
->expr
->ts
.u
.cl
->backend_decl
,
5866 /* A pointer to a scalar. */
5867 arg1se
.want_pointer
= 1;
5868 gfc_conv_expr (&arg1se
, arg1
->expr
);
5869 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5870 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5871 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5873 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5874 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
5876 arg2se
.want_pointer
= 1;
5877 gfc_conv_expr (&arg2se
, arg2
->expr
);
5878 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5879 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
5880 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
5882 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5883 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5884 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5885 arg1se
.expr
, arg2se
.expr
);
5886 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5887 arg1se
.expr
, null_pointer_node
);
5888 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5889 boolean_type_node
, tmp
, tmp2
);
5893 /* An array pointer of zero length is not associated if target is
5895 arg1se
.descriptor_only
= 1;
5896 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
5897 if (arg1
->expr
->rank
== -1)
5899 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
5900 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5901 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
5904 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
5905 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
5906 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
5907 boolean_type_node
, tmp
,
5908 build_int_cst (TREE_TYPE (tmp
), 0));
5910 /* A pointer to an array, call library function _gfor_associated. */
5911 arg1se
.want_pointer
= 1;
5912 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5914 arg2se
.want_pointer
= 1;
5915 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
5916 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
5917 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
5918 se
->expr
= build_call_expr_loc (input_location
,
5919 gfor_fndecl_associated
, 2,
5920 arg1se
.expr
, arg2se
.expr
);
5921 se
->expr
= convert (boolean_type_node
, se
->expr
);
5922 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5923 boolean_type_node
, se
->expr
,
5927 /* If target is present zero character length pointers cannot
5929 if (nonzero_charlen
!= NULL_TREE
)
5930 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5932 se
->expr
, nonzero_charlen
);
5935 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5939 /* Generate code for the SAME_TYPE_AS intrinsic.
5940 Generate inline code that directly checks the vindices. */
5943 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
5948 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
5950 gfc_init_se (&se1
, NULL
);
5951 gfc_init_se (&se2
, NULL
);
5953 a
= expr
->value
.function
.actual
->expr
;
5954 b
= expr
->value
.function
.actual
->next
->expr
;
5956 if (UNLIMITED_POLY (a
))
5958 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
5959 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5960 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
5963 if (UNLIMITED_POLY (b
))
5965 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
5966 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5967 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
5970 if (a
->ts
.type
== BT_CLASS
)
5972 gfc_add_vptr_component (a
);
5973 gfc_add_hash_component (a
);
5975 else if (a
->ts
.type
== BT_DERIVED
)
5976 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5977 a
->ts
.u
.derived
->hash_value
);
5979 if (b
->ts
.type
== BT_CLASS
)
5981 gfc_add_vptr_component (b
);
5982 gfc_add_hash_component (b
);
5984 else if (b
->ts
.type
== BT_DERIVED
)
5985 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5986 b
->ts
.u
.derived
->hash_value
);
5988 gfc_conv_expr (&se1
, a
);
5989 gfc_conv_expr (&se2
, b
);
5991 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
5992 boolean_type_node
, se1
.expr
,
5993 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
5996 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5997 boolean_type_node
, conda
, tmp
);
6000 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
6001 boolean_type_node
, condb
, tmp
);
6003 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6007 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6010 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6014 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6015 se
->expr
= build_call_expr_loc (input_location
,
6016 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6017 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6021 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6024 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6028 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6030 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6031 type
= gfc_get_int_type (4);
6032 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6034 /* Convert it to the required type. */
6035 type
= gfc_typenode_for_spec (&expr
->ts
);
6036 se
->expr
= build_call_expr_loc (input_location
,
6037 gfor_fndecl_si_kind
, 1, arg
);
6038 se
->expr
= fold_convert (type
, se
->expr
);
6042 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6045 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6047 gfc_actual_arglist
*actual
;
6050 vec
<tree
, va_gc
> *args
= NULL
;
6052 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6054 gfc_init_se (&argse
, se
);
6056 /* Pass a NULL pointer for an absent arg. */
6057 if (actual
->expr
== NULL
)
6058 argse
.expr
= null_pointer_node
;
6064 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6066 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6067 ts
.type
= BT_INTEGER
;
6068 ts
.kind
= gfc_c_int_kind
;
6069 gfc_convert_type (actual
->expr
, &ts
, 2);
6071 gfc_conv_expr_reference (&argse
, actual
->expr
);
6074 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6075 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6076 vec_safe_push (args
, argse
.expr
);
6079 /* Convert it to the required type. */
6080 type
= gfc_typenode_for_spec (&expr
->ts
);
6081 se
->expr
= build_call_expr_loc_vec (input_location
,
6082 gfor_fndecl_sr_kind
, args
);
6083 se
->expr
= fold_convert (type
, se
->expr
);
6087 /* Generate code for TRIM (A) intrinsic function. */
6090 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6100 unsigned int num_args
;
6102 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6103 args
= XALLOCAVEC (tree
, num_args
);
6105 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6106 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6107 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6109 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6110 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6113 if (expr
->ts
.kind
== 1)
6114 function
= gfor_fndecl_string_trim
;
6115 else if (expr
->ts
.kind
== 4)
6116 function
= gfor_fndecl_string_trim_char4
;
6120 fndecl
= build_addr (function
, current_function_decl
);
6121 tmp
= build_call_array_loc (input_location
,
6122 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6124 gfc_add_expr_to_block (&se
->pre
, tmp
);
6126 /* Free the temporary afterwards, if necessary. */
6127 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6128 len
, build_int_cst (TREE_TYPE (len
), 0));
6129 tmp
= gfc_call_free (var
);
6130 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6131 gfc_add_expr_to_block (&se
->post
, tmp
);
6134 se
->string_length
= len
;
6138 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6141 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6143 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6144 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6146 stmtblock_t block
, body
;
6149 /* We store in charsize the size of a character. */
6150 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6151 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6153 /* Get the arguments. */
6154 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6155 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6157 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6158 ncopies_type
= TREE_TYPE (ncopies
);
6160 /* Check that NCOPIES is not negative. */
6161 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6162 build_int_cst (ncopies_type
, 0));
6163 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6164 "Argument NCOPIES of REPEAT intrinsic is negative "
6165 "(its value is %ld)",
6166 fold_convert (long_integer_type_node
, ncopies
));
6168 /* If the source length is zero, any non negative value of NCOPIES
6169 is valid, and nothing happens. */
6170 n
= gfc_create_var (ncopies_type
, "ncopies");
6171 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6172 build_int_cst (size_type_node
, 0));
6173 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6174 build_int_cst (ncopies_type
, 0), ncopies
);
6175 gfc_add_modify (&se
->pre
, n
, tmp
);
6178 /* Check that ncopies is not too large: ncopies should be less than
6179 (or equal to) MAX / slen, where MAX is the maximal integer of
6180 the gfc_charlen_type_node type. If slen == 0, we need a special
6181 case to avoid the division by zero. */
6182 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6183 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6184 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6185 fold_convert (size_type_node
, max
), slen
);
6186 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6187 ? size_type_node
: ncopies_type
;
6188 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6189 fold_convert (largest
, ncopies
),
6190 fold_convert (largest
, max
));
6191 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6192 build_int_cst (size_type_node
, 0));
6193 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6194 boolean_false_node
, cond
);
6195 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6196 "Argument NCOPIES of REPEAT intrinsic is too large");
6198 /* Compute the destination length. */
6199 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6200 fold_convert (gfc_charlen_type_node
, slen
),
6201 fold_convert (gfc_charlen_type_node
, ncopies
));
6202 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6203 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6205 /* Generate the code to do the repeat operation:
6206 for (i = 0; i < ncopies; i++)
6207 memmove (dest + (i * slen * size), src, slen*size); */
6208 gfc_start_block (&block
);
6209 count
= gfc_create_var (ncopies_type
, "count");
6210 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6211 exit_label
= gfc_build_label_decl (NULL_TREE
);
6213 /* Start the loop body. */
6214 gfc_start_block (&body
);
6216 /* Exit the loop if count >= ncopies. */
6217 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6219 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6220 TREE_USED (exit_label
) = 1;
6221 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6222 build_empty_stmt (input_location
));
6223 gfc_add_expr_to_block (&body
, tmp
);
6225 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6226 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6227 fold_convert (gfc_charlen_type_node
, slen
),
6228 fold_convert (gfc_charlen_type_node
, count
));
6229 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6230 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6231 tmp
= fold_build_pointer_plus_loc (input_location
,
6232 fold_convert (pvoid_type_node
, dest
), tmp
);
6233 tmp
= build_call_expr_loc (input_location
,
6234 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6236 fold_build2_loc (input_location
, MULT_EXPR
,
6237 size_type_node
, slen
,
6238 fold_convert (size_type_node
,
6240 gfc_add_expr_to_block (&body
, tmp
);
6242 /* Increment count. */
6243 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6244 count
, build_int_cst (TREE_TYPE (count
), 1));
6245 gfc_add_modify (&body
, count
, tmp
);
6247 /* Build the loop. */
6248 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6249 gfc_add_expr_to_block (&block
, tmp
);
6251 /* Add the exit label. */
6252 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6253 gfc_add_expr_to_block (&block
, tmp
);
6255 /* Finish the block. */
6256 tmp
= gfc_finish_block (&block
);
6257 gfc_add_expr_to_block (&se
->pre
, tmp
);
6259 /* Set the result value. */
6261 se
->string_length
= dlen
;
6265 /* Generate code for the IARGC intrinsic. */
6268 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6274 /* Call the library function. This always returns an INTEGER(4). */
6275 fndecl
= gfor_fndecl_iargc
;
6276 tmp
= build_call_expr_loc (input_location
,
6279 /* Convert it to the required type. */
6280 type
= gfc_typenode_for_spec (&expr
->ts
);
6281 tmp
= fold_convert (type
, tmp
);
6287 /* The loc intrinsic returns the address of its argument as
6288 gfc_index_integer_kind integer. */
6291 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
6296 gcc_assert (!se
->ss
);
6298 arg_expr
= expr
->value
.function
.actual
->expr
;
6299 if (arg_expr
->rank
== 0)
6300 gfc_conv_expr_reference (se
, arg_expr
);
6302 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
6303 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
6305 /* Create a temporary variable for loc return value. Without this,
6306 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6307 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
6308 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
6309 se
->expr
= temp_var
;
6312 /* Generate code for an intrinsic function. Some map directly to library
6313 calls, others get special handling. In some cases the name of the function
6314 used depends on the type specifiers. */
6317 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
6323 name
= &expr
->value
.function
.name
[2];
6327 lib
= gfc_is_intrinsic_libcall (expr
);
6331 se
->ignore_optional
= 1;
6333 switch (expr
->value
.function
.isym
->id
)
6335 case GFC_ISYM_EOSHIFT
:
6337 case GFC_ISYM_RESHAPE
:
6338 /* For all of those the first argument specifies the type and the
6339 third is optional. */
6340 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
6344 gfc_conv_intrinsic_funcall (se
, expr
);
6352 switch (expr
->value
.function
.isym
->id
)
6357 case GFC_ISYM_REPEAT
:
6358 gfc_conv_intrinsic_repeat (se
, expr
);
6362 gfc_conv_intrinsic_trim (se
, expr
);
6365 case GFC_ISYM_SC_KIND
:
6366 gfc_conv_intrinsic_sc_kind (se
, expr
);
6369 case GFC_ISYM_SI_KIND
:
6370 gfc_conv_intrinsic_si_kind (se
, expr
);
6373 case GFC_ISYM_SR_KIND
:
6374 gfc_conv_intrinsic_sr_kind (se
, expr
);
6377 case GFC_ISYM_EXPONENT
:
6378 gfc_conv_intrinsic_exponent (se
, expr
);
6382 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6384 fndecl
= gfor_fndecl_string_scan
;
6386 fndecl
= gfor_fndecl_string_scan_char4
;
6390 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6393 case GFC_ISYM_VERIFY
:
6394 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6396 fndecl
= gfor_fndecl_string_verify
;
6398 fndecl
= gfor_fndecl_string_verify_char4
;
6402 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6405 case GFC_ISYM_ALLOCATED
:
6406 gfc_conv_allocated (se
, expr
);
6409 case GFC_ISYM_ASSOCIATED
:
6410 gfc_conv_associated(se
, expr
);
6413 case GFC_ISYM_SAME_TYPE_AS
:
6414 gfc_conv_same_type_as (se
, expr
);
6418 gfc_conv_intrinsic_abs (se
, expr
);
6421 case GFC_ISYM_ADJUSTL
:
6422 if (expr
->ts
.kind
== 1)
6423 fndecl
= gfor_fndecl_adjustl
;
6424 else if (expr
->ts
.kind
== 4)
6425 fndecl
= gfor_fndecl_adjustl_char4
;
6429 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6432 case GFC_ISYM_ADJUSTR
:
6433 if (expr
->ts
.kind
== 1)
6434 fndecl
= gfor_fndecl_adjustr
;
6435 else if (expr
->ts
.kind
== 4)
6436 fndecl
= gfor_fndecl_adjustr_char4
;
6440 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6443 case GFC_ISYM_AIMAG
:
6444 gfc_conv_intrinsic_imagpart (se
, expr
);
6448 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
6452 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
6455 case GFC_ISYM_ANINT
:
6456 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
6460 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6464 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
6467 case GFC_ISYM_BTEST
:
6468 gfc_conv_intrinsic_btest (se
, expr
);
6472 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
6476 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
6480 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
6484 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
6487 case GFC_ISYM_ACHAR
:
6489 gfc_conv_intrinsic_char (se
, expr
);
6492 case GFC_ISYM_CONVERSION
:
6494 case GFC_ISYM_LOGICAL
:
6496 gfc_conv_intrinsic_conversion (se
, expr
);
6499 /* Integer conversions are handled separately to make sure we get the
6500 correct rounding mode. */
6505 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
6509 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
6512 case GFC_ISYM_CEILING
:
6513 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
6516 case GFC_ISYM_FLOOR
:
6517 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
6521 gfc_conv_intrinsic_mod (se
, expr
, 0);
6524 case GFC_ISYM_MODULO
:
6525 gfc_conv_intrinsic_mod (se
, expr
, 1);
6528 case GFC_ISYM_CMPLX
:
6529 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
6532 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
6533 gfc_conv_intrinsic_iargc (se
, expr
);
6536 case GFC_ISYM_COMPLEX
:
6537 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
6540 case GFC_ISYM_CONJG
:
6541 gfc_conv_intrinsic_conjg (se
, expr
);
6544 case GFC_ISYM_COUNT
:
6545 gfc_conv_intrinsic_count (se
, expr
);
6548 case GFC_ISYM_CTIME
:
6549 gfc_conv_intrinsic_ctime (se
, expr
);
6553 gfc_conv_intrinsic_dim (se
, expr
);
6556 case GFC_ISYM_DOT_PRODUCT
:
6557 gfc_conv_intrinsic_dot_product (se
, expr
);
6560 case GFC_ISYM_DPROD
:
6561 gfc_conv_intrinsic_dprod (se
, expr
);
6564 case GFC_ISYM_DSHIFTL
:
6565 gfc_conv_intrinsic_dshift (se
, expr
, true);
6568 case GFC_ISYM_DSHIFTR
:
6569 gfc_conv_intrinsic_dshift (se
, expr
, false);
6572 case GFC_ISYM_FDATE
:
6573 gfc_conv_intrinsic_fdate (se
, expr
);
6576 case GFC_ISYM_FRACTION
:
6577 gfc_conv_intrinsic_fraction (se
, expr
);
6581 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
6585 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6589 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
6592 case GFC_ISYM_IBCLR
:
6593 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
6596 case GFC_ISYM_IBITS
:
6597 gfc_conv_intrinsic_ibits (se
, expr
);
6600 case GFC_ISYM_IBSET
:
6601 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
6604 case GFC_ISYM_IACHAR
:
6605 case GFC_ISYM_ICHAR
:
6606 /* We assume ASCII character sequence. */
6607 gfc_conv_intrinsic_ichar (se
, expr
);
6610 case GFC_ISYM_IARGC
:
6611 gfc_conv_intrinsic_iargc (se
, expr
);
6615 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6618 case GFC_ISYM_INDEX
:
6619 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6621 fndecl
= gfor_fndecl_string_index
;
6623 fndecl
= gfor_fndecl_string_index_char4
;
6627 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6631 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6634 case GFC_ISYM_IPARITY
:
6635 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
6638 case GFC_ISYM_IS_IOSTAT_END
:
6639 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
6642 case GFC_ISYM_IS_IOSTAT_EOR
:
6643 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
6646 case GFC_ISYM_ISNAN
:
6647 gfc_conv_intrinsic_isnan (se
, expr
);
6650 case GFC_ISYM_LSHIFT
:
6651 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6654 case GFC_ISYM_RSHIFT
:
6655 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6658 case GFC_ISYM_SHIFTA
:
6659 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6662 case GFC_ISYM_SHIFTL
:
6663 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6666 case GFC_ISYM_SHIFTR
:
6667 gfc_conv_intrinsic_shift (se
, expr
, true, false);
6670 case GFC_ISYM_ISHFT
:
6671 gfc_conv_intrinsic_ishft (se
, expr
);
6674 case GFC_ISYM_ISHFTC
:
6675 gfc_conv_intrinsic_ishftc (se
, expr
);
6678 case GFC_ISYM_LEADZ
:
6679 gfc_conv_intrinsic_leadz (se
, expr
);
6682 case GFC_ISYM_TRAILZ
:
6683 gfc_conv_intrinsic_trailz (se
, expr
);
6686 case GFC_ISYM_POPCNT
:
6687 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
6690 case GFC_ISYM_POPPAR
:
6691 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
6694 case GFC_ISYM_LBOUND
:
6695 gfc_conv_intrinsic_bound (se
, expr
, 0);
6698 case GFC_ISYM_LCOBOUND
:
6699 conv_intrinsic_cobound (se
, expr
);
6702 case GFC_ISYM_TRANSPOSE
:
6703 /* The scalarizer has already been set up for reversed dimension access
6704 order ; now we just get the argument value normally. */
6705 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
6709 gfc_conv_intrinsic_len (se
, expr
);
6712 case GFC_ISYM_LEN_TRIM
:
6713 gfc_conv_intrinsic_len_trim (se
, expr
);
6717 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
6721 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
6725 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
6729 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
6732 case GFC_ISYM_MASKL
:
6733 gfc_conv_intrinsic_mask (se
, expr
, 1);
6736 case GFC_ISYM_MASKR
:
6737 gfc_conv_intrinsic_mask (se
, expr
, 0);
6741 if (expr
->ts
.type
== BT_CHARACTER
)
6742 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
6744 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
6747 case GFC_ISYM_MAXLOC
:
6748 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
6751 case GFC_ISYM_MAXVAL
:
6752 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
6755 case GFC_ISYM_MERGE
:
6756 gfc_conv_intrinsic_merge (se
, expr
);
6759 case GFC_ISYM_MERGE_BITS
:
6760 gfc_conv_intrinsic_merge_bits (se
, expr
);
6764 if (expr
->ts
.type
== BT_CHARACTER
)
6765 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
6767 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
6770 case GFC_ISYM_MINLOC
:
6771 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
6774 case GFC_ISYM_MINVAL
:
6775 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
6778 case GFC_ISYM_NEAREST
:
6779 gfc_conv_intrinsic_nearest (se
, expr
);
6782 case GFC_ISYM_NORM2
:
6783 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
6787 gfc_conv_intrinsic_not (se
, expr
);
6791 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6794 case GFC_ISYM_PARITY
:
6795 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
6798 case GFC_ISYM_PRESENT
:
6799 gfc_conv_intrinsic_present (se
, expr
);
6802 case GFC_ISYM_PRODUCT
:
6803 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
6807 gfc_conv_intrinsic_rank (se
, expr
);
6810 case GFC_ISYM_RRSPACING
:
6811 gfc_conv_intrinsic_rrspacing (se
, expr
);
6814 case GFC_ISYM_SET_EXPONENT
:
6815 gfc_conv_intrinsic_set_exponent (se
, expr
);
6818 case GFC_ISYM_SCALE
:
6819 gfc_conv_intrinsic_scale (se
, expr
);
6823 gfc_conv_intrinsic_sign (se
, expr
);
6827 gfc_conv_intrinsic_size (se
, expr
);
6830 case GFC_ISYM_SIZEOF
:
6831 case GFC_ISYM_C_SIZEOF
:
6832 gfc_conv_intrinsic_sizeof (se
, expr
);
6835 case GFC_ISYM_STORAGE_SIZE
:
6836 gfc_conv_intrinsic_storage_size (se
, expr
);
6839 case GFC_ISYM_SPACING
:
6840 gfc_conv_intrinsic_spacing (se
, expr
);
6843 case GFC_ISYM_STRIDE
:
6844 conv_intrinsic_stride (se
, expr
);
6848 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
6851 case GFC_ISYM_TRANSFER
:
6852 if (se
->ss
&& se
->ss
->info
->useflags
)
6853 /* Access the previously obtained result. */
6854 gfc_conv_tmp_array_ref (se
);
6856 gfc_conv_intrinsic_transfer (se
, expr
);
6859 case GFC_ISYM_TTYNAM
:
6860 gfc_conv_intrinsic_ttynam (se
, expr
);
6863 case GFC_ISYM_UBOUND
:
6864 gfc_conv_intrinsic_bound (se
, expr
, 1);
6867 case GFC_ISYM_UCOBOUND
:
6868 conv_intrinsic_cobound (se
, expr
);
6872 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6876 gfc_conv_intrinsic_loc (se
, expr
);
6879 case GFC_ISYM_THIS_IMAGE
:
6880 /* For num_images() == 1, handle as LCOBOUND. */
6881 if (expr
->value
.function
.actual
->expr
6882 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
6883 conv_intrinsic_cobound (se
, expr
);
6885 trans_this_image (se
, expr
);
6888 case GFC_ISYM_IMAGE_INDEX
:
6889 trans_image_index (se
, expr
);
6892 case GFC_ISYM_NUM_IMAGES
:
6893 trans_num_images (se
);
6896 case GFC_ISYM_ACCESS
:
6897 case GFC_ISYM_CHDIR
:
6898 case GFC_ISYM_CHMOD
:
6899 case GFC_ISYM_DTIME
:
6900 case GFC_ISYM_ETIME
:
6901 case GFC_ISYM_EXTENDS_TYPE_OF
:
6903 case GFC_ISYM_FGETC
:
6906 case GFC_ISYM_FPUTC
:
6907 case GFC_ISYM_FSTAT
:
6908 case GFC_ISYM_FTELL
:
6909 case GFC_ISYM_GETCWD
:
6910 case GFC_ISYM_GETGID
:
6911 case GFC_ISYM_GETPID
:
6912 case GFC_ISYM_GETUID
:
6913 case GFC_ISYM_HOSTNM
:
6915 case GFC_ISYM_IERRNO
:
6916 case GFC_ISYM_IRAND
:
6917 case GFC_ISYM_ISATTY
:
6920 case GFC_ISYM_LSTAT
:
6921 case GFC_ISYM_MALLOC
:
6922 case GFC_ISYM_MATMUL
:
6923 case GFC_ISYM_MCLOCK
:
6924 case GFC_ISYM_MCLOCK8
:
6926 case GFC_ISYM_RENAME
:
6927 case GFC_ISYM_SECOND
:
6928 case GFC_ISYM_SECNDS
:
6929 case GFC_ISYM_SIGNAL
:
6931 case GFC_ISYM_SYMLNK
:
6932 case GFC_ISYM_SYSTEM
:
6934 case GFC_ISYM_TIME8
:
6935 case GFC_ISYM_UMASK
:
6936 case GFC_ISYM_UNLINK
:
6938 gfc_conv_intrinsic_funcall (se
, expr
);
6941 case GFC_ISYM_EOSHIFT
:
6943 case GFC_ISYM_RESHAPE
:
6944 /* For those, expr->rank should always be >0 and thus the if above the
6945 switch should have matched. */
6950 gfc_conv_intrinsic_lib_function (se
, expr
);
6957 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
6959 gfc_ss
*arg_ss
, *tmp_ss
;
6960 gfc_actual_arglist
*arg
;
6962 arg
= expr
->value
.function
.actual
;
6964 gcc_assert (arg
->expr
);
6966 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
6967 gcc_assert (arg_ss
!= gfc_ss_terminator
);
6969 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
6971 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
6972 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
6976 gcc_assert (tmp_ss
->dimen
== 2);
6978 /* We just invert dimensions. */
6979 tmp_dim
= tmp_ss
->dim
[0];
6980 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
6981 tmp_ss
->dim
[1] = tmp_dim
;
6984 /* Stop when tmp_ss points to the last valid element of the chain... */
6985 if (tmp_ss
->next
== gfc_ss_terminator
)
6989 /* ... so that we can attach the rest of the chain to it. */
6996 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
6997 This has the side effect of reversing the nested list, so there is no
6998 need to call gfc_reverse_ss on it (the given list is assumed not to be
7002 nest_loop_dimension (gfc_ss
*ss
, int dim
)
7005 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
7006 gfc_loopinfo
*new_loop
;
7008 gcc_assert (ss
!= gfc_ss_terminator
);
7010 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
7012 new_ss
= gfc_get_ss ();
7013 new_ss
->next
= prev_ss
;
7014 new_ss
->parent
= ss
;
7015 new_ss
->info
= ss
->info
;
7016 new_ss
->info
->refcount
++;
7019 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
7020 && ss
->info
->type
!= GFC_SS_REFERENCE
);
7023 new_ss
->dim
[0] = ss
->dim
[dim
];
7025 gcc_assert (dim
< ss
->dimen
);
7027 ss_dim
= --ss
->dimen
;
7028 for (i
= dim
; i
< ss_dim
; i
++)
7029 ss
->dim
[i
] = ss
->dim
[i
+ 1];
7031 ss
->dim
[ss_dim
] = 0;
7037 ss
->nested_ss
->parent
= new_ss
;
7038 new_ss
->nested_ss
= ss
->nested_ss
;
7040 ss
->nested_ss
= new_ss
;
7043 new_loop
= gfc_get_loopinfo ();
7044 gfc_init_loopinfo (new_loop
);
7046 gcc_assert (prev_ss
!= NULL
);
7047 gcc_assert (prev_ss
!= gfc_ss_terminator
);
7048 gfc_add_ss_to_loop (new_loop
, prev_ss
);
7049 return new_ss
->parent
;
7053 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
7054 is to be inlined. */
7057 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
7059 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
7060 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
7062 bool scalar_mask
= false;
7064 /* The rank of the result will be determined later. */
7065 arg1
= expr
->value
.function
.actual
;
7068 gcc_assert (arg3
!= NULL
);
7070 if (expr
->rank
== 0)
7073 tmp_ss
= gfc_ss_terminator
;
7079 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
7080 if (mask_ss
== tmp_ss
)
7086 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
7087 gcc_assert (array_ss
!= tmp_ss
);
7089 /* Odd thing: If the mask is scalar, it is used by the frontend after
7090 the array (to make an if around the nested loop). Thus it shall
7091 be after array_ss once the gfc_ss list is reversed. */
7093 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
7097 /* "Hide" the dimension on which we will sum in the first arg's scalarization
7099 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
7100 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
7108 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
7111 switch (expr
->value
.function
.isym
->id
)
7113 case GFC_ISYM_PRODUCT
:
7115 return walk_inline_intrinsic_arith (ss
, expr
);
7117 case GFC_ISYM_TRANSPOSE
:
7118 return walk_inline_intrinsic_transpose (ss
, expr
);
7127 /* This generates code to execute before entering the scalarization loop.
7128 Currently does nothing. */
7131 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
7133 switch (ss
->info
->expr
->value
.function
.isym
->id
)
7135 case GFC_ISYM_UBOUND
:
7136 case GFC_ISYM_LBOUND
:
7137 case GFC_ISYM_UCOBOUND
:
7138 case GFC_ISYM_LCOBOUND
:
7139 case GFC_ISYM_THIS_IMAGE
:
7148 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
7149 are expanded into code inside the scalarization loop. */
7152 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
7154 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
7155 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
7157 /* The two argument version returns a scalar. */
7158 if (expr
->value
.function
.actual
->next
->expr
)
7161 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
7165 /* Walk an intrinsic array libcall. */
7168 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
7170 gcc_assert (expr
->rank
> 0);
7171 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
7175 /* Return whether the function call expression EXPR will be expanded
7176 inline by gfc_conv_intrinsic_function. */
7179 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
7181 gfc_actual_arglist
*args
;
7183 if (!expr
->value
.function
.isym
)
7186 switch (expr
->value
.function
.isym
->id
)
7188 case GFC_ISYM_PRODUCT
:
7190 /* Disable inline expansion if code size matters. */
7194 args
= expr
->value
.function
.actual
;
7195 /* We need to be able to subset the SUM argument at compile-time. */
7196 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
7201 case GFC_ISYM_TRANSPOSE
:
7210 /* Returns nonzero if the specified intrinsic function call maps directly to
7211 an external library call. Should only be used for functions that return
7215 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
7217 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
7218 gcc_assert (expr
->rank
> 0);
7220 if (gfc_inline_intrinsic_function_p (expr
))
7223 switch (expr
->value
.function
.isym
->id
)
7227 case GFC_ISYM_COUNT
:
7231 case GFC_ISYM_IPARITY
:
7232 case GFC_ISYM_MATMUL
:
7233 case GFC_ISYM_MAXLOC
:
7234 case GFC_ISYM_MAXVAL
:
7235 case GFC_ISYM_MINLOC
:
7236 case GFC_ISYM_MINVAL
:
7237 case GFC_ISYM_NORM2
:
7238 case GFC_ISYM_PARITY
:
7239 case GFC_ISYM_PRODUCT
:
7241 case GFC_ISYM_SHAPE
:
7242 case GFC_ISYM_SPREAD
:
7244 /* Ignore absent optional parameters. */
7247 case GFC_ISYM_RESHAPE
:
7248 case GFC_ISYM_CSHIFT
:
7249 case GFC_ISYM_EOSHIFT
:
7251 case GFC_ISYM_UNPACK
:
7252 /* Pass absent optional parameters. */
7260 /* Walk an intrinsic function. */
7262 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
7263 gfc_intrinsic_sym
* isym
)
7267 if (isym
->elemental
)
7268 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
7269 NULL
, GFC_SS_SCALAR
);
7271 if (expr
->rank
== 0)
7274 if (gfc_inline_intrinsic_function_p (expr
))
7275 return walk_inline_intrinsic_function (ss
, expr
);
7277 if (gfc_is_intrinsic_libcall (expr
))
7278 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7280 /* Special cases. */
7283 case GFC_ISYM_LBOUND
:
7284 case GFC_ISYM_LCOBOUND
:
7285 case GFC_ISYM_UBOUND
:
7286 case GFC_ISYM_UCOBOUND
:
7287 case GFC_ISYM_THIS_IMAGE
:
7288 return gfc_walk_intrinsic_bound (ss
, expr
);
7290 case GFC_ISYM_TRANSFER
:
7291 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7294 /* This probably meant someone forgot to add an intrinsic to the above
7295 list(s) when they implemented it, or something's gone horribly
7303 conv_intrinsic_atomic_def (gfc_code
*code
)
7308 gfc_init_se (&atom
, NULL
);
7309 gfc_init_se (&value
, NULL
);
7310 gfc_conv_expr (&atom
, code
->ext
.actual
->expr
);
7311 gfc_conv_expr (&value
, code
->ext
.actual
->next
->expr
);
7313 gfc_init_block (&block
);
7314 gfc_add_modify (&block
, atom
.expr
,
7315 fold_convert (TREE_TYPE (atom
.expr
), value
.expr
));
7316 return gfc_finish_block (&block
);
7321 conv_intrinsic_atomic_ref (gfc_code
*code
)
7326 gfc_init_se (&atom
, NULL
);
7327 gfc_init_se (&value
, NULL
);
7328 gfc_conv_expr (&value
, code
->ext
.actual
->expr
);
7329 gfc_conv_expr (&atom
, code
->ext
.actual
->next
->expr
);
7331 gfc_init_block (&block
);
7332 gfc_add_modify (&block
, value
.expr
,
7333 fold_convert (TREE_TYPE (value
.expr
), atom
.expr
));
7334 return gfc_finish_block (&block
);
7339 conv_intrinsic_move_alloc (gfc_code
*code
)
7342 gfc_expr
*from_expr
, *to_expr
;
7343 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
7344 gfc_se from_se
, to_se
;
7348 gfc_start_block (&block
);
7350 from_expr
= code
->ext
.actual
->expr
;
7351 to_expr
= code
->ext
.actual
->next
->expr
;
7353 gfc_init_se (&from_se
, NULL
);
7354 gfc_init_se (&to_se
, NULL
);
7356 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
7357 || to_expr
->ts
.type
== BT_CLASS
);
7358 coarray
= gfc_get_corank (from_expr
) != 0;
7360 if (from_expr
->rank
== 0 && !coarray
)
7362 if (from_expr
->ts
.type
!= BT_CLASS
)
7363 from_expr2
= from_expr
;
7366 from_expr2
= gfc_copy_expr (from_expr
);
7367 gfc_add_data_component (from_expr2
);
7370 if (to_expr
->ts
.type
!= BT_CLASS
)
7374 to_expr2
= gfc_copy_expr (to_expr
);
7375 gfc_add_data_component (to_expr2
);
7378 from_se
.want_pointer
= 1;
7379 to_se
.want_pointer
= 1;
7380 gfc_conv_expr (&from_se
, from_expr2
);
7381 gfc_conv_expr (&to_se
, to_expr2
);
7382 gfc_add_block_to_block (&block
, &from_se
.pre
);
7383 gfc_add_block_to_block (&block
, &to_se
.pre
);
7385 /* Deallocate "to". */
7386 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
7387 to_expr
, to_expr
->ts
);
7388 gfc_add_expr_to_block (&block
, tmp
);
7390 /* Assign (_data) pointers. */
7391 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7392 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
7394 /* Set "from" to NULL. */
7395 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7396 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
7398 gfc_add_block_to_block (&block
, &from_se
.post
);
7399 gfc_add_block_to_block (&block
, &to_se
.post
);
7402 if (to_expr
->ts
.type
== BT_CLASS
)
7406 gfc_free_expr (to_expr2
);
7407 gfc_init_se (&to_se
, NULL
);
7408 to_se
.want_pointer
= 1;
7409 gfc_add_vptr_component (to_expr
);
7410 gfc_conv_expr (&to_se
, to_expr
);
7412 if (from_expr
->ts
.type
== BT_CLASS
)
7414 if (UNLIMITED_POLY (from_expr
))
7418 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7422 gfc_free_expr (from_expr2
);
7423 gfc_init_se (&from_se
, NULL
);
7424 from_se
.want_pointer
= 1;
7425 gfc_add_vptr_component (from_expr
);
7426 gfc_conv_expr (&from_se
, from_expr
);
7427 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7428 fold_convert (TREE_TYPE (to_se
.expr
),
7431 /* Reset _vptr component to declared type. */
7432 if (UNLIMITED_POLY (from_expr
))
7433 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7434 fold_convert (TREE_TYPE (from_se
.expr
),
7435 null_pointer_node
));
7438 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7439 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7440 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
7445 if (from_expr
->ts
.type
!= BT_DERIVED
)
7446 vtab
= gfc_find_intrinsic_vtab (&from_expr
->ts
);
7448 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7450 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7451 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7452 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7456 return gfc_finish_block (&block
);
7459 /* Update _vptr component. */
7460 if (to_expr
->ts
.type
== BT_CLASS
)
7464 to_se
.want_pointer
= 1;
7465 to_expr2
= gfc_copy_expr (to_expr
);
7466 gfc_add_vptr_component (to_expr2
);
7467 gfc_conv_expr (&to_se
, to_expr2
);
7469 if (from_expr
->ts
.type
== BT_CLASS
)
7471 if (UNLIMITED_POLY (from_expr
))
7475 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7479 from_se
.want_pointer
= 1;
7480 from_expr2
= gfc_copy_expr (from_expr
);
7481 gfc_add_vptr_component (from_expr2
);
7482 gfc_conv_expr (&from_se
, from_expr2
);
7483 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7484 fold_convert (TREE_TYPE (to_se
.expr
),
7487 /* Reset _vptr component to declared type. */
7488 if (UNLIMITED_POLY (from_expr
))
7489 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7490 fold_convert (TREE_TYPE (from_se
.expr
),
7491 null_pointer_node
));
7494 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7495 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7496 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
7501 if (from_expr
->ts
.type
!= BT_DERIVED
)
7502 vtab
= gfc_find_intrinsic_vtab (&from_expr
->ts
);
7504 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7506 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7507 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7508 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7511 gfc_free_expr (to_expr2
);
7512 gfc_init_se (&to_se
, NULL
);
7514 if (from_expr
->ts
.type
== BT_CLASS
)
7516 gfc_free_expr (from_expr2
);
7517 gfc_init_se (&from_se
, NULL
);
7522 /* Deallocate "to". */
7523 if (from_expr
->rank
== 0)
7525 to_se
.want_coarray
= 1;
7526 from_se
.want_coarray
= 1;
7528 gfc_conv_expr_descriptor (&to_se
, to_expr
);
7529 gfc_conv_expr_descriptor (&from_se
, from_expr
);
7531 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
7532 is an image control "statement", cf. IR F08/0040 in 12-006A. */
7533 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
7537 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
7538 NULL_TREE
, NULL_TREE
, true, to_expr
,
7540 gfc_add_expr_to_block (&block
, tmp
);
7542 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7543 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7544 boolean_type_node
, tmp
,
7545 fold_convert (TREE_TYPE (tmp
),
7546 null_pointer_node
));
7547 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
7548 3, null_pointer_node
, null_pointer_node
,
7549 build_int_cst (integer_type_node
, 0));
7551 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
7552 tmp
, build_empty_stmt (input_location
));
7553 gfc_add_expr_to_block (&block
, tmp
);
7557 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7558 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
7559 NULL_TREE
, true, to_expr
, false);
7560 gfc_add_expr_to_block (&block
, tmp
);
7563 /* Move the pointer and update the array descriptor data. */
7564 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
7566 /* Set "from" to NULL. */
7567 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
7568 gfc_add_modify_loc (input_location
, &block
, tmp
,
7569 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7571 return gfc_finish_block (&block
);
7576 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
7580 gcc_assert (code
->resolved_isym
);
7582 switch (code
->resolved_isym
->id
)
7584 case GFC_ISYM_MOVE_ALLOC
:
7585 res
= conv_intrinsic_move_alloc (code
);
7588 case GFC_ISYM_ATOMIC_DEF
:
7589 res
= conv_intrinsic_atomic_def (code
);
7592 case GFC_ISYM_ATOMIC_REF
:
7593 res
= conv_intrinsic_atomic_ref (code
);
7604 #include "gt-fortran-trans-intrinsic.h"