1 /* Intrinsic translation
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
26 #include "coretypes.h"
27 #include "tm.h" /* For UNITS_PER_WORD. */
29 #include "stringpool.h"
30 #include "tree-nested.h"
31 #include "stor-layout.h"
33 #include "diagnostic-core.h" /* For internal_error. */
34 #include "toplev.h" /* For rest_of_decl_compilation. */
38 #include "intrinsic.h"
40 #include "trans-const.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
45 #include "tree-nested.h"
48 /* This maps Fortran intrinsic math functions to external library or GCC
50 typedef struct GTY(()) gfc_intrinsic_map_t
{
51 /* The explicit enum is required to work around inadequacies in the
52 garbage collection/gengtype parsing mechanism. */
55 /* Enum value from the "language-independent", aka C-centric, part
56 of gcc, or END_BUILTINS of no such value set. */
57 enum built_in_function float_built_in
;
58 enum built_in_function double_built_in
;
59 enum built_in_function long_double_built_in
;
60 enum built_in_function complex_float_built_in
;
61 enum built_in_function complex_double_built_in
;
62 enum built_in_function complex_long_double_built_in
;
64 /* True if the naming pattern is to prepend "c" for complex and
65 append "f" for kind=4. False if the naming pattern is to
66 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
69 /* True if a complex version of the function exists. */
70 bool complex_available
;
72 /* True if the function should be marked const. */
75 /* The base library name of this function. */
78 /* Cache decls created for the various operand types. */
90 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
91 defines complex variants of all of the entries in mathbuiltins.def
93 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
94 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
95 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
96 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
97 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
100 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
101 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
102 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
103 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
105 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
106 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
109 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
111 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
112 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
113 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
114 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
115 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
117 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
119 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
120 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
121 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
122 #include "mathbuiltins.def"
124 /* Functions in libgfortran. */
125 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
128 LIB_FUNCTION (NONE
, NULL
, false)
133 #undef DEFINE_MATH_BUILTIN
134 #undef DEFINE_MATH_BUILTIN_C
137 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
140 /* Find the correct variant of a given builtin from its argument. */
142 builtin_decl_for_precision (enum built_in_function base_built_in
,
145 enum built_in_function i
= END_BUILTINS
;
147 gfc_intrinsic_map_t
*m
;
148 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
151 if (precision
== TYPE_PRECISION (float_type_node
))
152 i
= m
->float_built_in
;
153 else if (precision
== TYPE_PRECISION (double_type_node
))
154 i
= m
->double_built_in
;
155 else if (precision
== TYPE_PRECISION (long_double_type_node
))
156 i
= m
->long_double_built_in
;
157 else if (precision
== TYPE_PRECISION (float128_type_node
))
159 /* Special treatment, because it is not exactly a built-in, but
160 a library function. */
161 return m
->real16_decl
;
164 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
169 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
172 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
174 if (gfc_real_kinds
[i
].c_float128
)
176 /* For __float128, the story is a bit different, because we return
177 a decl to a library function rather than a built-in. */
178 gfc_intrinsic_map_t
*m
;
179 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
182 return m
->real16_decl
;
185 return builtin_decl_for_precision (double_built_in
,
186 gfc_real_kinds
[i
].mode_precision
);
190 /* Evaluate the arguments to an intrinsic function. The value
191 of NARGS may be less than the actual number of arguments in EXPR
192 to allow optional "KIND" arguments that are not included in the
193 generated code to be ignored. */
196 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
197 tree
*argarray
, int nargs
)
199 gfc_actual_arglist
*actual
;
201 gfc_intrinsic_arg
*formal
;
205 formal
= expr
->value
.function
.isym
->formal
;
206 actual
= expr
->value
.function
.actual
;
208 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
209 actual
= actual
->next
,
210 formal
= formal
? formal
->next
: NULL
)
214 /* Skip omitted optional arguments. */
221 /* Evaluate the parameter. This will substitute scalarized
222 references automatically. */
223 gfc_init_se (&argse
, se
);
225 if (e
->ts
.type
== BT_CHARACTER
)
227 gfc_conv_expr (&argse
, e
);
228 gfc_conv_string_parameter (&argse
);
229 argarray
[curr_arg
++] = argse
.string_length
;
230 gcc_assert (curr_arg
< nargs
);
233 gfc_conv_expr_val (&argse
, e
);
235 /* If an optional argument is itself an optional dummy argument,
236 check its presence and substitute a null if absent. */
237 if (e
->expr_type
== EXPR_VARIABLE
238 && e
->symtree
->n
.sym
->attr
.optional
241 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
243 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
244 gfc_add_block_to_block (&se
->post
, &argse
.post
);
245 argarray
[curr_arg
] = argse
.expr
;
249 /* Count the number of actual arguments to the intrinsic function EXPR
250 including any "hidden" string length arguments. */
253 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
256 gfc_actual_arglist
*actual
;
258 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
263 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
273 /* Conversions between different types are output by the frontend as
274 intrinsic functions. We implement these directly with inline code. */
277 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
283 nargs
= gfc_intrinsic_argument_list_length (expr
);
284 args
= XALLOCAVEC (tree
, nargs
);
286 /* Evaluate all the arguments passed. Whilst we're only interested in the
287 first one here, there are other parts of the front-end that assume this
288 and will trigger an ICE if it's not the case. */
289 type
= gfc_typenode_for_spec (&expr
->ts
);
290 gcc_assert (expr
->value
.function
.actual
->expr
);
291 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
293 /* Conversion between character kinds involves a call to a library
295 if (expr
->ts
.type
== BT_CHARACTER
)
297 tree fndecl
, var
, addr
, tmp
;
299 if (expr
->ts
.kind
== 1
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
301 fndecl
= gfor_fndecl_convert_char4_to_char1
;
302 else if (expr
->ts
.kind
== 4
303 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
304 fndecl
= gfor_fndecl_convert_char1_to_char4
;
308 /* Create the variable storing the converted value. */
309 type
= gfc_get_pchar_type (expr
->ts
.kind
);
310 var
= gfc_create_var (type
, "str");
311 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
313 /* Call the library function that will perform the conversion. */
314 gcc_assert (nargs
>= 2);
315 tmp
= build_call_expr_loc (input_location
,
316 fndecl
, 3, addr
, args
[0], args
[1]);
317 gfc_add_expr_to_block (&se
->pre
, tmp
);
319 /* Free the temporary afterwards. */
320 tmp
= gfc_call_free (var
);
321 gfc_add_expr_to_block (&se
->post
, tmp
);
324 se
->string_length
= args
[0];
329 /* Conversion from complex to non-complex involves taking the real
330 component of the value. */
331 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
332 && expr
->ts
.type
!= BT_COMPLEX
)
336 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
337 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
341 se
->expr
= convert (type
, args
[0]);
344 /* This is needed because the gcc backend only implements
345 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
346 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
347 Similarly for CEILING. */
350 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
357 argtype
= TREE_TYPE (arg
);
358 arg
= gfc_evaluate_now (arg
, pblock
);
360 intval
= convert (type
, arg
);
361 intval
= gfc_evaluate_now (intval
, pblock
);
363 tmp
= convert (argtype
, intval
);
364 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
365 boolean_type_node
, tmp
, arg
);
367 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
368 intval
, build_int_cst (type
, 1));
369 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
374 /* Round to nearest integer, away from zero. */
377 build_round_expr (tree arg
, tree restype
)
381 int argprec
, resprec
;
383 argtype
= TREE_TYPE (arg
);
384 argprec
= TYPE_PRECISION (argtype
);
385 resprec
= TYPE_PRECISION (restype
);
387 /* Depending on the type of the result, choose the int intrinsic
388 (iround, available only as a builtin, therefore cannot use it for
389 __float128), long int intrinsic (lround family) or long long
390 intrinsic (llround). We might also need to convert the result
392 if (resprec
<= INT_TYPE_SIZE
&& argprec
<= LONG_DOUBLE_TYPE_SIZE
)
393 fn
= builtin_decl_for_precision (BUILT_IN_IROUND
, argprec
);
394 else if (resprec
<= LONG_TYPE_SIZE
)
395 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
396 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
397 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
401 return fold_convert (restype
, build_call_expr_loc (input_location
,
406 /* Convert a real to an integer using a specific rounding mode.
407 Ideally we would just build the corresponding GENERIC node,
408 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
411 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
412 enum rounding_mode op
)
417 return build_fixbound_expr (pblock
, arg
, type
, 0);
421 return build_fixbound_expr (pblock
, arg
, type
, 1);
425 return build_round_expr (arg
, type
);
429 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
438 /* Round a real value using the specified rounding mode.
439 We use a temporary integer of that same kind size as the result.
440 Values larger than those that can be represented by this kind are
441 unchanged, as they will not be accurate enough to represent the
443 huge = HUGE (KIND (a))
444 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
448 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
460 kind
= expr
->ts
.kind
;
461 nargs
= gfc_intrinsic_argument_list_length (expr
);
464 /* We have builtin functions for some cases. */
468 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
472 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
479 /* Evaluate the argument. */
480 gcc_assert (expr
->value
.function
.actual
->expr
);
481 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
483 /* Use a builtin function if one exists. */
484 if (decl
!= NULL_TREE
)
486 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
490 /* This code is probably redundant, but we'll keep it lying around just
492 type
= gfc_typenode_for_spec (&expr
->ts
);
493 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
495 /* Test if the value is too large to handle sensibly. */
496 gfc_set_model_kind (kind
);
498 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
499 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
500 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
501 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
504 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
505 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
506 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
508 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
510 itype
= gfc_get_int_type (kind
);
512 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
513 tmp
= convert (type
, tmp
);
514 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
520 /* Convert to an integer using the specified rounding mode. */
523 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
529 nargs
= gfc_intrinsic_argument_list_length (expr
);
530 args
= XALLOCAVEC (tree
, nargs
);
532 /* Evaluate the argument, we process all arguments even though we only
533 use the first one for code generation purposes. */
534 type
= gfc_typenode_for_spec (&expr
->ts
);
535 gcc_assert (expr
->value
.function
.actual
->expr
);
536 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
538 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
540 /* Conversion to a different integer kind. */
541 se
->expr
= convert (type
, args
[0]);
545 /* Conversion from complex to non-complex involves taking the real
546 component of the value. */
547 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
548 && expr
->ts
.type
!= BT_COMPLEX
)
552 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
553 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
557 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
562 /* Get the imaginary component of a value. */
565 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
569 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
570 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
571 TREE_TYPE (TREE_TYPE (arg
)), arg
);
575 /* Get the complex conjugate of a value. */
578 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
582 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
583 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
589 define_quad_builtin (const char *name
, tree type
, bool is_const
)
592 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
595 /* Mark the decl as external. */
596 DECL_EXTERNAL (fndecl
) = 1;
597 TREE_PUBLIC (fndecl
) = 1;
599 /* Mark it __attribute__((const)). */
600 TREE_READONLY (fndecl
) = is_const
;
602 rest_of_decl_compilation (fndecl
, 1, 0);
609 /* Initialize function decls for library functions. The external functions
610 are created as required. Builtin functions are added here. */
613 gfc_build_intrinsic_lib_fndecls (void)
615 gfc_intrinsic_map_t
*m
;
616 tree quad_decls
[END_BUILTINS
+ 1];
618 if (gfc_real16_is_float128
)
620 /* If we have soft-float types, we create the decls for their
621 C99-like library functions. For now, we only handle __float128
622 q-suffixed functions. */
624 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
625 tree func_iround
, func_lround
, func_llround
, func_scalbn
, func_cpow
;
627 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
629 type
= float128_type_node
;
630 complex_type
= complex_float128_type_node
;
631 /* type (*) (type) */
632 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
634 func_iround
= build_function_type_list (integer_type_node
,
636 /* long (*) (type) */
637 func_lround
= build_function_type_list (long_integer_type_node
,
639 /* long long (*) (type) */
640 func_llround
= build_function_type_list (long_long_integer_type_node
,
642 /* type (*) (type, type) */
643 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
644 /* type (*) (type, &int) */
646 = build_function_type_list (type
,
648 build_pointer_type (integer_type_node
),
650 /* type (*) (type, int) */
651 func_scalbn
= build_function_type_list (type
,
652 type
, integer_type_node
, NULL_TREE
);
653 /* type (*) (complex type) */
654 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
655 /* complex type (*) (complex type, complex type) */
657 = build_function_type_list (complex_type
,
658 complex_type
, complex_type
, NULL_TREE
);
660 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
661 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
662 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
664 /* Only these built-ins are actually needed here. These are used directly
665 from the code, when calling builtin_decl_for_precision() or
666 builtin_decl_for_float_type(). The others are all constructed by
667 gfc_get_intrinsic_lib_fndecl(). */
668 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
669 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
671 #include "mathbuiltins.def"
675 #undef DEFINE_MATH_BUILTIN
676 #undef DEFINE_MATH_BUILTIN_C
680 /* Add GCC builtin functions. */
681 for (m
= gfc_intrinsic_map
;
682 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
684 if (m
->float_built_in
!= END_BUILTINS
)
685 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
686 if (m
->complex_float_built_in
!= END_BUILTINS
)
687 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
688 if (m
->double_built_in
!= END_BUILTINS
)
689 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
690 if (m
->complex_double_built_in
!= END_BUILTINS
)
691 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
693 /* If real(kind=10) exists, it is always long double. */
694 if (m
->long_double_built_in
!= END_BUILTINS
)
695 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
696 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
698 = builtin_decl_explicit (m
->complex_long_double_built_in
);
700 if (!gfc_real16_is_float128
)
702 if (m
->long_double_built_in
!= END_BUILTINS
)
703 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
704 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
706 = builtin_decl_explicit (m
->complex_long_double_built_in
);
708 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
710 /* Quad-precision function calls are constructed when first
711 needed by builtin_decl_for_precision(), except for those
712 that will be used directly (define by OTHER_BUILTIN). */
713 m
->real16_decl
= quad_decls
[m
->double_built_in
];
715 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
717 /* Same thing for the complex ones. */
718 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
724 /* Create a fndecl for a simple intrinsic library function. */
727 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
730 vec
<tree
, va_gc
> *argtypes
;
732 gfc_actual_arglist
*actual
;
735 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
738 if (ts
->type
== BT_REAL
)
743 pdecl
= &m
->real4_decl
;
746 pdecl
= &m
->real8_decl
;
749 pdecl
= &m
->real10_decl
;
752 pdecl
= &m
->real16_decl
;
758 else if (ts
->type
== BT_COMPLEX
)
760 gcc_assert (m
->complex_available
);
765 pdecl
= &m
->complex4_decl
;
768 pdecl
= &m
->complex8_decl
;
771 pdecl
= &m
->complex10_decl
;
774 pdecl
= &m
->complex16_decl
;
788 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
789 if (gfc_real_kinds
[n
].c_float
)
790 snprintf (name
, sizeof (name
), "%s%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
792 else if (gfc_real_kinds
[n
].c_double
)
793 snprintf (name
, sizeof (name
), "%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
795 else if (gfc_real_kinds
[n
].c_long_double
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
798 else if (gfc_real_kinds
[n
].c_float128
)
799 snprintf (name
, sizeof (name
), "%s%s%s",
800 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
806 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
807 ts
->type
== BT_COMPLEX
? 'c' : 'r',
812 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
814 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
815 vec_safe_push (argtypes
, type
);
817 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
818 fndecl
= build_decl (input_location
,
819 FUNCTION_DECL
, get_identifier (name
), type
);
821 /* Mark the decl as external. */
822 DECL_EXTERNAL (fndecl
) = 1;
823 TREE_PUBLIC (fndecl
) = 1;
825 /* Mark it __attribute__((const)), if possible. */
826 TREE_READONLY (fndecl
) = m
->is_constant
;
828 rest_of_decl_compilation (fndecl
, 1, 0);
835 /* Convert an intrinsic function into an external or builtin call. */
838 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
840 gfc_intrinsic_map_t
*m
;
844 unsigned int num_args
;
847 id
= expr
->value
.function
.isym
->id
;
848 /* Find the entry for this function. */
849 for (m
= gfc_intrinsic_map
;
850 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
856 if (m
->id
== GFC_ISYM_NONE
)
858 internal_error ("Intrinsic function %s(%d) not recognized",
859 expr
->value
.function
.name
, id
);
862 /* Get the decl and generate the call. */
863 num_args
= gfc_intrinsic_argument_list_length (expr
);
864 args
= XALLOCAVEC (tree
, num_args
);
866 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
867 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
868 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
870 fndecl
= build_addr (fndecl
, current_function_decl
);
871 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
875 /* If bounds-checking is enabled, create code to verify at runtime that the
876 string lengths for both expressions are the same (needed for e.g. MERGE).
877 If bounds-checking is not enabled, does nothing. */
880 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
881 tree a
, tree b
, stmtblock_t
* target
)
886 /* If bounds-checking is disabled, do nothing. */
887 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
890 /* Compare the two string lengths. */
891 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
893 /* Output the runtime-check. */
894 name
= gfc_build_cstring_const (intr_name
);
895 name
= gfc_build_addr_expr (pchar_type_node
, name
);
896 gfc_trans_runtime_check (true, false, cond
, target
, where
,
897 "Unequal character lengths (%ld/%ld) in %s",
898 fold_convert (long_integer_type_node
, a
),
899 fold_convert (long_integer_type_node
, b
), name
);
903 /* The EXPONENT(s) intrinsic function is translated into
910 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
912 tree arg
, type
, res
, tmp
, frexp
;
914 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
915 expr
->value
.function
.actual
->expr
->ts
.kind
);
917 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
919 res
= gfc_create_var (integer_type_node
, NULL
);
920 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
921 gfc_build_addr_expr (NULL_TREE
, res
));
922 gfc_add_expr_to_block (&se
->pre
, tmp
);
924 type
= gfc_typenode_for_spec (&expr
->ts
);
925 se
->expr
= fold_convert (type
, res
);
930 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
933 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
934 lbound
, ubound
, extent
, ml
;
938 /* The case -fcoarray=single is handled elsewhere. */
939 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
941 /* Argument-free version: THIS_IMAGE(). */
942 if (expr
->value
.function
.actual
->expr
== NULL
)
944 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
946 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
951 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
953 type
= gfc_get_int_type (gfc_default_integer_kind
);
954 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
955 rank
= expr
->value
.function
.actual
->expr
->rank
;
957 /* Obtain the descriptor of the COARRAY. */
958 gfc_init_se (&argse
, NULL
);
959 argse
.want_coarray
= 1;
960 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
961 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
962 gfc_add_block_to_block (&se
->post
, &argse
.post
);
967 /* Create an implicit second parameter from the loop variable. */
968 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
969 gcc_assert (corank
> 0);
970 gcc_assert (se
->loop
->dimen
== 1);
971 gcc_assert (se
->ss
->info
->expr
== expr
);
973 dim_arg
= se
->loop
->loopvar
[0];
974 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
975 gfc_array_index_type
, dim_arg
,
976 build_int_cst (TREE_TYPE (dim_arg
), 1));
977 gfc_advance_se_ss_chain (se
);
981 /* Use the passed DIM= argument. */
982 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
983 gfc_init_se (&argse
, NULL
);
984 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
985 gfc_array_index_type
);
986 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
987 dim_arg
= argse
.expr
;
989 if (INTEGER_CST_P (dim_arg
))
991 if (wi::ltu_p (dim_arg
, 1)
992 || wi::gtu_p (dim_arg
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
993 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
994 "dimension index", expr
->value
.function
.isym
->name
,
997 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
999 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1000 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1002 build_int_cst (TREE_TYPE (dim_arg
), 1));
1003 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1004 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1006 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1007 boolean_type_node
, cond
, tmp
);
1008 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1013 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1014 one always has a dim_arg argument.
1016 m = this_image() - 1
1019 sub(1) = m + lcobound(corank)
1023 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1026 extent = gfc_extent(i)
1034 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1035 : m + lcobound(corank)
1038 /* this_image () - 1. */
1039 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
1041 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
1042 fold_convert (type
, tmp
), 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
, PRED_FORTRAN_INVALID_BOUND
);
1199 /* See Fortran 2008, C.10 for the following algorithm. */
1201 /* coindex = sub(corank) - lcobound(n). */
1202 coindex
= fold_convert (gfc_array_index_type
,
1203 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1205 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1206 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1207 fold_convert (gfc_array_index_type
, coindex
),
1210 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1212 tree extent
, ubound
;
1214 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1215 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1216 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1217 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1219 /* coindex *= extent. */
1220 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1221 gfc_array_index_type
, coindex
, extent
);
1223 /* coindex += sub(codim). */
1224 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1225 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1226 gfc_array_index_type
, coindex
,
1227 fold_convert (gfc_array_index_type
, tmp
));
1229 /* coindex -= lbound(codim). */
1230 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1231 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1232 gfc_array_index_type
, coindex
, lbound
);
1235 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1236 fold_convert(type
, coindex
),
1237 build_int_cst (type
, 1));
1239 /* Return 0 if "coindex" exceeds num_images(). */
1241 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1242 num_images
= build_int_cst (type
, 1);
1245 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1247 build_int_cst (integer_type_node
, -1));
1248 num_images
= fold_convert (type
, tmp
);
1251 tmp
= gfc_create_var (type
, NULL
);
1252 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1254 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1256 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1258 fold_convert (boolean_type_node
, invalid_bound
));
1259 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1260 build_int_cst (type
, 0), tmp
);
1265 trans_num_images (gfc_se
* se
)
1267 tree tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
, 2,
1269 build_int_cst (integer_type_node
, -1));
1270 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
), tmp
);
1275 gfc_conv_intrinsic_rank (gfc_se
*se
, gfc_expr
*expr
)
1279 gfc_init_se (&argse
, NULL
);
1280 argse
.data_not_needed
= 1;
1281 argse
.descriptor_only
= 1;
1283 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
);
1284 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1285 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1287 se
->expr
= gfc_conv_descriptor_rank (argse
.expr
);
1291 /* Evaluate a single upper or lower bound. */
1292 /* TODO: bound intrinsic generates way too much unnecessary code. */
1295 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1297 gfc_actual_arglist
*arg
;
1298 gfc_actual_arglist
*arg2
;
1303 tree cond
, cond1
, cond3
, cond4
, size
;
1307 gfc_array_spec
* as
;
1308 bool assumed_rank_lb_one
;
1310 arg
= expr
->value
.function
.actual
;
1315 /* Create an implicit second parameter from the loop variable. */
1316 gcc_assert (!arg2
->expr
);
1317 gcc_assert (se
->loop
->dimen
== 1);
1318 gcc_assert (se
->ss
->info
->expr
== expr
);
1319 gfc_advance_se_ss_chain (se
);
1320 bound
= se
->loop
->loopvar
[0];
1321 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1322 gfc_array_index_type
, bound
,
1327 /* use the passed argument. */
1328 gcc_assert (arg2
->expr
);
1329 gfc_init_se (&argse
, NULL
);
1330 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1331 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1333 /* Convert from one based to zero based. */
1334 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1335 gfc_array_index_type
, bound
,
1336 gfc_index_one_node
);
1339 /* TODO: don't re-evaluate the descriptor on each iteration. */
1340 /* Get a descriptor for the first parameter. */
1341 gfc_init_se (&argse
, NULL
);
1342 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1343 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1344 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1348 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1350 if (INTEGER_CST_P (bound
))
1352 if (((!as
|| as
->type
!= AS_ASSUMED_RANK
)
1353 && wi::geu_p (bound
, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))))
1354 || wi::gtu_p (bound
, GFC_MAX_DIMENSIONS
))
1355 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1356 "dimension index", upper
? "UBOUND" : "LBOUND",
1360 if (!INTEGER_CST_P (bound
) || (as
&& as
->type
== AS_ASSUMED_RANK
))
1362 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1364 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1365 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1366 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1367 if (as
&& as
->type
== AS_ASSUMED_RANK
)
1368 tmp
= gfc_conv_descriptor_rank (desc
);
1370 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1371 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1372 bound
, fold_convert(TREE_TYPE (bound
), tmp
));
1373 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1374 boolean_type_node
, cond
, tmp
);
1375 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1380 /* Take care of the lbound shift for assumed-rank arrays, which are
1381 nonallocatable and nonpointers. Those has a lbound of 1. */
1382 assumed_rank_lb_one
= as
&& as
->type
== AS_ASSUMED_RANK
1383 && ((arg
->expr
->ts
.type
!= BT_CLASS
1384 && !arg
->expr
->symtree
->n
.sym
->attr
.allocatable
1385 && !arg
->expr
->symtree
->n
.sym
->attr
.pointer
)
1386 || (arg
->expr
->ts
.type
== BT_CLASS
1387 && !CLASS_DATA (arg
->expr
)->attr
.allocatable
1388 && !CLASS_DATA (arg
->expr
)->attr
.class_pointer
));
1390 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1391 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1393 /* 13.14.53: Result value for LBOUND
1395 Case (i): For an array section or for an array expression other than a
1396 whole array or array structure component, LBOUND(ARRAY, DIM)
1397 has the value 1. For a whole array or array structure
1398 component, LBOUND(ARRAY, DIM) has the value:
1399 (a) equal to the lower bound for subscript DIM of ARRAY if
1400 dimension DIM of ARRAY does not have extent zero
1401 or if ARRAY is an assumed-size array of rank DIM,
1404 13.14.113: Result value for UBOUND
1406 Case (i): For an array section or for an array expression other than a
1407 whole array or array structure component, UBOUND(ARRAY, DIM)
1408 has the value equal to the number of elements in the given
1409 dimension; otherwise, it has a value equal to the upper bound
1410 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1411 not have size zero and has value zero if dimension DIM has
1414 if (!upper
&& assumed_rank_lb_one
)
1415 se
->expr
= gfc_index_one_node
;
1418 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1420 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1422 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1423 stride
, gfc_index_zero_node
);
1424 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1425 boolean_type_node
, cond3
, cond1
);
1426 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1427 stride
, gfc_index_zero_node
);
1432 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1433 boolean_type_node
, cond3
, cond4
);
1434 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1435 gfc_index_one_node
, lbound
);
1436 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1437 boolean_type_node
, cond4
, cond5
);
1439 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1440 boolean_type_node
, cond
, cond5
);
1442 if (assumed_rank_lb_one
)
1444 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1445 gfc_array_index_type
, ubound
, lbound
);
1446 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
1447 gfc_array_index_type
, tmp
, gfc_index_one_node
);
1452 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1453 gfc_array_index_type
, cond
,
1454 tmp
, gfc_index_zero_node
);
1458 if (as
->type
== AS_ASSUMED_SIZE
)
1459 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1460 bound
, build_int_cst (TREE_TYPE (bound
),
1461 arg
->expr
->rank
- 1));
1463 cond
= boolean_false_node
;
1465 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1466 boolean_type_node
, cond3
, cond4
);
1467 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1468 boolean_type_node
, cond
, cond1
);
1470 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1471 gfc_array_index_type
, cond
,
1472 lbound
, gfc_index_one_node
);
1479 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1480 gfc_array_index_type
, ubound
, lbound
);
1481 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1482 gfc_array_index_type
, size
,
1483 gfc_index_one_node
);
1484 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1485 gfc_array_index_type
, se
->expr
,
1486 gfc_index_zero_node
);
1489 se
->expr
= gfc_index_one_node
;
1492 type
= gfc_typenode_for_spec (&expr
->ts
);
1493 se
->expr
= convert (type
, se
->expr
);
1498 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
1500 gfc_actual_arglist
*arg
;
1501 gfc_actual_arglist
*arg2
;
1503 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
1507 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
1508 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
1509 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
1511 arg
= expr
->value
.function
.actual
;
1514 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
1515 corank
= gfc_get_corank (arg
->expr
);
1517 gfc_init_se (&argse
, NULL
);
1518 argse
.want_coarray
= 1;
1520 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
1521 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1522 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1527 /* Create an implicit second parameter from the loop variable. */
1528 gcc_assert (!arg2
->expr
);
1529 gcc_assert (corank
> 0);
1530 gcc_assert (se
->loop
->dimen
== 1);
1531 gcc_assert (se
->ss
->info
->expr
== expr
);
1533 bound
= se
->loop
->loopvar
[0];
1534 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1535 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
1536 gfc_advance_se_ss_chain (se
);
1540 /* use the passed argument. */
1541 gcc_assert (arg2
->expr
);
1542 gfc_init_se (&argse
, NULL
);
1543 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1544 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1547 if (INTEGER_CST_P (bound
))
1549 if (wi::ltu_p (bound
, 1)
1550 || wi::gtu_p (bound
, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))))
1551 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1552 "dimension index", expr
->value
.function
.isym
->name
,
1555 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1557 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1558 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1559 bound
, build_int_cst (TREE_TYPE (bound
), 1));
1560 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1561 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1563 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1564 boolean_type_node
, cond
, tmp
);
1565 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1570 /* Subtract 1 to get to zero based and add dimensions. */
1571 switch (arg
->expr
->rank
)
1574 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1575 gfc_array_index_type
, bound
,
1576 gfc_index_one_node
);
1580 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1581 gfc_array_index_type
, bound
,
1582 gfc_rank_cst
[arg
->expr
->rank
- 1]);
1586 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1588 /* Handle UCOBOUND with special handling of the last codimension. */
1589 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
1591 /* Last codimension: For -fcoarray=single just return
1592 the lcobound - otherwise add
1593 ceiling (real (num_images ()) / real (size)) - 1
1594 = (num_images () + size - 1) / size - 1
1595 = (num_images - 1) / size(),
1596 where size is the product of the extent of all but the last
1599 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
1603 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
1604 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1605 2, integer_zero_node
,
1606 build_int_cst (integer_type_node
, -1));
1607 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1608 gfc_array_index_type
,
1609 fold_convert (gfc_array_index_type
, tmp
),
1610 build_int_cst (gfc_array_index_type
, 1));
1611 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1612 gfc_array_index_type
, tmp
,
1613 fold_convert (gfc_array_index_type
, cosize
));
1614 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1615 gfc_array_index_type
, resbound
, tmp
);
1617 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
1619 /* ubound = lbound + num_images() - 1. */
1620 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1621 2, integer_zero_node
,
1622 build_int_cst (integer_type_node
, -1));
1623 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1624 gfc_array_index_type
,
1625 fold_convert (gfc_array_index_type
, tmp
),
1626 build_int_cst (gfc_array_index_type
, 1));
1627 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1628 gfc_array_index_type
, resbound
, tmp
);
1633 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1635 build_int_cst (TREE_TYPE (bound
),
1636 arg
->expr
->rank
+ corank
- 1));
1638 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1639 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1640 gfc_array_index_type
, cond
,
1641 resbound
, resbound2
);
1644 se
->expr
= resbound
;
1647 se
->expr
= resbound
;
1649 type
= gfc_typenode_for_spec (&expr
->ts
);
1650 se
->expr
= convert (type
, se
->expr
);
1655 conv_intrinsic_stride (gfc_se
* se
, gfc_expr
* expr
)
1657 gfc_actual_arglist
*array_arg
;
1658 gfc_actual_arglist
*dim_arg
;
1662 array_arg
= expr
->value
.function
.actual
;
1663 dim_arg
= array_arg
->next
;
1665 gcc_assert (array_arg
->expr
->expr_type
== EXPR_VARIABLE
);
1667 gfc_init_se (&argse
, NULL
);
1668 gfc_conv_expr_descriptor (&argse
, array_arg
->expr
);
1669 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1670 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1673 gcc_assert (dim_arg
->expr
);
1674 gfc_init_se (&argse
, NULL
);
1675 gfc_conv_expr_type (&argse
, dim_arg
->expr
, gfc_array_index_type
);
1676 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1677 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1678 argse
.expr
, gfc_index_one_node
);
1679 se
->expr
= gfc_conv_descriptor_stride_get (desc
, tmp
);
1684 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1688 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1690 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1694 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1699 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1700 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1709 /* Create a complex value from one or two real components. */
1712 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1718 unsigned int num_args
;
1720 num_args
= gfc_intrinsic_argument_list_length (expr
);
1721 args
= XALLOCAVEC (tree
, num_args
);
1723 type
= gfc_typenode_for_spec (&expr
->ts
);
1724 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1725 real
= convert (TREE_TYPE (type
), args
[0]);
1727 imag
= convert (TREE_TYPE (type
), args
[1]);
1728 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1730 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1731 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1732 imag
= convert (TREE_TYPE (type
), imag
);
1735 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1737 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1741 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1742 MODULO(A, P) = A - FLOOR (A / P) * P
1744 The obvious algorithms above are numerically instable for large
1745 arguments, hence these intrinsics are instead implemented via calls
1746 to the fmod family of functions. It is the responsibility of the
1747 user to ensure that the second argument is non-zero. */
1750 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1760 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1762 switch (expr
->ts
.type
)
1765 /* Integer case is easy, we've got a builtin op. */
1766 type
= TREE_TYPE (args
[0]);
1769 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
1772 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
1778 /* Check if we have a builtin fmod. */
1779 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1781 /* The builtin should always be available. */
1782 gcc_assert (fmod
!= NULL_TREE
);
1784 tmp
= build_addr (fmod
, current_function_decl
);
1785 se
->expr
= build_call_array_loc (input_location
,
1786 TREE_TYPE (TREE_TYPE (fmod
)),
1791 type
= TREE_TYPE (args
[0]);
1793 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1794 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1797 modulo = arg - floor (arg/arg2) * arg2
1799 In order to calculate the result accurately, we use the fmod
1800 function as follows.
1802 res = fmod (arg, arg2);
1805 if ((arg < 0) xor (arg2 < 0))
1809 res = copysign (0., arg2);
1811 => As two nested ternary exprs:
1813 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
1814 : copysign (0., arg2);
1818 zero
= gfc_build_const (type
, integer_zero_node
);
1819 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1820 if (!flag_signed_zeros
)
1822 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1824 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1826 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1827 boolean_type_node
, test
, test2
);
1828 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1830 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1831 boolean_type_node
, test
, test2
);
1832 test
= gfc_evaluate_now (test
, &se
->pre
);
1833 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1834 fold_build2_loc (input_location
,
1836 type
, tmp
, args
[1]),
1841 tree expr1
, copysign
, cscall
;
1842 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
,
1844 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1846 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1848 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1849 boolean_type_node
, test
, test2
);
1850 expr1
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
,
1851 fold_build2_loc (input_location
,
1853 type
, tmp
, args
[1]),
1855 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1857 cscall
= build_call_expr_loc (input_location
, copysign
, 2, zero
,
1859 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1869 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1870 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1871 where the right shifts are logical (i.e. 0's are shifted in).
1872 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1873 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1875 DSHIFTL(I,J,BITSIZE) = J
1877 DSHIFTR(I,J,BITSIZE) = I. */
1880 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
1882 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
1883 tree args
[3], cond
, tmp
;
1886 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
1888 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
1889 type
= TREE_TYPE (args
[0]);
1890 bitsize
= TYPE_PRECISION (type
);
1891 utype
= unsigned_type_for (type
);
1892 stype
= TREE_TYPE (args
[2]);
1894 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
1895 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
1896 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
1898 /* The generic case. */
1899 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
1900 build_int_cst (stype
, bitsize
), shift
);
1901 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
1902 arg1
, dshiftl
? shift
: tmp
);
1904 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
1905 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
1906 right
= fold_convert (type
, right
);
1908 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
1910 /* Special cases. */
1911 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1912 build_int_cst (stype
, 0));
1913 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1914 dshiftl
? arg1
: arg2
, res
);
1916 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1917 build_int_cst (stype
, bitsize
));
1918 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1919 dshiftl
? arg2
: arg1
, res
);
1925 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1928 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1936 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1937 type
= TREE_TYPE (args
[0]);
1939 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
1940 val
= gfc_evaluate_now (val
, &se
->pre
);
1942 zero
= gfc_build_const (type
, integer_zero_node
);
1943 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
1944 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
1948 /* SIGN(A, B) is absolute value of A times sign of B.
1949 The real value versions use library functions to ensure the correct
1950 handling of negative zero. Integer case implemented as:
1951 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1955 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1961 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1962 if (expr
->ts
.type
== BT_REAL
)
1966 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1967 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1969 /* We explicitly have to ignore the minus sign. We do so by using
1970 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1971 if (!gfc_option
.flag_sign_zero
1972 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1975 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1976 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1978 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1979 TREE_TYPE (args
[0]), cond
,
1980 build_call_expr_loc (input_location
, abs
, 1,
1982 build_call_expr_loc (input_location
, tmp
, 2,
1986 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1991 /* Having excluded floating point types, we know we are now dealing
1992 with signed integer types. */
1993 type
= TREE_TYPE (args
[0]);
1995 /* Args[0] is used multiple times below. */
1996 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1998 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1999 the signs of A and B are the same, and of all ones if they differ. */
2000 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
2001 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
2002 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
2003 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2005 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
2006 is all ones (i.e. -1). */
2007 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
2008 fold_build2_loc (input_location
, PLUS_EXPR
,
2009 type
, args
[0], tmp
), tmp
);
2013 /* Test for the presence of an optional argument. */
2016 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2020 arg
= expr
->value
.function
.actual
->expr
;
2021 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2022 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2023 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2027 /* Calculate the double precision product of two single precision values. */
2030 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2035 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2037 /* Convert the args to double precision before multiplying. */
2038 type
= gfc_typenode_for_spec (&expr
->ts
);
2039 args
[0] = convert (type
, args
[0]);
2040 args
[1] = convert (type
, args
[1]);
2041 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2046 /* Return a length one character string containing an ascii character. */
2049 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2054 unsigned int num_args
;
2056 num_args
= gfc_intrinsic_argument_list_length (expr
);
2057 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2059 type
= gfc_get_char_type (expr
->ts
.kind
);
2060 var
= gfc_create_var (type
, "char");
2062 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2063 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2064 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2065 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2070 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2078 unsigned int num_args
;
2080 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2081 args
= XALLOCAVEC (tree
, num_args
);
2083 var
= gfc_create_var (pchar_type_node
, "pstr");
2084 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2086 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2087 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2088 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2090 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2091 tmp
= build_call_array_loc (input_location
,
2092 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2093 fndecl
, num_args
, args
);
2094 gfc_add_expr_to_block (&se
->pre
, tmp
);
2096 /* Free the temporary afterwards, if necessary. */
2097 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2098 len
, build_int_cst (TREE_TYPE (len
), 0));
2099 tmp
= gfc_call_free (var
);
2100 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2101 gfc_add_expr_to_block (&se
->post
, tmp
);
2104 se
->string_length
= len
;
2109 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2117 unsigned int num_args
;
2119 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2120 args
= XALLOCAVEC (tree
, num_args
);
2122 var
= gfc_create_var (pchar_type_node
, "pstr");
2123 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2125 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2126 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2127 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2129 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2130 tmp
= build_call_array_loc (input_location
,
2131 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2132 fndecl
, num_args
, args
);
2133 gfc_add_expr_to_block (&se
->pre
, tmp
);
2135 /* Free the temporary afterwards, if necessary. */
2136 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2137 len
, build_int_cst (TREE_TYPE (len
), 0));
2138 tmp
= gfc_call_free (var
);
2139 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2140 gfc_add_expr_to_block (&se
->post
, tmp
);
2143 se
->string_length
= len
;
2147 /* Return a character string containing the tty name. */
2150 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2158 unsigned int num_args
;
2160 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2161 args
= XALLOCAVEC (tree
, num_args
);
2163 var
= gfc_create_var (pchar_type_node
, "pstr");
2164 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2166 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2167 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2168 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2170 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2171 tmp
= build_call_array_loc (input_location
,
2172 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2173 fndecl
, num_args
, args
);
2174 gfc_add_expr_to_block (&se
->pre
, tmp
);
2176 /* Free the temporary afterwards, if necessary. */
2177 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2178 len
, build_int_cst (TREE_TYPE (len
), 0));
2179 tmp
= gfc_call_free (var
);
2180 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2181 gfc_add_expr_to_block (&se
->post
, tmp
);
2184 se
->string_length
= len
;
2188 /* Get the minimum/maximum value of all the parameters.
2189 minmax (a1, a2, a3, ...)
2192 if (a2 .op. mvar || isnan (mvar))
2194 if (a3 .op. mvar || isnan (mvar))
2201 /* TODO: Mismatching types can occur when specific names are used.
2202 These should be handled during resolution. */
2204 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2212 gfc_actual_arglist
*argexpr
;
2213 unsigned int i
, nargs
;
2215 nargs
= gfc_intrinsic_argument_list_length (expr
);
2216 args
= XALLOCAVEC (tree
, nargs
);
2218 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2219 type
= gfc_typenode_for_spec (&expr
->ts
);
2221 argexpr
= expr
->value
.function
.actual
;
2222 if (TREE_TYPE (args
[0]) != type
)
2223 args
[0] = convert (type
, args
[0]);
2224 /* Only evaluate the argument once. */
2225 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2226 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2228 mvar
= gfc_create_var (type
, "M");
2229 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2230 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2236 /* Handle absent optional arguments by ignoring the comparison. */
2237 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2238 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2239 && TREE_CODE (val
) == INDIRECT_REF
)
2240 cond
= fold_build2_loc (input_location
,
2241 NE_EXPR
, boolean_type_node
,
2242 TREE_OPERAND (val
, 0),
2243 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2248 /* Only evaluate the argument once. */
2249 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2250 val
= gfc_evaluate_now (val
, &se
->pre
);
2253 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2255 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2256 convert (type
, val
), mvar
);
2258 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2259 __builtin_isnan might be made dependent on that module being loaded,
2260 to help performance of programs that don't rely on IEEE semantics. */
2261 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2263 isnan
= build_call_expr_loc (input_location
,
2264 builtin_decl_explicit (BUILT_IN_ISNAN
),
2266 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2267 boolean_type_node
, tmp
,
2268 fold_convert (boolean_type_node
, isnan
));
2270 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2271 build_empty_stmt (input_location
));
2273 if (cond
!= NULL_TREE
)
2274 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2275 build_empty_stmt (input_location
));
2277 gfc_add_expr_to_block (&se
->pre
, tmp
);
2278 argexpr
= argexpr
->next
;
2284 /* Generate library calls for MIN and MAX intrinsics for character
2287 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2290 tree var
, len
, fndecl
, tmp
, cond
, function
;
2293 nargs
= gfc_intrinsic_argument_list_length (expr
);
2294 args
= XALLOCAVEC (tree
, nargs
+ 4);
2295 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2297 /* Create the result variables. */
2298 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2299 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2300 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2301 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2302 args
[2] = build_int_cst (integer_type_node
, op
);
2303 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2305 if (expr
->ts
.kind
== 1)
2306 function
= gfor_fndecl_string_minmax
;
2307 else if (expr
->ts
.kind
== 4)
2308 function
= gfor_fndecl_string_minmax_char4
;
2312 /* Make the function call. */
2313 fndecl
= build_addr (function
, current_function_decl
);
2314 tmp
= build_call_array_loc (input_location
,
2315 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2317 gfc_add_expr_to_block (&se
->pre
, tmp
);
2319 /* Free the temporary afterwards, if necessary. */
2320 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2321 len
, build_int_cst (TREE_TYPE (len
), 0));
2322 tmp
= gfc_call_free (var
);
2323 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2324 gfc_add_expr_to_block (&se
->post
, tmp
);
2327 se
->string_length
= len
;
2331 /* Create a symbol node for this intrinsic. The symbol from the frontend
2332 has the generic name. */
2335 gfc_get_symbol_for_expr (gfc_expr
* expr
)
2339 /* TODO: Add symbols for intrinsic function to the global namespace. */
2340 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2341 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2344 sym
->attr
.external
= 1;
2345 sym
->attr
.function
= 1;
2346 sym
->attr
.always_explicit
= 1;
2347 sym
->attr
.proc
= PROC_INTRINSIC
;
2348 sym
->attr
.flavor
= FL_PROCEDURE
;
2352 sym
->attr
.dimension
= 1;
2353 sym
->as
= gfc_get_array_spec ();
2354 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2355 sym
->as
->rank
= expr
->rank
;
2358 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
2363 /* Generate a call to an external intrinsic function. */
2365 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2368 vec
<tree
, va_gc
> *append_args
;
2370 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2373 gcc_assert (expr
->rank
> 0);
2375 gcc_assert (expr
->rank
== 0);
2377 sym
= gfc_get_symbol_for_expr (expr
);
2379 /* Calls to libgfortran_matmul need to be appended special arguments,
2380 to be able to call the BLAS ?gemm functions if required and possible. */
2382 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2383 && sym
->ts
.type
!= BT_LOGICAL
)
2385 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2387 if (gfc_option
.flag_external_blas
2388 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2389 && (sym
->ts
.kind
== 4 || sym
->ts
.kind
== 8))
2393 if (sym
->ts
.type
== BT_REAL
)
2395 if (sym
->ts
.kind
== 4)
2396 gemm_fndecl
= gfor_fndecl_sgemm
;
2398 gemm_fndecl
= gfor_fndecl_dgemm
;
2402 if (sym
->ts
.kind
== 4)
2403 gemm_fndecl
= gfor_fndecl_cgemm
;
2405 gemm_fndecl
= gfor_fndecl_zgemm
;
2408 vec_alloc (append_args
, 3);
2409 append_args
->quick_push (build_int_cst (cint
, 1));
2410 append_args
->quick_push (build_int_cst (cint
,
2411 gfc_option
.blas_matmul_limit
));
2412 append_args
->quick_push (gfc_build_addr_expr (NULL_TREE
,
2417 vec_alloc (append_args
, 3);
2418 append_args
->quick_push (build_int_cst (cint
, 0));
2419 append_args
->quick_push (build_int_cst (cint
, 0));
2420 append_args
->quick_push (null_pointer_node
);
2424 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
2426 gfc_free_symbol (sym
);
2429 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2449 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2458 gfc_actual_arglist
*actual
;
2465 gfc_conv_intrinsic_funcall (se
, expr
);
2469 actual
= expr
->value
.function
.actual
;
2470 type
= gfc_typenode_for_spec (&expr
->ts
);
2471 /* Initialize the result. */
2472 resvar
= gfc_create_var (type
, "test");
2474 tmp
= convert (type
, boolean_true_node
);
2476 tmp
= convert (type
, boolean_false_node
);
2477 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2479 /* Walk the arguments. */
2480 arrayss
= gfc_walk_expr (actual
->expr
);
2481 gcc_assert (arrayss
!= gfc_ss_terminator
);
2483 /* Initialize the scalarizer. */
2484 gfc_init_loopinfo (&loop
);
2485 exit_label
= gfc_build_label_decl (NULL_TREE
);
2486 TREE_USED (exit_label
) = 1;
2487 gfc_add_ss_to_loop (&loop
, arrayss
);
2489 /* Initialize the loop. */
2490 gfc_conv_ss_startstride (&loop
);
2491 gfc_conv_loop_setup (&loop
, &expr
->where
);
2493 gfc_mark_ss_chain_used (arrayss
, 1);
2494 /* Generate the loop body. */
2495 gfc_start_scalarized_body (&loop
, &body
);
2497 /* If the condition matches then set the return value. */
2498 gfc_start_block (&block
);
2500 tmp
= convert (type
, boolean_false_node
);
2502 tmp
= convert (type
, boolean_true_node
);
2503 gfc_add_modify (&block
, resvar
, tmp
);
2505 /* And break out of the loop. */
2506 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2507 gfc_add_expr_to_block (&block
, tmp
);
2509 found
= gfc_finish_block (&block
);
2511 /* Check this element. */
2512 gfc_init_se (&arrayse
, NULL
);
2513 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2514 arrayse
.ss
= arrayss
;
2515 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2517 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2518 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
2519 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
2520 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
2521 gfc_add_expr_to_block (&body
, tmp
);
2522 gfc_add_block_to_block (&body
, &arrayse
.post
);
2524 gfc_trans_scalarizing_loops (&loop
, &body
);
2526 /* Add the exit label. */
2527 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2528 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2530 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2531 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2532 gfc_cleanup_loop (&loop
);
2537 /* COUNT(A) = Number of true elements in A. */
2539 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
2546 gfc_actual_arglist
*actual
;
2552 gfc_conv_intrinsic_funcall (se
, expr
);
2556 actual
= expr
->value
.function
.actual
;
2558 type
= gfc_typenode_for_spec (&expr
->ts
);
2559 /* Initialize the result. */
2560 resvar
= gfc_create_var (type
, "count");
2561 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
2563 /* Walk the arguments. */
2564 arrayss
= gfc_walk_expr (actual
->expr
);
2565 gcc_assert (arrayss
!= gfc_ss_terminator
);
2567 /* Initialize the scalarizer. */
2568 gfc_init_loopinfo (&loop
);
2569 gfc_add_ss_to_loop (&loop
, arrayss
);
2571 /* Initialize the loop. */
2572 gfc_conv_ss_startstride (&loop
);
2573 gfc_conv_loop_setup (&loop
, &expr
->where
);
2575 gfc_mark_ss_chain_used (arrayss
, 1);
2576 /* Generate the loop body. */
2577 gfc_start_scalarized_body (&loop
, &body
);
2579 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2580 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2581 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2583 gfc_init_se (&arrayse
, NULL
);
2584 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2585 arrayse
.ss
= arrayss
;
2586 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2587 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2588 build_empty_stmt (input_location
));
2590 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2591 gfc_add_expr_to_block (&body
, tmp
);
2592 gfc_add_block_to_block (&body
, &arrayse
.post
);
2594 gfc_trans_scalarizing_loops (&loop
, &body
);
2596 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2597 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2598 gfc_cleanup_loop (&loop
);
2604 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
2605 struct and return the corresponding loopinfo. */
2607 static gfc_loopinfo
*
2608 enter_nested_loop (gfc_se
*se
)
2610 se
->ss
= se
->ss
->nested_ss
;
2611 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
2613 return se
->ss
->loop
;
2617 /* Inline implementation of the sum and product intrinsics. */
2619 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2623 tree scale
= NULL_TREE
;
2628 gfc_loopinfo loop
, *ploop
;
2629 gfc_actual_arglist
*arg_array
, *arg_mask
;
2630 gfc_ss
*arrayss
= NULL
;
2631 gfc_ss
*maskss
= NULL
;
2635 gfc_expr
*arrayexpr
;
2640 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
2646 type
= gfc_typenode_for_spec (&expr
->ts
);
2647 /* Initialize the result. */
2648 resvar
= gfc_create_var (type
, "val");
2653 scale
= gfc_create_var (type
, "scale");
2654 gfc_add_modify (&se
->pre
, scale
,
2655 gfc_build_const (type
, integer_one_node
));
2656 tmp
= gfc_build_const (type
, integer_zero_node
);
2658 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2659 tmp
= gfc_build_const (type
, integer_zero_node
);
2660 else if (op
== NE_EXPR
)
2662 tmp
= convert (type
, boolean_false_node
);
2663 else if (op
== BIT_AND_EXPR
)
2664 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2665 type
, integer_one_node
));
2667 tmp
= gfc_build_const (type
, integer_one_node
);
2669 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2671 arg_array
= expr
->value
.function
.actual
;
2673 arrayexpr
= arg_array
->expr
;
2675 if (op
== NE_EXPR
|| norm2
)
2676 /* PARITY and NORM2. */
2680 arg_mask
= arg_array
->next
->next
;
2681 gcc_assert (arg_mask
!= NULL
);
2682 maskexpr
= arg_mask
->expr
;
2685 if (expr
->rank
== 0)
2687 /* Walk the arguments. */
2688 arrayss
= gfc_walk_expr (arrayexpr
);
2689 gcc_assert (arrayss
!= gfc_ss_terminator
);
2691 if (maskexpr
&& maskexpr
->rank
> 0)
2693 maskss
= gfc_walk_expr (maskexpr
);
2694 gcc_assert (maskss
!= gfc_ss_terminator
);
2699 /* Initialize the scalarizer. */
2700 gfc_init_loopinfo (&loop
);
2701 gfc_add_ss_to_loop (&loop
, arrayss
);
2702 if (maskexpr
&& maskexpr
->rank
> 0)
2703 gfc_add_ss_to_loop (&loop
, maskss
);
2705 /* Initialize the loop. */
2706 gfc_conv_ss_startstride (&loop
);
2707 gfc_conv_loop_setup (&loop
, &expr
->where
);
2709 gfc_mark_ss_chain_used (arrayss
, 1);
2710 if (maskexpr
&& maskexpr
->rank
> 0)
2711 gfc_mark_ss_chain_used (maskss
, 1);
2716 /* All the work has been done in the parent loops. */
2717 ploop
= enter_nested_loop (se
);
2721 /* Generate the loop body. */
2722 gfc_start_scalarized_body (ploop
, &body
);
2724 /* If we have a mask, only add this element if the mask is set. */
2725 if (maskexpr
&& maskexpr
->rank
> 0)
2727 gfc_init_se (&maskse
, parent_se
);
2728 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
2729 if (expr
->rank
== 0)
2731 gfc_conv_expr_val (&maskse
, maskexpr
);
2732 gfc_add_block_to_block (&body
, &maskse
.pre
);
2734 gfc_start_block (&block
);
2737 gfc_init_block (&block
);
2739 /* Do the actual summation/product. */
2740 gfc_init_se (&arrayse
, parent_se
);
2741 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
2742 if (expr
->rank
== 0)
2743 arrayse
.ss
= arrayss
;
2744 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2745 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2749 /* if (x (i) != 0.0)
2755 result = 1.0 + result * val * val;
2761 result += val * val;
2764 tree res1
, res2
, cond
, absX
, val
;
2765 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
2767 gfc_init_block (&ifblock1
);
2769 absX
= gfc_create_var (type
, "absX");
2770 gfc_add_modify (&ifblock1
, absX
,
2771 fold_build1_loc (input_location
, ABS_EXPR
, type
,
2773 val
= gfc_create_var (type
, "val");
2774 gfc_add_expr_to_block (&ifblock1
, val
);
2776 gfc_init_block (&ifblock2
);
2777 gfc_add_modify (&ifblock2
, val
,
2778 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
2780 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2781 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
2782 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
2783 gfc_build_const (type
, integer_one_node
));
2784 gfc_add_modify (&ifblock2
, resvar
, res1
);
2785 gfc_add_modify (&ifblock2
, scale
, absX
);
2786 res1
= gfc_finish_block (&ifblock2
);
2788 gfc_init_block (&ifblock3
);
2789 gfc_add_modify (&ifblock3
, val
,
2790 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
2792 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2793 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
2794 gfc_add_modify (&ifblock3
, resvar
, res2
);
2795 res2
= gfc_finish_block (&ifblock3
);
2797 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2799 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
2800 gfc_add_expr_to_block (&ifblock1
, tmp
);
2801 tmp
= gfc_finish_block (&ifblock1
);
2803 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2805 gfc_build_const (type
, integer_zero_node
));
2807 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2808 gfc_add_expr_to_block (&block
, tmp
);
2812 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
2813 gfc_add_modify (&block
, resvar
, tmp
);
2816 gfc_add_block_to_block (&block
, &arrayse
.post
);
2818 if (maskexpr
&& maskexpr
->rank
> 0)
2820 /* We enclose the above in if (mask) {...} . */
2822 tmp
= gfc_finish_block (&block
);
2823 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2824 build_empty_stmt (input_location
));
2827 tmp
= gfc_finish_block (&block
);
2828 gfc_add_expr_to_block (&body
, tmp
);
2830 gfc_trans_scalarizing_loops (ploop
, &body
);
2832 /* For a scalar mask, enclose the loop in an if statement. */
2833 if (maskexpr
&& maskexpr
->rank
== 0)
2835 gfc_init_block (&block
);
2836 gfc_add_block_to_block (&block
, &ploop
->pre
);
2837 gfc_add_block_to_block (&block
, &ploop
->post
);
2838 tmp
= gfc_finish_block (&block
);
2842 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
2843 build_empty_stmt (input_location
));
2844 gfc_advance_se_ss_chain (se
);
2848 gcc_assert (expr
->rank
== 0);
2849 gfc_init_se (&maskse
, NULL
);
2850 gfc_conv_expr_val (&maskse
, maskexpr
);
2851 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2852 build_empty_stmt (input_location
));
2855 gfc_add_expr_to_block (&block
, tmp
);
2856 gfc_add_block_to_block (&se
->pre
, &block
);
2857 gcc_assert (se
->post
.head
== NULL
);
2861 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
2862 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
2865 if (expr
->rank
== 0)
2866 gfc_cleanup_loop (ploop
);
2870 /* result = scale * sqrt(result). */
2872 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
2873 resvar
= build_call_expr_loc (input_location
,
2875 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
2882 /* Inline implementation of the dot_product intrinsic. This function
2883 is based on gfc_conv_intrinsic_arith (the previous function). */
2885 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2893 gfc_actual_arglist
*actual
;
2894 gfc_ss
*arrayss1
, *arrayss2
;
2895 gfc_se arrayse1
, arrayse2
;
2896 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2898 type
= gfc_typenode_for_spec (&expr
->ts
);
2900 /* Initialize the result. */
2901 resvar
= gfc_create_var (type
, "val");
2902 if (expr
->ts
.type
== BT_LOGICAL
)
2903 tmp
= build_int_cst (type
, 0);
2905 tmp
= gfc_build_const (type
, integer_zero_node
);
2907 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2909 /* Walk argument #1. */
2910 actual
= expr
->value
.function
.actual
;
2911 arrayexpr1
= actual
->expr
;
2912 arrayss1
= gfc_walk_expr (arrayexpr1
);
2913 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2915 /* Walk argument #2. */
2916 actual
= actual
->next
;
2917 arrayexpr2
= actual
->expr
;
2918 arrayss2
= gfc_walk_expr (arrayexpr2
);
2919 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2921 /* Initialize the scalarizer. */
2922 gfc_init_loopinfo (&loop
);
2923 gfc_add_ss_to_loop (&loop
, arrayss1
);
2924 gfc_add_ss_to_loop (&loop
, arrayss2
);
2926 /* Initialize the loop. */
2927 gfc_conv_ss_startstride (&loop
);
2928 gfc_conv_loop_setup (&loop
, &expr
->where
);
2930 gfc_mark_ss_chain_used (arrayss1
, 1);
2931 gfc_mark_ss_chain_used (arrayss2
, 1);
2933 /* Generate the loop body. */
2934 gfc_start_scalarized_body (&loop
, &body
);
2935 gfc_init_block (&block
);
2937 /* Make the tree expression for [conjg(]array1[)]. */
2938 gfc_init_se (&arrayse1
, NULL
);
2939 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2940 arrayse1
.ss
= arrayss1
;
2941 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2942 if (expr
->ts
.type
== BT_COMPLEX
)
2943 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
2945 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2947 /* Make the tree expression for array2. */
2948 gfc_init_se (&arrayse2
, NULL
);
2949 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2950 arrayse2
.ss
= arrayss2
;
2951 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2952 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2954 /* Do the actual product and sum. */
2955 if (expr
->ts
.type
== BT_LOGICAL
)
2957 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
2958 arrayse1
.expr
, arrayse2
.expr
);
2959 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2963 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
2965 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
2967 gfc_add_modify (&block
, resvar
, tmp
);
2969 /* Finish up the loop block and the loop. */
2970 tmp
= gfc_finish_block (&block
);
2971 gfc_add_expr_to_block (&body
, tmp
);
2973 gfc_trans_scalarizing_loops (&loop
, &body
);
2974 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2975 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2976 gfc_cleanup_loop (&loop
);
2982 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2983 we need to handle. For performance reasons we sometimes create two
2984 loops instead of one, where the second one is much simpler.
2985 Examples for minloc intrinsic:
2986 1) Result is an array, a call is generated
2987 2) Array mask is used and NaNs need to be supported:
2993 if (pos == 0) pos = S + (1 - from);
2994 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3001 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3005 3) NaNs need to be supported, but it is known at compile time or cheaply
3006 at runtime whether array is nonempty or not:
3011 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3014 if (from <= to) pos = 1;
3018 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3022 4) NaNs aren't supported, array mask is used:
3023 limit = infinities_supported ? Infinity : huge (limit);
3027 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3033 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3037 5) Same without array mask:
3038 limit = infinities_supported ? Infinity : huge (limit);
3039 pos = (from <= to) ? 1 : 0;
3042 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3045 For 3) and 5), if mask is scalar, this all goes into a conditional,
3046 setting pos = 0; in the else branch. */
3049 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3053 stmtblock_t ifblock
;
3054 stmtblock_t elseblock
;
3065 gfc_actual_arglist
*actual
;
3070 gfc_expr
*arrayexpr
;
3077 gfc_conv_intrinsic_funcall (se
, expr
);
3081 /* Initialize the result. */
3082 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3083 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3084 type
= gfc_typenode_for_spec (&expr
->ts
);
3086 /* Walk the arguments. */
3087 actual
= expr
->value
.function
.actual
;
3088 arrayexpr
= actual
->expr
;
3089 arrayss
= gfc_walk_expr (arrayexpr
);
3090 gcc_assert (arrayss
!= gfc_ss_terminator
);
3092 actual
= actual
->next
->next
;
3093 gcc_assert (actual
);
3094 maskexpr
= actual
->expr
;
3096 if (maskexpr
&& maskexpr
->rank
!= 0)
3098 maskss
= gfc_walk_expr (maskexpr
);
3099 gcc_assert (maskss
!= gfc_ss_terminator
);
3104 if (gfc_array_size (arrayexpr
, &asize
))
3106 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3108 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3109 boolean_type_node
, nonempty
,
3110 gfc_index_zero_node
);
3115 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3116 switch (arrayexpr
->ts
.type
)
3119 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3123 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3124 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3125 arrayexpr
->ts
.kind
);
3132 /* We start with the most negative possible value for MAXLOC, and the most
3133 positive possible value for MINLOC. The most negative possible value is
3134 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3135 possible value is HUGE in both cases. */
3137 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3138 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3139 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3140 build_int_cst (type
, 1));
3142 gfc_add_modify (&se
->pre
, limit
, tmp
);
3144 /* Initialize the scalarizer. */
3145 gfc_init_loopinfo (&loop
);
3146 gfc_add_ss_to_loop (&loop
, arrayss
);
3148 gfc_add_ss_to_loop (&loop
, maskss
);
3150 /* Initialize the loop. */
3151 gfc_conv_ss_startstride (&loop
);
3153 /* The code generated can have more than one loop in sequence (see the
3154 comment at the function header). This doesn't work well with the
3155 scalarizer, which changes arrays' offset when the scalarization loops
3156 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3157 are currently inlined in the scalar case only (for which loop is of rank
3158 one). As there is no dependency to care about in that case, there is no
3159 temporary, so that we can use the scalarizer temporary code to handle
3160 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3161 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3163 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3164 should eventually go away. We could either create two loops properly,
3165 or find another way to save/restore the array offsets between the two
3166 loops (without conflicting with temporary management), or use a single
3167 loop minmaxloc implementation. See PR 31067. */
3168 loop
.temp_dim
= loop
.dimen
;
3169 gfc_conv_loop_setup (&loop
, &expr
->where
);
3171 gcc_assert (loop
.dimen
== 1);
3172 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3173 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3174 loop
.from
[0], loop
.to
[0]);
3178 /* Initialize the position to zero, following Fortran 2003. We are free
3179 to do this because Fortran 95 allows the result of an entirely false
3180 mask to be processor dependent. If we know at compile time the array
3181 is non-empty and no MASK is used, we can initialize to 1 to simplify
3183 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3184 gfc_add_modify (&loop
.pre
, pos
,
3185 fold_build3_loc (input_location
, COND_EXPR
,
3186 gfc_array_index_type
,
3187 nonempty
, gfc_index_one_node
,
3188 gfc_index_zero_node
));
3191 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3192 lab1
= gfc_build_label_decl (NULL_TREE
);
3193 TREE_USED (lab1
) = 1;
3194 lab2
= gfc_build_label_decl (NULL_TREE
);
3195 TREE_USED (lab2
) = 1;
3198 /* An offset must be added to the loop
3199 counter to obtain the required position. */
3200 gcc_assert (loop
.from
[0]);
3202 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3203 gfc_index_one_node
, loop
.from
[0]);
3204 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3206 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3208 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3209 /* Generate the loop body. */
3210 gfc_start_scalarized_body (&loop
, &body
);
3212 /* If we have a mask, only check this element if the mask is set. */
3215 gfc_init_se (&maskse
, NULL
);
3216 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3218 gfc_conv_expr_val (&maskse
, maskexpr
);
3219 gfc_add_block_to_block (&body
, &maskse
.pre
);
3221 gfc_start_block (&block
);
3224 gfc_init_block (&block
);
3226 /* Compare with the current limit. */
3227 gfc_init_se (&arrayse
, NULL
);
3228 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3229 arrayse
.ss
= arrayss
;
3230 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3231 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3233 /* We do the following if this is a more extreme value. */
3234 gfc_start_block (&ifblock
);
3236 /* Assign the value to the limit... */
3237 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3239 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3241 stmtblock_t ifblock2
;
3244 gfc_start_block (&ifblock2
);
3245 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3246 loop
.loopvar
[0], offset
);
3247 gfc_add_modify (&ifblock2
, pos
, tmp
);
3248 ifbody2
= gfc_finish_block (&ifblock2
);
3249 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3250 gfc_index_zero_node
);
3251 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3252 build_empty_stmt (input_location
));
3253 gfc_add_expr_to_block (&block
, tmp
);
3256 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3257 loop
.loopvar
[0], offset
);
3258 gfc_add_modify (&ifblock
, pos
, tmp
);
3261 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3263 ifbody
= gfc_finish_block (&ifblock
);
3265 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3268 cond
= fold_build2_loc (input_location
,
3269 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3270 boolean_type_node
, arrayse
.expr
, limit
);
3272 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3273 arrayse
.expr
, limit
);
3275 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3276 build_empty_stmt (input_location
));
3278 gfc_add_expr_to_block (&block
, ifbody
);
3282 /* We enclose the above in if (mask) {...}. */
3283 tmp
= gfc_finish_block (&block
);
3285 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3286 build_empty_stmt (input_location
));
3289 tmp
= gfc_finish_block (&block
);
3290 gfc_add_expr_to_block (&body
, tmp
);
3294 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3296 if (HONOR_NANS (DECL_MODE (limit
)))
3298 if (nonempty
!= NULL
)
3300 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3301 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3302 build_empty_stmt (input_location
));
3303 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3307 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3308 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3310 /* If we have a mask, only check this element if the mask is set. */
3313 gfc_init_se (&maskse
, NULL
);
3314 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3316 gfc_conv_expr_val (&maskse
, maskexpr
);
3317 gfc_add_block_to_block (&body
, &maskse
.pre
);
3319 gfc_start_block (&block
);
3322 gfc_init_block (&block
);
3324 /* Compare with the current limit. */
3325 gfc_init_se (&arrayse
, NULL
);
3326 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3327 arrayse
.ss
= arrayss
;
3328 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3329 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3331 /* We do the following if this is a more extreme value. */
3332 gfc_start_block (&ifblock
);
3334 /* Assign the value to the limit... */
3335 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3337 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3338 loop
.loopvar
[0], offset
);
3339 gfc_add_modify (&ifblock
, pos
, tmp
);
3341 ifbody
= gfc_finish_block (&ifblock
);
3343 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3344 arrayse
.expr
, limit
);
3346 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3347 build_empty_stmt (input_location
));
3348 gfc_add_expr_to_block (&block
, tmp
);
3352 /* We enclose the above in if (mask) {...}. */
3353 tmp
= gfc_finish_block (&block
);
3355 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3356 build_empty_stmt (input_location
));
3359 tmp
= gfc_finish_block (&block
);
3360 gfc_add_expr_to_block (&body
, tmp
);
3361 /* Avoid initializing loopvar[0] again, it should be left where
3362 it finished by the first loop. */
3363 loop
.from
[0] = loop
.loopvar
[0];
3366 gfc_trans_scalarizing_loops (&loop
, &body
);
3369 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3371 /* For a scalar mask, enclose the loop in an if statement. */
3372 if (maskexpr
&& maskss
== NULL
)
3374 gfc_init_se (&maskse
, NULL
);
3375 gfc_conv_expr_val (&maskse
, maskexpr
);
3376 gfc_init_block (&block
);
3377 gfc_add_block_to_block (&block
, &loop
.pre
);
3378 gfc_add_block_to_block (&block
, &loop
.post
);
3379 tmp
= gfc_finish_block (&block
);
3381 /* For the else part of the scalar mask, just initialize
3382 the pos variable the same way as above. */
3384 gfc_init_block (&elseblock
);
3385 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3386 elsetmp
= gfc_finish_block (&elseblock
);
3388 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3389 gfc_add_expr_to_block (&block
, tmp
);
3390 gfc_add_block_to_block (&se
->pre
, &block
);
3394 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3395 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3397 gfc_cleanup_loop (&loop
);
3399 se
->expr
= convert (type
, pos
);
3402 /* Emit code for minval or maxval intrinsic. There are many different cases
3403 we need to handle. For performance reasons we sometimes create two
3404 loops instead of one, where the second one is much simpler.
3405 Examples for minval intrinsic:
3406 1) Result is an array, a call is generated
3407 2) Array mask is used and NaNs need to be supported, rank 1:
3412 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3415 limit = nonempty ? NaN : huge (limit);
3417 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3418 3) NaNs need to be supported, but it is known at compile time or cheaply
3419 at runtime whether array is nonempty or not, rank 1:
3422 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3423 limit = (from <= to) ? NaN : huge (limit);
3425 while (S <= to) { limit = min (a[S], limit); S++; }
3426 4) Array mask is used and NaNs need to be supported, rank > 1:
3435 if (fast) limit = min (a[S1][S2], limit);
3438 if (a[S1][S2] <= limit) {
3449 limit = nonempty ? NaN : huge (limit);
3450 5) NaNs need to be supported, but it is known at compile time or cheaply
3451 at runtime whether array is nonempty or not, rank > 1:
3458 if (fast) limit = min (a[S1][S2], limit);
3460 if (a[S1][S2] <= limit) {
3470 limit = (nonempty_array) ? NaN : huge (limit);
3471 6) NaNs aren't supported, but infinities are. Array mask is used:
3476 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3479 limit = nonempty ? limit : huge (limit);
3480 7) Same without array mask:
3483 while (S <= to) { limit = min (a[S], limit); S++; }
3484 limit = (from <= to) ? limit : huge (limit);
3485 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3486 limit = huge (limit);
3488 while (S <= to) { limit = min (a[S], limit); S++); }
3490 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3491 with array mask instead).
3492 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3493 setting limit = huge (limit); in the else branch. */
3496 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3506 tree huge_cst
= NULL
, nan_cst
= NULL
;
3508 stmtblock_t block
, block2
;
3510 gfc_actual_arglist
*actual
;
3515 gfc_expr
*arrayexpr
;
3521 gfc_conv_intrinsic_funcall (se
, expr
);
3525 type
= gfc_typenode_for_spec (&expr
->ts
);
3526 /* Initialize the result. */
3527 limit
= gfc_create_var (type
, "limit");
3528 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
3529 switch (expr
->ts
.type
)
3532 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
3534 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3536 REAL_VALUE_TYPE real
;
3538 tmp
= build_real (type
, real
);
3542 if (HONOR_NANS (DECL_MODE (limit
)))
3544 REAL_VALUE_TYPE real
;
3545 real_nan (&real
, "", 1, DECL_MODE (limit
));
3546 nan_cst
= build_real (type
, real
);
3551 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
3558 /* We start with the most negative possible value for MAXVAL, and the most
3559 positive possible value for MINVAL. The most negative possible value is
3560 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3561 possible value is HUGE in both cases. */
3564 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3566 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
3567 TREE_TYPE (huge_cst
), huge_cst
);
3570 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3571 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
3572 tmp
, build_int_cst (type
, 1));
3574 gfc_add_modify (&se
->pre
, limit
, tmp
);
3576 /* Walk the arguments. */
3577 actual
= expr
->value
.function
.actual
;
3578 arrayexpr
= actual
->expr
;
3579 arrayss
= gfc_walk_expr (arrayexpr
);
3580 gcc_assert (arrayss
!= gfc_ss_terminator
);
3582 actual
= actual
->next
->next
;
3583 gcc_assert (actual
);
3584 maskexpr
= actual
->expr
;
3586 if (maskexpr
&& maskexpr
->rank
!= 0)
3588 maskss
= gfc_walk_expr (maskexpr
);
3589 gcc_assert (maskss
!= gfc_ss_terminator
);
3594 if (gfc_array_size (arrayexpr
, &asize
))
3596 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3598 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3599 boolean_type_node
, nonempty
,
3600 gfc_index_zero_node
);
3605 /* Initialize the scalarizer. */
3606 gfc_init_loopinfo (&loop
);
3607 gfc_add_ss_to_loop (&loop
, arrayss
);
3609 gfc_add_ss_to_loop (&loop
, maskss
);
3611 /* Initialize the loop. */
3612 gfc_conv_ss_startstride (&loop
);
3614 /* The code generated can have more than one loop in sequence (see the
3615 comment at the function header). This doesn't work well with the
3616 scalarizer, which changes arrays' offset when the scalarization loops
3617 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3618 are currently inlined in the scalar case only. As there is no dependency
3619 to care about in that case, there is no temporary, so that we can use the
3620 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3621 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3622 gfc_trans_scalarized_loop_boundary even later to restore offset.
3623 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3624 should eventually go away. We could either create two loops properly,
3625 or find another way to save/restore the array offsets between the two
3626 loops (without conflicting with temporary management), or use a single
3627 loop minmaxval implementation. See PR 31067. */
3628 loop
.temp_dim
= loop
.dimen
;
3629 gfc_conv_loop_setup (&loop
, &expr
->where
);
3631 if (nonempty
== NULL
&& maskss
== NULL
3632 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
3633 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3634 loop
.from
[0], loop
.to
[0]);
3635 nonempty_var
= NULL
;
3636 if (nonempty
== NULL
3637 && (HONOR_INFINITIES (DECL_MODE (limit
))
3638 || HONOR_NANS (DECL_MODE (limit
))))
3640 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3641 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3642 nonempty
= nonempty_var
;
3646 if (HONOR_NANS (DECL_MODE (limit
)))
3648 if (loop
.dimen
== 1)
3650 lab
= gfc_build_label_decl (NULL_TREE
);
3651 TREE_USED (lab
) = 1;
3655 fast
= gfc_create_var (boolean_type_node
, "fast");
3656 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3660 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
3662 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
3663 /* Generate the loop body. */
3664 gfc_start_scalarized_body (&loop
, &body
);
3666 /* If we have a mask, only add this element if the mask is set. */
3669 gfc_init_se (&maskse
, NULL
);
3670 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3672 gfc_conv_expr_val (&maskse
, maskexpr
);
3673 gfc_add_block_to_block (&body
, &maskse
.pre
);
3675 gfc_start_block (&block
);
3678 gfc_init_block (&block
);
3680 /* Compare with the current limit. */
3681 gfc_init_se (&arrayse
, NULL
);
3682 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3683 arrayse
.ss
= arrayss
;
3684 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3685 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3687 gfc_init_block (&block2
);
3690 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3692 if (HONOR_NANS (DECL_MODE (limit
)))
3694 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3695 boolean_type_node
, arrayse
.expr
, limit
);
3697 ifbody
= build1_v (GOTO_EXPR
, lab
);
3700 stmtblock_t ifblock
;
3702 gfc_init_block (&ifblock
);
3703 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3704 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3705 ifbody
= gfc_finish_block (&ifblock
);
3707 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3708 build_empty_stmt (input_location
));
3709 gfc_add_expr_to_block (&block2
, tmp
);
3713 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3715 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3717 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3718 arrayse
.expr
, limit
);
3719 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3720 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3721 build_empty_stmt (input_location
));
3722 gfc_add_expr_to_block (&block2
, tmp
);
3726 tmp
= fold_build2_loc (input_location
,
3727 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3728 type
, arrayse
.expr
, limit
);
3729 gfc_add_modify (&block2
, limit
, tmp
);
3735 tree elsebody
= gfc_finish_block (&block2
);
3737 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3739 if (HONOR_NANS (DECL_MODE (limit
))
3740 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3742 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3743 arrayse
.expr
, limit
);
3744 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3745 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3746 build_empty_stmt (input_location
));
3750 tmp
= fold_build2_loc (input_location
,
3751 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3752 type
, arrayse
.expr
, limit
);
3753 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3755 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3756 gfc_add_expr_to_block (&block
, tmp
);
3759 gfc_add_block_to_block (&block
, &block2
);
3761 gfc_add_block_to_block (&block
, &arrayse
.post
);
3763 tmp
= gfc_finish_block (&block
);
3765 /* We enclose the above in if (mask) {...}. */
3766 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3767 build_empty_stmt (input_location
));
3768 gfc_add_expr_to_block (&body
, tmp
);
3772 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3774 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3776 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
3777 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
3779 /* If we have a mask, only add this element if the mask is set. */
3782 gfc_init_se (&maskse
, NULL
);
3783 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3785 gfc_conv_expr_val (&maskse
, maskexpr
);
3786 gfc_add_block_to_block (&body
, &maskse
.pre
);
3788 gfc_start_block (&block
);
3791 gfc_init_block (&block
);
3793 /* Compare with the current limit. */
3794 gfc_init_se (&arrayse
, NULL
);
3795 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3796 arrayse
.ss
= arrayss
;
3797 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3798 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3800 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3802 if (HONOR_NANS (DECL_MODE (limit
))
3803 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3805 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3806 arrayse
.expr
, limit
);
3807 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3808 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3809 build_empty_stmt (input_location
));
3810 gfc_add_expr_to_block (&block
, tmp
);
3814 tmp
= fold_build2_loc (input_location
,
3815 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3816 type
, arrayse
.expr
, limit
);
3817 gfc_add_modify (&block
, limit
, tmp
);
3820 gfc_add_block_to_block (&block
, &arrayse
.post
);
3822 tmp
= gfc_finish_block (&block
);
3824 /* We enclose the above in if (mask) {...}. */
3825 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3826 build_empty_stmt (input_location
));
3827 gfc_add_expr_to_block (&body
, tmp
);
3828 /* Avoid initializing loopvar[0] again, it should be left where
3829 it finished by the first loop. */
3830 loop
.from
[0] = loop
.loopvar
[0];
3832 gfc_trans_scalarizing_loops (&loop
, &body
);
3836 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3838 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3839 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
3841 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3843 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
3845 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
3847 gfc_add_modify (&loop
.pre
, limit
, tmp
);
3850 /* For a scalar mask, enclose the loop in an if statement. */
3851 if (maskexpr
&& maskss
== NULL
)
3855 gfc_init_se (&maskse
, NULL
);
3856 gfc_conv_expr_val (&maskse
, maskexpr
);
3857 gfc_init_block (&block
);
3858 gfc_add_block_to_block (&block
, &loop
.pre
);
3859 gfc_add_block_to_block (&block
, &loop
.post
);
3860 tmp
= gfc_finish_block (&block
);
3862 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3863 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
3865 else_stmt
= build_empty_stmt (input_location
);
3866 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
3867 gfc_add_expr_to_block (&block
, tmp
);
3868 gfc_add_block_to_block (&se
->pre
, &block
);
3872 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3873 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3876 gfc_cleanup_loop (&loop
);
3881 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3883 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
3889 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3890 type
= TREE_TYPE (args
[0]);
3892 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3893 build_int_cst (type
, 1), args
[1]);
3894 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
3895 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
3896 build_int_cst (type
, 0));
3897 type
= gfc_typenode_for_spec (&expr
->ts
);
3898 se
->expr
= convert (type
, tmp
);
3902 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3904 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3908 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3910 /* Convert both arguments to the unsigned type of the same size. */
3911 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
3912 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
3914 /* If they have unequal type size, convert to the larger one. */
3915 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
3916 > TYPE_PRECISION (TREE_TYPE (args
[1])))
3917 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
3918 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
3919 > TYPE_PRECISION (TREE_TYPE (args
[0])))
3920 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
3922 /* Now, we compare them. */
3923 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3928 /* Generate code to perform the specified operation. */
3930 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3934 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3935 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
3941 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
3945 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3946 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3947 TREE_TYPE (arg
), arg
);
3950 /* Set or clear a single bit. */
3952 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
3959 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3960 type
= TREE_TYPE (args
[0]);
3962 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3963 build_int_cst (type
, 1), args
[1]);
3969 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
3971 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
3974 /* Extract a sequence of bits.
3975 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3977 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
3984 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3985 type
= TREE_TYPE (args
[0]);
3987 mask
= build_int_cst (type
, -1);
3988 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
3989 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
3991 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
3993 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
3997 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
4000 tree args
[2], type
, num_bits
, cond
;
4002 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4004 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4005 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4006 type
= TREE_TYPE (args
[0]);
4009 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
4011 gcc_assert (right_shift
);
4013 se
->expr
= fold_build2_loc (input_location
,
4014 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
4015 TREE_TYPE (args
[0]), args
[0], args
[1]);
4018 se
->expr
= fold_convert (type
, se
->expr
);
4020 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4021 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4023 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4024 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4027 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4028 build_int_cst (type
, 0), se
->expr
);
4031 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4033 : ((shift >= 0) ? i << shift : i >> -shift)
4034 where all shifts are logical shifts. */
4036 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4048 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4050 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4051 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4053 type
= TREE_TYPE (args
[0]);
4054 utype
= unsigned_type_for (type
);
4056 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4059 /* Left shift if positive. */
4060 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4062 /* Right shift if negative.
4063 We convert to an unsigned type because we want a logical shift.
4064 The standard doesn't define the case of shifting negative
4065 numbers, and we try to be compatible with other compilers, most
4066 notably g77, here. */
4067 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4068 utype
, convert (utype
, args
[0]), width
));
4070 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4071 build_int_cst (TREE_TYPE (args
[1]), 0));
4072 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4074 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4075 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4077 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4078 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4080 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4081 build_int_cst (type
, 0), tmp
);
4085 /* Circular shift. AKA rotate or barrel shift. */
4088 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4096 unsigned int num_args
;
4098 num_args
= gfc_intrinsic_argument_list_length (expr
);
4099 args
= XALLOCAVEC (tree
, num_args
);
4101 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4105 /* Use a library function for the 3 parameter version. */
4106 tree int4type
= gfc_get_int_type (4);
4108 type
= TREE_TYPE (args
[0]);
4109 /* We convert the first argument to at least 4 bytes, and
4110 convert back afterwards. This removes the need for library
4111 functions for all argument sizes, and function will be
4112 aligned to at least 32 bits, so there's no loss. */
4113 if (expr
->ts
.kind
< 4)
4114 args
[0] = convert (int4type
, args
[0]);
4116 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4117 need loads of library functions. They cannot have values >
4118 BIT_SIZE (I) so the conversion is safe. */
4119 args
[1] = convert (int4type
, args
[1]);
4120 args
[2] = convert (int4type
, args
[2]);
4122 switch (expr
->ts
.kind
)
4127 tmp
= gfor_fndecl_math_ishftc4
;
4130 tmp
= gfor_fndecl_math_ishftc8
;
4133 tmp
= gfor_fndecl_math_ishftc16
;
4138 se
->expr
= build_call_expr_loc (input_location
,
4139 tmp
, 3, args
[0], args
[1], args
[2]);
4140 /* Convert the result back to the original type, if we extended
4141 the first argument's width above. */
4142 if (expr
->ts
.kind
< 4)
4143 se
->expr
= convert (type
, se
->expr
);
4147 type
= TREE_TYPE (args
[0]);
4149 /* Evaluate arguments only once. */
4150 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4151 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4153 /* Rotate left if positive. */
4154 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4156 /* Rotate right if negative. */
4157 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4159 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4161 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4162 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4164 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4166 /* Do nothing if shift == 0. */
4167 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4169 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4174 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4175 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4177 The conditional expression is necessary because the result of LEADZ(0)
4178 is defined, but the result of __builtin_clz(0) is undefined for most
4181 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4182 difference in bit size between the argument of LEADZ and the C int. */
4185 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4197 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4198 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4200 /* Which variant of __builtin_clz* should we call? */
4201 if (argsize
<= INT_TYPE_SIZE
)
4203 arg_type
= unsigned_type_node
;
4204 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4206 else if (argsize
<= LONG_TYPE_SIZE
)
4208 arg_type
= long_unsigned_type_node
;
4209 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4211 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4213 arg_type
= long_long_unsigned_type_node
;
4214 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4218 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4219 arg_type
= gfc_build_uint_type (argsize
);
4223 /* Convert the actual argument twice: first, to the unsigned type of the
4224 same size; then, to the proper argument type for the built-in
4225 function. But the return type is of the default INTEGER kind. */
4226 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4227 arg
= fold_convert (arg_type
, arg
);
4228 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4229 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4231 /* Compute LEADZ for the case i .ne. 0. */
4234 s
= TYPE_PRECISION (arg_type
) - argsize
;
4235 tmp
= fold_convert (result_type
,
4236 build_call_expr_loc (input_location
, func
,
4238 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4239 tmp
, build_int_cst (result_type
, s
));
4243 /* We end up here if the argument type is larger than 'long long'.
4244 We generate this code:
4246 if (x & (ULL_MAX << ULL_SIZE) != 0)
4247 return clzll ((unsigned long long) (x >> ULLSIZE));
4249 return ULL_SIZE + clzll ((unsigned long long) x);
4250 where ULL_MAX is the largest value that a ULL_MAX can hold
4251 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4252 is the bit-size of the long long type (64 in this example). */
4253 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4255 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4256 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4257 long_long_unsigned_type_node
,
4258 build_int_cst (long_long_unsigned_type_node
,
4261 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4262 fold_convert (arg_type
, ullmax
), ullsize
);
4263 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4265 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4266 cond
, build_int_cst (arg_type
, 0));
4268 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4270 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4271 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4272 tmp1
= fold_convert (result_type
,
4273 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4275 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4276 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4277 tmp2
= fold_convert (result_type
,
4278 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4279 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4282 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4286 /* Build BIT_SIZE. */
4287 bit_size
= build_int_cst (result_type
, argsize
);
4289 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4290 arg
, build_int_cst (arg_type
, 0));
4291 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4296 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4298 The conditional expression is necessary because the result of TRAILZ(0)
4299 is defined, but the result of __builtin_ctz(0) is undefined for most
4303 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4314 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4315 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4317 /* Which variant of __builtin_ctz* should we call? */
4318 if (argsize
<= INT_TYPE_SIZE
)
4320 arg_type
= unsigned_type_node
;
4321 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4323 else if (argsize
<= LONG_TYPE_SIZE
)
4325 arg_type
= long_unsigned_type_node
;
4326 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4328 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4330 arg_type
= long_long_unsigned_type_node
;
4331 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4335 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4336 arg_type
= gfc_build_uint_type (argsize
);
4340 /* Convert the actual argument twice: first, to the unsigned type of the
4341 same size; then, to the proper argument type for the built-in
4342 function. But the return type is of the default INTEGER kind. */
4343 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4344 arg
= fold_convert (arg_type
, arg
);
4345 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4346 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4348 /* Compute TRAILZ for the case i .ne. 0. */
4350 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4354 /* We end up here if the argument type is larger than 'long long'.
4355 We generate this code:
4357 if ((x & ULL_MAX) == 0)
4358 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4360 return ctzll ((unsigned long long) x);
4362 where ULL_MAX is the largest value that a ULL_MAX can hold
4363 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4364 is the bit-size of the long long type (64 in this example). */
4365 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4367 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4368 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4369 long_long_unsigned_type_node
,
4370 build_int_cst (long_long_unsigned_type_node
, 0));
4372 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4373 fold_convert (arg_type
, ullmax
));
4374 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4375 build_int_cst (arg_type
, 0));
4377 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4379 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4380 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4381 tmp1
= fold_convert (result_type
,
4382 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4383 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4386 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4387 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4388 tmp2
= fold_convert (result_type
,
4389 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4391 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4395 /* Build BIT_SIZE. */
4396 bit_size
= build_int_cst (result_type
, argsize
);
4398 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4399 arg
, build_int_cst (arg_type
, 0));
4400 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4404 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4405 for types larger than "long long", we call the long long built-in for
4406 the lower and higher bits and combine the result. */
4409 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
4417 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4418 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4419 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4421 /* Which variant of the builtin should we call? */
4422 if (argsize
<= INT_TYPE_SIZE
)
4424 arg_type
= unsigned_type_node
;
4425 func
= builtin_decl_explicit (parity
4427 : BUILT_IN_POPCOUNT
);
4429 else if (argsize
<= LONG_TYPE_SIZE
)
4431 arg_type
= long_unsigned_type_node
;
4432 func
= builtin_decl_explicit (parity
4434 : BUILT_IN_POPCOUNTL
);
4436 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4438 arg_type
= long_long_unsigned_type_node
;
4439 func
= builtin_decl_explicit (parity
4441 : BUILT_IN_POPCOUNTLL
);
4445 /* Our argument type is larger than 'long long', which mean none
4446 of the POPCOUNT builtins covers it. We thus call the 'long long'
4447 variant multiple times, and add the results. */
4448 tree utype
, arg2
, call1
, call2
;
4450 /* For now, we only cover the case where argsize is twice as large
4452 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4454 func
= builtin_decl_explicit (parity
4456 : BUILT_IN_POPCOUNTLL
);
4458 /* Convert it to an integer, and store into a variable. */
4459 utype
= gfc_build_uint_type (argsize
);
4460 arg
= fold_convert (utype
, arg
);
4461 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4463 /* Call the builtin twice. */
4464 call1
= build_call_expr_loc (input_location
, func
, 1,
4465 fold_convert (long_long_unsigned_type_node
,
4468 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
4469 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
4470 call2
= build_call_expr_loc (input_location
, func
, 1,
4471 fold_convert (long_long_unsigned_type_node
,
4474 /* Combine the results. */
4476 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
4479 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4485 /* Convert the actual argument twice: first, to the unsigned type of the
4486 same size; then, to the proper argument type for the built-in
4488 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4489 arg
= fold_convert (arg_type
, arg
);
4491 se
->expr
= fold_convert (result_type
,
4492 build_call_expr_loc (input_location
, func
, 1, arg
));
4496 /* Process an intrinsic with unspecified argument-types that has an optional
4497 argument (which could be of type character), e.g. EOSHIFT. For those, we
4498 need to append the string length of the optional argument if it is not
4499 present and the type is really character.
4500 primary specifies the position (starting at 1) of the non-optional argument
4501 specifying the type and optional gives the position of the optional
4502 argument in the arglist. */
4505 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
4506 unsigned primary
, unsigned optional
)
4508 gfc_actual_arglist
* prim_arg
;
4509 gfc_actual_arglist
* opt_arg
;
4511 gfc_actual_arglist
* arg
;
4513 vec
<tree
, va_gc
> *append_args
;
4515 /* Find the two arguments given as position. */
4519 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4523 if (cur_pos
== primary
)
4525 if (cur_pos
== optional
)
4528 if (cur_pos
>= primary
&& cur_pos
>= optional
)
4531 gcc_assert (prim_arg
);
4532 gcc_assert (prim_arg
->expr
);
4533 gcc_assert (opt_arg
);
4535 /* If we do have type CHARACTER and the optional argument is really absent,
4536 append a dummy 0 as string length. */
4538 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
4542 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
4543 vec_alloc (append_args
, 1);
4544 append_args
->quick_push (dummy
);
4547 /* Build the call itself. */
4548 sym
= gfc_get_symbol_for_expr (expr
);
4549 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4551 gfc_free_symbol (sym
);
4555 /* The length of a character string. */
4557 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
4566 gcc_assert (!se
->ss
);
4568 arg
= expr
->value
.function
.actual
->expr
;
4570 type
= gfc_typenode_for_spec (&expr
->ts
);
4571 switch (arg
->expr_type
)
4574 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
4578 /* Obtain the string length from the function used by
4579 trans-array.c(gfc_trans_array_constructor). */
4581 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
4585 if (arg
->ref
== NULL
4586 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
4588 /* This doesn't catch all cases.
4589 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4590 and the surrounding thread. */
4591 sym
= arg
->symtree
->n
.sym
;
4592 decl
= gfc_get_symbol_decl (sym
);
4593 if (decl
== current_function_decl
&& sym
->attr
.function
4594 && (sym
->result
== sym
))
4595 decl
= gfc_get_fake_result_decl (sym
, 0);
4597 len
= sym
->ts
.u
.cl
->backend_decl
;
4602 /* Otherwise fall through. */
4605 /* Anybody stupid enough to do this deserves inefficient code. */
4606 gfc_init_se (&argse
, se
);
4608 gfc_conv_expr (&argse
, arg
);
4610 gfc_conv_expr_descriptor (&argse
, arg
);
4611 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4612 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4613 len
= argse
.string_length
;
4616 se
->expr
= convert (type
, len
);
4619 /* The length of a character string not including trailing blanks. */
4621 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
4623 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4624 tree args
[2], type
, fndecl
;
4626 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4627 type
= gfc_typenode_for_spec (&expr
->ts
);
4630 fndecl
= gfor_fndecl_string_len_trim
;
4632 fndecl
= gfor_fndecl_string_len_trim_char4
;
4636 se
->expr
= build_call_expr_loc (input_location
,
4637 fndecl
, 2, args
[0], args
[1]);
4638 se
->expr
= convert (type
, se
->expr
);
4642 /* Returns the starting position of a substring within a string. */
4645 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4648 tree logical4_type_node
= gfc_get_logical_type (4);
4652 unsigned int num_args
;
4654 args
= XALLOCAVEC (tree
, 5);
4656 /* Get number of arguments; characters count double due to the
4657 string length argument. Kind= is not passed to the library
4658 and thus ignored. */
4659 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4664 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4665 type
= gfc_typenode_for_spec (&expr
->ts
);
4668 args
[4] = build_int_cst (logical4_type_node
, 0);
4670 args
[4] = convert (logical4_type_node
, args
[4]);
4672 fndecl
= build_addr (function
, current_function_decl
);
4673 se
->expr
= build_call_array_loc (input_location
,
4674 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4676 se
->expr
= convert (type
, se
->expr
);
4680 /* The ascii value for a single character. */
4682 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4684 tree args
[3], type
, pchartype
;
4687 nargs
= gfc_intrinsic_argument_list_length (expr
);
4688 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
4689 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
4690 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
4691 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
4692 type
= gfc_typenode_for_spec (&expr
->ts
);
4694 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4696 se
->expr
= convert (type
, se
->expr
);
4700 /* Intrinsic ISNAN calls __builtin_isnan. */
4703 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
4707 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4708 se
->expr
= build_call_expr_loc (input_location
,
4709 builtin_decl_explicit (BUILT_IN_ISNAN
),
4711 STRIP_TYPE_NOPS (se
->expr
);
4712 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4716 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4717 their argument against a constant integer value. */
4720 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
4724 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4725 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
4726 gfc_typenode_for_spec (&expr
->ts
),
4727 arg
, build_int_cst (TREE_TYPE (arg
), value
));
4732 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4735 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
4743 unsigned int num_args
;
4745 num_args
= gfc_intrinsic_argument_list_length (expr
);
4746 args
= XALLOCAVEC (tree
, num_args
);
4748 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4749 if (expr
->ts
.type
!= BT_CHARACTER
)
4757 /* We do the same as in the non-character case, but the argument
4758 list is different because of the string length arguments. We
4759 also have to set the string length for the result. */
4766 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
4768 se
->string_length
= len
;
4770 type
= TREE_TYPE (tsource
);
4771 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
4772 fold_convert (type
, fsource
));
4776 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4779 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
4781 tree args
[3], mask
, type
;
4783 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4784 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
4786 type
= TREE_TYPE (args
[0]);
4787 gcc_assert (TREE_TYPE (args
[1]) == type
);
4788 gcc_assert (TREE_TYPE (mask
) == type
);
4790 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
4791 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
4792 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4794 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
4799 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4800 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4803 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
4805 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
4808 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4809 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4811 type
= gfc_get_int_type (expr
->ts
.kind
);
4812 utype
= unsigned_type_for (type
);
4814 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
4815 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
4817 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
4818 build_int_cst (utype
, 0));
4822 /* Left-justified mask. */
4823 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
4825 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4826 fold_convert (utype
, res
));
4828 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4829 smaller than type width. */
4830 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4831 build_int_cst (TREE_TYPE (arg
), 0));
4832 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
4833 build_int_cst (utype
, 0), res
);
4837 /* Right-justified mask. */
4838 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4839 fold_convert (utype
, arg
));
4840 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
4842 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4843 strictly smaller than type width. */
4844 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4846 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
4847 cond
, allones
, res
);
4850 se
->expr
= fold_convert (type
, res
);
4854 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4856 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
4858 tree arg
, type
, tmp
, frexp
;
4860 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4862 type
= gfc_typenode_for_spec (&expr
->ts
);
4863 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4864 tmp
= gfc_create_var (integer_type_node
, NULL
);
4865 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
4866 fold_convert (type
, arg
),
4867 gfc_build_addr_expr (NULL_TREE
, tmp
));
4868 se
->expr
= fold_convert (type
, se
->expr
);
4872 /* NEAREST (s, dir) is translated into
4873 tmp = copysign (HUGE_VAL, dir);
4874 return nextafter (s, tmp);
4877 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
4879 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
4881 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
4882 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
4884 type
= gfc_typenode_for_spec (&expr
->ts
);
4885 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4887 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
4888 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
4889 fold_convert (type
, args
[1]));
4890 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
4891 fold_convert (type
, args
[0]), tmp
);
4892 se
->expr
= fold_convert (type
, se
->expr
);
4896 /* SPACING (s) is translated into
4904 e = MAX_EXPR (e, emin);
4905 res = scalbn (1., e);
4909 where prec is the precision of s, gfc_real_kinds[k].digits,
4910 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4911 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4914 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
4916 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
4917 tree cond
, tmp
, frexp
, scalbn
;
4921 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4922 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
4923 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
4924 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
4926 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4927 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4929 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4930 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4932 type
= gfc_typenode_for_spec (&expr
->ts
);
4933 e
= gfc_create_var (integer_type_node
, NULL
);
4934 res
= gfc_create_var (type
, NULL
);
4937 /* Build the block for s /= 0. */
4938 gfc_start_block (&block
);
4939 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4940 gfc_build_addr_expr (NULL_TREE
, e
));
4941 gfc_add_expr_to_block (&block
, tmp
);
4943 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
4945 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
4946 integer_type_node
, tmp
, emin
));
4948 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
4949 build_real_from_int_cst (type
, integer_one_node
), e
);
4950 gfc_add_modify (&block
, res
, tmp
);
4952 /* Finish by building the IF statement. */
4953 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4954 build_real_from_int_cst (type
, integer_zero_node
));
4955 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
4956 gfc_finish_block (&block
));
4958 gfc_add_expr_to_block (&se
->pre
, tmp
);
4963 /* RRSPACING (s) is translated into
4970 x = scalbn (x, precision - e);
4974 where precision is gfc_real_kinds[k].digits. */
4977 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
4979 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
4983 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4984 prec
= gfc_real_kinds
[k
].digits
;
4986 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4987 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4988 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
4990 type
= gfc_typenode_for_spec (&expr
->ts
);
4991 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4992 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4994 e
= gfc_create_var (integer_type_node
, NULL
);
4995 x
= gfc_create_var (type
, NULL
);
4996 gfc_add_modify (&se
->pre
, x
,
4997 build_call_expr_loc (input_location
, fabs
, 1, arg
));
5000 gfc_start_block (&block
);
5001 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
5002 gfc_build_addr_expr (NULL_TREE
, e
));
5003 gfc_add_expr_to_block (&block
, tmp
);
5005 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
5006 build_int_cst (integer_type_node
, prec
), e
);
5007 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
5008 gfc_add_modify (&block
, x
, tmp
);
5009 stmt
= gfc_finish_block (&block
);
5011 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
5012 build_real_from_int_cst (type
, integer_zero_node
));
5013 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
5014 gfc_add_expr_to_block (&se
->pre
, tmp
);
5016 se
->expr
= fold_convert (type
, x
);
5020 /* SCALE (s, i) is translated into scalbn (s, i). */
5022 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5024 tree args
[2], type
, scalbn
;
5026 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5028 type
= gfc_typenode_for_spec (&expr
->ts
);
5029 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5030 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5031 fold_convert (type
, args
[0]),
5032 fold_convert (integer_type_node
, args
[1]));
5033 se
->expr
= fold_convert (type
, se
->expr
);
5037 /* SET_EXPONENT (s, i) is translated into
5038 scalbn (frexp (s, &dummy_int), i). */
5040 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5042 tree args
[2], type
, tmp
, frexp
, scalbn
;
5044 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5045 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5047 type
= gfc_typenode_for_spec (&expr
->ts
);
5048 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5050 tmp
= gfc_create_var (integer_type_node
, NULL
);
5051 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5052 fold_convert (type
, args
[0]),
5053 gfc_build_addr_expr (NULL_TREE
, tmp
));
5054 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5055 fold_convert (integer_type_node
, args
[1]));
5056 se
->expr
= fold_convert (type
, se
->expr
);
5061 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5063 gfc_actual_arglist
*actual
;
5070 gfc_init_se (&argse
, NULL
);
5071 actual
= expr
->value
.function
.actual
;
5073 if (actual
->expr
->ts
.type
== BT_CLASS
)
5074 gfc_add_class_array_ref (actual
->expr
);
5076 argse
.want_pointer
= 1;
5077 argse
.data_not_needed
= 1;
5078 gfc_conv_expr_descriptor (&argse
, actual
->expr
);
5079 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5080 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5081 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5083 /* Build the call to size0. */
5084 fncall0
= build_call_expr_loc (input_location
,
5085 gfor_fndecl_size0
, 1, arg1
);
5087 actual
= actual
->next
;
5091 gfc_init_se (&argse
, NULL
);
5092 gfc_conv_expr_type (&argse
, actual
->expr
,
5093 gfc_array_index_type
);
5094 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5096 /* Unusually, for an intrinsic, size does not exclude
5097 an optional arg2, so we must test for it. */
5098 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5099 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5100 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5103 /* Build the call to size1. */
5104 fncall1
= build_call_expr_loc (input_location
,
5105 gfor_fndecl_size1
, 2,
5108 gfc_init_se (&argse
, NULL
);
5109 argse
.want_pointer
= 1;
5110 argse
.data_not_needed
= 1;
5111 gfc_conv_expr (&argse
, actual
->expr
);
5112 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5113 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5114 argse
.expr
, null_pointer_node
);
5115 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5116 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5117 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5121 se
->expr
= NULL_TREE
;
5122 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5123 gfc_array_index_type
,
5124 argse
.expr
, gfc_index_one_node
);
5127 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5129 argse
.expr
= gfc_index_zero_node
;
5130 se
->expr
= NULL_TREE
;
5135 if (se
->expr
== NULL_TREE
)
5137 tree ubound
, lbound
;
5139 arg1
= build_fold_indirect_ref_loc (input_location
,
5141 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5142 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5143 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5144 gfc_array_index_type
, ubound
, lbound
);
5145 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5146 gfc_array_index_type
,
5147 se
->expr
, gfc_index_one_node
);
5148 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5149 gfc_array_index_type
, se
->expr
,
5150 gfc_index_zero_node
);
5153 type
= gfc_typenode_for_spec (&expr
->ts
);
5154 se
->expr
= convert (type
, se
->expr
);
5158 /* Helper function to compute the size of a character variable,
5159 excluding the terminating null characters. The result has
5160 gfc_array_index_type type. */
5163 size_of_string_in_bytes (int kind
, tree string_length
)
5166 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5168 bytesize
= build_int_cst (gfc_array_index_type
,
5169 gfc_character_kinds
[i
].bit_size
/ 8);
5171 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5173 fold_convert (gfc_array_index_type
, string_length
));
5178 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5189 arg
= expr
->value
.function
.actual
->expr
;
5191 gfc_init_se (&argse
, NULL
);
5195 if (arg
->ts
.type
== BT_CLASS
)
5196 gfc_add_data_component (arg
);
5198 gfc_conv_expr_reference (&argse
, arg
);
5200 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5203 /* Obtain the source word length. */
5204 if (arg
->ts
.type
== BT_CHARACTER
)
5205 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
5206 argse
.string_length
);
5208 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
5212 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5213 argse
.want_pointer
= 0;
5214 gfc_conv_expr_descriptor (&argse
, arg
);
5215 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5217 /* Obtain the argument's word length. */
5218 if (arg
->ts
.type
== BT_CHARACTER
)
5219 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5221 tmp
= fold_convert (gfc_array_index_type
,
5222 size_in_bytes (type
));
5223 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5225 /* Obtain the size of the array in bytes. */
5226 for (n
= 0; n
< arg
->rank
; n
++)
5229 idx
= gfc_rank_cst
[n
];
5230 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5231 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5232 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5233 gfc_array_index_type
, upper
, lower
);
5234 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5235 gfc_array_index_type
, tmp
, gfc_index_one_node
);
5236 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5237 gfc_array_index_type
, tmp
, source_bytes
);
5238 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5240 se
->expr
= source_bytes
;
5243 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5248 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
5252 tree type
, result_type
, tmp
;
5254 arg
= expr
->value
.function
.actual
->expr
;
5256 gfc_init_se (&argse
, NULL
);
5257 result_type
= gfc_get_int_type (expr
->ts
.kind
);
5261 if (arg
->ts
.type
== BT_CLASS
)
5263 gfc_add_vptr_component (arg
);
5264 gfc_add_size_component (arg
);
5265 gfc_conv_expr (&argse
, arg
);
5266 tmp
= fold_convert (result_type
, argse
.expr
);
5270 gfc_conv_expr_reference (&argse
, arg
);
5271 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5276 argse
.want_pointer
= 0;
5277 gfc_conv_expr_descriptor (&argse
, arg
);
5278 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5281 /* Obtain the argument's word length. */
5282 if (arg
->ts
.type
== BT_CHARACTER
)
5283 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5285 tmp
= size_in_bytes (type
);
5286 tmp
= fold_convert (result_type
, tmp
);
5289 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
5290 build_int_cst (result_type
, BITS_PER_UNIT
));
5291 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5295 /* Intrinsic string comparison functions. */
5298 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5302 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
5305 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
5306 expr
->value
.function
.actual
->expr
->ts
.kind
,
5308 se
->expr
= fold_build2_loc (input_location
, op
,
5309 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
5310 build_int_cst (TREE_TYPE (se
->expr
), 0));
5313 /* Generate a call to the adjustl/adjustr library function. */
5315 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
5323 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
5326 type
= TREE_TYPE (args
[2]);
5327 var
= gfc_conv_string_tmp (se
, type
, len
);
5330 tmp
= build_call_expr_loc (input_location
,
5331 fndecl
, 3, args
[0], args
[1], args
[2]);
5332 gfc_add_expr_to_block (&se
->pre
, tmp
);
5334 se
->string_length
= len
;
5338 /* Generate code for the TRANSFER intrinsic:
5340 DEST = TRANSFER (SOURCE, MOLD)
5342 typeof<DEST> = typeof<MOLD>
5347 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5349 typeof<DEST> = typeof<MOLD>
5351 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5352 sizeof (DEST(0) * SIZE). */
5354 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
5370 gfc_actual_arglist
*arg
;
5372 gfc_array_info
*info
;
5376 gfc_expr
*source_expr
, *mold_expr
;
5380 info
= &se
->ss
->info
->data
.array
;
5382 /* Convert SOURCE. The output from this stage is:-
5383 source_bytes = length of the source in bytes
5384 source = pointer to the source data. */
5385 arg
= expr
->value
.function
.actual
;
5386 source_expr
= arg
->expr
;
5388 /* Ensure double transfer through LOGICAL preserves all
5390 if (arg
->expr
->expr_type
== EXPR_FUNCTION
5391 && arg
->expr
->value
.function
.esym
== NULL
5392 && arg
->expr
->value
.function
.isym
!= NULL
5393 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
5394 && arg
->expr
->ts
.type
== BT_LOGICAL
5395 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
5396 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
5398 gfc_init_se (&argse
, NULL
);
5400 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5402 /* Obtain the pointer to source and the length of source in bytes. */
5403 if (arg
->expr
->rank
== 0)
5405 gfc_conv_expr_reference (&argse
, arg
->expr
);
5406 if (arg
->expr
->ts
.type
== BT_CLASS
)
5407 source
= gfc_class_data_get (argse
.expr
);
5409 source
= argse
.expr
;
5411 /* Obtain the source word length. */
5412 switch (arg
->expr
->ts
.type
)
5415 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5416 argse
.string_length
);
5419 tmp
= gfc_vtable_size_get (argse
.expr
);
5422 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5424 tmp
= fold_convert (gfc_array_index_type
,
5425 size_in_bytes (source_type
));
5431 argse
.want_pointer
= 0;
5432 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5433 source
= gfc_conv_descriptor_data_get (argse
.expr
);
5434 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5436 /* Repack the source if not simply contiguous. */
5437 if (!gfc_is_simply_contiguous (arg
->expr
, false))
5439 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
5441 if (gfc_option
.warn_array_temp
)
5442 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5444 source
= build_call_expr_loc (input_location
,
5445 gfor_fndecl_in_pack
, 1, tmp
);
5446 source
= gfc_evaluate_now (source
, &argse
.pre
);
5448 /* Free the temporary. */
5449 gfc_start_block (&block
);
5450 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
5451 gfc_add_expr_to_block (&block
, tmp
);
5452 stmt
= gfc_finish_block (&block
);
5454 /* Clean up if it was repacked. */
5455 gfc_init_block (&block
);
5456 tmp
= gfc_conv_array_data (argse
.expr
);
5457 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5459 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
5460 build_empty_stmt (input_location
));
5461 gfc_add_expr_to_block (&block
, tmp
);
5462 gfc_add_block_to_block (&block
, &se
->post
);
5463 gfc_init_block (&se
->post
);
5464 gfc_add_block_to_block (&se
->post
, &block
);
5467 /* Obtain the source word length. */
5468 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5469 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5470 argse
.string_length
);
5472 tmp
= fold_convert (gfc_array_index_type
,
5473 size_in_bytes (source_type
));
5475 /* Obtain the size of the array in bytes. */
5476 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
5477 for (n
= 0; n
< arg
->expr
->rank
; n
++)
5480 idx
= gfc_rank_cst
[n
];
5481 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5482 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5483 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5484 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5485 gfc_array_index_type
, upper
, lower
);
5486 gfc_add_modify (&argse
.pre
, extent
, tmp
);
5487 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5488 gfc_array_index_type
, extent
,
5489 gfc_index_one_node
);
5490 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5491 gfc_array_index_type
, tmp
, source_bytes
);
5495 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5496 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5497 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5499 /* Now convert MOLD. The outputs are:
5500 mold_type = the TREE type of MOLD
5501 dest_word_len = destination word length in bytes. */
5503 mold_expr
= arg
->expr
;
5505 gfc_init_se (&argse
, NULL
);
5507 scalar_mold
= arg
->expr
->rank
== 0;
5509 if (arg
->expr
->rank
== 0)
5511 gfc_conv_expr_reference (&argse
, arg
->expr
);
5512 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5517 gfc_init_se (&argse
, NULL
);
5518 argse
.want_pointer
= 0;
5519 gfc_conv_expr_descriptor (&argse
, arg
->expr
);
5520 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5523 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5524 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5526 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
5528 /* If this TRANSFER is nested in another TRANSFER, use a type
5529 that preserves all bits. */
5530 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
5531 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
5534 /* Obtain the destination word length. */
5535 switch (arg
->expr
->ts
.type
)
5538 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
5539 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
5542 tmp
= gfc_vtable_size_get (argse
.expr
);
5545 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (mold_type
));
5548 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
5549 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
5551 /* Finally convert SIZE, if it is present. */
5553 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
5557 gfc_init_se (&argse
, NULL
);
5558 gfc_conv_expr_reference (&argse
, arg
->expr
);
5559 tmp
= convert (gfc_array_index_type
,
5560 build_fold_indirect_ref_loc (input_location
,
5562 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5563 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5568 /* Separate array and scalar results. */
5569 if (scalar_mold
&& tmp
== NULL_TREE
)
5570 goto scalar_transfer
;
5572 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5573 if (tmp
!= NULL_TREE
)
5574 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5575 tmp
, dest_word_len
);
5579 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
5580 gfc_add_modify (&se
->pre
, size_words
,
5581 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
5582 gfc_array_index_type
,
5583 size_bytes
, dest_word_len
));
5585 /* Evaluate the bounds of the result. If the loop range exists, we have
5586 to check if it is too large. If so, we modify loop->to be consistent
5587 with min(size, size(source)). Otherwise, size is made consistent with
5588 the loop range, so that the right number of bytes is transferred.*/
5589 n
= se
->loop
->order
[0];
5590 if (se
->loop
->to
[n
] != NULL_TREE
)
5592 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5593 se
->loop
->to
[n
], se
->loop
->from
[n
]);
5594 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5595 tmp
, gfc_index_one_node
);
5596 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5598 gfc_add_modify (&se
->pre
, size_words
, tmp
);
5599 gfc_add_modify (&se
->pre
, size_bytes
,
5600 fold_build2_loc (input_location
, MULT_EXPR
,
5601 gfc_array_index_type
,
5602 size_words
, dest_word_len
));
5603 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5604 size_words
, se
->loop
->from
[n
]);
5605 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5606 upper
, gfc_index_one_node
);
5610 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5611 size_words
, gfc_index_one_node
);
5612 se
->loop
->from
[n
] = gfc_index_zero_node
;
5615 se
->loop
->to
[n
] = upper
;
5617 /* Build a destination descriptor, using the pointer, source, as the
5619 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
5620 NULL_TREE
, false, true, false, &expr
->where
);
5622 /* Cast the pointer to the result. */
5623 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5624 tmp
= fold_convert (pvoid_type_node
, tmp
);
5626 /* Use memcpy to do the transfer. */
5628 = build_call_expr_loc (input_location
,
5629 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3, tmp
,
5630 fold_convert (pvoid_type_node
, source
),
5631 fold_convert (size_type_node
,
5632 fold_build2_loc (input_location
,
5634 gfc_array_index_type
,
5637 gfc_add_expr_to_block (&se
->pre
, tmp
);
5639 se
->expr
= info
->descriptor
;
5640 if (expr
->ts
.type
== BT_CHARACTER
)
5641 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5645 /* Deal with scalar results. */
5647 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5648 dest_word_len
, source_bytes
);
5649 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5650 extent
, gfc_index_zero_node
);
5652 if (expr
->ts
.type
== BT_CHARACTER
)
5654 tree direct
, indirect
, free
;
5656 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5657 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5660 /* If source is longer than the destination, use a pointer to
5661 the source directly. */
5662 gfc_init_block (&block
);
5663 gfc_add_modify (&block
, tmpdecl
, ptr
);
5664 direct
= gfc_finish_block (&block
);
5666 /* Otherwise, allocate a string with the length of the destination
5667 and copy the source into it. */
5668 gfc_init_block (&block
);
5669 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5670 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5671 gfc_add_modify (&block
, tmpdecl
,
5672 fold_convert (TREE_TYPE (ptr
), tmp
));
5673 tmp
= build_call_expr_loc (input_location
,
5674 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5675 fold_convert (pvoid_type_node
, tmpdecl
),
5676 fold_convert (pvoid_type_node
, ptr
),
5677 fold_convert (size_type_node
, extent
));
5678 gfc_add_expr_to_block (&block
, tmp
);
5679 indirect
= gfc_finish_block (&block
);
5681 /* Wrap it up with the condition. */
5682 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5683 dest_word_len
, source_bytes
);
5684 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5685 gfc_add_expr_to_block (&se
->pre
, tmp
);
5687 /* Free the temporary string, if necessary. */
5688 free
= gfc_call_free (tmpdecl
);
5689 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
5690 dest_word_len
, source_bytes
);
5691 tmp
= build3_v (COND_EXPR
, tmp
, free
, build_empty_stmt (input_location
));
5692 gfc_add_expr_to_block (&se
->post
, tmp
);
5695 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5699 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5701 ptr
= convert (build_pointer_type (mold_type
), source
);
5703 /* For CLASS results, allocate the needed memory first. */
5704 if (mold_expr
->ts
.type
== BT_CLASS
)
5707 cdata
= gfc_class_data_get (tmpdecl
);
5708 tmp
= gfc_call_malloc (&se
->pre
, TREE_TYPE (cdata
), dest_word_len
);
5709 gfc_add_modify (&se
->pre
, cdata
, tmp
);
5712 /* Use memcpy to do the transfer. */
5713 if (mold_expr
->ts
.type
== BT_CLASS
)
5714 tmp
= gfc_class_data_get (tmpdecl
);
5716 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5718 tmp
= build_call_expr_loc (input_location
,
5719 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5720 fold_convert (pvoid_type_node
, tmp
),
5721 fold_convert (pvoid_type_node
, ptr
),
5722 fold_convert (size_type_node
, extent
));
5723 gfc_add_expr_to_block (&se
->pre
, tmp
);
5725 /* For CLASS results, set the _vptr. */
5726 if (mold_expr
->ts
.type
== BT_CLASS
)
5730 vptr
= gfc_class_vptr_get (tmpdecl
);
5731 vtab
= gfc_find_derived_vtab (source_expr
->ts
.u
.derived
);
5733 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
5734 gfc_add_modify (&se
->pre
, vptr
, fold_convert (TREE_TYPE (vptr
), tmp
));
5742 /* Generate code for the ALLOCATED intrinsic.
5743 Generate inline code that directly check the address of the argument. */
5746 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5748 gfc_actual_arglist
*arg1
;
5752 gfc_init_se (&arg1se
, NULL
);
5753 arg1
= expr
->value
.function
.actual
;
5755 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5757 /* Make sure that class array expressions have both a _data
5758 component reference and an array reference.... */
5759 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
5760 gfc_add_class_array_ref (arg1
->expr
);
5761 /* .... whilst scalars only need the _data component. */
5763 gfc_add_data_component (arg1
->expr
);
5766 if (arg1
->expr
->rank
== 0)
5768 /* Allocatable scalar. */
5769 arg1se
.want_pointer
= 1;
5770 gfc_conv_expr (&arg1se
, arg1
->expr
);
5775 /* Allocatable array. */
5776 arg1se
.descriptor_only
= 1;
5777 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5778 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5781 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5782 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5783 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5787 /* Generate code for the ASSOCIATED intrinsic.
5788 If both POINTER and TARGET are arrays, generate a call to library function
5789 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5790 In other cases, generate inline code that directly compare the address of
5791 POINTER with the address of TARGET. */
5794 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
5796 gfc_actual_arglist
*arg1
;
5797 gfc_actual_arglist
*arg2
;
5802 tree nonzero_charlen
;
5803 tree nonzero_arraylen
;
5807 gfc_init_se (&arg1se
, NULL
);
5808 gfc_init_se (&arg2se
, NULL
);
5809 arg1
= expr
->value
.function
.actual
;
5812 /* Check whether the expression is a scalar or not; we cannot use
5813 arg1->expr->rank as it can be nonzero for proc pointers. */
5814 ss
= gfc_walk_expr (arg1
->expr
);
5815 scalar
= ss
== gfc_ss_terminator
;
5817 gfc_free_ss_chain (ss
);
5821 /* No optional target. */
5824 /* A pointer to a scalar. */
5825 arg1se
.want_pointer
= 1;
5826 gfc_conv_expr (&arg1se
, arg1
->expr
);
5827 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5828 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5829 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5831 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5832 tmp2
= gfc_class_data_get (arg1se
.expr
);
5838 /* A pointer to an array. */
5839 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5840 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5842 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5843 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5844 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
5845 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
5850 /* An optional target. */
5851 if (arg2
->expr
->ts
.type
== BT_CLASS
)
5852 gfc_add_data_component (arg2
->expr
);
5854 nonzero_charlen
= NULL_TREE
;
5855 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
5856 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
5858 arg1
->expr
->ts
.u
.cl
->backend_decl
,
5862 /* A pointer to a scalar. */
5863 arg1se
.want_pointer
= 1;
5864 gfc_conv_expr (&arg1se
, arg1
->expr
);
5865 if (arg1
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5866 && arg1
->expr
->symtree
->n
.sym
->attr
.dummy
)
5867 arg1se
.expr
= build_fold_indirect_ref_loc (input_location
,
5869 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5870 arg1se
.expr
= gfc_class_data_get (arg1se
.expr
);
5872 arg2se
.want_pointer
= 1;
5873 gfc_conv_expr (&arg2se
, arg2
->expr
);
5874 if (arg2
->expr
->symtree
->n
.sym
->attr
.proc_pointer
5875 && arg2
->expr
->symtree
->n
.sym
->attr
.dummy
)
5876 arg2se
.expr
= build_fold_indirect_ref_loc (input_location
,
5878 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5879 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5880 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5881 arg1se
.expr
, arg2se
.expr
);
5882 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5883 arg1se
.expr
, null_pointer_node
);
5884 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5885 boolean_type_node
, tmp
, tmp2
);
5889 /* An array pointer of zero length is not associated if target is
5891 arg1se
.descriptor_only
= 1;
5892 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
5893 if (arg1
->expr
->rank
== -1)
5895 tmp
= gfc_conv_descriptor_rank (arg1se
.expr
);
5896 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5897 TREE_TYPE (tmp
), tmp
, gfc_index_one_node
);
5900 tmp
= gfc_rank_cst
[arg1
->expr
->rank
- 1];
5901 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
, tmp
);
5902 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
5903 boolean_type_node
, tmp
,
5904 build_int_cst (TREE_TYPE (tmp
), 0));
5906 /* A pointer to an array, call library function _gfor_associated. */
5907 arg1se
.want_pointer
= 1;
5908 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
);
5910 arg2se
.want_pointer
= 1;
5911 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
);
5912 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
5913 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
5914 se
->expr
= build_call_expr_loc (input_location
,
5915 gfor_fndecl_associated
, 2,
5916 arg1se
.expr
, arg2se
.expr
);
5917 se
->expr
= convert (boolean_type_node
, se
->expr
);
5918 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5919 boolean_type_node
, se
->expr
,
5923 /* If target is present zero character length pointers cannot
5925 if (nonzero_charlen
!= NULL_TREE
)
5926 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5928 se
->expr
, nonzero_charlen
);
5931 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5935 /* Generate code for the SAME_TYPE_AS intrinsic.
5936 Generate inline code that directly checks the vindices. */
5939 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
5944 tree conda
= NULL_TREE
, condb
= NULL_TREE
;
5946 gfc_init_se (&se1
, NULL
);
5947 gfc_init_se (&se2
, NULL
);
5949 a
= expr
->value
.function
.actual
->expr
;
5950 b
= expr
->value
.function
.actual
->next
->expr
;
5952 if (UNLIMITED_POLY (a
))
5954 tmp
= gfc_class_vptr_get (a
->symtree
->n
.sym
->backend_decl
);
5955 conda
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5956 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
5959 if (UNLIMITED_POLY (b
))
5961 tmp
= gfc_class_vptr_get (b
->symtree
->n
.sym
->backend_decl
);
5962 condb
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5963 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
5966 if (a
->ts
.type
== BT_CLASS
)
5968 gfc_add_vptr_component (a
);
5969 gfc_add_hash_component (a
);
5971 else if (a
->ts
.type
== BT_DERIVED
)
5972 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5973 a
->ts
.u
.derived
->hash_value
);
5975 if (b
->ts
.type
== BT_CLASS
)
5977 gfc_add_vptr_component (b
);
5978 gfc_add_hash_component (b
);
5980 else if (b
->ts
.type
== BT_DERIVED
)
5981 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5982 b
->ts
.u
.derived
->hash_value
);
5984 gfc_conv_expr (&se1
, a
);
5985 gfc_conv_expr (&se2
, b
);
5987 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
5988 boolean_type_node
, se1
.expr
,
5989 fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
5992 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5993 boolean_type_node
, conda
, tmp
);
5996 tmp
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5997 boolean_type_node
, condb
, tmp
);
5999 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
6003 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
6006 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
6010 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
6011 se
->expr
= build_call_expr_loc (input_location
,
6012 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
6013 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
6017 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
6020 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
6024 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
6026 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
6027 type
= gfc_get_int_type (4);
6028 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
6030 /* Convert it to the required type. */
6031 type
= gfc_typenode_for_spec (&expr
->ts
);
6032 se
->expr
= build_call_expr_loc (input_location
,
6033 gfor_fndecl_si_kind
, 1, arg
);
6034 se
->expr
= fold_convert (type
, se
->expr
);
6038 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
6041 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
6043 gfc_actual_arglist
*actual
;
6046 vec
<tree
, va_gc
> *args
= NULL
;
6048 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
6050 gfc_init_se (&argse
, se
);
6052 /* Pass a NULL pointer for an absent arg. */
6053 if (actual
->expr
== NULL
)
6054 argse
.expr
= null_pointer_node
;
6060 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
6062 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
6063 ts
.type
= BT_INTEGER
;
6064 ts
.kind
= gfc_c_int_kind
;
6065 gfc_convert_type (actual
->expr
, &ts
, 2);
6067 gfc_conv_expr_reference (&argse
, actual
->expr
);
6070 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
6071 gfc_add_block_to_block (&se
->post
, &argse
.post
);
6072 vec_safe_push (args
, argse
.expr
);
6075 /* Convert it to the required type. */
6076 type
= gfc_typenode_for_spec (&expr
->ts
);
6077 se
->expr
= build_call_expr_loc_vec (input_location
,
6078 gfor_fndecl_sr_kind
, args
);
6079 se
->expr
= fold_convert (type
, se
->expr
);
6083 /* Generate code for TRIM (A) intrinsic function. */
6086 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
6096 unsigned int num_args
;
6098 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
6099 args
= XALLOCAVEC (tree
, num_args
);
6101 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
6102 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
6103 len
= gfc_create_var (gfc_charlen_type_node
, "len");
6105 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6106 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6109 if (expr
->ts
.kind
== 1)
6110 function
= gfor_fndecl_string_trim
;
6111 else if (expr
->ts
.kind
== 4)
6112 function
= gfor_fndecl_string_trim_char4
;
6116 fndecl
= build_addr (function
, current_function_decl
);
6117 tmp
= build_call_array_loc (input_location
,
6118 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6120 gfc_add_expr_to_block (&se
->pre
, tmp
);
6122 /* Free the temporary afterwards, if necessary. */
6123 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6124 len
, build_int_cst (TREE_TYPE (len
), 0));
6125 tmp
= gfc_call_free (var
);
6126 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6127 gfc_add_expr_to_block (&se
->post
, tmp
);
6130 se
->string_length
= len
;
6134 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6137 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6139 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6140 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6142 stmtblock_t block
, body
;
6145 /* We store in charsize the size of a character. */
6146 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6147 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6149 /* Get the arguments. */
6150 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6151 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6153 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6154 ncopies_type
= TREE_TYPE (ncopies
);
6156 /* Check that NCOPIES is not negative. */
6157 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6158 build_int_cst (ncopies_type
, 0));
6159 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6160 "Argument NCOPIES of REPEAT intrinsic is negative "
6161 "(its value is %ld)",
6162 fold_convert (long_integer_type_node
, ncopies
));
6164 /* If the source length is zero, any non negative value of NCOPIES
6165 is valid, and nothing happens. */
6166 n
= gfc_create_var (ncopies_type
, "ncopies");
6167 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6168 build_int_cst (size_type_node
, 0));
6169 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6170 build_int_cst (ncopies_type
, 0), ncopies
);
6171 gfc_add_modify (&se
->pre
, n
, tmp
);
6174 /* Check that ncopies is not too large: ncopies should be less than
6175 (or equal to) MAX / slen, where MAX is the maximal integer of
6176 the gfc_charlen_type_node type. If slen == 0, we need a special
6177 case to avoid the division by zero. */
6178 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6179 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6180 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6181 fold_convert (size_type_node
, max
), slen
);
6182 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6183 ? size_type_node
: ncopies_type
;
6184 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6185 fold_convert (largest
, ncopies
),
6186 fold_convert (largest
, max
));
6187 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6188 build_int_cst (size_type_node
, 0));
6189 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6190 boolean_false_node
, cond
);
6191 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6192 "Argument NCOPIES of REPEAT intrinsic is too large");
6194 /* Compute the destination length. */
6195 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6196 fold_convert (gfc_charlen_type_node
, slen
),
6197 fold_convert (gfc_charlen_type_node
, ncopies
));
6198 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6199 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6201 /* Generate the code to do the repeat operation:
6202 for (i = 0; i < ncopies; i++)
6203 memmove (dest + (i * slen * size), src, slen*size); */
6204 gfc_start_block (&block
);
6205 count
= gfc_create_var (ncopies_type
, "count");
6206 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6207 exit_label
= gfc_build_label_decl (NULL_TREE
);
6209 /* Start the loop body. */
6210 gfc_start_block (&body
);
6212 /* Exit the loop if count >= ncopies. */
6213 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6215 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6216 TREE_USED (exit_label
) = 1;
6217 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6218 build_empty_stmt (input_location
));
6219 gfc_add_expr_to_block (&body
, tmp
);
6221 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6222 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6223 fold_convert (gfc_charlen_type_node
, slen
),
6224 fold_convert (gfc_charlen_type_node
, count
));
6225 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6226 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6227 tmp
= fold_build_pointer_plus_loc (input_location
,
6228 fold_convert (pvoid_type_node
, dest
), tmp
);
6229 tmp
= build_call_expr_loc (input_location
,
6230 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6232 fold_build2_loc (input_location
, MULT_EXPR
,
6233 size_type_node
, slen
,
6234 fold_convert (size_type_node
,
6236 gfc_add_expr_to_block (&body
, tmp
);
6238 /* Increment count. */
6239 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6240 count
, build_int_cst (TREE_TYPE (count
), 1));
6241 gfc_add_modify (&body
, count
, tmp
);
6243 /* Build the loop. */
6244 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6245 gfc_add_expr_to_block (&block
, tmp
);
6247 /* Add the exit label. */
6248 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6249 gfc_add_expr_to_block (&block
, tmp
);
6251 /* Finish the block. */
6252 tmp
= gfc_finish_block (&block
);
6253 gfc_add_expr_to_block (&se
->pre
, tmp
);
6255 /* Set the result value. */
6257 se
->string_length
= dlen
;
6261 /* Generate code for the IARGC intrinsic. */
6264 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6270 /* Call the library function. This always returns an INTEGER(4). */
6271 fndecl
= gfor_fndecl_iargc
;
6272 tmp
= build_call_expr_loc (input_location
,
6275 /* Convert it to the required type. */
6276 type
= gfc_typenode_for_spec (&expr
->ts
);
6277 tmp
= fold_convert (type
, tmp
);
6283 /* The loc intrinsic returns the address of its argument as
6284 gfc_index_integer_kind integer. */
6287 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
6292 gcc_assert (!se
->ss
);
6294 arg_expr
= expr
->value
.function
.actual
->expr
;
6295 if (arg_expr
->rank
== 0)
6296 gfc_conv_expr_reference (se
, arg_expr
);
6298 gfc_conv_array_parameter (se
, arg_expr
, true, NULL
, NULL
, NULL
);
6299 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
6301 /* Create a temporary variable for loc return value. Without this,
6302 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6303 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
6304 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
6305 se
->expr
= temp_var
;
6309 /* The following routine generates code for the intrinsic
6310 functions from the ISO_C_BINDING module:
6316 conv_isocbinding_function (gfc_se
*se
, gfc_expr
*expr
)
6318 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
6320 if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_LOC
)
6322 if (arg
->expr
->rank
== 0)
6323 gfc_conv_expr_reference (se
, arg
->expr
);
6324 else if (gfc_is_simply_contiguous (arg
->expr
, false))
6325 gfc_conv_array_parameter (se
, arg
->expr
, true, NULL
, NULL
, NULL
);
6328 gfc_conv_expr_descriptor (se
, arg
->expr
);
6329 se
->expr
= gfc_conv_descriptor_data_get (se
->expr
);
6332 /* TODO -- the following two lines shouldn't be necessary, but if
6333 they're removed, a bug is exposed later in the code path.
6334 This workaround was thus introduced, but will have to be
6335 removed; please see PR 35150 for details about the issue. */
6336 se
->expr
= convert (pvoid_type_node
, se
->expr
);
6337 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6339 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_FUNLOC
)
6340 gfc_conv_expr_reference (se
, arg
->expr
);
6341 else if (expr
->value
.function
.isym
->id
== GFC_ISYM_C_ASSOCIATED
)
6346 /* Build the addr_expr for the first argument. The argument is
6347 already an *address* so we don't need to set want_pointer in
6349 gfc_init_se (&arg1se
, NULL
);
6350 gfc_conv_expr (&arg1se
, arg
->expr
);
6351 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
6352 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
6354 /* See if we were given two arguments. */
6355 if (arg
->next
->expr
== NULL
)
6356 /* Only given one arg so generate a null and do a
6357 not-equal comparison against the first arg. */
6358 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6360 fold_convert (TREE_TYPE (arg1se
.expr
),
6361 null_pointer_node
));
6367 /* Given two arguments so build the arg2se from second arg. */
6368 gfc_init_se (&arg2se
, NULL
);
6369 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
6370 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
6371 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
6373 /* Generate test to compare that the two args are equal. */
6374 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6375 arg1se
.expr
, arg2se
.expr
);
6376 /* Generate test to ensure that the first arg is not null. */
6377 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
6379 arg1se
.expr
, null_pointer_node
);
6381 /* Finally, the generated test must check that both arg1 is not
6382 NULL and that it is equal to the second arg. */
6383 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6385 not_null_expr
, eq_expr
);
6393 /* The following routine generates code for the intrinsic
6394 subroutines from the ISO_C_BINDING module:
6396 * C_F_PROCPOINTER. */
6399 conv_isocbinding_subroutine (gfc_code
*code
)
6406 tree desc
, dim
, tmp
, stride
, offset
;
6407 stmtblock_t body
, block
;
6409 gfc_actual_arglist
*arg
= code
->ext
.actual
;
6411 gfc_init_se (&se
, NULL
);
6412 gfc_init_se (&cptrse
, NULL
);
6413 gfc_conv_expr (&cptrse
, arg
->expr
);
6414 gfc_add_block_to_block (&se
.pre
, &cptrse
.pre
);
6415 gfc_add_block_to_block (&se
.post
, &cptrse
.post
);
6417 gfc_init_se (&fptrse
, NULL
);
6418 if (arg
->next
->expr
->rank
== 0)
6420 fptrse
.want_pointer
= 1;
6421 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
6422 gfc_add_block_to_block (&se
.pre
, &fptrse
.pre
);
6423 gfc_add_block_to_block (&se
.post
, &fptrse
.post
);
6424 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
6425 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
6426 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
6428 se
.expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6429 TREE_TYPE (fptrse
.expr
),
6431 fold_convert (TREE_TYPE (fptrse
.expr
),
6433 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
6434 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6435 return gfc_finish_block (&se
.pre
);
6438 gfc_start_block (&block
);
6440 /* Get the descriptor of the Fortran pointer. */
6441 fptrse
.descriptor_only
= 1;
6442 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
6443 gfc_add_block_to_block (&block
, &fptrse
.pre
);
6446 /* Set data value, dtype, and offset. */
6447 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
6448 gfc_conv_descriptor_data_set (&block
, desc
, fold_convert (tmp
, cptrse
.expr
));
6449 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
6450 gfc_get_dtype (TREE_TYPE (desc
)));
6452 /* Start scalarization of the bounds, using the shape argument. */
6454 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
6455 gcc_assert (shape_ss
!= gfc_ss_terminator
);
6456 gfc_init_se (&shapese
, NULL
);
6458 gfc_init_loopinfo (&loop
);
6459 gfc_add_ss_to_loop (&loop
, shape_ss
);
6460 gfc_conv_ss_startstride (&loop
);
6461 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
6462 gfc_mark_ss_chain_used (shape_ss
, 1);
6464 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
6465 shapese
.ss
= shape_ss
;
6467 stride
= gfc_create_var (gfc_array_index_type
, "stride");
6468 offset
= gfc_create_var (gfc_array_index_type
, "offset");
6469 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
6470 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6473 gfc_start_scalarized_body (&loop
, &body
);
6475 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6476 loop
.loopvar
[0], loop
.from
[0]);
6478 /* Set bounds and stride. */
6479 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
6480 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
6482 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
6483 gfc_add_block_to_block (&body
, &shapese
.pre
);
6484 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
6485 gfc_add_block_to_block (&body
, &shapese
.post
);
6487 /* Calculate offset. */
6488 gfc_add_modify (&body
, offset
,
6489 fold_build2_loc (input_location
, PLUS_EXPR
,
6490 gfc_array_index_type
, offset
, stride
));
6491 /* Update stride. */
6492 gfc_add_modify (&body
, stride
,
6493 fold_build2_loc (input_location
, MULT_EXPR
,
6494 gfc_array_index_type
, stride
,
6495 fold_convert (gfc_array_index_type
,
6497 /* Finish scalarization loop. */
6498 gfc_trans_scalarizing_loops (&loop
, &body
);
6499 gfc_add_block_to_block (&block
, &loop
.pre
);
6500 gfc_add_block_to_block (&block
, &loop
.post
);
6501 gfc_add_block_to_block (&block
, &fptrse
.post
);
6502 gfc_cleanup_loop (&loop
);
6504 gfc_add_modify (&block
, offset
,
6505 fold_build1_loc (input_location
, NEGATE_EXPR
,
6506 gfc_array_index_type
, offset
));
6507 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
6509 gfc_add_expr_to_block (&se
.pre
, gfc_finish_block (&block
));
6510 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6511 return gfc_finish_block (&se
.pre
);
6515 /* Generate code for an intrinsic function. Some map directly to library
6516 calls, others get special handling. In some cases the name of the function
6517 used depends on the type specifiers. */
6520 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
6526 name
= &expr
->value
.function
.name
[2];
6530 lib
= gfc_is_intrinsic_libcall (expr
);
6534 se
->ignore_optional
= 1;
6536 switch (expr
->value
.function
.isym
->id
)
6538 case GFC_ISYM_EOSHIFT
:
6540 case GFC_ISYM_RESHAPE
:
6541 /* For all of those the first argument specifies the type and the
6542 third is optional. */
6543 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
6547 gfc_conv_intrinsic_funcall (se
, expr
);
6555 switch (expr
->value
.function
.isym
->id
)
6560 case GFC_ISYM_REPEAT
:
6561 gfc_conv_intrinsic_repeat (se
, expr
);
6565 gfc_conv_intrinsic_trim (se
, expr
);
6568 case GFC_ISYM_SC_KIND
:
6569 gfc_conv_intrinsic_sc_kind (se
, expr
);
6572 case GFC_ISYM_SI_KIND
:
6573 gfc_conv_intrinsic_si_kind (se
, expr
);
6576 case GFC_ISYM_SR_KIND
:
6577 gfc_conv_intrinsic_sr_kind (se
, expr
);
6580 case GFC_ISYM_EXPONENT
:
6581 gfc_conv_intrinsic_exponent (se
, expr
);
6585 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6587 fndecl
= gfor_fndecl_string_scan
;
6589 fndecl
= gfor_fndecl_string_scan_char4
;
6593 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6596 case GFC_ISYM_VERIFY
:
6597 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6599 fndecl
= gfor_fndecl_string_verify
;
6601 fndecl
= gfor_fndecl_string_verify_char4
;
6605 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6608 case GFC_ISYM_ALLOCATED
:
6609 gfc_conv_allocated (se
, expr
);
6612 case GFC_ISYM_ASSOCIATED
:
6613 gfc_conv_associated(se
, expr
);
6616 case GFC_ISYM_SAME_TYPE_AS
:
6617 gfc_conv_same_type_as (se
, expr
);
6621 gfc_conv_intrinsic_abs (se
, expr
);
6624 case GFC_ISYM_ADJUSTL
:
6625 if (expr
->ts
.kind
== 1)
6626 fndecl
= gfor_fndecl_adjustl
;
6627 else if (expr
->ts
.kind
== 4)
6628 fndecl
= gfor_fndecl_adjustl_char4
;
6632 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6635 case GFC_ISYM_ADJUSTR
:
6636 if (expr
->ts
.kind
== 1)
6637 fndecl
= gfor_fndecl_adjustr
;
6638 else if (expr
->ts
.kind
== 4)
6639 fndecl
= gfor_fndecl_adjustr_char4
;
6643 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6646 case GFC_ISYM_AIMAG
:
6647 gfc_conv_intrinsic_imagpart (se
, expr
);
6651 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
6655 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
6658 case GFC_ISYM_ANINT
:
6659 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
6663 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6667 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
6670 case GFC_ISYM_BTEST
:
6671 gfc_conv_intrinsic_btest (se
, expr
);
6675 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
6679 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
6683 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
6687 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
6690 case GFC_ISYM_C_ASSOCIATED
:
6691 case GFC_ISYM_C_FUNLOC
:
6692 case GFC_ISYM_C_LOC
:
6693 conv_isocbinding_function (se
, expr
);
6696 case GFC_ISYM_ACHAR
:
6698 gfc_conv_intrinsic_char (se
, expr
);
6701 case GFC_ISYM_CONVERSION
:
6703 case GFC_ISYM_LOGICAL
:
6705 gfc_conv_intrinsic_conversion (se
, expr
);
6708 /* Integer conversions are handled separately to make sure we get the
6709 correct rounding mode. */
6714 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
6718 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
6721 case GFC_ISYM_CEILING
:
6722 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
6725 case GFC_ISYM_FLOOR
:
6726 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
6730 gfc_conv_intrinsic_mod (se
, expr
, 0);
6733 case GFC_ISYM_MODULO
:
6734 gfc_conv_intrinsic_mod (se
, expr
, 1);
6737 case GFC_ISYM_CMPLX
:
6738 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
6741 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
6742 gfc_conv_intrinsic_iargc (se
, expr
);
6745 case GFC_ISYM_COMPLEX
:
6746 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
6749 case GFC_ISYM_CONJG
:
6750 gfc_conv_intrinsic_conjg (se
, expr
);
6753 case GFC_ISYM_COUNT
:
6754 gfc_conv_intrinsic_count (se
, expr
);
6757 case GFC_ISYM_CTIME
:
6758 gfc_conv_intrinsic_ctime (se
, expr
);
6762 gfc_conv_intrinsic_dim (se
, expr
);
6765 case GFC_ISYM_DOT_PRODUCT
:
6766 gfc_conv_intrinsic_dot_product (se
, expr
);
6769 case GFC_ISYM_DPROD
:
6770 gfc_conv_intrinsic_dprod (se
, expr
);
6773 case GFC_ISYM_DSHIFTL
:
6774 gfc_conv_intrinsic_dshift (se
, expr
, true);
6777 case GFC_ISYM_DSHIFTR
:
6778 gfc_conv_intrinsic_dshift (se
, expr
, false);
6781 case GFC_ISYM_FDATE
:
6782 gfc_conv_intrinsic_fdate (se
, expr
);
6785 case GFC_ISYM_FRACTION
:
6786 gfc_conv_intrinsic_fraction (se
, expr
);
6790 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
6794 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6798 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
6801 case GFC_ISYM_IBCLR
:
6802 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
6805 case GFC_ISYM_IBITS
:
6806 gfc_conv_intrinsic_ibits (se
, expr
);
6809 case GFC_ISYM_IBSET
:
6810 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
6813 case GFC_ISYM_IACHAR
:
6814 case GFC_ISYM_ICHAR
:
6815 /* We assume ASCII character sequence. */
6816 gfc_conv_intrinsic_ichar (se
, expr
);
6819 case GFC_ISYM_IARGC
:
6820 gfc_conv_intrinsic_iargc (se
, expr
);
6824 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6827 case GFC_ISYM_INDEX
:
6828 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6830 fndecl
= gfor_fndecl_string_index
;
6832 fndecl
= gfor_fndecl_string_index_char4
;
6836 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6840 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6843 case GFC_ISYM_IPARITY
:
6844 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
6847 case GFC_ISYM_IS_IOSTAT_END
:
6848 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
6851 case GFC_ISYM_IS_IOSTAT_EOR
:
6852 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
6855 case GFC_ISYM_ISNAN
:
6856 gfc_conv_intrinsic_isnan (se
, expr
);
6859 case GFC_ISYM_LSHIFT
:
6860 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6863 case GFC_ISYM_RSHIFT
:
6864 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6867 case GFC_ISYM_SHIFTA
:
6868 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6871 case GFC_ISYM_SHIFTL
:
6872 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6875 case GFC_ISYM_SHIFTR
:
6876 gfc_conv_intrinsic_shift (se
, expr
, true, false);
6879 case GFC_ISYM_ISHFT
:
6880 gfc_conv_intrinsic_ishft (se
, expr
);
6883 case GFC_ISYM_ISHFTC
:
6884 gfc_conv_intrinsic_ishftc (se
, expr
);
6887 case GFC_ISYM_LEADZ
:
6888 gfc_conv_intrinsic_leadz (se
, expr
);
6891 case GFC_ISYM_TRAILZ
:
6892 gfc_conv_intrinsic_trailz (se
, expr
);
6895 case GFC_ISYM_POPCNT
:
6896 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
6899 case GFC_ISYM_POPPAR
:
6900 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
6903 case GFC_ISYM_LBOUND
:
6904 gfc_conv_intrinsic_bound (se
, expr
, 0);
6907 case GFC_ISYM_LCOBOUND
:
6908 conv_intrinsic_cobound (se
, expr
);
6911 case GFC_ISYM_TRANSPOSE
:
6912 /* The scalarizer has already been set up for reversed dimension access
6913 order ; now we just get the argument value normally. */
6914 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
6918 gfc_conv_intrinsic_len (se
, expr
);
6921 case GFC_ISYM_LEN_TRIM
:
6922 gfc_conv_intrinsic_len_trim (se
, expr
);
6926 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
6930 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
6934 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
6938 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
6941 case GFC_ISYM_MASKL
:
6942 gfc_conv_intrinsic_mask (se
, expr
, 1);
6945 case GFC_ISYM_MASKR
:
6946 gfc_conv_intrinsic_mask (se
, expr
, 0);
6950 if (expr
->ts
.type
== BT_CHARACTER
)
6951 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
6953 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
6956 case GFC_ISYM_MAXLOC
:
6957 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
6960 case GFC_ISYM_MAXVAL
:
6961 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
6964 case GFC_ISYM_MERGE
:
6965 gfc_conv_intrinsic_merge (se
, expr
);
6968 case GFC_ISYM_MERGE_BITS
:
6969 gfc_conv_intrinsic_merge_bits (se
, expr
);
6973 if (expr
->ts
.type
== BT_CHARACTER
)
6974 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
6976 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
6979 case GFC_ISYM_MINLOC
:
6980 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
6983 case GFC_ISYM_MINVAL
:
6984 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
6987 case GFC_ISYM_NEAREST
:
6988 gfc_conv_intrinsic_nearest (se
, expr
);
6991 case GFC_ISYM_NORM2
:
6992 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
6996 gfc_conv_intrinsic_not (se
, expr
);
7000 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
7003 case GFC_ISYM_PARITY
:
7004 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
7007 case GFC_ISYM_PRESENT
:
7008 gfc_conv_intrinsic_present (se
, expr
);
7011 case GFC_ISYM_PRODUCT
:
7012 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
7016 gfc_conv_intrinsic_rank (se
, expr
);
7019 case GFC_ISYM_RRSPACING
:
7020 gfc_conv_intrinsic_rrspacing (se
, expr
);
7023 case GFC_ISYM_SET_EXPONENT
:
7024 gfc_conv_intrinsic_set_exponent (se
, expr
);
7027 case GFC_ISYM_SCALE
:
7028 gfc_conv_intrinsic_scale (se
, expr
);
7032 gfc_conv_intrinsic_sign (se
, expr
);
7036 gfc_conv_intrinsic_size (se
, expr
);
7039 case GFC_ISYM_SIZEOF
:
7040 case GFC_ISYM_C_SIZEOF
:
7041 gfc_conv_intrinsic_sizeof (se
, expr
);
7044 case GFC_ISYM_STORAGE_SIZE
:
7045 gfc_conv_intrinsic_storage_size (se
, expr
);
7048 case GFC_ISYM_SPACING
:
7049 gfc_conv_intrinsic_spacing (se
, expr
);
7052 case GFC_ISYM_STRIDE
:
7053 conv_intrinsic_stride (se
, expr
);
7057 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
7060 case GFC_ISYM_TRANSFER
:
7061 if (se
->ss
&& se
->ss
->info
->useflags
)
7062 /* Access the previously obtained result. */
7063 gfc_conv_tmp_array_ref (se
);
7065 gfc_conv_intrinsic_transfer (se
, expr
);
7068 case GFC_ISYM_TTYNAM
:
7069 gfc_conv_intrinsic_ttynam (se
, expr
);
7072 case GFC_ISYM_UBOUND
:
7073 gfc_conv_intrinsic_bound (se
, expr
, 1);
7076 case GFC_ISYM_UCOBOUND
:
7077 conv_intrinsic_cobound (se
, expr
);
7081 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
7085 gfc_conv_intrinsic_loc (se
, expr
);
7088 case GFC_ISYM_THIS_IMAGE
:
7089 /* For num_images() == 1, handle as LCOBOUND. */
7090 if (expr
->value
.function
.actual
->expr
7091 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
7092 conv_intrinsic_cobound (se
, expr
);
7094 trans_this_image (se
, expr
);
7097 case GFC_ISYM_IMAGE_INDEX
:
7098 trans_image_index (se
, expr
);
7101 case GFC_ISYM_NUM_IMAGES
:
7102 trans_num_images (se
);
7105 case GFC_ISYM_ACCESS
:
7106 case GFC_ISYM_CHDIR
:
7107 case GFC_ISYM_CHMOD
:
7108 case GFC_ISYM_DTIME
:
7109 case GFC_ISYM_ETIME
:
7110 case GFC_ISYM_EXTENDS_TYPE_OF
:
7112 case GFC_ISYM_FGETC
:
7115 case GFC_ISYM_FPUTC
:
7116 case GFC_ISYM_FSTAT
:
7117 case GFC_ISYM_FTELL
:
7118 case GFC_ISYM_GETCWD
:
7119 case GFC_ISYM_GETGID
:
7120 case GFC_ISYM_GETPID
:
7121 case GFC_ISYM_GETUID
:
7122 case GFC_ISYM_HOSTNM
:
7124 case GFC_ISYM_IERRNO
:
7125 case GFC_ISYM_IRAND
:
7126 case GFC_ISYM_ISATTY
:
7129 case GFC_ISYM_LSTAT
:
7130 case GFC_ISYM_MALLOC
:
7131 case GFC_ISYM_MATMUL
:
7132 case GFC_ISYM_MCLOCK
:
7133 case GFC_ISYM_MCLOCK8
:
7135 case GFC_ISYM_RENAME
:
7136 case GFC_ISYM_SECOND
:
7137 case GFC_ISYM_SECNDS
:
7138 case GFC_ISYM_SIGNAL
:
7140 case GFC_ISYM_SYMLNK
:
7141 case GFC_ISYM_SYSTEM
:
7143 case GFC_ISYM_TIME8
:
7144 case GFC_ISYM_UMASK
:
7145 case GFC_ISYM_UNLINK
:
7147 gfc_conv_intrinsic_funcall (se
, expr
);
7150 case GFC_ISYM_EOSHIFT
:
7152 case GFC_ISYM_RESHAPE
:
7153 /* For those, expr->rank should always be >0 and thus the if above the
7154 switch should have matched. */
7159 gfc_conv_intrinsic_lib_function (se
, expr
);
7166 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
7168 gfc_ss
*arg_ss
, *tmp_ss
;
7169 gfc_actual_arglist
*arg
;
7171 arg
= expr
->value
.function
.actual
;
7173 gcc_assert (arg
->expr
);
7175 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
7176 gcc_assert (arg_ss
!= gfc_ss_terminator
);
7178 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
7180 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
7181 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
7185 gcc_assert (tmp_ss
->dimen
== 2);
7187 /* We just invert dimensions. */
7188 tmp_dim
= tmp_ss
->dim
[0];
7189 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
7190 tmp_ss
->dim
[1] = tmp_dim
;
7193 /* Stop when tmp_ss points to the last valid element of the chain... */
7194 if (tmp_ss
->next
== gfc_ss_terminator
)
7198 /* ... so that we can attach the rest of the chain to it. */
7205 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
7206 This has the side effect of reversing the nested list, so there is no
7207 need to call gfc_reverse_ss on it (the given list is assumed not to be
7211 nest_loop_dimension (gfc_ss
*ss
, int dim
)
7214 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
7215 gfc_loopinfo
*new_loop
;
7217 gcc_assert (ss
!= gfc_ss_terminator
);
7219 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
7221 new_ss
= gfc_get_ss ();
7222 new_ss
->next
= prev_ss
;
7223 new_ss
->parent
= ss
;
7224 new_ss
->info
= ss
->info
;
7225 new_ss
->info
->refcount
++;
7228 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
7229 && ss
->info
->type
!= GFC_SS_REFERENCE
);
7232 new_ss
->dim
[0] = ss
->dim
[dim
];
7234 gcc_assert (dim
< ss
->dimen
);
7236 ss_dim
= --ss
->dimen
;
7237 for (i
= dim
; i
< ss_dim
; i
++)
7238 ss
->dim
[i
] = ss
->dim
[i
+ 1];
7240 ss
->dim
[ss_dim
] = 0;
7246 ss
->nested_ss
->parent
= new_ss
;
7247 new_ss
->nested_ss
= ss
->nested_ss
;
7249 ss
->nested_ss
= new_ss
;
7252 new_loop
= gfc_get_loopinfo ();
7253 gfc_init_loopinfo (new_loop
);
7255 gcc_assert (prev_ss
!= NULL
);
7256 gcc_assert (prev_ss
!= gfc_ss_terminator
);
7257 gfc_add_ss_to_loop (new_loop
, prev_ss
);
7258 return new_ss
->parent
;
7262 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
7263 is to be inlined. */
7266 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
7268 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
7269 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
7271 bool scalar_mask
= false;
7273 /* The rank of the result will be determined later. */
7274 arg1
= expr
->value
.function
.actual
;
7277 gcc_assert (arg3
!= NULL
);
7279 if (expr
->rank
== 0)
7282 tmp_ss
= gfc_ss_terminator
;
7288 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
7289 if (mask_ss
== tmp_ss
)
7295 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
7296 gcc_assert (array_ss
!= tmp_ss
);
7298 /* Odd thing: If the mask is scalar, it is used by the frontend after
7299 the array (to make an if around the nested loop). Thus it shall
7300 be after array_ss once the gfc_ss list is reversed. */
7302 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
7306 /* "Hide" the dimension on which we will sum in the first arg's scalarization
7308 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
7309 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
7317 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
7320 switch (expr
->value
.function
.isym
->id
)
7322 case GFC_ISYM_PRODUCT
:
7324 return walk_inline_intrinsic_arith (ss
, expr
);
7326 case GFC_ISYM_TRANSPOSE
:
7327 return walk_inline_intrinsic_transpose (ss
, expr
);
7336 /* This generates code to execute before entering the scalarization loop.
7337 Currently does nothing. */
7340 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
7342 switch (ss
->info
->expr
->value
.function
.isym
->id
)
7344 case GFC_ISYM_UBOUND
:
7345 case GFC_ISYM_LBOUND
:
7346 case GFC_ISYM_UCOBOUND
:
7347 case GFC_ISYM_LCOBOUND
:
7348 case GFC_ISYM_THIS_IMAGE
:
7357 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
7358 are expanded into code inside the scalarization loop. */
7361 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
7363 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
7364 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
7366 /* The two argument version returns a scalar. */
7367 if (expr
->value
.function
.actual
->next
->expr
)
7370 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
7374 /* Walk an intrinsic array libcall. */
7377 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
7379 gcc_assert (expr
->rank
> 0);
7380 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
7384 /* Return whether the function call expression EXPR will be expanded
7385 inline by gfc_conv_intrinsic_function. */
7388 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
7390 gfc_actual_arglist
*args
;
7392 if (!expr
->value
.function
.isym
)
7395 switch (expr
->value
.function
.isym
->id
)
7397 case GFC_ISYM_PRODUCT
:
7399 /* Disable inline expansion if code size matters. */
7403 args
= expr
->value
.function
.actual
;
7404 /* We need to be able to subset the SUM argument at compile-time. */
7405 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
7410 case GFC_ISYM_TRANSPOSE
:
7419 /* Returns nonzero if the specified intrinsic function call maps directly to
7420 an external library call. Should only be used for functions that return
7424 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
7426 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
7427 gcc_assert (expr
->rank
> 0);
7429 if (gfc_inline_intrinsic_function_p (expr
))
7432 switch (expr
->value
.function
.isym
->id
)
7436 case GFC_ISYM_COUNT
:
7440 case GFC_ISYM_IPARITY
:
7441 case GFC_ISYM_MATMUL
:
7442 case GFC_ISYM_MAXLOC
:
7443 case GFC_ISYM_MAXVAL
:
7444 case GFC_ISYM_MINLOC
:
7445 case GFC_ISYM_MINVAL
:
7446 case GFC_ISYM_NORM2
:
7447 case GFC_ISYM_PARITY
:
7448 case GFC_ISYM_PRODUCT
:
7450 case GFC_ISYM_SHAPE
:
7451 case GFC_ISYM_SPREAD
:
7453 /* Ignore absent optional parameters. */
7456 case GFC_ISYM_RESHAPE
:
7457 case GFC_ISYM_CSHIFT
:
7458 case GFC_ISYM_EOSHIFT
:
7460 case GFC_ISYM_UNPACK
:
7461 /* Pass absent optional parameters. */
7469 /* Walk an intrinsic function. */
7471 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
7472 gfc_intrinsic_sym
* isym
)
7476 if (isym
->elemental
)
7477 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
7478 NULL
, GFC_SS_SCALAR
);
7480 if (expr
->rank
== 0)
7483 if (gfc_inline_intrinsic_function_p (expr
))
7484 return walk_inline_intrinsic_function (ss
, expr
);
7486 if (gfc_is_intrinsic_libcall (expr
))
7487 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7489 /* Special cases. */
7492 case GFC_ISYM_LBOUND
:
7493 case GFC_ISYM_LCOBOUND
:
7494 case GFC_ISYM_UBOUND
:
7495 case GFC_ISYM_UCOBOUND
:
7496 case GFC_ISYM_THIS_IMAGE
:
7497 return gfc_walk_intrinsic_bound (ss
, expr
);
7499 case GFC_ISYM_TRANSFER
:
7500 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7503 /* This probably meant someone forgot to add an intrinsic to the above
7504 list(s) when they implemented it, or something's gone horribly
7512 conv_co_minmaxsum (gfc_code
*code
)
7515 stmtblock_t block
, post_block
;
7516 tree fndecl
, array
, vec
, strlen
, image_index
, stat
, errmsg
, errmsg_len
;
7518 gfc_start_block (&block
);
7519 gfc_init_block (&post_block
);
7522 if (code
->ext
.actual
->next
->next
->expr
)
7524 gfc_init_se (&argse
, NULL
);
7525 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->expr
);
7526 gfc_add_block_to_block (&block
, &argse
.pre
);
7527 gfc_add_block_to_block (&post_block
, &argse
.post
);
7529 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
7530 stat
= gfc_build_addr_expr (NULL_TREE
, stat
);
7532 else if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
7535 stat
= null_pointer_node
;
7537 /* Early exit for GFC_FCOARRAY_SINGLE. */
7538 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
7540 if (stat
!= NULL_TREE
)
7541 gfc_add_modify (&block
, stat
,
7542 fold_convert (TREE_TYPE (stat
), integer_zero_node
));
7543 return gfc_finish_block (&block
);
7546 /* Handle the array. */
7547 gfc_init_se (&argse
, NULL
);
7548 if (code
->ext
.actual
->expr
->rank
== 0)
7550 symbol_attribute attr
;
7551 gfc_clear_attr (&attr
);
7552 gfc_init_se (&argse
, NULL
);
7553 gfc_conv_expr (&argse
, code
->ext
.actual
->expr
);
7554 gfc_add_block_to_block (&block
, &argse
.pre
);
7555 gfc_add_block_to_block (&post_block
, &argse
.post
);
7556 array
= gfc_conv_scalar_to_descriptor (&argse
, argse
.expr
, attr
);
7557 array
= gfc_build_addr_expr (NULL_TREE
, array
);
7561 argse
.want_pointer
= 1;
7562 gfc_conv_expr_descriptor (&argse
, code
->ext
.actual
->expr
);
7565 gfc_add_block_to_block (&block
, &argse
.pre
);
7566 gfc_add_block_to_block (&post_block
, &argse
.post
);
7568 if (code
->ext
.actual
->expr
->ts
.type
== BT_CHARACTER
)
7569 strlen
= argse
.string_length
;
7571 strlen
= integer_zero_node
;
7573 vec
= null_pointer_node
;
7576 if (code
->ext
.actual
->next
->expr
)
7578 gfc_init_se (&argse
, NULL
);
7579 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->expr
);
7580 gfc_add_block_to_block (&block
, &argse
.pre
);
7581 gfc_add_block_to_block (&post_block
, &argse
.post
);
7582 image_index
= fold_convert (integer_type_node
, argse
.expr
);
7585 image_index
= integer_zero_node
;
7588 if (code
->ext
.actual
->next
->next
->next
->expr
)
7590 gfc_init_se (&argse
, NULL
);
7591 gfc_conv_expr (&argse
, code
->ext
.actual
->next
->next
->next
->expr
);
7592 gfc_add_block_to_block (&block
, &argse
.pre
);
7593 gfc_add_block_to_block (&post_block
, &argse
.post
);
7594 errmsg
= argse
.expr
;
7595 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
7599 errmsg
= null_pointer_node
;
7600 errmsg_len
= integer_zero_node
;
7603 /* Generate the function call. */
7604 if (code
->resolved_isym
->id
== GFC_ISYM_CO_MAX
)
7605 fndecl
= gfor_fndecl_co_max
;
7606 else if (code
->resolved_isym
->id
== GFC_ISYM_CO_MIN
)
7607 fndecl
= gfor_fndecl_co_min
;
7608 else if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
)
7609 fndecl
= gfor_fndecl_co_sum
;
7613 if (code
->resolved_isym
->id
== GFC_ISYM_CO_SUM
)
7614 fndecl
= build_call_expr_loc (input_location
, fndecl
, 6, array
, vec
,
7615 image_index
, stat
, errmsg
, errmsg_len
);
7617 fndecl
= build_call_expr_loc (input_location
, fndecl
, 7, array
, vec
,
7618 image_index
, stat
, errmsg
, strlen
,
7620 gfc_add_expr_to_block (&block
, fndecl
);
7621 gfc_add_block_to_block (&block
, &post_block
);
7623 /* Add CALL to CO_SUM/MIN/MAX: array descriptor, vector descriptor, stat, errmsg, strlen, errmsglen */
7624 return gfc_finish_block (&block
);
7629 conv_intrinsic_atomic_def (gfc_code
*code
)
7634 gfc_init_se (&atom
, NULL
);
7635 gfc_init_se (&value
, NULL
);
7636 gfc_conv_expr (&atom
, code
->ext
.actual
->expr
);
7637 gfc_conv_expr (&value
, code
->ext
.actual
->next
->expr
);
7639 gfc_init_block (&block
);
7640 gfc_add_modify (&block
, atom
.expr
,
7641 fold_convert (TREE_TYPE (atom
.expr
), value
.expr
));
7642 return gfc_finish_block (&block
);
7647 conv_intrinsic_atomic_ref (gfc_code
*code
)
7652 gfc_init_se (&atom
, NULL
);
7653 gfc_init_se (&value
, NULL
);
7654 gfc_conv_expr (&value
, code
->ext
.actual
->expr
);
7655 gfc_conv_expr (&atom
, code
->ext
.actual
->next
->expr
);
7657 gfc_init_block (&block
);
7658 gfc_add_modify (&block
, value
.expr
,
7659 fold_convert (TREE_TYPE (value
.expr
), atom
.expr
));
7660 return gfc_finish_block (&block
);
7665 conv_intrinsic_move_alloc (gfc_code
*code
)
7668 gfc_expr
*from_expr
, *to_expr
;
7669 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
7670 gfc_se from_se
, to_se
;
7674 gfc_start_block (&block
);
7676 from_expr
= code
->ext
.actual
->expr
;
7677 to_expr
= code
->ext
.actual
->next
->expr
;
7679 gfc_init_se (&from_se
, NULL
);
7680 gfc_init_se (&to_se
, NULL
);
7682 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
7683 || to_expr
->ts
.type
== BT_CLASS
);
7684 coarray
= gfc_get_corank (from_expr
) != 0;
7686 if (from_expr
->rank
== 0 && !coarray
)
7688 if (from_expr
->ts
.type
!= BT_CLASS
)
7689 from_expr2
= from_expr
;
7692 from_expr2
= gfc_copy_expr (from_expr
);
7693 gfc_add_data_component (from_expr2
);
7696 if (to_expr
->ts
.type
!= BT_CLASS
)
7700 to_expr2
= gfc_copy_expr (to_expr
);
7701 gfc_add_data_component (to_expr2
);
7704 from_se
.want_pointer
= 1;
7705 to_se
.want_pointer
= 1;
7706 gfc_conv_expr (&from_se
, from_expr2
);
7707 gfc_conv_expr (&to_se
, to_expr2
);
7708 gfc_add_block_to_block (&block
, &from_se
.pre
);
7709 gfc_add_block_to_block (&block
, &to_se
.pre
);
7711 /* Deallocate "to". */
7712 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
7713 to_expr
, to_expr
->ts
);
7714 gfc_add_expr_to_block (&block
, tmp
);
7716 /* Assign (_data) pointers. */
7717 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7718 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
7720 /* Set "from" to NULL. */
7721 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7722 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
7724 gfc_add_block_to_block (&block
, &from_se
.post
);
7725 gfc_add_block_to_block (&block
, &to_se
.post
);
7728 if (to_expr
->ts
.type
== BT_CLASS
)
7732 gfc_free_expr (to_expr2
);
7733 gfc_init_se (&to_se
, NULL
);
7734 to_se
.want_pointer
= 1;
7735 gfc_add_vptr_component (to_expr
);
7736 gfc_conv_expr (&to_se
, to_expr
);
7738 if (from_expr
->ts
.type
== BT_CLASS
)
7740 if (UNLIMITED_POLY (from_expr
))
7744 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7748 gfc_free_expr (from_expr2
);
7749 gfc_init_se (&from_se
, NULL
);
7750 from_se
.want_pointer
= 1;
7751 gfc_add_vptr_component (from_expr
);
7752 gfc_conv_expr (&from_se
, from_expr
);
7753 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7754 fold_convert (TREE_TYPE (to_se
.expr
),
7757 /* Reset _vptr component to declared type. */
7759 /* Unlimited polymorphic. */
7760 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7761 fold_convert (TREE_TYPE (from_se
.expr
),
7762 null_pointer_node
));
7765 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7766 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7767 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
7772 vtab
= gfc_find_vtab (&from_expr
->ts
);
7774 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7775 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7776 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7780 return gfc_finish_block (&block
);
7783 /* Update _vptr component. */
7784 if (to_expr
->ts
.type
== BT_CLASS
)
7788 to_se
.want_pointer
= 1;
7789 to_expr2
= gfc_copy_expr (to_expr
);
7790 gfc_add_vptr_component (to_expr2
);
7791 gfc_conv_expr (&to_se
, to_expr2
);
7793 if (from_expr
->ts
.type
== BT_CLASS
)
7795 if (UNLIMITED_POLY (from_expr
))
7799 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7803 from_se
.want_pointer
= 1;
7804 from_expr2
= gfc_copy_expr (from_expr
);
7805 gfc_add_vptr_component (from_expr2
);
7806 gfc_conv_expr (&from_se
, from_expr2
);
7807 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7808 fold_convert (TREE_TYPE (to_se
.expr
),
7811 /* Reset _vptr component to declared type. */
7813 /* Unlimited polymorphic. */
7814 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7815 fold_convert (TREE_TYPE (from_se
.expr
),
7816 null_pointer_node
));
7819 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7820 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7821 fold_convert (TREE_TYPE (from_se
.expr
), tmp
));
7826 vtab
= gfc_find_vtab (&from_expr
->ts
);
7828 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7829 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7830 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7833 gfc_free_expr (to_expr2
);
7834 gfc_init_se (&to_se
, NULL
);
7836 if (from_expr
->ts
.type
== BT_CLASS
)
7838 gfc_free_expr (from_expr2
);
7839 gfc_init_se (&from_se
, NULL
);
7844 /* Deallocate "to". */
7845 if (from_expr
->rank
== 0)
7847 to_se
.want_coarray
= 1;
7848 from_se
.want_coarray
= 1;
7850 gfc_conv_expr_descriptor (&to_se
, to_expr
);
7851 gfc_conv_expr_descriptor (&from_se
, from_expr
);
7853 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
7854 is an image control "statement", cf. IR F08/0040 in 12-006A. */
7855 if (coarray
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
7859 tmp
= gfc_deallocate_with_status (to_se
.expr
, NULL_TREE
, NULL_TREE
,
7860 NULL_TREE
, NULL_TREE
, true, to_expr
,
7862 gfc_add_expr_to_block (&block
, tmp
);
7864 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7865 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7866 boolean_type_node
, tmp
,
7867 fold_convert (TREE_TYPE (tmp
),
7868 null_pointer_node
));
7869 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
7870 3, null_pointer_node
, null_pointer_node
,
7871 build_int_cst (integer_type_node
, 0));
7873 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
7874 tmp
, build_empty_stmt (input_location
));
7875 gfc_add_expr_to_block (&block
, tmp
);
7879 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7880 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
7881 NULL_TREE
, true, to_expr
, false);
7882 gfc_add_expr_to_block (&block
, tmp
);
7885 /* Move the pointer and update the array descriptor data. */
7886 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
7888 /* Set "from" to NULL. */
7889 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
7890 gfc_add_modify_loc (input_location
, &block
, tmp
,
7891 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7893 return gfc_finish_block (&block
);
7898 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
7902 gcc_assert (code
->resolved_isym
);
7904 switch (code
->resolved_isym
->id
)
7906 case GFC_ISYM_MOVE_ALLOC
:
7907 res
= conv_intrinsic_move_alloc (code
);
7910 case GFC_ISYM_ATOMIC_DEF
:
7911 res
= conv_intrinsic_atomic_def (code
);
7914 case GFC_ISYM_ATOMIC_REF
:
7915 res
= conv_intrinsic_atomic_ref (code
);
7918 case GFC_ISYM_C_F_POINTER
:
7919 case GFC_ISYM_C_F_PROCPOINTER
:
7920 res
= conv_isocbinding_subroutine (code
);
7923 case GFC_ISYM_CO_MIN
:
7924 case GFC_ISYM_CO_MAX
:
7925 case GFC_ISYM_CO_SUM
:
7926 res
= conv_co_minmaxsum (code
);
7937 #include "gt-fortran-trans-intrinsic.h"