1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
28 #include "coretypes.h"
29 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "diagnostic-core.h" /* For internal_error. */
33 #include "toplev.h" /* For rest_of_decl_compilation. */
37 #include "intrinsic.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps Fortran intrinsic math functions to external library or GCC
47 typedef struct GTY(()) gfc_intrinsic_map_t
{
48 /* The explicit enum is required to work around inadequacies in the
49 garbage collection/gengtype parsing mechanism. */
52 /* Enum value from the "language-independent", aka C-centric, part
53 of gcc, or END_BUILTINS of no such value set. */
54 enum built_in_function float_built_in
;
55 enum built_in_function double_built_in
;
56 enum built_in_function long_double_built_in
;
57 enum built_in_function complex_float_built_in
;
58 enum built_in_function complex_double_built_in
;
59 enum built_in_function complex_long_double_built_in
;
61 /* True if the naming pattern is to prepend "c" for complex and
62 append "f" for kind=4. False if the naming pattern is to
63 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 /* True if a complex version of the function exists. */
67 bool complex_available
;
69 /* True if the function should be marked const. */
72 /* The base library name of this function. */
75 /* Cache decls created for the various operand types. */
87 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
88 defines complex variants of all of the entries in mathbuiltins.def
90 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
91 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
92 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
93 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
94 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
96 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
97 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
98 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
99 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
100 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
102 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
108 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
109 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
110 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
116 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
117 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
118 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
119 #include "mathbuiltins.def"
121 /* Functions in libgfortran. */
122 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
125 LIB_FUNCTION (NONE
, NULL
, false)
130 #undef DEFINE_MATH_BUILTIN
131 #undef DEFINE_MATH_BUILTIN_C
134 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
137 /* Find the correct variant of a given builtin from its argument. */
139 builtin_decl_for_precision (enum built_in_function base_built_in
,
142 enum built_in_function i
= END_BUILTINS
;
144 gfc_intrinsic_map_t
*m
;
145 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
148 if (precision
== TYPE_PRECISION (float_type_node
))
149 i
= m
->float_built_in
;
150 else if (precision
== TYPE_PRECISION (double_type_node
))
151 i
= m
->double_built_in
;
152 else if (precision
== TYPE_PRECISION (long_double_type_node
))
153 i
= m
->long_double_built_in
;
154 else if (precision
== TYPE_PRECISION (float128_type_node
))
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m
->real16_decl
;
161 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
169 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
171 if (gfc_real_kinds
[i
].c_float128
)
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t
*m
;
176 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
179 return m
->real16_decl
;
182 return builtin_decl_for_precision (double_built_in
,
183 gfc_real_kinds
[i
].mode_precision
);
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
193 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
194 tree
*argarray
, int nargs
)
196 gfc_actual_arglist
*actual
;
198 gfc_intrinsic_arg
*formal
;
202 formal
= expr
->value
.function
.isym
->formal
;
203 actual
= expr
->value
.function
.actual
;
205 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
206 actual
= actual
->next
,
207 formal
= formal
? formal
->next
: NULL
)
211 /* Skip omitted optional arguments. */
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse
, se
);
222 if (e
->ts
.type
== BT_CHARACTER
)
224 gfc_conv_expr (&argse
, e
);
225 gfc_conv_string_parameter (&argse
);
226 argarray
[curr_arg
++] = argse
.string_length
;
227 gcc_assert (curr_arg
< nargs
);
230 gfc_conv_expr_val (&argse
, e
);
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e
->expr_type
== EXPR_VARIABLE
235 && e
->symtree
->n
.sym
->attr
.optional
238 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
240 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
241 gfc_add_block_to_block (&se
->post
, &argse
.post
);
242 argarray
[curr_arg
] = argse
.expr
;
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
250 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
253 gfc_actual_arglist
*actual
;
255 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
260 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
274 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
280 nargs
= gfc_intrinsic_argument_list_length (expr
);
281 args
= XALLOCAVEC (tree
, nargs
);
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type
= gfc_typenode_for_spec (&expr
->ts
);
287 gcc_assert (expr
->value
.function
.actual
->expr
);
288 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
290 /* Conversion between character kinds involves a call to a library
292 if (expr
->ts
.type
== BT_CHARACTER
)
294 tree fndecl
, var
, addr
, tmp
;
296 if (expr
->ts
.kind
== 1
297 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
298 fndecl
= gfor_fndecl_convert_char4_to_char1
;
299 else if (expr
->ts
.kind
== 4
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
301 fndecl
= gfor_fndecl_convert_char1_to_char4
;
305 /* Create the variable storing the converted value. */
306 type
= gfc_get_pchar_type (expr
->ts
.kind
);
307 var
= gfc_create_var (type
, "str");
308 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs
>= 2);
312 tmp
= build_call_expr_loc (input_location
,
313 fndecl
, 3, addr
, args
[0], args
[1]);
314 gfc_add_expr_to_block (&se
->pre
, tmp
);
316 /* Free the temporary afterwards. */
317 tmp
= gfc_call_free (var
);
318 gfc_add_expr_to_block (&se
->post
, tmp
);
321 se
->string_length
= args
[0];
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
329 && expr
->ts
.type
!= BT_COMPLEX
)
333 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
334 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
338 se
->expr
= convert (type
, args
[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
354 argtype
= TREE_TYPE (arg
);
355 arg
= gfc_evaluate_now (arg
, pblock
);
357 intval
= convert (type
, arg
);
358 intval
= gfc_evaluate_now (intval
, pblock
);
360 tmp
= convert (argtype
, intval
);
361 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
362 boolean_type_node
, tmp
, arg
);
364 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
365 intval
, build_int_cst (type
, 1));
366 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg
, tree restype
)
378 int argprec
, resprec
;
380 argtype
= TREE_TYPE (arg
);
381 argprec
= TYPE_PRECISION (argtype
);
382 resprec
= TYPE_PRECISION (restype
);
384 /* Depending on the type of the result, choose the int intrinsic
385 (iround, available only as a builtin, therefore cannot use it for
386 __float128), long int intrinsic (lround family) or long long
387 intrinsic (llround). We might also need to convert the result
389 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
390 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
391 else if (resprec
<= LONG_TYPE_SIZE
)
392 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
393 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
394 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
398 return fold_convert (restype
, build_call_expr_loc (input_location
,
403 /* Convert a real to an integer using a specific rounding mode.
404 Ideally we would just build the corresponding GENERIC node,
405 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
408 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
409 enum rounding_mode op
)
414 return build_fixbound_expr (pblock
, arg
, type
, 0);
418 return build_fixbound_expr (pblock
, arg
, type
, 1);
422 return build_round_expr (arg
, type
);
426 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
435 /* Round a real value using the specified rounding mode.
436 We use a temporary integer of that same kind size as the result.
437 Values larger than those that can be represented by this kind are
438 unchanged, as they will not be accurate enough to represent the
440 huge = HUGE (KIND (a))
441 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
445 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
457 kind
= expr
->ts
.kind
;
458 nargs
= gfc_intrinsic_argument_list_length (expr
);
461 /* We have builtin functions for some cases. */
465 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
469 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
476 /* Evaluate the argument. */
477 gcc_assert (expr
->value
.function
.actual
->expr
);
478 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
480 /* Use a builtin function if one exists. */
481 if (decl
!= NULL_TREE
)
483 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
487 /* This code is probably redundant, but we'll keep it lying around just
489 type
= gfc_typenode_for_spec (&expr
->ts
);
490 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
492 /* Test if the value is too large to handle sensibly. */
493 gfc_set_model_kind (kind
);
495 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
496 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
497 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
498 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
501 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
502 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
503 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
505 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
507 itype
= gfc_get_int_type (kind
);
509 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
510 tmp
= convert (type
, tmp
);
511 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
517 /* Convert to an integer using the specified rounding mode. */
520 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
526 nargs
= gfc_intrinsic_argument_list_length (expr
);
527 args
= XALLOCAVEC (tree
, nargs
);
529 /* Evaluate the argument, we process all arguments even though we only
530 use the first one for code generation purposes. */
531 type
= gfc_typenode_for_spec (&expr
->ts
);
532 gcc_assert (expr
->value
.function
.actual
->expr
);
533 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
535 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
537 /* Conversion to a different integer kind. */
538 se
->expr
= convert (type
, args
[0]);
542 /* Conversion from complex to non-complex involves taking the real
543 component of the value. */
544 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
545 && expr
->ts
.type
!= BT_COMPLEX
)
549 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
550 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
554 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
559 /* Get the imaginary component of a value. */
562 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
566 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
567 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
568 TREE_TYPE (TREE_TYPE (arg
)), arg
);
572 /* Get the complex conjugate of a value. */
575 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
579 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
580 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
586 define_quad_builtin (const char *name
, tree type
, bool is_const
)
589 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
592 /* Mark the decl as external. */
593 DECL_EXTERNAL (fndecl
) = 1;
594 TREE_PUBLIC (fndecl
) = 1;
596 /* Mark it __attribute__((const)). */
597 TREE_READONLY (fndecl
) = is_const
;
599 rest_of_decl_compilation (fndecl
, 1, 0);
606 /* Initialize function decls for library functions. The external functions
607 are created as required. Builtin functions are added here. */
610 gfc_build_intrinsic_lib_fndecls (void)
612 gfc_intrinsic_map_t
*m
;
613 tree quad_decls
[END_BUILTINS
+ 1];
615 if (gfc_real16_is_float128
)
617 /* If we have soft-float types, we create the decls for their
618 C99-like library functions. For now, we only handle __float128
619 q-suffixed functions. */
621 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
622 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
624 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
626 type
= float128_type_node
;
627 complex_type
= complex_float128_type_node
;
628 /* type (*) (type) */
629 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
631 func_iround
= build_function_type_list (integer_type_node
,
633 /* long (*) (type) */
634 func_lround
= build_function_type_list (long_integer_type_node
,
636 /* long long (*) (type) */
637 func_llround
= build_function_type_list (long_long_integer_type_node
,
639 /* type (*) (type, type) */
640 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
641 /* type (*) (type, &int) */
643 = build_function_type_list (type
,
645 build_pointer_type (integer_type_node
),
647 /* type (*) (type, int) */
648 func_scalbn
= build_function_type_list (type
,
649 type
, integer_type_node
, NULL_TREE
);
650 /* type (*) (complex type) */
651 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
652 /* complex type (*) (complex type, complex type) */
654 = build_function_type_list (complex_type
,
655 complex_type
, complex_type
, NULL_TREE
);
657 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
658 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
659 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
661 /* Only these built-ins are actually needed here. These are used directly
662 from the code, when calling builtin_decl_for_precision() or
663 builtin_decl_for_float_type(). The others are all constructed by
664 gfc_get_intrinsic_lib_fndecl(). */
665 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
666 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
668 #include "mathbuiltins.def"
672 #undef DEFINE_MATH_BUILTIN
673 #undef DEFINE_MATH_BUILTIN_C
677 /* Add GCC builtin functions. */
678 for (m
= gfc_intrinsic_map
;
679 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
681 if (m
->float_built_in
!= END_BUILTINS
)
682 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
683 if (m
->complex_float_built_in
!= END_BUILTINS
)
684 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
685 if (m
->double_built_in
!= END_BUILTINS
)
686 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
687 if (m
->complex_double_built_in
!= END_BUILTINS
)
688 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
690 /* If real(kind=10) exists, it is always long double. */
691 if (m
->long_double_built_in
!= END_BUILTINS
)
692 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
693 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
695 = builtin_decl_explicit (m
->complex_long_double_built_in
);
697 if (!gfc_real16_is_float128
)
699 if (m
->long_double_built_in
!= END_BUILTINS
)
700 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
701 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
703 = builtin_decl_explicit (m
->complex_long_double_built_in
);
705 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m
->real16_decl
= quad_decls
[m
->double_built_in
];
712 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
714 /* Same thing for the complex ones. */
715 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
721 /* Create a fndecl for a simple intrinsic library function. */
724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
727 vec
<tree
, va_gc
> *argtypes
;
729 gfc_actual_arglist
*actual
;
732 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
735 if (ts
->type
== BT_REAL
)
740 pdecl
= &m
->real4_decl
;
743 pdecl
= &m
->real8_decl
;
746 pdecl
= &m
->real10_decl
;
749 pdecl
= &m
->real16_decl
;
755 else if (ts
->type
== BT_COMPLEX
)
757 gcc_assert (m
->complex_available
);
762 pdecl
= &m
->complex4_decl
;
765 pdecl
= &m
->complex8_decl
;
768 pdecl
= &m
->complex10_decl
;
771 pdecl
= &m
->complex16_decl
;
785 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
786 if (gfc_real_kinds
[n
].c_float
)
787 snprintf (name
, sizeof (name
), "%s%s%s",
788 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
789 else if (gfc_real_kinds
[n
].c_double
)
790 snprintf (name
, sizeof (name
), "%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
792 else if (gfc_real_kinds
[n
].c_long_double
)
793 snprintf (name
, sizeof (name
), "%s%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
795 else if (gfc_real_kinds
[n
].c_float128
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
803 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
804 ts
->type
== BT_COMPLEX
? 'c' : 'r',
809 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
811 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
812 vec_safe_push (argtypes
, type
);
814 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
815 fndecl
= build_decl (input_location
,
816 FUNCTION_DECL
, get_identifier (name
), type
);
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl
) = 1;
820 TREE_PUBLIC (fndecl
) = 1;
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl
) = m
->is_constant
;
825 rest_of_decl_compilation (fndecl
, 1, 0);
832 /* Convert an intrinsic function into an external or builtin call. */
835 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
837 gfc_intrinsic_map_t
*m
;
841 unsigned int num_args
;
844 id
= expr
->value
.function
.isym
->id
;
845 /* Find the entry for this function. */
846 for (m
= gfc_intrinsic_map
;
847 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
853 if (m
->id
== GFC_ISYM_NONE
)
855 internal_error ("Intrinsic function %s(%d) not recognized",
856 expr
->value
.function
.name
, id
);
859 /* Get the decl and generate the call. */
860 num_args
= gfc_intrinsic_argument_list_length (expr
);
861 args
= XALLOCAVEC (tree
, num_args
);
863 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
864 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
865 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
867 fndecl
= build_addr (fndecl
, current_function_decl
);
868 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
877 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
878 tree a
, tree b
, stmtblock_t
* target
)
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
887 /* Compare the two string lengths. */
888 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
890 /* Output the runtime-check. */
891 name
= gfc_build_cstring_const (intr_name
);
892 name
= gfc_build_addr_expr (pchar_type_node
, name
);
893 gfc_trans_runtime_check (true, false, cond
, target
, where
,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node
, a
),
896 fold_convert (long_integer_type_node
, b
), name
);
900 /* The EXPONENT(s) intrinsic function is translated into
907 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
909 tree arg
, type
, res
, tmp
, frexp
;
911 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
912 expr
->value
.function
.actual
->expr
->ts
.kind
);
914 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
916 res
= gfc_create_var (integer_type_node
, NULL
);
917 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
918 gfc_build_addr_expr (NULL_TREE
, res
));
919 gfc_add_expr_to_block (&se
->pre
, tmp
);
921 type
= gfc_typenode_for_spec (&expr
->ts
);
922 se
->expr
= fold_convert (type
, res
);
927 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
930 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
931 lbound
, ubound
, extent
, ml
;
935 /* The case -fcoarray=single is handled elsewhere. */
936 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
938 gfc_init_coarray_decl (false);
940 /* Argument-free version: THIS_IMAGE(). */
941 if (expr
->value
.function
.actual
->expr
== NULL
)
943 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
944 gfort_gvar_caf_this_image
);
948 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
950 type
= gfc_get_int_type (gfc_default_integer_kind
);
951 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
952 rank
= expr
->value
.function
.actual
->expr
->rank
;
954 /* Obtain the descriptor of the COARRAY. */
955 gfc_init_se (&argse
, NULL
);
956 argse
.want_coarray
= 1;
957 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
958 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
959 gfc_add_block_to_block (&se
->post
, &argse
.post
);
964 /* Create an implicit second parameter from the loop variable. */
965 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
966 gcc_assert (corank
> 0);
967 gcc_assert (se
->loop
->dimen
== 1);
968 gcc_assert (se
->ss
->info
->expr
== expr
);
970 dim_arg
= se
->loop
->loopvar
[0];
971 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
972 gfc_array_index_type
, dim_arg
,
973 build_int_cst (TREE_TYPE (dim_arg
), 1));
974 gfc_advance_se_ss_chain (se
);
978 /* Use the passed DIM= argument. */
979 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
980 gfc_init_se (&argse
, NULL
);
981 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
982 gfc_array_index_type
);
983 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
984 dim_arg
= argse
.expr
;
986 if (INTEGER_CST_P (dim_arg
))
990 hi
= TREE_INT_CST_HIGH (dim_arg
);
991 co_dim
= TREE_INT_CST_LOW (dim_arg
);
993 || co_dim
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
994 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
995 "dimension index", expr
->value
.function
.isym
->name
,
998 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1000 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1001 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1003 build_int_cst (TREE_TYPE (dim_arg
), 1));
1004 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1005 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1007 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1008 boolean_type_node
, cond
, tmp
);
1009 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1014 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1015 one always has a dim_arg argument.
1017 m = this_image() - 1
1020 sub(1) = m + lcobound(corank)
1024 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1027 extent = gfc_extent(i)
1035 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1036 : m + lcobound(corank)
1039 /* this_image () - 1. */
1040 tmp
= fold_convert (type
, gfort_gvar_caf_this_image
);
1041 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, tmp
,
1042 build_int_cst (type
, 1));
1045 /* sub(1) = m + lcobound(corank). */
1046 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1047 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1049 lbound
= fold_convert (type
, lbound
);
1050 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1056 m
= gfc_create_var (type
, NULL
);
1057 ml
= gfc_create_var (type
, NULL
);
1058 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1059 min_var
= gfc_create_var (integer_type_node
, NULL
);
1061 /* m = this_image () - 1. */
1062 gfc_add_modify (&se
->pre
, m
, tmp
);
1064 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1065 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1066 fold_convert (integer_type_node
, dim_arg
),
1067 build_int_cst (integer_type_node
, rank
- 1));
1068 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1069 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1071 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1074 tmp
= build_int_cst (integer_type_node
, rank
);
1075 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1077 exit_label
= gfc_build_label_decl (NULL_TREE
);
1078 TREE_USED (exit_label
) = 1;
1081 gfc_init_block (&loop
);
1084 gfc_add_modify (&loop
, ml
, m
);
1087 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1088 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1089 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1090 extent
= fold_convert (type
, extent
);
1093 gfc_add_modify (&loop
, m
,
1094 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1097 /* Exit condition: if (i >= min_var) goto exit_label. */
1098 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1100 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1101 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1102 build_empty_stmt (input_location
));
1103 gfc_add_expr_to_block (&loop
, tmp
);
1105 /* Increment loop variable: i++. */
1106 gfc_add_modify (&loop
, loop_var
,
1107 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1109 build_int_cst (integer_type_node
, 1)));
1111 /* Making the loop... actually loop! */
1112 tmp
= gfc_finish_block (&loop
);
1113 tmp
= build1_v (LOOP_EXPR
, tmp
);
1114 gfc_add_expr_to_block (&se
->pre
, tmp
);
1116 /* The exit label. */
1117 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1118 gfc_add_expr_to_block (&se
->pre
, tmp
);
1120 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1121 : m + lcobound(corank) */
1123 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1124 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1126 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1127 fold_build2_loc (input_location
, PLUS_EXPR
,
1128 gfc_array_index_type
, dim_arg
,
1129 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1130 lbound
= fold_convert (type
, lbound
);
1132 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1133 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1135 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1137 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1138 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1144 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1146 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1148 gfc_se argse
, subse
;
1149 int rank
, corank
, codim
;
1151 type
= gfc_get_int_type (gfc_default_integer_kind
);
1152 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1153 rank
= expr
->value
.function
.actual
->expr
->rank
;
1155 /* Obtain the descriptor of the COARRAY. */
1156 gfc_init_se (&argse
, NULL
);
1157 argse
.want_coarray
= 1;
1158 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1159 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1160 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1163 /* Obtain a handle to the SUB argument. */
1164 gfc_init_se (&subse
, NULL
);
1165 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
);
1166 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1167 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1168 subdesc
= build_fold_indirect_ref_loc (input_location
,
1169 gfc_conv_descriptor_data_get (subse
.expr
));
1171 /* Fortran 2008 does not require that the values remain in the cobounds,
1172 thus we need explicitly check this - and return 0 if they are exceeded. */
1174 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1175 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1176 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1177 fold_convert (gfc_array_index_type
, tmp
),
1180 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1182 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1183 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1184 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1185 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1186 fold_convert (gfc_array_index_type
, tmp
),
1188 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1189 boolean_type_node
, invalid_bound
, cond
);
1190 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1191 fold_convert (gfc_array_index_type
, tmp
),
1193 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1194 boolean_type_node
, invalid_bound
, cond
);
1197 invalid_bound
= gfc_unlikely (invalid_bound
);
1200 /* See Fortran 2008, C.10 for the following algorithm. */
1202 /* coindex = sub(corank) - lcobound(n). */
1203 coindex
= fold_convert (gfc_array_index_type
,
1204 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1206 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1207 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1208 fold_convert (gfc_array_index_type
, coindex
),
1211 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1213 tree extent
, ubound
;
1215 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1216 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1217 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1218 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1220 /* coindex *= extent. */
1221 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1222 gfc_array_index_type
, coindex
, extent
);
1224 /* coindex += sub(codim). */
1225 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1226 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1227 gfc_array_index_type
, coindex
,
1228 fold_convert (gfc_array_index_type
, tmp
));
1230 /* coindex -= lbound(codim). */
1231 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1232 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1233 gfc_array_index_type
, coindex
, lbound
);
1236 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1237 fold_convert(type
, coindex
),
1238 build_int_cst (type
, 1));
1240 /* Return 0 if "coindex" exceeds num_images(). */
1242 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1243 num_images
= build_int_cst (type
, 1);
1246 gfc_init_coarray_decl (false);
1247 num_images
= fold_convert (type
, gfort_gvar_caf_num_images
);
1250 tmp
= gfc_create_var (type
, NULL
);
1251 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1253 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1255 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1257 fold_convert (boolean_type_node
, invalid_bound
));
1258 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1259 build_int_cst (type
, 0), tmp
);
1264 trans_num_images (gfc_se
* se
)
1266 gfc_init_coarray_decl (false);
1267 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1268 gfort_gvar_caf_num_images
);
1273 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1277 gfc_init_se (&argse
, NULL
);
1278 argse
.data_not_needed
= 1;
1279 argse
.descriptor_only
= 1;
1281 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1282 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1283 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1285 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1289 /* Evaluate a single upper or lower bound. */
1290 /* TODO: bound intrinsic generates way too much unnecessary code. */
1293 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1295 gfc_actual_arglist
*arg
;
1296 gfc_actual_arglist
*arg2
;
1301 tree cond
, cond1
, cond3
, cond4
, size
;
1305 gfc_array_spec
* as
;
1306 bool assumed_rank_lb_one
;
1308 arg
= expr
->value
.function
.actual
;
1313 /* Create an implicit second parameter from the loop variable. */
1314 gcc_assert (!arg2
->expr
);
1315 gcc_assert (se
->loop
->dimen
== 1);
1316 gcc_assert (se
->ss
->info
->expr
== expr
);
1317 gfc_advance_se_ss_chain (se
);
1318 bound
= se
->loop
->loopvar
[0];
1319 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1320 gfc_array_index_type
, bound
,
1325 /* use the passed argument. */
1326 gcc_assert (arg2
->expr
);
1327 gfc_init_se (&argse
, NULL
);
1328 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1329 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1331 /* Convert from one based to zero based. */
1332 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1333 gfc_array_index_type
, bound
,
1334 gfc_index_one_node
);
1337 /* TODO: don't re-evaluate the descriptor on each iteration. */
1338 /* Get a descriptor for the first parameter. */
1339 gfc_init_se (&argse
, NULL
);
1340 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1341 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1342 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1346 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1348 if (INTEGER_CST_P (bound
))
1352 hi
= TREE_INT_CST_HIGH (bound
);
1353 low
= TREE_INT_CST_LOW (bound
);
1355 || ((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1356 && low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
1357 || low
> GFC_MAX_DIMENSIONS
)
1358 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1359 "dimension index", upper
? "UBOUND" : "LBOUND",
1363 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1365 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1367 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1368 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1369 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1370 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1371 tmp
= gfc_conv_descriptor_rank (desc
);
1373 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1374 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1375 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1376 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1377 boolean_type_node
, cond
, tmp
);
1378 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1383 /* Take care of the lbound shift for assumed-rank arrays, which are
1384 nonallocatable and nonpointers. Those has a lbound of 1. */
1385 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1386 && ((arg
->expr
->ts
.type
!= BT_CLASS
1387 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1388 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1389 || (arg
->expr
->ts
.type
== BT_CLASS
1390 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1391 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1393 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1394 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1396 /* 13.14.53: Result value for LBOUND
1398 Case (i): For an array section or for an array expression other than a
1399 whole array or array structure component, LBOUND(ARRAY, DIM)
1400 has the value 1. For a whole array or array structure
1401 component, LBOUND(ARRAY, DIM) has the value:
1402 (a) equal to the lower bound for subscript DIM of ARRAY if
1403 dimension DIM of ARRAY does not have extent zero
1404 or if ARRAY is an assumed-size array of rank DIM,
1407 13.14.113: Result value for UBOUND
1409 Case (i): For an array section or for an array expression other than a
1410 whole array or array structure component, UBOUND(ARRAY, DIM)
1411 has the value equal to the number of elements in the given
1412 dimension; otherwise, it has a value equal to the upper bound
1413 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1414 not have size zero and has value zero if dimension DIM has
1417 if (!upper
&& assumed_rank_lb_one
)
1418 se
->expr
= gfc_index_one_node
;
1421 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1423 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1425 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1426 stride
, gfc_index_zero_node
);
1427 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1428 boolean_type_node
, cond3
, cond1
);
1429 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1430 stride
, gfc_index_zero_node
);
1435 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1436 boolean_type_node
, cond3
, cond4
);
1437 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1438 gfc_index_one_node
, lbound
);
1439 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1440 boolean_type_node
, cond4
, cond5
);
1442 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1443 boolean_type_node
, cond
, cond5
);
1445 if (assumed_rank_lb_one
)
1447 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1448 gfc_array_index_type
, ubound
, lbound
);
1449 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1450 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1455 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1456 gfc_array_index_type
, cond
,
1457 tmp
, gfc_index_zero_node
);
1461 if (as
->type
== AS_ASSUMED_SIZE
)
1462 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1463 bound
, build_int_cst (TREE_TYPE (bound
),
1464 arg
->expr
->rank
- 1));
1466 cond
= boolean_false_node
;
1468 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1469 boolean_type_node
, cond3
, cond4
);
1470 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1471 boolean_type_node
, cond
, cond1
);
1473 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1474 gfc_array_index_type
, cond
,
1475 lbound
, gfc_index_one_node
);
1482 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1483 gfc_array_index_type
, ubound
, lbound
);
1484 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1485 gfc_array_index_type
, size
,
1486 gfc_index_one_node
);
1487 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1488 gfc_array_index_type
, se
->expr
,
1489 gfc_index_zero_node
);
1492 se
->expr
= gfc_index_one_node
;
1495 type
= gfc_typenode_for_spec (&expr
->ts
);
1496 se
->expr
= convert (type
, se
->expr
);
1501 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
1503 gfc_actual_arglist
*arg
;
1504 gfc_actual_arglist
*arg2
;
1506 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
1510 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
1511 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
1512 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
1514 arg
= expr
->value
.function
.actual
;
1517 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
1518 corank
= gfc_get_corank (arg
->expr
);
1520 gfc_init_se (&argse
, NULL
);
1521 argse
.want_coarray
= 1;
1523 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1524 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1525 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1530 /* Create an implicit second parameter from the loop variable. */
1531 gcc_assert (!arg2
->expr
);
1532 gcc_assert (corank
> 0);
1533 gcc_assert (se
->loop
->dimen
== 1);
1534 gcc_assert (se
->ss
->info
->expr
== expr
);
1536 bound
= se
->loop
->loopvar
[0];
1537 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1538 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
1539 gfc_advance_se_ss_chain (se
);
1543 /* use the passed argument. */
1544 gcc_assert (arg2
->expr
);
1545 gfc_init_se (&argse
, NULL
);
1546 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1547 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1550 if (INTEGER_CST_P (bound
))
1554 hi
= TREE_INT_CST_HIGH (bound
);
1555 low
= TREE_INT_CST_LOW (bound
);
1556 if (hi
|| low
< 1 || low
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
1557 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1558 "dimension index", expr
->value
.function
.isym
->name
,
1561 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1563 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1564 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1565 bound
, build_int_cst (TREE_TYPE (bound
), 1));
1566 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1567 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1569 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1570 boolean_type_node
, cond
, tmp
);
1571 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1576 /* Subtract 1 to get to zero based and add dimensions. */
1577 switch (arg
->expr
->rank
)
1580 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1581 gfc_array_index_type
, bound
,
1582 gfc_index_one_node
);
1586 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1587 gfc_array_index_type
, bound
,
1588 gfc_rank_cst
[arg
->expr
->rank
- 1]);
1592 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1594 /* Handle UCOBOUND with special handling of the last codimension. */
1595 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
1597 /* Last codimension: For -fcoarray=single just return
1598 the lcobound - otherwise add
1599 ceiling (real (num_images ()) / real (size)) - 1
1600 = (num_images () + size - 1) / size - 1
1601 = (num_images - 1) / size(),
1602 where size is the product of the extent of all but the last
1605 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
1609 gfc_init_coarray_decl (false);
1610 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
1612 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1613 gfc_array_index_type
,
1614 fold_convert (gfc_array_index_type
,
1615 gfort_gvar_caf_num_images
),
1616 build_int_cst (gfc_array_index_type
, 1));
1617 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1618 gfc_array_index_type
, tmp
,
1619 fold_convert (gfc_array_index_type
, cosize
));
1620 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1621 gfc_array_index_type
, resbound
, tmp
);
1623 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
1625 /* ubound = lbound + num_images() - 1. */
1626 gfc_init_coarray_decl (false);
1627 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1628 gfc_array_index_type
,
1629 fold_convert (gfc_array_index_type
,
1630 gfort_gvar_caf_num_images
),
1631 build_int_cst (gfc_array_index_type
, 1));
1632 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1633 gfc_array_index_type
, resbound
, tmp
);
1638 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1640 build_int_cst (TREE_TYPE (bound
),
1641 arg
->expr
->rank
+ corank
- 1));
1643 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1644 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1645 gfc_array_index_type
, cond
,
1646 resbound
, resbound2
);
1649 se
->expr
= resbound
;
1652 se
->expr
= resbound
;
1654 type
= gfc_typenode_for_spec (&expr
->ts
);
1655 se
->expr
= convert (type
, se
->expr
);
1660 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1664 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1666 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1670 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1675 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1676 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1685 /* Create a complex value from one or two real components. */
1688 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1694 unsigned int num_args
;
1696 num_args
= gfc_intrinsic_argument_list_length (expr
);
1697 args
= XALLOCAVEC (tree
, num_args
);
1699 type
= gfc_typenode_for_spec (&expr
->ts
);
1700 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1701 real
= convert (TREE_TYPE (type
), args
[0]);
1703 imag
= convert (TREE_TYPE (type
), args
[1]);
1704 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1706 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1707 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1708 imag
= convert (TREE_TYPE (type
), imag
);
1711 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1713 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1717 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1718 MODULO(A, P) = A - FLOOR (A / P) * P
1720 The obvious algorithms above are numerically instable for large
1721 arguments, hence these intrinsics are instead implemented via calls
1722 to the fmod family of functions. It is the responsibility of the
1723 user to ensure that the second argument is non-zero. */
1726 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1736 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1738 switch (expr
->ts
.type
)
1741 /* Integer case is easy, we've got a builtin op. */
1742 type
= TREE_TYPE (args
[0]);
1745 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
1748 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
1754 /* Check if we have a builtin fmod. */
1755 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1757 /* The builtin should always be available. */
1758 gcc_assert (fmod
!= NULL_TREE
);
1760 tmp
= build_addr (fmod
, current_function_decl
);
1761 se
->expr
= build_call_array_loc (input_location
,
1762 TREE_TYPE (TREE_TYPE (fmod
)),
1767 type
= TREE_TYPE (args
[0]);
1769 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1770 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1773 modulo = arg - floor (arg/arg2) * arg2
1775 In order to calculate the result accurately, we use the fmod
1776 function as follows.
1778 res = fmod (arg, arg2);
1781 if ((arg < 0) xor (arg2 < 0))
1785 res = copysign (0., arg2);
1787 => As two nested ternary exprs:
1789 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
1790 : copysign (0., arg2);
1794 zero
= gfc_build_const (type
, integer_zero_node
);
1795 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1796 if (!flag_signed_zeros
)
1798 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1800 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1802 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1803 boolean_type_node
, test
, test2
);
1804 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1806 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1807 boolean_type_node
, test
, test2
);
1808 test
= gfc_evaluate_now (test
, &se
->pre
);
1809 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1810 fold_build2_loc (input_location
,
1812 type
, tmp
, args
[1]),
1817 tree expr1
, copysign
, cscall
;
1818 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
1820 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1822 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1824 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1825 boolean_type_node
, test
, test2
);
1826 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
1827 fold_build2_loc (input_location
,
1829 type
, tmp
, args
[1]),
1831 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1833 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
1835 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1845 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1846 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1847 where the right shifts are logical (i.e. 0's are shifted in).
1848 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1849 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1851 DSHIFTL(I,J,BITSIZE) = J
1853 DSHIFTR(I,J,BITSIZE) = I. */
1856 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
1858 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
1859 tree args
[3], cond
, tmp
;
1862 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
1864 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
1865 type
= TREE_TYPE (args
[0]);
1866 bitsize
= TYPE_PRECISION (type
);
1867 utype
= unsigned_type_for (type
);
1868 stype
= TREE_TYPE (args
[2]);
1870 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
1871 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
1872 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
1874 /* The generic case. */
1875 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
1876 build_int_cst (stype
, bitsize
), shift
);
1877 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
1878 arg1
, dshiftl
? shift
: tmp
);
1880 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
1881 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
1882 right
= fold_convert (type
, right
);
1884 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
1886 /* Special cases. */
1887 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1888 build_int_cst (stype
, 0));
1889 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1890 dshiftl
? arg1
: arg2
, res
);
1892 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1893 build_int_cst (stype
, bitsize
));
1894 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1895 dshiftl
? arg2
: arg1
, res
);
1901 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1904 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1912 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1913 type
= TREE_TYPE (args
[0]);
1915 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
1916 val
= gfc_evaluate_now (val
, &se
->pre
);
1918 zero
= gfc_build_const (type
, integer_zero_node
);
1919 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
1920 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
1924 /* SIGN(A, B) is absolute value of A times sign of B.
1925 The real value versions use library functions to ensure the correct
1926 handling of negative zero. Integer case implemented as:
1927 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1931 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1937 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1938 if (expr
->ts
.type
== BT_REAL
)
1942 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1943 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1945 /* We explicitly have to ignore the minus sign. We do so by using
1946 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1947 if (!gfc_option
.flag_sign_zero
1948 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1951 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1952 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1954 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1955 TREE_TYPE (args
[0]), cond
,
1956 build_call_expr_loc (input_location
, abs
, 1,
1958 build_call_expr_loc (input_location
, tmp
, 2,
1962 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1967 /* Having excluded floating point types, we know we are now dealing
1968 with signed integer types. */
1969 type
= TREE_TYPE (args
[0]);
1971 /* Args[0] is used multiple times below. */
1972 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1974 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1975 the signs of A and B are the same, and of all ones if they differ. */
1976 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1977 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
1978 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1979 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1981 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1982 is all ones (i.e. -1). */
1983 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
1984 fold_build2_loc (input_location
, PLUS_EXPR
,
1985 type
, args
[0], tmp
), tmp
);
1989 /* Test for the presence of an optional argument. */
1992 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1996 arg
= expr
->value
.function
.actual
->expr
;
1997 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1998 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1999 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2003 /* Calculate the double precision product of two single precision values. */
2006 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2011 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2013 /* Convert the args to double precision before multiplying. */
2014 type
= gfc_typenode_for_spec (&expr
->ts
);
2015 args
[0] = convert (type
, args
[0]);
2016 args
[1] = convert (type
, args
[1]);
2017 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2022 /* Return a length one character string containing an ascii character. */
2025 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2030 unsigned int num_args
;
2032 num_args
= gfc_intrinsic_argument_list_length (expr
);
2033 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2035 type
= gfc_get_char_type (expr
->ts
.kind
);
2036 var
= gfc_create_var (type
, "char");
2038 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2039 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2040 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2041 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2046 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2054 unsigned int num_args
;
2056 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2057 args
= XALLOCAVEC (tree
, num_args
);
2059 var
= gfc_create_var (pchar_type_node
, "pstr");
2060 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2062 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2063 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2064 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2066 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2067 tmp
= build_call_array_loc (input_location
,
2068 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2069 fndecl
, num_args
, args
);
2070 gfc_add_expr_to_block (&se
->pre
, tmp
);
2072 /* Free the temporary afterwards, if necessary. */
2073 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2074 len
, build_int_cst (TREE_TYPE (len
), 0));
2075 tmp
= gfc_call_free (var
);
2076 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2077 gfc_add_expr_to_block (&se
->post
, tmp
);
2080 se
->string_length
= len
;
2085 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2093 unsigned int num_args
;
2095 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2096 args
= XALLOCAVEC (tree
, num_args
);
2098 var
= gfc_create_var (pchar_type_node
, "pstr");
2099 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2101 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2102 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2103 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2105 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2106 tmp
= build_call_array_loc (input_location
,
2107 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2108 fndecl
, num_args
, args
);
2109 gfc_add_expr_to_block (&se
->pre
, tmp
);
2111 /* Free the temporary afterwards, if necessary. */
2112 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2113 len
, build_int_cst (TREE_TYPE (len
), 0));
2114 tmp
= gfc_call_free (var
);
2115 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2116 gfc_add_expr_to_block (&se
->post
, tmp
);
2119 se
->string_length
= len
;
2123 /* Return a character string containing the tty name. */
2126 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2134 unsigned int num_args
;
2136 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2137 args
= XALLOCAVEC (tree
, num_args
);
2139 var
= gfc_create_var (pchar_type_node
, "pstr");
2140 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2142 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2143 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2144 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2146 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2147 tmp
= build_call_array_loc (input_location
,
2148 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2149 fndecl
, num_args
, args
);
2150 gfc_add_expr_to_block (&se
->pre
, tmp
);
2152 /* Free the temporary afterwards, if necessary. */
2153 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2154 len
, build_int_cst (TREE_TYPE (len
), 0));
2155 tmp
= gfc_call_free (var
);
2156 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2157 gfc_add_expr_to_block (&se
->post
, tmp
);
2160 se
->string_length
= len
;
2164 /* Get the minimum/maximum value of all the parameters.
2165 minmax (a1, a2, a3, ...)
2168 if (a2 .op. mvar || isnan(mvar))
2170 if (a3 .op. mvar || isnan(mvar))
2177 /* TODO: Mismatching types can occur when specific names are used.
2178 These should be handled during resolution. */
2180 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2188 gfc_actual_arglist
*argexpr
;
2189 unsigned int i
, nargs
;
2191 nargs
= gfc_intrinsic_argument_list_length (expr
);
2192 args
= XALLOCAVEC (tree
, nargs
);
2194 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2195 type
= gfc_typenode_for_spec (&expr
->ts
);
2197 argexpr
= expr
->value
.function
.actual
;
2198 if (TREE_TYPE (args
[0]) != type
)
2199 args
[0] = convert (type
, args
[0]);
2200 /* Only evaluate the argument once. */
2201 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2202 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2204 mvar
= gfc_create_var (type
, "M");
2205 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2206 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2212 /* Handle absent optional arguments by ignoring the comparison. */
2213 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2214 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2215 && TREE_CODE (val
) == INDIRECT_REF
)
2216 cond
= fold_build2_loc (input_location
,
2217 NE_EXPR
, boolean_type_node
,
2218 TREE_OPERAND (val
, 0),
2219 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2224 /* Only evaluate the argument once. */
2225 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2226 val
= gfc_evaluate_now (val
, &se
->pre
);
2229 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2231 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2232 convert (type
, val
), mvar
);
2234 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2235 __builtin_isnan might be made dependent on that module being loaded,
2236 to help performance of programs that don't rely on IEEE semantics. */
2237 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2239 isnan
= build_call_expr_loc (input_location
,
2240 builtin_decl_explicit (BUILT_IN_ISNAN
),
2242 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2243 boolean_type_node
, tmp
,
2244 fold_convert (boolean_type_node
, isnan
));
2246 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2247 build_empty_stmt (input_location
));
2249 if (cond
!= NULL_TREE
)
2250 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2251 build_empty_stmt (input_location
));
2253 gfc_add_expr_to_block (&se
->pre
, tmp
);
2254 argexpr
= argexpr
->next
;
2260 /* Generate library calls for MIN and MAX intrinsics for character
2263 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2266 tree var
, len
, fndecl
, tmp
, cond
, function
;
2269 nargs
= gfc_intrinsic_argument_list_length (expr
);
2270 args
= XALLOCAVEC (tree
, nargs
+ 4);
2271 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2273 /* Create the result variables. */
2274 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2275 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2276 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2277 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2278 args
[2] = build_int_cst (integer_type_node
, op
);
2279 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2281 if (expr
->ts
.kind
== 1)
2282 function
= gfor_fndecl_string_minmax
;
2283 else if (expr
->ts
.kind
== 4)
2284 function
= gfor_fndecl_string_minmax_char4
;
2288 /* Make the function call. */
2289 fndecl
= build_addr (function
, current_function_decl
);
2290 tmp
= build_call_array_loc (input_location
,
2291 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2293 gfc_add_expr_to_block (&se
->pre
, tmp
);
2295 /* Free the temporary afterwards, if necessary. */
2296 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2297 len
, build_int_cst (TREE_TYPE (len
), 0));
2298 tmp
= gfc_call_free (var
);
2299 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2300 gfc_add_expr_to_block (&se
->post
, tmp
);
2303 se
->string_length
= len
;
2307 /* Create a symbol node for this intrinsic. The symbol from the frontend
2308 has the generic name. */
2311 gfc_get_symbol_for_expr (gfc_expr
* expr
)
2315 /* TODO: Add symbols for intrinsic function to the global namespace. */
2316 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2317 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2320 sym
->attr
.external
= 1;
2321 sym
->attr
.function
= 1;
2322 sym
->attr
.always_explicit
= 1;
2323 sym
->attr
.proc
= PROC_INTRINSIC
;
2324 sym
->attr
.flavor
= FL_PROCEDURE
;
2328 sym
->attr
.dimension
= 1;
2329 sym
->as
= gfc_get_array_spec ();
2330 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2331 sym
->as
->rank
= expr
->rank
;
2334 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
2339 /* Generate a call to an external intrinsic function. */
2341 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2344 vec
<tree
, va_gc
> *append_args
;
2346 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2349 gcc_assert (expr
->rank
> 0);
2351 gcc_assert (expr
->rank
== 0);
2353 sym
= gfc_get_symbol_for_expr (expr
);
2355 /* Calls to libgfortran_matmul need to be appended special arguments,
2356 to be able to call the BLAS ?gemm functions if required and possible. */
2358 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2359 && sym
->ts
.type
!= BT_LOGICAL
)
2361 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2363 if (gfc_option
.flag_external_blas
2364 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2365 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
2369 if (sym
->ts
.type
== BT_REAL
)
2371 if (sym
->ts
.kind
== 4)
2372 gemm_fndecl
= gfor_fndecl_sgemm
;
2374 gemm_fndecl
= gfor_fndecl_dgemm
;
2378 if (sym
->ts
.kind
== 4)
2379 gemm_fndecl
= gfor_fndecl_cgemm
;
2381 gemm_fndecl
= gfor_fndecl_zgemm
;
2384 vec_alloc (append_args
, 3);
2385 append_args
->quick_push (build_int_cst (cint
, 1));
2386 append_args
->quick_push (build_int_cst (cint
,
2387 gfc_option
.blas_matmul_limit
));
2388 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
2393 vec_alloc (append_args
, 3);
2394 append_args
->quick_push (build_int_cst (cint
, 0));
2395 append_args
->quick_push (build_int_cst (cint
, 0));
2396 append_args
->quick_push (null_pointer_node
);
2400 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
2402 gfc_free_symbol (sym
);
2405 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2425 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2434 gfc_actual_arglist
*actual
;
2441 gfc_conv_intrinsic_funcall (se
, expr
);
2445 actual
= expr
->value
.function
.actual
;
2446 type
= gfc_typenode_for_spec (&expr
->ts
);
2447 /* Initialize the result. */
2448 resvar
= gfc_create_var (type
, "test");
2450 tmp
= convert (type
, boolean_true_node
);
2452 tmp
= convert (type
, boolean_false_node
);
2453 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2455 /* Walk the arguments. */
2456 arrayss
= gfc_walk_expr (actual
->expr
);
2457 gcc_assert (arrayss
!= gfc_ss_terminator
);
2459 /* Initialize the scalarizer. */
2460 gfc_init_loopinfo (&loop
);
2461 exit_label
= gfc_build_label_decl (NULL_TREE
);
2462 TREE_USED (exit_label
) = 1;
2463 gfc_add_ss_to_loop (&loop
, arrayss
);
2465 /* Initialize the loop. */
2466 gfc_conv_ss_startstride (&loop
);
2467 gfc_conv_loop_setup (&loop
, &expr
->where
);
2469 gfc_mark_ss_chain_used (arrayss
, 1);
2470 /* Generate the loop body. */
2471 gfc_start_scalarized_body (&loop
, &body
);
2473 /* If the condition matches then set the return value. */
2474 gfc_start_block (&block
);
2476 tmp
= convert (type
, boolean_false_node
);
2478 tmp
= convert (type
, boolean_true_node
);
2479 gfc_add_modify (&block
, resvar
, tmp
);
2481 /* And break out of the loop. */
2482 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2483 gfc_add_expr_to_block (&block
, tmp
);
2485 found
= gfc_finish_block (&block
);
2487 /* Check this element. */
2488 gfc_init_se (&arrayse
, NULL
);
2489 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2490 arrayse
.ss
= arrayss
;
2491 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2493 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2494 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
2495 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
2496 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
2497 gfc_add_expr_to_block (&body
, tmp
);
2498 gfc_add_block_to_block (&body
, &arrayse
.post
);
2500 gfc_trans_scalarizing_loops (&loop
, &body
);
2502 /* Add the exit label. */
2503 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2504 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2506 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2507 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2508 gfc_cleanup_loop (&loop
);
2513 /* COUNT(A) = Number of true elements in A. */
2515 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
2522 gfc_actual_arglist
*actual
;
2528 gfc_conv_intrinsic_funcall (se
, expr
);
2532 actual
= expr
->value
.function
.actual
;
2534 type
= gfc_typenode_for_spec (&expr
->ts
);
2535 /* Initialize the result. */
2536 resvar
= gfc_create_var (type
, "count");
2537 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
2539 /* Walk the arguments. */
2540 arrayss
= gfc_walk_expr (actual
->expr
);
2541 gcc_assert (arrayss
!= gfc_ss_terminator
);
2543 /* Initialize the scalarizer. */
2544 gfc_init_loopinfo (&loop
);
2545 gfc_add_ss_to_loop (&loop
, arrayss
);
2547 /* Initialize the loop. */
2548 gfc_conv_ss_startstride (&loop
);
2549 gfc_conv_loop_setup (&loop
, &expr
->where
);
2551 gfc_mark_ss_chain_used (arrayss
, 1);
2552 /* Generate the loop body. */
2553 gfc_start_scalarized_body (&loop
, &body
);
2555 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2556 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2557 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2559 gfc_init_se (&arrayse
, NULL
);
2560 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2561 arrayse
.ss
= arrayss
;
2562 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2563 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2564 build_empty_stmt (input_location
));
2566 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2567 gfc_add_expr_to_block (&body
, tmp
);
2568 gfc_add_block_to_block (&body
, &arrayse
.post
);
2570 gfc_trans_scalarizing_loops (&loop
, &body
);
2572 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2573 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2574 gfc_cleanup_loop (&loop
);
2580 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
2581 struct and return the corresponding loopinfo. */
2583 static gfc_loopinfo
*
2584 enter_nested_loop (gfc_se
*se
)
2586 se
->ss
= se
->ss
->nested_ss
;
2587 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
2589 return se
->ss
->loop
;
2593 /* Inline implementation of the sum and product intrinsics. */
2595 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2599 tree scale
= NULL_TREE
;
2604 gfc_loopinfo loop
, *ploop
;
2605 gfc_actual_arglist
*arg_array
, *arg_mask
;
2606 gfc_ss
*arrayss
= NULL
;
2607 gfc_ss
*maskss
= NULL
;
2611 gfc_expr
*arrayexpr
;
2616 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
2622 type
= gfc_typenode_for_spec (&expr
->ts
);
2623 /* Initialize the result. */
2624 resvar
= gfc_create_var (type
, "val");
2629 scale
= gfc_create_var (type
, "scale");
2630 gfc_add_modify (&se
->pre
, scale
,
2631 gfc_build_const (type
, integer_one_node
));
2632 tmp
= gfc_build_const (type
, integer_zero_node
);
2634 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2635 tmp
= gfc_build_const (type
, integer_zero_node
);
2636 else if (op
== NE_EXPR
)
2638 tmp
= convert (type
, boolean_false_node
);
2639 else if (op
== BIT_AND_EXPR
)
2640 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2641 type
, integer_one_node
));
2643 tmp
= gfc_build_const (type
, integer_one_node
);
2645 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2647 arg_array
= expr
->value
.function
.actual
;
2649 arrayexpr
= arg_array
->expr
;
2651 if (op
== NE_EXPR
|| norm2
)
2652 /* PARITY and NORM2. */
2656 arg_mask
= arg_array
->next
->next
;
2657 gcc_assert (arg_mask
!= NULL
);
2658 maskexpr
= arg_mask
->expr
;
2661 if (expr
->rank
== 0)
2663 /* Walk the arguments. */
2664 arrayss
= gfc_walk_expr (arrayexpr
);
2665 gcc_assert (arrayss
!= gfc_ss_terminator
);
2667 if (maskexpr
&& maskexpr
->rank
> 0)
2669 maskss
= gfc_walk_expr (maskexpr
);
2670 gcc_assert (maskss
!= gfc_ss_terminator
);
2675 /* Initialize the scalarizer. */
2676 gfc_init_loopinfo (&loop
);
2677 gfc_add_ss_to_loop (&loop
, arrayss
);
2678 if (maskexpr
&& maskexpr
->rank
> 0)
2679 gfc_add_ss_to_loop (&loop
, maskss
);
2681 /* Initialize the loop. */
2682 gfc_conv_ss_startstride (&loop
);
2683 gfc_conv_loop_setup (&loop
, &expr
->where
);
2685 gfc_mark_ss_chain_used (arrayss
, 1);
2686 if (maskexpr
&& maskexpr
->rank
> 0)
2687 gfc_mark_ss_chain_used (maskss
, 1);
2692 /* All the work has been done in the parent loops. */
2693 ploop
= enter_nested_loop (se
);
2697 /* Generate the loop body. */
2698 gfc_start_scalarized_body (ploop
, &body
);
2700 /* If we have a mask, only add this element if the mask is set. */
2701 if (maskexpr
&& maskexpr
->rank
> 0)
2703 gfc_init_se (&maskse
, parent_se
);
2704 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
2705 if (expr
->rank
== 0)
2707 gfc_conv_expr_val (&maskse
, maskexpr
);
2708 gfc_add_block_to_block (&body
, &maskse
.pre
);
2710 gfc_start_block (&block
);
2713 gfc_init_block (&block
);
2715 /* Do the actual summation/product. */
2716 gfc_init_se (&arrayse
, parent_se
);
2717 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
2718 if (expr
->rank
== 0)
2719 arrayse
.ss
= arrayss
;
2720 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2721 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2731 result = 1.0 + result * val * val;
2737 result += val * val;
2740 tree res1
, res2
, cond
, absX
, val
;
2741 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
2743 gfc_init_block (&ifblock1
);
2745 absX
= gfc_create_var (type
, "absX");
2746 gfc_add_modify (&ifblock1
, absX
,
2747 fold_build1_loc (input_location
, ABS_EXPR
, type
,
2749 val
= gfc_create_var (type
, "val");
2750 gfc_add_expr_to_block (&ifblock1
, val
);
2752 gfc_init_block (&ifblock2
);
2753 gfc_add_modify (&ifblock2
, val
,
2754 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
2756 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2757 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
2758 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
2759 gfc_build_const (type
, integer_one_node
));
2760 gfc_add_modify (&ifblock2
, resvar
, res1
);
2761 gfc_add_modify (&ifblock2
, scale
, absX
);
2762 res1
= gfc_finish_block (&ifblock2
);
2764 gfc_init_block (&ifblock3
);
2765 gfc_add_modify (&ifblock3
, val
,
2766 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
2768 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2769 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
2770 gfc_add_modify (&ifblock3
, resvar
, res2
);
2771 res2
= gfc_finish_block (&ifblock3
);
2773 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2775 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
2776 gfc_add_expr_to_block (&ifblock1
, tmp
);
2777 tmp
= gfc_finish_block (&ifblock1
);
2779 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2781 gfc_build_const (type
, integer_zero_node
));
2783 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2784 gfc_add_expr_to_block (&block
, tmp
);
2788 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
2789 gfc_add_modify (&block
, resvar
, tmp
);
2792 gfc_add_block_to_block (&block
, &arrayse
.post
);
2794 if (maskexpr
&& maskexpr
->rank
> 0)
2796 /* We enclose the above in if (mask) {...} . */
2798 tmp
= gfc_finish_block (&block
);
2799 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2800 build_empty_stmt (input_location
));
2803 tmp
= gfc_finish_block (&block
);
2804 gfc_add_expr_to_block (&body
, tmp
);
2806 gfc_trans_scalarizing_loops (ploop
, &body
);
2808 /* For a scalar mask, enclose the loop in an if statement. */
2809 if (maskexpr
&& maskexpr
->rank
== 0)
2811 gfc_init_block (&block
);
2812 gfc_add_block_to_block (&block
, &ploop
->pre
);
2813 gfc_add_block_to_block (&block
, &ploop
->post
);
2814 tmp
= gfc_finish_block (&block
);
2818 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
2819 build_empty_stmt (input_location
));
2820 gfc_advance_se_ss_chain (se
);
2824 gcc_assert (expr
->rank
== 0);
2825 gfc_init_se (&maskse
, NULL
);
2826 gfc_conv_expr_val (&maskse
, maskexpr
);
2827 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2828 build_empty_stmt (input_location
));
2831 gfc_add_expr_to_block (&block
, tmp
);
2832 gfc_add_block_to_block (&se
->pre
, &block
);
2833 gcc_assert (se
->post
.head
== NULL
);
2837 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
2838 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
2841 if (expr
->rank
== 0)
2842 gfc_cleanup_loop (ploop
);
2846 /* result = scale * sqrt(result). */
2848 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
2849 resvar
= build_call_expr_loc (input_location
,
2851 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
2858 /* Inline implementation of the dot_product intrinsic. This function
2859 is based on gfc_conv_intrinsic_arith (the previous function). */
2861 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2869 gfc_actual_arglist
*actual
;
2870 gfc_ss
*arrayss1
, *arrayss2
;
2871 gfc_se arrayse1
, arrayse2
;
2872 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2874 type
= gfc_typenode_for_spec (&expr
->ts
);
2876 /* Initialize the result. */
2877 resvar
= gfc_create_var (type
, "val");
2878 if (expr
->ts
.type
== BT_LOGICAL
)
2879 tmp
= build_int_cst (type
, 0);
2881 tmp
= gfc_build_const (type
, integer_zero_node
);
2883 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2885 /* Walk argument #1. */
2886 actual
= expr
->value
.function
.actual
;
2887 arrayexpr1
= actual
->expr
;
2888 arrayss1
= gfc_walk_expr (arrayexpr1
);
2889 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2891 /* Walk argument #2. */
2892 actual
= actual
->next
;
2893 arrayexpr2
= actual
->expr
;
2894 arrayss2
= gfc_walk_expr (arrayexpr2
);
2895 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2897 /* Initialize the scalarizer. */
2898 gfc_init_loopinfo (&loop
);
2899 gfc_add_ss_to_loop (&loop
, arrayss1
);
2900 gfc_add_ss_to_loop (&loop
, arrayss2
);
2902 /* Initialize the loop. */
2903 gfc_conv_ss_startstride (&loop
);
2904 gfc_conv_loop_setup (&loop
, &expr
->where
);
2906 gfc_mark_ss_chain_used (arrayss1
, 1);
2907 gfc_mark_ss_chain_used (arrayss2
, 1);
2909 /* Generate the loop body. */
2910 gfc_start_scalarized_body (&loop
, &body
);
2911 gfc_init_block (&block
);
2913 /* Make the tree expression for [conjg(]array1[)]. */
2914 gfc_init_se (&arrayse1
, NULL
);
2915 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2916 arrayse1
.ss
= arrayss1
;
2917 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2918 if (expr
->ts
.type
== BT_COMPLEX
)
2919 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
2921 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2923 /* Make the tree expression for array2. */
2924 gfc_init_se (&arrayse2
, NULL
);
2925 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2926 arrayse2
.ss
= arrayss2
;
2927 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2928 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2930 /* Do the actual product and sum. */
2931 if (expr
->ts
.type
== BT_LOGICAL
)
2933 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
2934 arrayse1
.expr
, arrayse2
.expr
);
2935 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2939 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
2941 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
2943 gfc_add_modify (&block
, resvar
, tmp
);
2945 /* Finish up the loop block and the loop. */
2946 tmp
= gfc_finish_block (&block
);
2947 gfc_add_expr_to_block (&body
, tmp
);
2949 gfc_trans_scalarizing_loops (&loop
, &body
);
2950 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2951 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2952 gfc_cleanup_loop (&loop
);
2958 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2959 we need to handle. For performance reasons we sometimes create two
2960 loops instead of one, where the second one is much simpler.
2961 Examples for minloc intrinsic:
2962 1) Result is an array, a call is generated
2963 2) Array mask is used and NaNs need to be supported:
2969 if (pos == 0) pos = S + (1 - from);
2970 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2977 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2981 3) NaNs need to be supported, but it is known at compile time or cheaply
2982 at runtime whether array is nonempty or not:
2987 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2990 if (from <= to) pos = 1;
2994 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2998 4) NaNs aren't supported, array mask is used:
2999 limit = infinities_supported ? Infinity : huge (limit);
3003 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3009 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3013 5) Same without array mask:
3014 limit = infinities_supported ? Infinity : huge (limit);
3015 pos = (from <= to) ? 1 : 0;
3018 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3021 For 3) and 5), if mask is scalar, this all goes into a conditional,
3022 setting pos = 0; in the else branch. */
3025 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3029 stmtblock_t ifblock
;
3030 stmtblock_t elseblock
;
3041 gfc_actual_arglist
*actual
;
3046 gfc_expr
*arrayexpr
;
3053 gfc_conv_intrinsic_funcall (se
, expr
);
3057 /* Initialize the result. */
3058 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3059 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3060 type
= gfc_typenode_for_spec (&expr
->ts
);
3062 /* Walk the arguments. */
3063 actual
= expr
->value
.function
.actual
;
3064 arrayexpr
= actual
->expr
;
3065 arrayss
= gfc_walk_expr (arrayexpr
);
3066 gcc_assert (arrayss
!= gfc_ss_terminator
);
3068 actual
= actual
->next
->next
;
3069 gcc_assert (actual
);
3070 maskexpr
= actual
->expr
;
3072 if (maskexpr
&& maskexpr
->rank
!= 0)
3074 maskss
= gfc_walk_expr (maskexpr
);
3075 gcc_assert (maskss
!= gfc_ss_terminator
);
3080 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3082 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3084 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3085 boolean_type_node
, nonempty
,
3086 gfc_index_zero_node
);
3091 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3092 switch (arrayexpr
->ts
.type
)
3095 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3099 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3100 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3101 arrayexpr
->ts
.kind
);
3108 /* We start with the most negative possible value for MAXLOC, and the most
3109 positive possible value for MINLOC. The most negative possible value is
3110 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3111 possible value is HUGE in both cases. */
3113 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3114 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3115 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3116 build_int_cst (type
, 1));
3118 gfc_add_modify (&se
->pre
, limit
, tmp
);
3120 /* Initialize the scalarizer. */
3121 gfc_init_loopinfo (&loop
);
3122 gfc_add_ss_to_loop (&loop
, arrayss
);
3124 gfc_add_ss_to_loop (&loop
, maskss
);
3126 /* Initialize the loop. */
3127 gfc_conv_ss_startstride (&loop
);
3129 /* The code generated can have more than one loop in sequence (see the
3130 comment at the function header). This doesn't work well with the
3131 scalarizer, which changes arrays' offset when the scalarization loops
3132 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3133 are currently inlined in the scalar case only (for which loop is of rank
3134 one). As there is no dependency to care about in that case, there is no
3135 temporary, so that we can use the scalarizer temporary code to handle
3136 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3137 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3139 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3140 should eventually go away. We could either create two loops properly,
3141 or find another way to save/restore the array offsets between the two
3142 loops (without conflicting with temporary management), or use a single
3143 loop minmaxloc implementation. See PR 31067. */
3144 loop
.temp_dim
= loop
.dimen
;
3145 gfc_conv_loop_setup (&loop
, &expr
->where
);
3147 gcc_assert (loop
.dimen
== 1);
3148 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3149 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3150 loop
.from
[0], loop
.to
[0]);
3154 /* Initialize the position to zero, following Fortran 2003. We are free
3155 to do this because Fortran 95 allows the result of an entirely false
3156 mask to be processor dependent. If we know at compile time the array
3157 is non-empty and no MASK is used, we can initialize to 1 to simplify
3159 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3160 gfc_add_modify (&loop
.pre
, pos
,
3161 fold_build3_loc (input_location
, COND_EXPR
,
3162 gfc_array_index_type
,
3163 nonempty
, gfc_index_one_node
,
3164 gfc_index_zero_node
));
3167 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3168 lab1
= gfc_build_label_decl (NULL_TREE
);
3169 TREE_USED (lab1
) = 1;
3170 lab2
= gfc_build_label_decl (NULL_TREE
);
3171 TREE_USED (lab2
) = 1;
3174 /* An offset must be added to the loop
3175 counter to obtain the required position. */
3176 gcc_assert (loop
.from
[0]);
3178 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3179 gfc_index_one_node
, loop
.from
[0]);
3180 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3182 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3184 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3185 /* Generate the loop body. */
3186 gfc_start_scalarized_body (&loop
, &body
);
3188 /* If we have a mask, only check this element if the mask is set. */
3191 gfc_init_se (&maskse
, NULL
);
3192 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3194 gfc_conv_expr_val (&maskse
, maskexpr
);
3195 gfc_add_block_to_block (&body
, &maskse
.pre
);
3197 gfc_start_block (&block
);
3200 gfc_init_block (&block
);
3202 /* Compare with the current limit. */
3203 gfc_init_se (&arrayse
, NULL
);
3204 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3205 arrayse
.ss
= arrayss
;
3206 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3207 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3209 /* We do the following if this is a more extreme value. */
3210 gfc_start_block (&ifblock
);
3212 /* Assign the value to the limit... */
3213 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3215 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3217 stmtblock_t ifblock2
;
3220 gfc_start_block (&ifblock2
);
3221 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3222 loop
.loopvar
[0], offset
);
3223 gfc_add_modify (&ifblock2
, pos
, tmp
);
3224 ifbody2
= gfc_finish_block (&ifblock2
);
3225 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3226 gfc_index_zero_node
);
3227 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3228 build_empty_stmt (input_location
));
3229 gfc_add_expr_to_block (&block
, tmp
);
3232 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3233 loop
.loopvar
[0], offset
);
3234 gfc_add_modify (&ifblock
, pos
, tmp
);
3237 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3239 ifbody
= gfc_finish_block (&ifblock
);
3241 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3244 cond
= fold_build2_loc (input_location
,
3245 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3246 boolean_type_node
, arrayse
.expr
, limit
);
3248 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3249 arrayse
.expr
, limit
);
3251 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3252 build_empty_stmt (input_location
));
3254 gfc_add_expr_to_block (&block
, ifbody
);
3258 /* We enclose the above in if (mask) {...}. */
3259 tmp
= gfc_finish_block (&block
);
3261 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3262 build_empty_stmt (input_location
));
3265 tmp
= gfc_finish_block (&block
);
3266 gfc_add_expr_to_block (&body
, tmp
);
3270 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3272 if (HONOR_NANS (DECL_MODE (limit
)))
3274 if (nonempty
!= NULL
)
3276 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3277 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3278 build_empty_stmt (input_location
));
3279 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3283 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3284 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3286 /* If we have a mask, only check this element if the mask is set. */
3289 gfc_init_se (&maskse
, NULL
);
3290 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3292 gfc_conv_expr_val (&maskse
, maskexpr
);
3293 gfc_add_block_to_block (&body
, &maskse
.pre
);
3295 gfc_start_block (&block
);
3298 gfc_init_block (&block
);
3300 /* Compare with the current limit. */
3301 gfc_init_se (&arrayse
, NULL
);
3302 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3303 arrayse
.ss
= arrayss
;
3304 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3305 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3307 /* We do the following if this is a more extreme value. */
3308 gfc_start_block (&ifblock
);
3310 /* Assign the value to the limit... */
3311 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3313 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3314 loop
.loopvar
[0], offset
);
3315 gfc_add_modify (&ifblock
, pos
, tmp
);
3317 ifbody
= gfc_finish_block (&ifblock
);
3319 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3320 arrayse
.expr
, limit
);
3322 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3323 build_empty_stmt (input_location
));
3324 gfc_add_expr_to_block (&block
, tmp
);
3328 /* We enclose the above in if (mask) {...}. */
3329 tmp
= gfc_finish_block (&block
);
3331 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3332 build_empty_stmt (input_location
));
3335 tmp
= gfc_finish_block (&block
);
3336 gfc_add_expr_to_block (&body
, tmp
);
3337 /* Avoid initializing loopvar[0] again, it should be left where
3338 it finished by the first loop. */
3339 loop
.from
[0] = loop
.loopvar
[0];
3342 gfc_trans_scalarizing_loops (&loop
, &body
);
3345 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3347 /* For a scalar mask, enclose the loop in an if statement. */
3348 if (maskexpr
&& maskss
== NULL
)
3350 gfc_init_se (&maskse
, NULL
);
3351 gfc_conv_expr_val (&maskse
, maskexpr
);
3352 gfc_init_block (&block
);
3353 gfc_add_block_to_block (&block
, &loop
.pre
);
3354 gfc_add_block_to_block (&block
, &loop
.post
);
3355 tmp
= gfc_finish_block (&block
);
3357 /* For the else part of the scalar mask, just initialize
3358 the pos variable the same way as above. */
3360 gfc_init_block (&elseblock
);
3361 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3362 elsetmp
= gfc_finish_block (&elseblock
);
3364 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3365 gfc_add_expr_to_block (&block
, tmp
);
3366 gfc_add_block_to_block (&se
->pre
, &block
);
3370 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3371 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3373 gfc_cleanup_loop (&loop
);
3375 se
->expr
= convert (type
, pos
);
3378 /* Emit code for minval or maxval intrinsic. There are many different cases
3379 we need to handle. For performance reasons we sometimes create two
3380 loops instead of one, where the second one is much simpler.
3381 Examples for minval intrinsic:
3382 1) Result is an array, a call is generated
3383 2) Array mask is used and NaNs need to be supported, rank 1:
3388 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3391 limit = nonempty ? NaN : huge (limit);
3393 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3394 3) NaNs need to be supported, but it is known at compile time or cheaply
3395 at runtime whether array is nonempty or not, rank 1:
3398 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3399 limit = (from <= to) ? NaN : huge (limit);
3401 while (S <= to) { limit = min (a[S], limit); S++; }
3402 4) Array mask is used and NaNs need to be supported, rank > 1:
3411 if (fast) limit = min (a[S1][S2], limit);
3414 if (a[S1][S2] <= limit) {
3425 limit = nonempty ? NaN : huge (limit);
3426 5) NaNs need to be supported, but it is known at compile time or cheaply
3427 at runtime whether array is nonempty or not, rank > 1:
3434 if (fast) limit = min (a[S1][S2], limit);
3436 if (a[S1][S2] <= limit) {
3446 limit = (nonempty_array) ? NaN : huge (limit);
3447 6) NaNs aren't supported, but infinities are. Array mask is used:
3452 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3455 limit = nonempty ? limit : huge (limit);
3456 7) Same without array mask:
3459 while (S <= to) { limit = min (a[S], limit); S++; }
3460 limit = (from <= to) ? limit : huge (limit);
3461 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3462 limit = huge (limit);
3464 while (S <= to) { limit = min (a[S], limit); S++); }
3466 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3467 with array mask instead).
3468 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3469 setting limit = huge (limit); in the else branch. */
3472 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3482 tree huge_cst
= NULL
, nan_cst
= NULL
;
3484 stmtblock_t block
, block2
;
3486 gfc_actual_arglist
*actual
;
3491 gfc_expr
*arrayexpr
;
3497 gfc_conv_intrinsic_funcall (se
, expr
);
3501 type
= gfc_typenode_for_spec (&expr
->ts
);
3502 /* Initialize the result. */
3503 limit
= gfc_create_var (type
, "limit");
3504 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
3505 switch (expr
->ts
.type
)
3508 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
3510 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3512 REAL_VALUE_TYPE real
;
3514 tmp
= build_real (type
, real
);
3518 if (HONOR_NANS (DECL_MODE (limit
)))
3520 REAL_VALUE_TYPE real
;
3521 real_nan (&real
, "", 1, DECL_MODE (limit
));
3522 nan_cst
= build_real (type
, real
);
3527 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
3534 /* We start with the most negative possible value for MAXVAL, and the most
3535 positive possible value for MINVAL. The most negative possible value is
3536 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3537 possible value is HUGE in both cases. */
3540 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3542 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
3543 TREE_TYPE (huge_cst
), huge_cst
);
3546 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3547 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
3548 tmp
, build_int_cst (type
, 1));
3550 gfc_add_modify (&se
->pre
, limit
, tmp
);
3552 /* Walk the arguments. */
3553 actual
= expr
->value
.function
.actual
;
3554 arrayexpr
= actual
->expr
;
3555 arrayss
= gfc_walk_expr (arrayexpr
);
3556 gcc_assert (arrayss
!= gfc_ss_terminator
);
3558 actual
= actual
->next
->next
;
3559 gcc_assert (actual
);
3560 maskexpr
= actual
->expr
;
3562 if (maskexpr
&& maskexpr
->rank
!= 0)
3564 maskss
= gfc_walk_expr (maskexpr
);
3565 gcc_assert (maskss
!= gfc_ss_terminator
);
3570 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3572 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3574 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3575 boolean_type_node
, nonempty
,
3576 gfc_index_zero_node
);
3581 /* Initialize the scalarizer. */
3582 gfc_init_loopinfo (&loop
);
3583 gfc_add_ss_to_loop (&loop
, arrayss
);
3585 gfc_add_ss_to_loop (&loop
, maskss
);
3587 /* Initialize the loop. */
3588 gfc_conv_ss_startstride (&loop
);
3590 /* The code generated can have more than one loop in sequence (see the
3591 comment at the function header). This doesn't work well with the
3592 scalarizer, which changes arrays' offset when the scalarization loops
3593 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3594 are currently inlined in the scalar case only. As there is no dependency
3595 to care about in that case, there is no temporary, so that we can use the
3596 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3597 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3598 gfc_trans_scalarized_loop_boundary even later to restore offset.
3599 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3600 should eventually go away. We could either create two loops properly,
3601 or find another way to save/restore the array offsets between the two
3602 loops (without conflicting with temporary management), or use a single
3603 loop minmaxval implementation. See PR 31067. */
3604 loop
.temp_dim
= loop
.dimen
;
3605 gfc_conv_loop_setup (&loop
, &expr
->where
);
3607 if (nonempty
== NULL
&& maskss
== NULL
3608 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
3609 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3610 loop
.from
[0], loop
.to
[0]);
3611 nonempty_var
= NULL
;
3612 if (nonempty
== NULL
3613 && (HONOR_INFINITIES (DECL_MODE (limit
))
3614 || HONOR_NANS (DECL_MODE (limit
))))
3616 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3617 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3618 nonempty
= nonempty_var
;
3622 if (HONOR_NANS (DECL_MODE (limit
)))
3624 if (loop
.dimen
== 1)
3626 lab
= gfc_build_label_decl (NULL_TREE
);
3627 TREE_USED (lab
) = 1;
3631 fast
= gfc_create_var (boolean_type_node
, "fast");
3632 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3636 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
3638 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
3639 /* Generate the loop body. */
3640 gfc_start_scalarized_body (&loop
, &body
);
3642 /* If we have a mask, only add this element if the mask is set. */
3645 gfc_init_se (&maskse
, NULL
);
3646 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3648 gfc_conv_expr_val (&maskse
, maskexpr
);
3649 gfc_add_block_to_block (&body
, &maskse
.pre
);
3651 gfc_start_block (&block
);
3654 gfc_init_block (&block
);
3656 /* Compare with the current limit. */
3657 gfc_init_se (&arrayse
, NULL
);
3658 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3659 arrayse
.ss
= arrayss
;
3660 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3661 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3663 gfc_init_block (&block2
);
3666 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3668 if (HONOR_NANS (DECL_MODE (limit
)))
3670 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3671 boolean_type_node
, arrayse
.expr
, limit
);
3673 ifbody
= build1_v (GOTO_EXPR
, lab
);
3676 stmtblock_t ifblock
;
3678 gfc_init_block (&ifblock
);
3679 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3680 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3681 ifbody
= gfc_finish_block (&ifblock
);
3683 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3684 build_empty_stmt (input_location
));
3685 gfc_add_expr_to_block (&block2
, tmp
);
3689 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3691 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3693 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3694 arrayse
.expr
, limit
);
3695 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3696 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3697 build_empty_stmt (input_location
));
3698 gfc_add_expr_to_block (&block2
, tmp
);
3702 tmp
= fold_build2_loc (input_location
,
3703 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3704 type
, arrayse
.expr
, limit
);
3705 gfc_add_modify (&block2
, limit
, tmp
);
3711 tree elsebody
= gfc_finish_block (&block2
);
3713 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3715 if (HONOR_NANS (DECL_MODE (limit
))
3716 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3718 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3719 arrayse
.expr
, limit
);
3720 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3721 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3722 build_empty_stmt (input_location
));
3726 tmp
= fold_build2_loc (input_location
,
3727 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3728 type
, arrayse
.expr
, limit
);
3729 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3731 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3732 gfc_add_expr_to_block (&block
, tmp
);
3735 gfc_add_block_to_block (&block
, &block2
);
3737 gfc_add_block_to_block (&block
, &arrayse
.post
);
3739 tmp
= gfc_finish_block (&block
);
3741 /* We enclose the above in if (mask) {...}. */
3742 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3743 build_empty_stmt (input_location
));
3744 gfc_add_expr_to_block (&body
, tmp
);
3748 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3750 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3752 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
3753 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
3755 /* If we have a mask, only add this element if the mask is set. */
3758 gfc_init_se (&maskse
, NULL
);
3759 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3761 gfc_conv_expr_val (&maskse
, maskexpr
);
3762 gfc_add_block_to_block (&body
, &maskse
.pre
);
3764 gfc_start_block (&block
);
3767 gfc_init_block (&block
);
3769 /* Compare with the current limit. */
3770 gfc_init_se (&arrayse
, NULL
);
3771 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3772 arrayse
.ss
= arrayss
;
3773 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3774 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3776 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3778 if (HONOR_NANS (DECL_MODE (limit
))
3779 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3781 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3782 arrayse
.expr
, limit
);
3783 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3784 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3785 build_empty_stmt (input_location
));
3786 gfc_add_expr_to_block (&block
, tmp
);
3790 tmp
= fold_build2_loc (input_location
,
3791 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3792 type
, arrayse
.expr
, limit
);
3793 gfc_add_modify (&block
, limit
, tmp
);
3796 gfc_add_block_to_block (&block
, &arrayse
.post
);
3798 tmp
= gfc_finish_block (&block
);
3800 /* We enclose the above in if (mask) {...}. */
3801 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3802 build_empty_stmt (input_location
));
3803 gfc_add_expr_to_block (&body
, tmp
);
3804 /* Avoid initializing loopvar[0] again, it should be left where
3805 it finished by the first loop. */
3806 loop
.from
[0] = loop
.loopvar
[0];
3808 gfc_trans_scalarizing_loops (&loop
, &body
);
3812 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3814 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3815 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
3817 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3819 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
3821 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
3823 gfc_add_modify (&loop
.pre
, limit
, tmp
);
3826 /* For a scalar mask, enclose the loop in an if statement. */
3827 if (maskexpr
&& maskss
== NULL
)
3831 gfc_init_se (&maskse
, NULL
);
3832 gfc_conv_expr_val (&maskse
, maskexpr
);
3833 gfc_init_block (&block
);
3834 gfc_add_block_to_block (&block
, &loop
.pre
);
3835 gfc_add_block_to_block (&block
, &loop
.post
);
3836 tmp
= gfc_finish_block (&block
);
3838 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3839 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
3841 else_stmt
= build_empty_stmt (input_location
);
3842 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
3843 gfc_add_expr_to_block (&block
, tmp
);
3844 gfc_add_block_to_block (&se
->pre
, &block
);
3848 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3849 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3852 gfc_cleanup_loop (&loop
);
3857 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3859 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
3865 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3866 type
= TREE_TYPE (args
[0]);
3868 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3869 build_int_cst (type
, 1), args
[1]);
3870 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
3871 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
3872 build_int_cst (type
, 0));
3873 type
= gfc_typenode_for_spec (&expr
->ts
);
3874 se
->expr
= convert (type
, tmp
);
3878 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3880 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3884 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3886 /* Convert both arguments to the unsigned type of the same size. */
3887 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
3888 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
3890 /* If they have unequal type size, convert to the larger one. */
3891 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
3892 > TYPE_PRECISION (TREE_TYPE (args
[1])))
3893 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
3894 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
3895 > TYPE_PRECISION (TREE_TYPE (args
[0])))
3896 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
3898 /* Now, we compare them. */
3899 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3904 /* Generate code to perform the specified operation. */
3906 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3910 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3911 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
3917 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
3921 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3922 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3923 TREE_TYPE (arg
), arg
);
3926 /* Set or clear a single bit. */
3928 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
3935 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3936 type
= TREE_TYPE (args
[0]);
3938 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3939 build_int_cst (type
, 1), args
[1]);
3945 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
3947 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
3950 /* Extract a sequence of bits.
3951 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3953 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
3960 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3961 type
= TREE_TYPE (args
[0]);
3963 mask
= build_int_cst (type
, -1);
3964 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
3965 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
3967 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
3969 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
3973 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
3976 tree args
[2], type
, num_bits
, cond
;
3978 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3980 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3981 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3982 type
= TREE_TYPE (args
[0]);
3985 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
3987 gcc_assert (right_shift
);
3989 se
->expr
= fold_build2_loc (input_location
,
3990 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
3991 TREE_TYPE (args
[0]), args
[0], args
[1]);
3994 se
->expr
= fold_convert (type
, se
->expr
);
3996 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3997 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3999 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4000 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4003 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4004 build_int_cst (type
, 0), se
->expr
);
4007 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4009 : ((shift >= 0) ? i << shift : i >> -shift)
4010 where all shifts are logical shifts. */
4012 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4024 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4026 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4027 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4029 type
= TREE_TYPE (args
[0]);
4030 utype
= unsigned_type_for (type
);
4032 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4035 /* Left shift if positive. */
4036 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4038 /* Right shift if negative.
4039 We convert to an unsigned type because we want a logical shift.
4040 The standard doesn't define the case of shifting negative
4041 numbers, and we try to be compatible with other compilers, most
4042 notably g77, here. */
4043 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4044 utype
, convert (utype
, args
[0]), width
));
4046 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4047 build_int_cst (TREE_TYPE (args
[1]), 0));
4048 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4050 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4051 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4053 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4054 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4056 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4057 build_int_cst (type
, 0), tmp
);
4061 /* Circular shift. AKA rotate or barrel shift. */
4064 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4072 unsigned int num_args
;
4074 num_args
= gfc_intrinsic_argument_list_length (expr
);
4075 args
= XALLOCAVEC (tree
, num_args
);
4077 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4081 /* Use a library function for the 3 parameter version. */
4082 tree int4type
= gfc_get_int_type (4);
4084 type
= TREE_TYPE (args
[0]);
4085 /* We convert the first argument to at least 4 bytes, and
4086 convert back afterwards. This removes the need for library
4087 functions for all argument sizes, and function will be
4088 aligned to at least 32 bits, so there's no loss. */
4089 if (expr
->ts
.kind
< 4)
4090 args
[0] = convert (int4type
, args
[0]);
4092 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4093 need loads of library functions. They cannot have values >
4094 BIT_SIZE (I) so the conversion is safe. */
4095 args
[1] = convert (int4type
, args
[1]);
4096 args
[2] = convert (int4type
, args
[2]);
4098 switch (expr
->ts
.kind
)
4103 tmp
= gfor_fndecl_math_ishftc4
;
4106 tmp
= gfor_fndecl_math_ishftc8
;
4109 tmp
= gfor_fndecl_math_ishftc16
;
4114 se
->expr
= build_call_expr_loc (input_location
,
4115 tmp
, 3, args
[0], args
[1], args
[2]);
4116 /* Convert the result back to the original type, if we extended
4117 the first argument's width above. */
4118 if (expr
->ts
.kind
< 4)
4119 se
->expr
= convert (type
, se
->expr
);
4123 type
= TREE_TYPE (args
[0]);
4125 /* Evaluate arguments only once. */
4126 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4127 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4129 /* Rotate left if positive. */
4130 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4132 /* Rotate right if negative. */
4133 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4135 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4137 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4138 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4140 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4142 /* Do nothing if shift == 0. */
4143 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4145 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4150 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4151 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4153 The conditional expression is necessary because the result of LEADZ(0)
4154 is defined, but the result of __builtin_clz(0) is undefined for most
4157 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4158 difference in bit size between the argument of LEADZ and the C int. */
4161 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4173 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4174 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4176 /* Which variant of __builtin_clz* should we call? */
4177 if (argsize
<= INT_TYPE_SIZE
)
4179 arg_type
= unsigned_type_node
;
4180 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4182 else if (argsize
<= LONG_TYPE_SIZE
)
4184 arg_type
= long_unsigned_type_node
;
4185 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4187 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4189 arg_type
= long_long_unsigned_type_node
;
4190 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4194 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4195 arg_type
= gfc_build_uint_type (argsize
);
4199 /* Convert the actual argument twice: first, to the unsigned type of the
4200 same size; then, to the proper argument type for the built-in
4201 function. But the return type is of the default INTEGER kind. */
4202 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4203 arg
= fold_convert (arg_type
, arg
);
4204 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4205 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4207 /* Compute LEADZ for the case i .ne. 0. */
4210 s
= TYPE_PRECISION (arg_type
) - argsize
;
4211 tmp
= fold_convert (result_type
,
4212 build_call_expr_loc (input_location
, func
,
4214 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4215 tmp
, build_int_cst (result_type
, s
));
4219 /* We end up here if the argument type is larger than 'long long'.
4220 We generate this code:
4222 if (x & (ULL_MAX << ULL_SIZE) != 0)
4223 return clzll ((unsigned long long) (x >> ULLSIZE));
4225 return ULL_SIZE + clzll ((unsigned long long) x);
4226 where ULL_MAX is the largest value that a ULL_MAX can hold
4227 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4228 is the bit-size of the long long type (64 in this example). */
4229 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4231 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4232 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4233 long_long_unsigned_type_node
,
4234 build_int_cst (long_long_unsigned_type_node
,
4237 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4238 fold_convert (arg_type
, ullmax
), ullsize
);
4239 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4241 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4242 cond
, build_int_cst (arg_type
, 0));
4244 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4246 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4247 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4248 tmp1
= fold_convert (result_type
,
4249 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4251 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4252 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4253 tmp2
= fold_convert (result_type
,
4254 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4255 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4258 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4262 /* Build BIT_SIZE. */
4263 bit_size
= build_int_cst (result_type
, argsize
);
4265 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4266 arg
, build_int_cst (arg_type
, 0));
4267 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4272 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4274 The conditional expression is necessary because the result of TRAILZ(0)
4275 is defined, but the result of __builtin_ctz(0) is undefined for most
4279 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4290 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4291 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4293 /* Which variant of __builtin_ctz* should we call? */
4294 if (argsize
<= INT_TYPE_SIZE
)
4296 arg_type
= unsigned_type_node
;
4297 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4299 else if (argsize
<= LONG_TYPE_SIZE
)
4301 arg_type
= long_unsigned_type_node
;
4302 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4304 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4306 arg_type
= long_long_unsigned_type_node
;
4307 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4311 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4312 arg_type
= gfc_build_uint_type (argsize
);
4316 /* Convert the actual argument twice: first, to the unsigned type of the
4317 same size; then, to the proper argument type for the built-in
4318 function. But the return type is of the default INTEGER kind. */
4319 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4320 arg
= fold_convert (arg_type
, arg
);
4321 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4322 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4324 /* Compute TRAILZ for the case i .ne. 0. */
4326 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4330 /* We end up here if the argument type is larger than 'long long'.
4331 We generate this code:
4333 if ((x & ULL_MAX) == 0)
4334 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4336 return ctzll ((unsigned long long) x);
4338 where ULL_MAX is the largest value that a ULL_MAX can hold
4339 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4340 is the bit-size of the long long type (64 in this example). */
4341 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4343 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4344 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4345 long_long_unsigned_type_node
,
4346 build_int_cst (long_long_unsigned_type_node
, 0));
4348 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4349 fold_convert (arg_type
, ullmax
));
4350 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4351 build_int_cst (arg_type
, 0));
4353 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4355 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4356 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4357 tmp1
= fold_convert (result_type
,
4358 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4359 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4362 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4363 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4364 tmp2
= fold_convert (result_type
,
4365 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4367 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4371 /* Build BIT_SIZE. */
4372 bit_size
= build_int_cst (result_type
, argsize
);
4374 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4375 arg
, build_int_cst (arg_type
, 0));
4376 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4380 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4381 for types larger than "long long", we call the long long built-in for
4382 the lower and higher bits and combine the result. */
4385 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
4393 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4394 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4395 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4397 /* Which variant of the builtin should we call? */
4398 if (argsize
<= INT_TYPE_SIZE
)
4400 arg_type
= unsigned_type_node
;
4401 func
= builtin_decl_explicit (parity
4403 : BUILT_IN_POPCOUNT
);
4405 else if (argsize
<= LONG_TYPE_SIZE
)
4407 arg_type
= long_unsigned_type_node
;
4408 func
= builtin_decl_explicit (parity
4410 : BUILT_IN_POPCOUNTL
);
4412 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4414 arg_type
= long_long_unsigned_type_node
;
4415 func
= builtin_decl_explicit (parity
4417 : BUILT_IN_POPCOUNTLL
);
4421 /* Our argument type is larger than 'long long', which mean none
4422 of the POPCOUNT builtins covers it. We thus call the 'long long'
4423 variant multiple times, and add the results. */
4424 tree utype
, arg2
, call1
, call2
;
4426 /* For now, we only cover the case where argsize is twice as large
4428 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4430 func
= builtin_decl_explicit (parity
4432 : BUILT_IN_POPCOUNTLL
);
4434 /* Convert it to an integer, and store into a variable. */
4435 utype
= gfc_build_uint_type (argsize
);
4436 arg
= fold_convert (utype
, arg
);
4437 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4439 /* Call the builtin twice. */
4440 call1
= build_call_expr_loc (input_location
, func
, 1,
4441 fold_convert (long_long_unsigned_type_node
,
4444 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
4445 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
4446 call2
= build_call_expr_loc (input_location
, func
, 1,
4447 fold_convert (long_long_unsigned_type_node
,
4450 /* Combine the results. */
4452 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
4455 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4461 /* Convert the actual argument twice: first, to the unsigned type of the
4462 same size; then, to the proper argument type for the built-in
4464 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4465 arg
= fold_convert (arg_type
, arg
);
4467 se
->expr
= fold_convert (result_type
,
4468 build_call_expr_loc (input_location
, func
, 1, arg
));
4472 /* Process an intrinsic with unspecified argument-types that has an optional
4473 argument (which could be of type character), e.g. EOSHIFT. For those, we
4474 need to append the string length of the optional argument if it is not
4475 present and the type is really character.
4476 primary specifies the position (starting at 1) of the non-optional argument
4477 specifying the type and optional gives the position of the optional
4478 argument in the arglist. */
4481 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
4482 unsigned primary
, unsigned optional
)
4484 gfc_actual_arglist
* prim_arg
;
4485 gfc_actual_arglist
* opt_arg
;
4487 gfc_actual_arglist
* arg
;
4489 vec
<tree
, va_gc
> *append_args
;
4491 /* Find the two arguments given as position. */
4495 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4499 if (cur_pos
== primary
)
4501 if (cur_pos
== optional
)
4504 if (cur_pos
>= primary
&& cur_pos
>= optional
)
4507 gcc_assert (prim_arg
);
4508 gcc_assert (prim_arg
->expr
);
4509 gcc_assert (opt_arg
);
4511 /* If we do have type CHARACTER and the optional argument is really absent,
4512 append a dummy 0 as string length. */
4514 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
4518 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
4519 vec_alloc (append_args
, 1);
4520 append_args
->quick_push (dummy
);
4523 /* Build the call itself. */
4524 sym
= gfc_get_symbol_for_expr (expr
);
4525 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4527 gfc_free_symbol (sym
);
4531 /* The length of a character string. */
4533 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
4542 gcc_assert (!se
->ss
);
4544 arg
= expr
->value
.function
.actual
->expr
;
4546 type
= gfc_typenode_for_spec (&expr
->ts
);
4547 switch (arg
->expr_type
)
4550 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
4554 /* Obtain the string length from the function used by
4555 trans-array.c(gfc_trans_array_constructor). */
4557 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
4561 if (arg
->ref
== NULL
4562 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
4564 /* This doesn't catch all cases.
4565 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4566 and the surrounding thread. */
4567 sym
= arg
->symtree
->n
.sym
;
4568 decl
= gfc_get_symbol_decl (sym
);
4569 if (decl
== current_function_decl
&& sym
->attr
.function
4570 && (sym
->result
== sym
))
4571 decl
= gfc_get_fake_result_decl (sym
, 0);
4573 len
= sym
->ts
.u
.cl
->backend_decl
;
4578 /* Otherwise fall through. */
4581 /* Anybody stupid enough to do this deserves inefficient code. */
4582 gfc_init_se (&argse
, se
);
4584 gfc_conv_expr (&argse
, arg
);
4586 gfc_conv_expr_descriptor (&argse
, arg
);
4587 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4588 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4589 len
= argse
.string_length
;
4592 se
->expr
= convert (type
, len
);
4595 /* The length of a character string not including trailing blanks. */
4597 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
4599 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4600 tree args
[2], type
, fndecl
;
4602 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4603 type
= gfc_typenode_for_spec (&expr
->ts
);
4606 fndecl
= gfor_fndecl_string_len_trim
;
4608 fndecl
= gfor_fndecl_string_len_trim_char4
;
4612 se
->expr
= build_call_expr_loc (input_location
,
4613 fndecl
, 2, args
[0], args
[1]);
4614 se
->expr
= convert (type
, se
->expr
);
4618 /* Returns the starting position of a substring within a string. */
4621 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4624 tree logical4_type_node
= gfc_get_logical_type (4);
4628 unsigned int num_args
;
4630 args
= XALLOCAVEC (tree
, 5);
4632 /* Get number of arguments; characters count double due to the
4633 string length argument. Kind= is not passed to the library
4634 and thus ignored. */
4635 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4640 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4641 type
= gfc_typenode_for_spec (&expr
->ts
);
4644 args
[4] = build_int_cst (logical4_type_node
, 0);
4646 args
[4] = convert (logical4_type_node
, args
[4]);
4648 fndecl
= build_addr (function
, current_function_decl
);
4649 se
->expr
= build_call_array_loc (input_location
,
4650 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4652 se
->expr
= convert (type
, se
->expr
);
4656 /* The ascii value for a single character. */
4658 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4660 tree args
[2], type
, pchartype
;
4662 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4663 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
4664 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
4665 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
4666 type
= gfc_typenode_for_spec (&expr
->ts
);
4668 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4670 se
->expr
= convert (type
, se
->expr
);
4674 /* Intrinsic ISNAN calls __builtin_isnan. */
4677 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
4681 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4682 se
->expr
= build_call_expr_loc (input_location
,
4683 builtin_decl_explicit (BUILT_IN_ISNAN
),
4685 STRIP_TYPE_NOPS (se
->expr
);
4686 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4690 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4691 their argument against a constant integer value. */
4694 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
4698 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4699 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
4700 gfc_typenode_for_spec (&expr
->ts
),
4701 arg
, build_int_cst (TREE_TYPE (arg
), value
));
4706 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4709 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
4717 unsigned int num_args
;
4719 num_args
= gfc_intrinsic_argument_list_length (expr
);
4720 args
= XALLOCAVEC (tree
, num_args
);
4722 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4723 if (expr
->ts
.type
!= BT_CHARACTER
)
4731 /* We do the same as in the non-character case, but the argument
4732 list is different because of the string length arguments. We
4733 also have to set the string length for the result. */
4740 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
4742 se
->string_length
= len
;
4744 type
= TREE_TYPE (tsource
);
4745 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
4746 fold_convert (type
, fsource
));
4750 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4753 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
4755 tree args
[3], mask
, type
;
4757 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4758 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
4760 type
= TREE_TYPE (args
[0]);
4761 gcc_assert (TREE_TYPE (args
[1]) == type
);
4762 gcc_assert (TREE_TYPE (mask
) == type
);
4764 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
4765 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
4766 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4768 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
4773 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4774 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4777 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
4779 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
4782 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4783 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4785 type
= gfc_get_int_type (expr
->ts
.kind
);
4786 utype
= unsigned_type_for (type
);
4788 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
4789 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
4791 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
4792 build_int_cst (utype
, 0));
4796 /* Left-justified mask. */
4797 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
4799 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4800 fold_convert (utype
, res
));
4802 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4803 smaller than type width. */
4804 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4805 build_int_cst (TREE_TYPE (arg
), 0));
4806 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
4807 build_int_cst (utype
, 0), res
);
4811 /* Right-justified mask. */
4812 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4813 fold_convert (utype
, arg
));
4814 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
4816 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4817 strictly smaller than type width. */
4818 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4820 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
4821 cond
, allones
, res
);
4824 se
->expr
= fold_convert (type
, res
);
4828 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4830 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
4832 tree arg
, type
, tmp
, frexp
;
4834 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4836 type
= gfc_typenode_for_spec (&expr
->ts
);
4837 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4838 tmp
= gfc_create_var (integer_type_node
, NULL
);
4839 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
4840 fold_convert (type
, arg
),
4841 gfc_build_addr_expr (NULL_TREE
, tmp
));
4842 se
->expr
= fold_convert (type
, se
->expr
);
4846 /* NEAREST (s, dir) is translated into
4847 tmp = copysign (HUGE_VAL, dir);
4848 return nextafter (s, tmp);
4851 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
4853 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
4855 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
4856 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
4858 type
= gfc_typenode_for_spec (&expr
->ts
);
4859 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4861 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
4862 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
4863 fold_convert (type
, args
[1]));
4864 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
4865 fold_convert (type
, args
[0]), tmp
);
4866 se
->expr
= fold_convert (type
, se
->expr
);
4870 /* SPACING (s) is translated into
4878 e = MAX_EXPR (e, emin);
4879 res = scalbn (1., e);
4883 where prec is the precision of s, gfc_real_kinds[k].digits,
4884 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4885 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4888 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
4890 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
4891 tree cond
, tmp
, frexp
, scalbn
;
4895 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4896 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
4897 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
4898 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
4900 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4901 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4903 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4904 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4906 type
= gfc_typenode_for_spec (&expr
->ts
);
4907 e
= gfc_create_var (integer_type_node
, NULL
);
4908 res
= gfc_create_var (type
, NULL
);
4911 /* Build the block for s /= 0. */
4912 gfc_start_block (&block
);
4913 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4914 gfc_build_addr_expr (NULL_TREE
, e
));
4915 gfc_add_expr_to_block (&block
, tmp
);
4917 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
4919 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
4920 integer_type_node
, tmp
, emin
));
4922 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
4923 build_real_from_int_cst (type
, integer_one_node
), e
);
4924 gfc_add_modify (&block
, res
, tmp
);
4926 /* Finish by building the IF statement. */
4927 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4928 build_real_from_int_cst (type
, integer_zero_node
));
4929 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
4930 gfc_finish_block (&block
));
4932 gfc_add_expr_to_block (&se
->pre
, tmp
);
4937 /* RRSPACING (s) is translated into
4944 x = scalbn (x, precision - e);
4948 where precision is gfc_real_kinds[k].digits. */
4951 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
4953 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
4957 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4958 prec
= gfc_real_kinds
[k
].digits
;
4960 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4961 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4962 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
4964 type
= gfc_typenode_for_spec (&expr
->ts
);
4965 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4966 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4968 e
= gfc_create_var (integer_type_node
, NULL
);
4969 x
= gfc_create_var (type
, NULL
);
4970 gfc_add_modify (&se
->pre
, x
,
4971 build_call_expr_loc (input_location
, fabs
, 1, arg
));
4974 gfc_start_block (&block
);
4975 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4976 gfc_build_addr_expr (NULL_TREE
, e
));
4977 gfc_add_expr_to_block (&block
, tmp
);
4979 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
4980 build_int_cst (integer_type_node
, prec
), e
);
4981 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
4982 gfc_add_modify (&block
, x
, tmp
);
4983 stmt
= gfc_finish_block (&block
);
4985 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
4986 build_real_from_int_cst (type
, integer_zero_node
));
4987 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
4988 gfc_add_expr_to_block (&se
->pre
, tmp
);
4990 se
->expr
= fold_convert (type
, x
);
4994 /* SCALE (s, i) is translated into scalbn (s, i). */
4996 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
4998 tree args
[2], type
, scalbn
;
5000 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5002 type
= gfc_typenode_for_spec (&expr
->ts
);
5003 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5004 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5005 fold_convert (type
, args
[0]),
5006 fold_convert (integer_type_node
, args
[1]));
5007 se
->expr
= fold_convert (type
, se
->expr
);
5011 /* SET_EXPONENT (s, i) is translated into
5012 scalbn (frexp (s, &dummy_int), i). */
5014 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5016 tree args
[2], type
, tmp
, frexp
, scalbn
;
5018 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5019 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5021 type
= gfc_typenode_for_spec (&expr
->ts
);
5022 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5024 tmp
= gfc_create_var (integer_type_node
, NULL
);
5025 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5026 fold_convert (type
, args
[0]),
5027 gfc_build_addr_expr (NULL_TREE
, tmp
));
5028 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5029 fold_convert (integer_type_node
, args
[1]));
5030 se
->expr
= fold_convert (type
, se
->expr
);
5035 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5037 gfc_actual_arglist
*actual
;
5044 gfc_init_se (&argse
, NULL
);
5045 actual
= expr
->value
.function
.actual
;
5047 if (actual
->expr
->ts
.type
== BT_CLASS
)
5048 gfc_add_class_array_ref (actual
->expr
);
5050 argse
.want_pointer
= 1;
5051 argse
.data_not_needed
= 1;
5052 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5053 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5054 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5055 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5057 /* Build the call to size0. */
5058 fncall0
= build_call_expr_loc (input_location
,
5059 gfor_fndecl_size0
, 1, arg1
);
5061 actual
= actual
->next
;
5065 gfc_init_se (&argse
, NULL
);
5066 gfc_conv_expr_type (&argse
, actual
->expr
,
5067 gfc_array_index_type
);
5068 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5070 /* Unusually, for an intrinsic, size does not exclude
5071 an optional arg2, so we must test for it. */
5072 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5073 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5074 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5077 /* Build the call to size1. */
5078 fncall1
= build_call_expr_loc (input_location
,
5079 gfor_fndecl_size1
, 2,
5082 gfc_init_se (&argse
, NULL
);
5083 argse
.want_pointer
= 1;
5084 argse
.data_not_needed
= 1;
5085 gfc_conv_expr (&argse
, actual
->expr
);
5086 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5087 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5088 argse
.expr
, null_pointer_node
);
5089 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5090 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5091 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5095 se
->expr
= NULL_TREE
;
5096 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5097 gfc_array_index_type
,
5098 argse
.expr
, gfc_index_one_node
);
5101 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5103 argse
.expr
= gfc_index_zero_node
;
5104 se
->expr
= NULL_TREE
;
5109 if (se
->expr
== NULL_TREE
)
5111 tree ubound
, lbound
;
5113 arg1
= build_fold_indirect_ref_loc (input_location
,
5115 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5116 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5117 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5118 gfc_array_index_type
, ubound
, lbound
);
5119 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5120 gfc_array_index_type
,
5121 se
->expr
, gfc_index_one_node
);
5122 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5123 gfc_array_index_type
, se
->expr
,
5124 gfc_index_zero_node
);
5127 type
= gfc_typenode_for_spec (&expr
->ts
);
5128 se
->expr
= convert (type
, se
->expr
);
5132 /* Helper function to compute the size of a character variable,
5133 excluding the terminating null characters. The result has
5134 gfc_array_index_type type. */
5137 size_of_string_in_bytes (int kind
, tree string_length
)
5140 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5142 bytesize
= build_int_cst (gfc_array_index_type
,
5143 gfc_character_kinds
[i
].bit_size
/ 8);
5145 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5147 fold_convert (gfc_array_index_type
, string_length
));
5152 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5163 arg
= expr
->value
.function
.actual
->expr
;
5165 gfc_init_se (&argse
, NULL
);
5169 if (arg
->ts
.type
== BT_CLASS
)
5170 gfc_add_data_component (arg
);
5172 gfc_conv_expr_reference (&argse
, arg
);
5174 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5177 /* Obtain the source word length. */
5178 if (arg
->ts
.type
== BT_CHARACTER
)
5179 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
5180 argse
.string_length
);
5182 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
5186 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5187 argse
.want_pointer
= 0;
5188 gfc_conv_expr_descriptor (&argse
, arg
);
5189 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5191 /* Obtain the argument's word length. */
5192 if (arg
->ts
.type
== BT_CHARACTER
)
5193 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5195 tmp
= fold_convert (gfc_array_index_type
,
5196 size_in_bytes (type
));
5197 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5199 /* Obtain the size of the array in bytes. */
5200 for (n
= 0; n
< arg
->rank
; n
++)
5203 idx
= gfc_rank_cst
[n
];
5204 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5205 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5206 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5207 gfc_array_index_type
, upper
, lower
);
5208 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5209 gfc_array_index_type
, tmp
, gfc_index_one_node
);
5210 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5211 gfc_array_index_type
, tmp
, source_bytes
);
5212 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5214 se
->expr
= source_bytes
;
5217 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5222 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
5226 tree type
, result_type
, tmp
;
5228 arg
= expr
->value
.function
.actual
->expr
;
5229 gfc_init_se (&eight
, NULL
);
5230 gfc_conv_expr (&eight
, gfc_get_int_expr (expr
->ts
.kind
, NULL
, 8));
5232 gfc_init_se (&argse
, NULL
);
5233 result_type
= gfc_get_int_type (expr
->ts
.kind
);
5237 if (arg
->ts
.type
== BT_CLASS
)
5239 gfc_add_vptr_component (arg
);
5240 gfc_add_size_component (arg
);
5241 gfc_conv_expr (&argse
, arg
);
5242 tmp
= fold_convert (result_type
, argse
.expr
);
5246 gfc_conv_expr_reference (&argse
, arg
);
5247 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5252 argse
.want_pointer
= 0;
5253 gfc_conv_expr_descriptor (&argse
, arg
);
5254 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5257 /* Obtain the argument's word length. */
5258 if (arg
->ts
.type
== BT_CHARACTER
)
5259 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5261 tmp
= fold_convert (result_type
, size_in_bytes (type
));
5264 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
5266 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5270 /* Intrinsic string comparison functions. */
5273 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5277 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
5280 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
5281 expr
->value
.function
.actual
->expr
->ts
.kind
,
5283 se
->expr
= fold_build2_loc (input_location
, op
,
5284 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
5285 build_int_cst (TREE_TYPE (se
->expr
), 0));
5288 /* Generate a call to the adjustl/adjustr library function. */
5290 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
5298 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
5301 type
= TREE_TYPE (args
[2]);
5302 var
= gfc_conv_string_tmp (se
, type
, len
);
5305 tmp
= build_call_expr_loc (input_location
,
5306 fndecl
, 3, args
[0], args
[1], args
[2]);
5307 gfc_add_expr_to_block (&se
->pre
, tmp
);
5309 se
->string_length
= len
;
5313 /* Generate code for the TRANSFER intrinsic:
5315 DEST = TRANSFER (SOURCE, MOLD)
5317 typeof<DEST> = typeof<MOLD>
5322 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5324 typeof<DEST> = typeof<MOLD>
5326 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5327 sizeof (DEST(0) * SIZE). */
5329 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
5345 gfc_actual_arglist
*arg
;
5347 gfc_array_info
*info
;
5351 gfc_expr
*source_expr
, *mold_expr
;
5355 info
= &se
->ss
->info
->data
.array
;
5357 /* Convert SOURCE. The output from this stage is:-
5358 source_bytes = length of the source in bytes
5359 source = pointer to the source data. */
5360 arg
= expr
->value
.function
.actual
;
5361 source_expr
= arg
->expr
;
5363 /* Ensure double transfer through LOGICAL preserves all
5365 if (arg
->expr
->expr_type
== EXPR_FUNCTION
5366 && arg
->expr
->value
.function
.esym
== NULL
5367 && arg
->expr
->value
.function
.isym
!= NULL
5368 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
5369 && arg
->expr
->ts
.type
== BT_LOGICAL
5370 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
5371 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
5373 gfc_init_se (&argse
, NULL
);
5375 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5377 /* Obtain the pointer to source and the length of source in bytes. */
5378 if (arg
->expr
->rank
== 0)
5380 gfc_conv_expr_reference (&argse
, arg
->expr
);
5381 if (arg
->expr
->ts
.type
== BT_CLASS
)
5382 source
= gfc_class_data_get (argse
.expr
);
5384 source
= argse
.expr
;
5386 /* Obtain the source word length. */
5387 switch (arg
->expr
->ts
.type
)
5390 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5391 argse
.string_length
);
5394 tmp
= gfc_vtable_size_get (argse
.expr
);
5397 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5399 tmp
= fold_convert (gfc_array_index_type
,
5400 size_in_bytes (source_type
));
5406 argse
.want_pointer
= 0;
5407 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5408 source
= gfc_conv_descriptor_data_get (argse
.expr
);
5409 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5411 /* Repack the source if not a full variable array. */
5412 if (arg
->expr
->expr_type
== EXPR_VARIABLE
5413 && arg
->expr
->ref
->u
.ar
.type
!= AR_FULL
)
5415 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
5417 if (gfc_option
.warn_array_temp
)
5418 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5420 source
= build_call_expr_loc (input_location
,
5421 gfor_fndecl_in_pack
, 1, tmp
);
5422 source
= gfc_evaluate_now (source
, &argse
.pre
);
5424 /* Free the temporary. */
5425 gfc_start_block (&block
);
5426 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
5427 gfc_add_expr_to_block (&block
, tmp
);
5428 stmt
= gfc_finish_block (&block
);
5430 /* Clean up if it was repacked. */
5431 gfc_init_block (&block
);
5432 tmp
= gfc_conv_array_data (argse
.expr
);
5433 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5435 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
5436 build_empty_stmt (input_location
));
5437 gfc_add_expr_to_block (&block
, tmp
);
5438 gfc_add_block_to_block (&block
, &se
->post
);
5439 gfc_init_block (&se
->post
);
5440 gfc_add_block_to_block (&se
->post
, &block
);
5443 /* Obtain the source word length. */
5444 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5445 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5446 argse
.string_length
);
5448 tmp
= fold_convert (gfc_array_index_type
,
5449 size_in_bytes (source_type
));
5451 /* Obtain the size of the array in bytes. */
5452 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
5453 for (n
= 0; n
< arg
->expr
->rank
; n
++)
5456 idx
= gfc_rank_cst
[n
];
5457 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5458 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5459 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5460 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5461 gfc_array_index_type
, upper
, lower
);
5462 gfc_add_modify (&argse
.pre
, extent
, tmp
);
5463 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5464 gfc_array_index_type
, extent
,
5465 gfc_index_one_node
);
5466 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5467 gfc_array_index_type
, tmp
, source_bytes
);
5471 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5472 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5473 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5475 /* Now convert MOLD. The outputs are:
5476 mold_type = the TREE type of MOLD
5477 dest_word_len = destination word length in bytes. */
5479 mold_expr
= arg
->expr
;
5481 gfc_init_se (&argse
, NULL
);
5483 scalar_mold
= arg
->expr
->rank
== 0;
5485 if (arg
->expr
->rank
== 0)
5487 gfc_conv_expr_reference (&argse
, arg
->expr
);
5488 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5493 gfc_init_se (&argse
, NULL
);
5494 argse
.want_pointer
= 0;
5495 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5496 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5499 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5500 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5502 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
5504 /* If this TRANSFER is nested in another TRANSFER, use a type
5505 that preserves all bits. */
5506 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
5507 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
5510 /* Obtain the destination word length. */
5511 switch (arg
->expr
->ts
.type
)
5514 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
5515 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
5518 tmp
= gfc_vtable_size_get (argse
.expr
);
5521 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
5524 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
5525 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
5527 /* Finally convert SIZE, if it is present. */
5529 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
5533 gfc_init_se (&argse
, NULL
);
5534 gfc_conv_expr_reference (&argse
, arg
->expr
);
5535 tmp
= convert (gfc_array_index_type
,
5536 build_fold_indirect_ref_loc (input_location
,
5538 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5539 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5544 /* Separate array and scalar results. */
5545 if (scalar_mold
&& tmp
== NULL_TREE
)
5546 goto scalar_transfer
;
5548 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5549 if (tmp
!= NULL_TREE
)
5550 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5551 tmp
, dest_word_len
);
5555 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
5556 gfc_add_modify (&se
->pre
, size_words
,
5557 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
5558 gfc_array_index_type
,
5559 size_bytes
, dest_word_len
));
5561 /* Evaluate the bounds of the result. If the loop range exists, we have
5562 to check if it is too large. If so, we modify loop->to be consistent
5563 with min(size, size(source)). Otherwise, size is made consistent with
5564 the loop range, so that the right number of bytes is transferred.*/
5565 n
= se
->loop
->order
[0];
5566 if (se
->loop
->to
[n
] != NULL_TREE
)
5568 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5569 se
->loop
->to
[n
], se
->loop
->from
[n
]);
5570 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5571 tmp
, gfc_index_one_node
);
5572 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5574 gfc_add_modify (&se
->pre
, size_words
, tmp
);
5575 gfc_add_modify (&se
->pre
, size_bytes
,
5576 fold_build2_loc (input_location
, MULT_EXPR
,
5577 gfc_array_index_type
,
5578 size_words
, dest_word_len
));
5579 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5580 size_words
, se
->loop
->from
[n
]);
5581 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5582 upper
, gfc_index_one_node
);
5586 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5587 size_words
, gfc_index_one_node
);
5588 se
->loop
->from
[n
] = gfc_index_zero_node
;
5591 se
->loop
->to
[n
] = upper
;
5593 /* Build a destination descriptor, using the pointer, source, as the
5595 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
5596 NULL_TREE
, false, true, false, &expr
->where
);
5598 /* Cast the pointer to the result. */
5599 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5600 tmp
= fold_convert (pvoid_type_node
, tmp
);
5602 /* Use memcpy to do the transfer. */
5604 = build_call_expr_loc (input_location
,
5605 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
5606 fold_convert (pvoid_type_node
, source
),
5607 fold_convert (size_type_node
,
5608 fold_build2_loc (input_location
,
5610 gfc_array_index_type
,
5613 gfc_add_expr_to_block (&se
->pre
, tmp
);
5615 se
->expr
= info
->descriptor
;
5616 if (expr
->ts
.type
== BT_CHARACTER
)
5617 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5621 /* Deal with scalar results. */
5623 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5624 dest_word_len
, source_bytes
);
5625 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5626 extent
, gfc_index_zero_node
);
5628 if (expr
->ts
.type
== BT_CHARACTER
)
5633 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5634 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5637 /* If source is longer than the destination, use a pointer to
5638 the source directly. */
5639 gfc_init_block (&block
);
5640 gfc_add_modify (&block
, tmpdecl
, ptr
);
5641 direct
= gfc_finish_block (&block
);
5643 /* Otherwise, allocate a string with the length of the destination
5644 and copy the source into it. */
5645 gfc_init_block (&block
);
5646 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5647 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5648 gfc_add_modify (&block
, tmpdecl
,
5649 fold_convert (TREE_TYPE (ptr
), tmp
));
5650 tmp
= build_call_expr_loc (input_location
,
5651 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5652 fold_convert (pvoid_type_node
, tmpdecl
),
5653 fold_convert (pvoid_type_node
, ptr
),
5654 fold_convert (size_type_node
, extent
));
5655 gfc_add_expr_to_block (&block
, tmp
);
5656 indirect
= gfc_finish_block (&block
);
5658 /* Wrap it up with the condition. */
5659 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5660 dest_word_len
, source_bytes
);
5661 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5662 gfc_add_expr_to_block (&se
->pre
, tmp
);
5665 se
->string_length
= dest_word_len
;
5669 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5671 ptr
= convert (build_pointer_type (mold_type
), source
);
5673 /* For CLASS results, allocate the needed memory first. */
5674 if (mold_expr
->ts
.type
== BT_CLASS
)
5677 cdata
= gfc_class_data_get (tmpdecl
);
5678 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
5679 gfc_add_modify (&se
->pre
, cdata
, tmp
);
5682 /* Use memcpy to do the transfer. */
5683 if (mold_expr
->ts
.type
== BT_CLASS
)
5684 tmp
= gfc_class_data_get (tmpdecl
);
5686 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5688 tmp
= build_call_expr_loc (input_location
,
5689 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5690 fold_convert (pvoid_type_node
, tmp
),
5691 fold_convert (pvoid_type_node
, ptr
),
5692 fold_convert (size_type_node
, extent
));
5693 gfc_add_expr_to_block (&se
->pre
, tmp
);
5695 /* For CLASS results, set the _vptr. */
5696 if (mold_expr
->ts
.type
== BT_CLASS
)
5700 vptr
= gfc_class_vptr_get (tmpdecl
);
5701 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
5703 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
5704 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
5712 /* Generate code for the ALLOCATED intrinsic.
5713 Generate inline code that directly check the address of the argument. */
5716 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5718 gfc_actual_arglist
*arg1
;
5722 gfc_init_se (&arg1se
, NULL
);
5723 arg1
= expr
->value
.function
.actual
;
5725 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5727 /* Make sure that class array expressions have both a _data
5728 component reference and an array reference.... */
5729 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
5730 gfc_add_class_array_ref (arg1
->expr
);
5731 /* .... whilst scalars only need the _data component. */
5733 gfc_add_data_component (arg1
->expr
);
5736 if (arg1
->expr
->rank
== 0)
5738 /* Allocatable scalar. */
5739 arg1se
.want_pointer
= 1;
5740 gfc_conv_expr (&arg1se
, arg1
->expr
);
5745 /* Allocatable array. */
5746 arg1se
.descriptor_only
= 1;
5747 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5748 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5751 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5752 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5753 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5757 /* Generate code for the ASSOCIATED intrinsic.
5758 If both POINTER and TARGET are arrays, generate a call to library function
5759 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5760 In other cases, generate inline code that directly compare the address of
5761 POINTER with the address of TARGET. */
5764 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
5766 gfc_actual_arglist
*arg1
;
5767 gfc_actual_arglist
*arg2
;
5772 tree nonzero_charlen
;
5773 tree nonzero_arraylen
;
5777 gfc_init_se (&arg1se
, NULL
);
5778 gfc_init_se (&arg2se
, NULL
);
5779 arg1
= expr
->value
.function
.actual
;
5780 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5781 gfc_add_data_component (arg1
->expr
);
5784 /* Check whether the expression is a scalar or not; we cannot use
5785 arg1->expr->rank as it can be nonzero for proc pointers. */
5786 ss
= gfc_walk_expr (arg1
->expr
);
5787 scalar
= ss
== gfc_ss_terminator
;
5789 gfc_free_ss_chain (ss
);
5793 /* No optional target. */
5796 /* A pointer to a scalar. */
5797 arg1se
.want_pointer
= 1;
5798 gfc_conv_expr (&arg1se
, arg1
->expr
);
5799 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5800 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5801 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5807 /* A pointer to an array. */
5808 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5809 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5811 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5812 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5813 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
5814 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
5819 /* An optional target. */
5820 if (arg2
->expr
->ts
.type
== BT_CLASS
)
5821 gfc_add_data_component (arg2
->expr
);
5823 nonzero_charlen
= NULL_TREE
;
5824 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
5825 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
5827 arg1
->expr
->ts
.u
.cl
->backend_decl
,
5831 /* A pointer to a scalar. */
5832 arg1se
.want_pointer
= 1;
5833 gfc_conv_expr (&arg1se
, arg1
->expr
);
5834 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5835 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5836 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5839 arg2se
.want_pointer
= 1;
5840 gfc_conv_expr (&arg2se
, arg2
->expr
);
5841 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5842 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
5843 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
5845 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5846 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5847 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5848 arg1se
.expr
, arg2se
.expr
);
5849 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5850 arg1se
.expr
, null_pointer_node
);
5851 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5852 boolean_type_node
, tmp
, tmp2
);
5856 /* An array pointer of zero length is not associated if target is
5858 arg1se
.descriptor_only
= 1;
5859 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
5860 if (arg1
->expr
->rank
== -1)
5862 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
5863 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5864 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
5867 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
5868 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
5869 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
5870 boolean_type_node
, tmp
,
5871 build_int_cst (TREE_TYPE (tmp
), 0));
5873 /* A pointer to an array, call library function _gfor_associated. */
5874 arg1se
.want_pointer
= 1;
5875 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5877 arg2se
.want_pointer
= 1;
5878 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
5879 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
5880 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
5881 se
->expr
= build_call_expr_loc (input_location
,
5882 gfor_fndecl_associated
, 2,
5883 arg1se
.expr
, arg2se
.expr
);
5884 se
->expr
= convert (boolean_type_node
, se
->expr
);
5885 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5886 boolean_type_node
, se
->expr
,
5890 /* If target is present zero character length pointers cannot
5892 if (nonzero_charlen
!= NULL_TREE
)
5893 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5895 se
->expr
, nonzero_charlen
);
5898 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5902 /* Generate code for the SAME_TYPE_AS intrinsic.
5903 Generate inline code that directly checks the vindices. */
5906 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
5912 gfc_init_se (&se1
, NULL
);
5913 gfc_init_se (&se2
, NULL
);
5915 a
= expr
->value
.function
.actual
->expr
;
5916 b
= expr
->value
.function
.actual
->next
->expr
;
5918 if (a
->ts
.type
== BT_CLASS
)
5920 gfc_add_vptr_component (a
);
5921 gfc_add_hash_component (a
);
5923 else if (a
->ts
.type
== BT_DERIVED
)
5924 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5925 a
->ts
.u
.derived
->hash_value
);
5927 if (b
->ts
.type
== BT_CLASS
)
5929 gfc_add_vptr_component (b
);
5930 gfc_add_hash_component (b
);
5932 else if (b
->ts
.type
== BT_DERIVED
)
5933 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5934 b
->ts
.u
.derived
->hash_value
);
5936 gfc_conv_expr (&se1
, a
);
5937 gfc_conv_expr (&se2
, b
);
5939 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5940 se1
.expr
, fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
5941 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5945 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
5948 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
5952 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5953 se
->expr
= build_call_expr_loc (input_location
,
5954 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
5955 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5959 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
5962 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
5966 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5968 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5969 type
= gfc_get_int_type (4);
5970 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
5972 /* Convert it to the required type. */
5973 type
= gfc_typenode_for_spec (&expr
->ts
);
5974 se
->expr
= build_call_expr_loc (input_location
,
5975 gfor_fndecl_si_kind
, 1, arg
);
5976 se
->expr
= fold_convert (type
, se
->expr
);
5980 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
5983 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
5985 gfc_actual_arglist
*actual
;
5988 vec
<tree
, va_gc
> *args
= NULL
;
5990 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
5992 gfc_init_se (&argse
, se
);
5994 /* Pass a NULL pointer for an absent arg. */
5995 if (actual
->expr
== NULL
)
5996 argse
.expr
= null_pointer_node
;
6002 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6004 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6005 ts
.type
= BT_INTEGER
;
6006 ts
.kind
= gfc_c_int_kind
;
6007 gfc_convert_type (actual
->expr
, &ts
, 2);
6009 gfc_conv_expr_reference (&argse
, actual
->expr
);
6012 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6013 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6014 vec_safe_push (args
, argse
.expr
);
6017 /* Convert it to the required type. */
6018 type
= gfc_typenode_for_spec (&expr
->ts
);
6019 se
->expr
= build_call_expr_loc_vec (input_location
,
6020 gfor_fndecl_sr_kind
, args
);
6021 se
->expr
= fold_convert (type
, se
->expr
);
6025 /* Generate code for TRIM (A) intrinsic function. */
6028 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6038 unsigned int num_args
;
6040 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6041 args
= XALLOCAVEC (tree
, num_args
);
6043 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6044 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6045 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6047 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6048 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6051 if (expr
->ts
.kind
== 1)
6052 function
= gfor_fndecl_string_trim
;
6053 else if (expr
->ts
.kind
== 4)
6054 function
= gfor_fndecl_string_trim_char4
;
6058 fndecl
= build_addr (function
, current_function_decl
);
6059 tmp
= build_call_array_loc (input_location
,
6060 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6062 gfc_add_expr_to_block (&se
->pre
, tmp
);
6064 /* Free the temporary afterwards, if necessary. */
6065 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6066 len
, build_int_cst (TREE_TYPE (len
), 0));
6067 tmp
= gfc_call_free (var
);
6068 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6069 gfc_add_expr_to_block (&se
->post
, tmp
);
6072 se
->string_length
= len
;
6076 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6079 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6081 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6082 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6084 stmtblock_t block
, body
;
6087 /* We store in charsize the size of a character. */
6088 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6089 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6091 /* Get the arguments. */
6092 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6093 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6095 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6096 ncopies_type
= TREE_TYPE (ncopies
);
6098 /* Check that NCOPIES is not negative. */
6099 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6100 build_int_cst (ncopies_type
, 0));
6101 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6102 "Argument NCOPIES of REPEAT intrinsic is negative "
6103 "(its value is %ld)",
6104 fold_convert (long_integer_type_node
, ncopies
));
6106 /* If the source length is zero, any non negative value of NCOPIES
6107 is valid, and nothing happens. */
6108 n
= gfc_create_var (ncopies_type
, "ncopies");
6109 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6110 build_int_cst (size_type_node
, 0));
6111 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6112 build_int_cst (ncopies_type
, 0), ncopies
);
6113 gfc_add_modify (&se
->pre
, n
, tmp
);
6116 /* Check that ncopies is not too large: ncopies should be less than
6117 (or equal to) MAX / slen, where MAX is the maximal integer of
6118 the gfc_charlen_type_node type. If slen == 0, we need a special
6119 case to avoid the division by zero. */
6120 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6121 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6122 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6123 fold_convert (size_type_node
, max
), slen
);
6124 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6125 ? size_type_node
: ncopies_type
;
6126 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6127 fold_convert (largest
, ncopies
),
6128 fold_convert (largest
, max
));
6129 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6130 build_int_cst (size_type_node
, 0));
6131 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6132 boolean_false_node
, cond
);
6133 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6134 "Argument NCOPIES of REPEAT intrinsic is too large");
6136 /* Compute the destination length. */
6137 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6138 fold_convert (gfc_charlen_type_node
, slen
),
6139 fold_convert (gfc_charlen_type_node
, ncopies
));
6140 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6141 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6143 /* Generate the code to do the repeat operation:
6144 for (i = 0; i < ncopies; i++)
6145 memmove (dest + (i * slen * size), src, slen*size); */
6146 gfc_start_block (&block
);
6147 count
= gfc_create_var (ncopies_type
, "count");
6148 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6149 exit_label
= gfc_build_label_decl (NULL_TREE
);
6151 /* Start the loop body. */
6152 gfc_start_block (&body
);
6154 /* Exit the loop if count >= ncopies. */
6155 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6157 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6158 TREE_USED (exit_label
) = 1;
6159 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6160 build_empty_stmt (input_location
));
6161 gfc_add_expr_to_block (&body
, tmp
);
6163 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6164 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6165 fold_convert (gfc_charlen_type_node
, slen
),
6166 fold_convert (gfc_charlen_type_node
, count
));
6167 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6168 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6169 tmp
= fold_build_pointer_plus_loc (input_location
,
6170 fold_convert (pvoid_type_node
, dest
), tmp
);
6171 tmp
= build_call_expr_loc (input_location
,
6172 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6174 fold_build2_loc (input_location
, MULT_EXPR
,
6175 size_type_node
, slen
,
6176 fold_convert (size_type_node
,
6178 gfc_add_expr_to_block (&body
, tmp
);
6180 /* Increment count. */
6181 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6182 count
, build_int_cst (TREE_TYPE (count
), 1));
6183 gfc_add_modify (&body
, count
, tmp
);
6185 /* Build the loop. */
6186 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6187 gfc_add_expr_to_block (&block
, tmp
);
6189 /* Add the exit label. */
6190 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6191 gfc_add_expr_to_block (&block
, tmp
);
6193 /* Finish the block. */
6194 tmp
= gfc_finish_block (&block
);
6195 gfc_add_expr_to_block (&se
->pre
, tmp
);
6197 /* Set the result value. */
6199 se
->string_length
= dlen
;
6203 /* Generate code for the IARGC intrinsic. */
6206 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6212 /* Call the library function. This always returns an INTEGER(4). */
6213 fndecl
= gfor_fndecl_iargc
;
6214 tmp
= build_call_expr_loc (input_location
,
6217 /* Convert it to the required type. */
6218 type
= gfc_typenode_for_spec (&expr
->ts
);
6219 tmp
= fold_convert (type
, tmp
);
6225 /* The loc intrinsic returns the address of its argument as
6226 gfc_index_integer_kind integer. */
6229 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
6234 gcc_assert (!se
->ss
);
6236 arg_expr
= expr
->value
.function
.actual
->expr
;
6237 if (arg_expr
->rank
== 0)
6238 gfc_conv_expr_reference (se
, arg_expr
);
6240 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
6241 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
6243 /* Create a temporary variable for loc return value. Without this,
6244 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6245 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
6246 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
6247 se
->expr
= temp_var
;
6250 /* Generate code for an intrinsic function. Some map directly to library
6251 calls, others get special handling. In some cases the name of the function
6252 used depends on the type specifiers. */
6255 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
6261 name
= &expr
->value
.function
.name
[2];
6265 lib
= gfc_is_intrinsic_libcall (expr
);
6269 se
->ignore_optional
= 1;
6271 switch (expr
->value
.function
.isym
->id
)
6273 case GFC_ISYM_EOSHIFT
:
6275 case GFC_ISYM_RESHAPE
:
6276 /* For all of those the first argument specifies the type and the
6277 third is optional. */
6278 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
6282 gfc_conv_intrinsic_funcall (se
, expr
);
6290 switch (expr
->value
.function
.isym
->id
)
6295 case GFC_ISYM_REPEAT
:
6296 gfc_conv_intrinsic_repeat (se
, expr
);
6300 gfc_conv_intrinsic_trim (se
, expr
);
6303 case GFC_ISYM_SC_KIND
:
6304 gfc_conv_intrinsic_sc_kind (se
, expr
);
6307 case GFC_ISYM_SI_KIND
:
6308 gfc_conv_intrinsic_si_kind (se
, expr
);
6311 case GFC_ISYM_SR_KIND
:
6312 gfc_conv_intrinsic_sr_kind (se
, expr
);
6315 case GFC_ISYM_EXPONENT
:
6316 gfc_conv_intrinsic_exponent (se
, expr
);
6320 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6322 fndecl
= gfor_fndecl_string_scan
;
6324 fndecl
= gfor_fndecl_string_scan_char4
;
6328 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6331 case GFC_ISYM_VERIFY
:
6332 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6334 fndecl
= gfor_fndecl_string_verify
;
6336 fndecl
= gfor_fndecl_string_verify_char4
;
6340 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6343 case GFC_ISYM_ALLOCATED
:
6344 gfc_conv_allocated (se
, expr
);
6347 case GFC_ISYM_ASSOCIATED
:
6348 gfc_conv_associated(se
, expr
);
6351 case GFC_ISYM_SAME_TYPE_AS
:
6352 gfc_conv_same_type_as (se
, expr
);
6356 gfc_conv_intrinsic_abs (se
, expr
);
6359 case GFC_ISYM_ADJUSTL
:
6360 if (expr
->ts
.kind
== 1)
6361 fndecl
= gfor_fndecl_adjustl
;
6362 else if (expr
->ts
.kind
== 4)
6363 fndecl
= gfor_fndecl_adjustl_char4
;
6367 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6370 case GFC_ISYM_ADJUSTR
:
6371 if (expr
->ts
.kind
== 1)
6372 fndecl
= gfor_fndecl_adjustr
;
6373 else if (expr
->ts
.kind
== 4)
6374 fndecl
= gfor_fndecl_adjustr_char4
;
6378 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6381 case GFC_ISYM_AIMAG
:
6382 gfc_conv_intrinsic_imagpart (se
, expr
);
6386 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
6390 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
6393 case GFC_ISYM_ANINT
:
6394 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
6398 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6402 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
6405 case GFC_ISYM_BTEST
:
6406 gfc_conv_intrinsic_btest (se
, expr
);
6410 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
6414 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
6418 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
6422 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
6425 case GFC_ISYM_ACHAR
:
6427 gfc_conv_intrinsic_char (se
, expr
);
6430 case GFC_ISYM_CONVERSION
:
6432 case GFC_ISYM_LOGICAL
:
6434 gfc_conv_intrinsic_conversion (se
, expr
);
6437 /* Integer conversions are handled separately to make sure we get the
6438 correct rounding mode. */
6443 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
6447 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
6450 case GFC_ISYM_CEILING
:
6451 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
6454 case GFC_ISYM_FLOOR
:
6455 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
6459 gfc_conv_intrinsic_mod (se
, expr
, 0);
6462 case GFC_ISYM_MODULO
:
6463 gfc_conv_intrinsic_mod (se
, expr
, 1);
6466 case GFC_ISYM_CMPLX
:
6467 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
6470 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
6471 gfc_conv_intrinsic_iargc (se
, expr
);
6474 case GFC_ISYM_COMPLEX
:
6475 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
6478 case GFC_ISYM_CONJG
:
6479 gfc_conv_intrinsic_conjg (se
, expr
);
6482 case GFC_ISYM_COUNT
:
6483 gfc_conv_intrinsic_count (se
, expr
);
6486 case GFC_ISYM_CTIME
:
6487 gfc_conv_intrinsic_ctime (se
, expr
);
6491 gfc_conv_intrinsic_dim (se
, expr
);
6494 case GFC_ISYM_DOT_PRODUCT
:
6495 gfc_conv_intrinsic_dot_product (se
, expr
);
6498 case GFC_ISYM_DPROD
:
6499 gfc_conv_intrinsic_dprod (se
, expr
);
6502 case GFC_ISYM_DSHIFTL
:
6503 gfc_conv_intrinsic_dshift (se
, expr
, true);
6506 case GFC_ISYM_DSHIFTR
:
6507 gfc_conv_intrinsic_dshift (se
, expr
, false);
6510 case GFC_ISYM_FDATE
:
6511 gfc_conv_intrinsic_fdate (se
, expr
);
6514 case GFC_ISYM_FRACTION
:
6515 gfc_conv_intrinsic_fraction (se
, expr
);
6519 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
6523 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6527 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
6530 case GFC_ISYM_IBCLR
:
6531 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
6534 case GFC_ISYM_IBITS
:
6535 gfc_conv_intrinsic_ibits (se
, expr
);
6538 case GFC_ISYM_IBSET
:
6539 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
6542 case GFC_ISYM_IACHAR
:
6543 case GFC_ISYM_ICHAR
:
6544 /* We assume ASCII character sequence. */
6545 gfc_conv_intrinsic_ichar (se
, expr
);
6548 case GFC_ISYM_IARGC
:
6549 gfc_conv_intrinsic_iargc (se
, expr
);
6553 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6556 case GFC_ISYM_INDEX
:
6557 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6559 fndecl
= gfor_fndecl_string_index
;
6561 fndecl
= gfor_fndecl_string_index_char4
;
6565 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6569 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6572 case GFC_ISYM_IPARITY
:
6573 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
6576 case GFC_ISYM_IS_IOSTAT_END
:
6577 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
6580 case GFC_ISYM_IS_IOSTAT_EOR
:
6581 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
6584 case GFC_ISYM_ISNAN
:
6585 gfc_conv_intrinsic_isnan (se
, expr
);
6588 case GFC_ISYM_LSHIFT
:
6589 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6592 case GFC_ISYM_RSHIFT
:
6593 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6596 case GFC_ISYM_SHIFTA
:
6597 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6600 case GFC_ISYM_SHIFTL
:
6601 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6604 case GFC_ISYM_SHIFTR
:
6605 gfc_conv_intrinsic_shift (se
, expr
, true, false);
6608 case GFC_ISYM_ISHFT
:
6609 gfc_conv_intrinsic_ishft (se
, expr
);
6612 case GFC_ISYM_ISHFTC
:
6613 gfc_conv_intrinsic_ishftc (se
, expr
);
6616 case GFC_ISYM_LEADZ
:
6617 gfc_conv_intrinsic_leadz (se
, expr
);
6620 case GFC_ISYM_TRAILZ
:
6621 gfc_conv_intrinsic_trailz (se
, expr
);
6624 case GFC_ISYM_POPCNT
:
6625 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
6628 case GFC_ISYM_POPPAR
:
6629 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
6632 case GFC_ISYM_LBOUND
:
6633 gfc_conv_intrinsic_bound (se
, expr
, 0);
6636 case GFC_ISYM_LCOBOUND
:
6637 conv_intrinsic_cobound (se
, expr
);
6640 case GFC_ISYM_TRANSPOSE
:
6641 /* The scalarizer has already been set up for reversed dimension access
6642 order ; now we just get the argument value normally. */
6643 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
6647 gfc_conv_intrinsic_len (se
, expr
);
6650 case GFC_ISYM_LEN_TRIM
:
6651 gfc_conv_intrinsic_len_trim (se
, expr
);
6655 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
6659 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
6663 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
6667 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
6670 case GFC_ISYM_MASKL
:
6671 gfc_conv_intrinsic_mask (se
, expr
, 1);
6674 case GFC_ISYM_MASKR
:
6675 gfc_conv_intrinsic_mask (se
, expr
, 0);
6679 if (expr
->ts
.type
== BT_CHARACTER
)
6680 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
6682 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
6685 case GFC_ISYM_MAXLOC
:
6686 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
6689 case GFC_ISYM_MAXVAL
:
6690 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
6693 case GFC_ISYM_MERGE
:
6694 gfc_conv_intrinsic_merge (se
, expr
);
6697 case GFC_ISYM_MERGE_BITS
:
6698 gfc_conv_intrinsic_merge_bits (se
, expr
);
6702 if (expr
->ts
.type
== BT_CHARACTER
)
6703 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
6705 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
6708 case GFC_ISYM_MINLOC
:
6709 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
6712 case GFC_ISYM_MINVAL
:
6713 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
6716 case GFC_ISYM_NEAREST
:
6717 gfc_conv_intrinsic_nearest (se
, expr
);
6720 case GFC_ISYM_NORM2
:
6721 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
6725 gfc_conv_intrinsic_not (se
, expr
);
6729 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6732 case GFC_ISYM_PARITY
:
6733 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
6736 case GFC_ISYM_PRESENT
:
6737 gfc_conv_intrinsic_present (se
, expr
);
6740 case GFC_ISYM_PRODUCT
:
6741 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
6745 gfc_conv_intrinsic_rank (se
, expr
);
6748 case GFC_ISYM_RRSPACING
:
6749 gfc_conv_intrinsic_rrspacing (se
, expr
);
6752 case GFC_ISYM_SET_EXPONENT
:
6753 gfc_conv_intrinsic_set_exponent (se
, expr
);
6756 case GFC_ISYM_SCALE
:
6757 gfc_conv_intrinsic_scale (se
, expr
);
6761 gfc_conv_intrinsic_sign (se
, expr
);
6765 gfc_conv_intrinsic_size (se
, expr
);
6768 case GFC_ISYM_SIZEOF
:
6769 case GFC_ISYM_C_SIZEOF
:
6770 gfc_conv_intrinsic_sizeof (se
, expr
);
6773 case GFC_ISYM_STORAGE_SIZE
:
6774 gfc_conv_intrinsic_storage_size (se
, expr
);
6777 case GFC_ISYM_SPACING
:
6778 gfc_conv_intrinsic_spacing (se
, expr
);
6782 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
6785 case GFC_ISYM_TRANSFER
:
6786 if (se
->ss
&& se
->ss
->info
->useflags
)
6787 /* Access the previously obtained result. */
6788 gfc_conv_tmp_array_ref (se
);
6790 gfc_conv_intrinsic_transfer (se
, expr
);
6793 case GFC_ISYM_TTYNAM
:
6794 gfc_conv_intrinsic_ttynam (se
, expr
);
6797 case GFC_ISYM_UBOUND
:
6798 gfc_conv_intrinsic_bound (se
, expr
, 1);
6801 case GFC_ISYM_UCOBOUND
:
6802 conv_intrinsic_cobound (se
, expr
);
6806 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6810 gfc_conv_intrinsic_loc (se
, expr
);
6813 case GFC_ISYM_THIS_IMAGE
:
6814 /* For num_images() == 1, handle as LCOBOUND. */
6815 if (expr
->value
.function
.actual
->expr
6816 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
6817 conv_intrinsic_cobound (se
, expr
);
6819 trans_this_image (se
, expr
);
6822 case GFC_ISYM_IMAGE_INDEX
:
6823 trans_image_index (se
, expr
);
6826 case GFC_ISYM_NUM_IMAGES
:
6827 trans_num_images (se
);
6830 case GFC_ISYM_ACCESS
:
6831 case GFC_ISYM_CHDIR
:
6832 case GFC_ISYM_CHMOD
:
6833 case GFC_ISYM_DTIME
:
6834 case GFC_ISYM_ETIME
:
6835 case GFC_ISYM_EXTENDS_TYPE_OF
:
6837 case GFC_ISYM_FGETC
:
6840 case GFC_ISYM_FPUTC
:
6841 case GFC_ISYM_FSTAT
:
6842 case GFC_ISYM_FTELL
:
6843 case GFC_ISYM_GETCWD
:
6844 case GFC_ISYM_GETGID
:
6845 case GFC_ISYM_GETPID
:
6846 case GFC_ISYM_GETUID
:
6847 case GFC_ISYM_HOSTNM
:
6849 case GFC_ISYM_IERRNO
:
6850 case GFC_ISYM_IRAND
:
6851 case GFC_ISYM_ISATTY
:
6854 case GFC_ISYM_LSTAT
:
6855 case GFC_ISYM_MALLOC
:
6856 case GFC_ISYM_MATMUL
:
6857 case GFC_ISYM_MCLOCK
:
6858 case GFC_ISYM_MCLOCK8
:
6860 case GFC_ISYM_RENAME
:
6861 case GFC_ISYM_SECOND
:
6862 case GFC_ISYM_SECNDS
:
6863 case GFC_ISYM_SIGNAL
:
6865 case GFC_ISYM_SYMLNK
:
6866 case GFC_ISYM_SYSTEM
:
6868 case GFC_ISYM_TIME8
:
6869 case GFC_ISYM_UMASK
:
6870 case GFC_ISYM_UNLINK
:
6872 gfc_conv_intrinsic_funcall (se
, expr
);
6875 case GFC_ISYM_EOSHIFT
:
6877 case GFC_ISYM_RESHAPE
:
6878 /* For those, expr->rank should always be >0 and thus the if above the
6879 switch should have matched. */
6884 gfc_conv_intrinsic_lib_function (se
, expr
);
6891 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
6893 gfc_ss
*arg_ss
, *tmp_ss
;
6894 gfc_actual_arglist
*arg
;
6896 arg
= expr
->value
.function
.actual
;
6898 gcc_assert (arg
->expr
);
6900 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
6901 gcc_assert (arg_ss
!= gfc_ss_terminator
);
6903 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
6905 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
6906 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
6910 gcc_assert (tmp_ss
->dimen
== 2);
6912 /* We just invert dimensions. */
6913 tmp_dim
= tmp_ss
->dim
[0];
6914 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
6915 tmp_ss
->dim
[1] = tmp_dim
;
6918 /* Stop when tmp_ss points to the last valid element of the chain... */
6919 if (tmp_ss
->next
== gfc_ss_terminator
)
6923 /* ... so that we can attach the rest of the chain to it. */
6930 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
6931 This has the side effect of reversing the nested list, so there is no
6932 need to call gfc_reverse_ss on it (the given list is assumed not to be
6936 nest_loop_dimension (gfc_ss
*ss
, int dim
)
6939 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
6940 gfc_loopinfo
*new_loop
;
6942 gcc_assert (ss
!= gfc_ss_terminator
);
6944 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
6946 new_ss
= gfc_get_ss ();
6947 new_ss
->next
= prev_ss
;
6948 new_ss
->parent
= ss
;
6949 new_ss
->info
= ss
->info
;
6950 new_ss
->info
->refcount
++;
6953 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
6954 && ss
->info
->type
!= GFC_SS_REFERENCE
);
6957 new_ss
->dim
[0] = ss
->dim
[dim
];
6959 gcc_assert (dim
< ss
->dimen
);
6961 ss_dim
= --ss
->dimen
;
6962 for (i
= dim
; i
< ss_dim
; i
++)
6963 ss
->dim
[i
] = ss
->dim
[i
+ 1];
6965 ss
->dim
[ss_dim
] = 0;
6971 ss
->nested_ss
->parent
= new_ss
;
6972 new_ss
->nested_ss
= ss
->nested_ss
;
6974 ss
->nested_ss
= new_ss
;
6977 new_loop
= gfc_get_loopinfo ();
6978 gfc_init_loopinfo (new_loop
);
6980 gcc_assert (prev_ss
!= NULL
);
6981 gcc_assert (prev_ss
!= gfc_ss_terminator
);
6982 gfc_add_ss_to_loop (new_loop
, prev_ss
);
6983 return new_ss
->parent
;
6987 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
6988 is to be inlined. */
6991 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
6993 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
6994 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
6996 bool scalar_mask
= false;
6998 /* The rank of the result will be determined later. */
6999 arg1
= expr
->value
.function
.actual
;
7002 gcc_assert (arg3
!= NULL
);
7004 if (expr
->rank
== 0)
7007 tmp_ss
= gfc_ss_terminator
;
7013 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
7014 if (mask_ss
== tmp_ss
)
7020 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
7021 gcc_assert (array_ss
!= tmp_ss
);
7023 /* Odd thing: If the mask is scalar, it is used by the frontend after
7024 the array (to make an if around the nested loop). Thus it shall
7025 be after array_ss once the gfc_ss list is reversed. */
7027 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
7031 /* "Hide" the dimension on which we will sum in the first arg's scalarization
7033 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
7034 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
7042 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
7045 switch (expr
->value
.function
.isym
->id
)
7047 case GFC_ISYM_PRODUCT
:
7049 return walk_inline_intrinsic_arith (ss
, expr
);
7051 case GFC_ISYM_TRANSPOSE
:
7052 return walk_inline_intrinsic_transpose (ss
, expr
);
7061 /* This generates code to execute before entering the scalarization loop.
7062 Currently does nothing. */
7065 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
7067 switch (ss
->info
->expr
->value
.function
.isym
->id
)
7069 case GFC_ISYM_UBOUND
:
7070 case GFC_ISYM_LBOUND
:
7071 case GFC_ISYM_UCOBOUND
:
7072 case GFC_ISYM_LCOBOUND
:
7073 case GFC_ISYM_THIS_IMAGE
:
7082 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
7083 are expanded into code inside the scalarization loop. */
7086 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
7088 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
7089 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
7091 /* The two argument version returns a scalar. */
7092 if (expr
->value
.function
.actual
->next
->expr
)
7095 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
7099 /* Walk an intrinsic array libcall. */
7102 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
7104 gcc_assert (expr
->rank
> 0);
7105 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
7109 /* Return whether the function call expression EXPR will be expanded
7110 inline by gfc_conv_intrinsic_function. */
7113 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
7115 gfc_actual_arglist
*args
;
7117 if (!expr
->value
.function
.isym
)
7120 switch (expr
->value
.function
.isym
->id
)
7122 case GFC_ISYM_PRODUCT
:
7124 /* Disable inline expansion if code size matters. */
7128 args
= expr
->value
.function
.actual
;
7129 /* We need to be able to subset the SUM argument at compile-time. */
7130 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
7135 case GFC_ISYM_TRANSPOSE
:
7144 /* Returns nonzero if the specified intrinsic function call maps directly to
7145 an external library call. Should only be used for functions that return
7149 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
7151 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
7152 gcc_assert (expr
->rank
> 0);
7154 if (gfc_inline_intrinsic_function_p (expr
))
7157 switch (expr
->value
.function
.isym
->id
)
7161 case GFC_ISYM_COUNT
:
7165 case GFC_ISYM_IPARITY
:
7166 case GFC_ISYM_MATMUL
:
7167 case GFC_ISYM_MAXLOC
:
7168 case GFC_ISYM_MAXVAL
:
7169 case GFC_ISYM_MINLOC
:
7170 case GFC_ISYM_MINVAL
:
7171 case GFC_ISYM_NORM2
:
7172 case GFC_ISYM_PARITY
:
7173 case GFC_ISYM_PRODUCT
:
7175 case GFC_ISYM_SHAPE
:
7176 case GFC_ISYM_SPREAD
:
7178 /* Ignore absent optional parameters. */
7181 case GFC_ISYM_RESHAPE
:
7182 case GFC_ISYM_CSHIFT
:
7183 case GFC_ISYM_EOSHIFT
:
7185 case GFC_ISYM_UNPACK
:
7186 /* Pass absent optional parameters. */
7194 /* Walk an intrinsic function. */
7196 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
7197 gfc_intrinsic_sym
* isym
)
7201 if (isym
->elemental
)
7202 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
7203 NULL
, GFC_SS_SCALAR
);
7205 if (expr
->rank
== 0)
7208 if (gfc_inline_intrinsic_function_p (expr
))
7209 return walk_inline_intrinsic_function (ss
, expr
);
7211 if (gfc_is_intrinsic_libcall (expr
))
7212 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7214 /* Special cases. */
7217 case GFC_ISYM_LBOUND
:
7218 case GFC_ISYM_LCOBOUND
:
7219 case GFC_ISYM_UBOUND
:
7220 case GFC_ISYM_UCOBOUND
:
7221 case GFC_ISYM_THIS_IMAGE
:
7222 return gfc_walk_intrinsic_bound (ss
, expr
);
7224 case GFC_ISYM_TRANSFER
:
7225 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7228 /* This probably meant someone forgot to add an intrinsic to the above
7229 list(s) when they implemented it, or something's gone horribly
7237 conv_intrinsic_atomic_def (gfc_code
*code
)
7242 gfc_init_se (&atom
, NULL
);
7243 gfc_init_se (&value
, NULL
);
7244 gfc_conv_expr (&atom
, code
->ext
.actual
->expr
);
7245 gfc_conv_expr (&value
, code
->ext
.actual
->next
->expr
);
7247 gfc_init_block (&block
);
7248 gfc_add_modify (&block
, atom
.expr
,
7249 fold_convert (TREE_TYPE (atom
.expr
), value
.expr
));
7250 return gfc_finish_block (&block
);
7255 conv_intrinsic_atomic_ref (gfc_code
*code
)
7260 gfc_init_se (&atom
, NULL
);
7261 gfc_init_se (&value
, NULL
);
7262 gfc_conv_expr (&value
, code
->ext
.actual
->expr
);
7263 gfc_conv_expr (&atom
, code
->ext
.actual
->next
->expr
);
7265 gfc_init_block (&block
);
7266 gfc_add_modify (&block
, value
.expr
,
7267 fold_convert (TREE_TYPE (value
.expr
), atom
.expr
));
7268 return gfc_finish_block (&block
);
7273 conv_intrinsic_move_alloc (gfc_code
*code
)
7276 gfc_expr
*from_expr
, *to_expr
;
7277 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
7278 gfc_se from_se
, to_se
;
7282 gfc_start_block (&block
);
7284 from_expr
= code
->ext
.actual
->expr
;
7285 to_expr
= code
->ext
.actual
->next
->expr
;
7287 gfc_init_se (&from_se
, NULL
);
7288 gfc_init_se (&to_se
, NULL
);
7290 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
7291 || to_expr
->ts
.type
== BT_CLASS
);
7292 coarray
= gfc_get_corank (from_expr
) != 0;
7294 if (from_expr
->rank
== 0 && !coarray
)
7296 if (from_expr
->ts
.type
!= BT_CLASS
)
7297 from_expr2
= from_expr
;
7300 from_expr2
= gfc_copy_expr (from_expr
);
7301 gfc_add_data_component (from_expr2
);
7304 if (to_expr
->ts
.type
!= BT_CLASS
)
7308 to_expr2
= gfc_copy_expr (to_expr
);
7309 gfc_add_data_component (to_expr2
);
7312 from_se
.want_pointer
= 1;
7313 to_se
.want_pointer
= 1;
7314 gfc_conv_expr (&from_se
, from_expr2
);
7315 gfc_conv_expr (&to_se
, to_expr2
);
7316 gfc_add_block_to_block (&block
, &from_se
.pre
);
7317 gfc_add_block_to_block (&block
, &to_se
.pre
);
7319 /* Deallocate "to". */
7320 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
7321 to_expr2
, to_expr
->ts
);
7322 gfc_add_expr_to_block (&block
, tmp
);
7324 /* Assign (_data) pointers. */
7325 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7326 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
7328 /* Set "from" to NULL. */
7329 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7330 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
7332 gfc_add_block_to_block (&block
, &from_se
.post
);
7333 gfc_add_block_to_block (&block
, &to_se
.post
);
7336 if (to_expr
->ts
.type
== BT_CLASS
)
7338 gfc_free_expr (to_expr2
);
7339 gfc_init_se (&to_se
, NULL
);
7340 to_se
.want_pointer
= 1;
7341 gfc_add_vptr_component (to_expr
);
7342 gfc_conv_expr (&to_se
, to_expr
);
7344 if (from_expr
->ts
.type
== BT_CLASS
)
7346 gfc_free_expr (from_expr2
);
7347 gfc_init_se (&from_se
, NULL
);
7348 from_se
.want_pointer
= 1;
7349 gfc_add_vptr_component (from_expr
);
7350 gfc_conv_expr (&from_se
, from_expr
);
7356 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7358 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7361 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7362 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7365 return gfc_finish_block (&block
);
7368 /* Update _vptr component. */
7369 if (to_expr
->ts
.type
== BT_CLASS
)
7371 to_se
.want_pointer
= 1;
7372 to_expr2
= gfc_copy_expr (to_expr
);
7373 gfc_add_vptr_component (to_expr2
);
7374 gfc_conv_expr (&to_se
, to_expr2
);
7376 if (from_expr
->ts
.type
== BT_CLASS
)
7378 from_se
.want_pointer
= 1;
7379 from_expr2
= gfc_copy_expr (from_expr
);
7380 gfc_add_vptr_component (from_expr2
);
7381 gfc_conv_expr (&from_se
, from_expr2
);
7387 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7389 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7392 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7393 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7394 gfc_free_expr (to_expr2
);
7395 gfc_init_se (&to_se
, NULL
);
7397 if (from_expr
->ts
.type
== BT_CLASS
)
7399 gfc_free_expr (from_expr2
);
7400 gfc_init_se (&from_se
, NULL
);
7405 /* Deallocate "to". */
7406 if (from_expr
->rank
== 0)
7408 to_se
.want_coarray
= 1;
7409 from_se
.want_coarray
= 1;
7411 gfc_conv_expr_descriptor (&to_se
, to_expr
);
7412 gfc_conv_expr_descriptor (&from_se
, from_expr
);
7414 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
7415 is an image control "statement", cf. IR F08/0040 in 12-006A. */
7416 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
7420 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
7421 NULL_TREE
, NULL_TREE
, true, to_expr
,
7423 gfc_add_expr_to_block (&block
, tmp
);
7425 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7426 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7427 boolean_type_node
, tmp
,
7428 fold_convert (TREE_TYPE (tmp
),
7429 null_pointer_node
));
7430 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
7431 3, null_pointer_node
, null_pointer_node
,
7432 build_int_cst (integer_type_node
, 0));
7434 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
7435 tmp
, build_empty_stmt (input_location
));
7436 gfc_add_expr_to_block (&block
, tmp
);
7440 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7441 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
7442 NULL_TREE
, true, to_expr
, false);
7443 gfc_add_expr_to_block (&block
, tmp
);
7446 /* Move the pointer and update the array descriptor data. */
7447 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
7449 /* Set "to" to NULL. */
7450 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
7451 gfc_add_modify_loc (input_location
, &block
, tmp
,
7452 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7454 return gfc_finish_block (&block
);
7459 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
7463 gcc_assert (code
->resolved_isym
);
7465 switch (code
->resolved_isym
->id
)
7467 case GFC_ISYM_MOVE_ALLOC
:
7468 res
= conv_intrinsic_move_alloc (code
);
7471 case GFC_ISYM_ATOMIC_DEF
:
7472 res
= conv_intrinsic_atomic_def (code
);
7475 case GFC_ISYM_ATOMIC_REF
:
7476 res
= conv_intrinsic_atomic_ref (code
);
7487 #include "gt-fortran-trans-intrinsic.h"