1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
31 #include "diagnostic-core.h" /* For internal_error. */
32 #include "toplev.h" /* For rest_of_decl_compilation. */
36 #include "intrinsic.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps fortran intrinsic math functions to external library or GCC
47 typedef struct GTY(()) gfc_intrinsic_map_t
{
48 /* The explicit enum is required to work around inadequacies in the
49 garbage collection/gengtype parsing mechanism. */
52 /* Enum value from the "language-independent", aka C-centric, part
53 of gcc, or END_BUILTINS of no such value set. */
54 enum built_in_function float_built_in
;
55 enum built_in_function double_built_in
;
56 enum built_in_function long_double_built_in
;
57 enum built_in_function complex_float_built_in
;
58 enum built_in_function complex_double_built_in
;
59 enum built_in_function complex_long_double_built_in
;
61 /* True if the naming pattern is to prepend "c" for complex and
62 append "f" for kind=4. False if the naming pattern is to
63 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 /* True if a complex version of the function exists. */
67 bool complex_available
;
69 /* True if the function should be marked const. */
72 /* The base library name of this function. */
75 /* Cache decls created for the various operand types. */
87 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
88 defines complex variants of all of the entries in mathbuiltins.def
90 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
91 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
92 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
93 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
94 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
96 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
97 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
98 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
99 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
100 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
102 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
108 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
109 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
110 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
116 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
117 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
118 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
119 #include "mathbuiltins.def"
121 /* Functions in libgfortran. */
122 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
125 LIB_FUNCTION (NONE
, NULL
, false)
130 #undef DEFINE_MATH_BUILTIN
131 #undef DEFINE_MATH_BUILTIN_C
134 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
137 /* Find the correct variant of a given builtin from its argument. */
139 builtin_decl_for_precision (enum built_in_function base_built_in
,
142 int i
= END_BUILTINS
;
144 gfc_intrinsic_map_t
*m
;
145 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
148 if (precision
== TYPE_PRECISION (float_type_node
))
149 i
= m
->float_built_in
;
150 else if (precision
== TYPE_PRECISION (double_type_node
))
151 i
= m
->double_built_in
;
152 else if (precision
== TYPE_PRECISION (long_double_type_node
))
153 i
= m
->long_double_built_in
;
154 else if (precision
== TYPE_PRECISION (float128_type_node
))
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m
->real16_decl
;
161 return (i
== END_BUILTINS
? NULL_TREE
: built_in_decls
[i
]);
166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
169 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
171 if (gfc_real_kinds
[i
].c_float128
)
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t
*m
;
176 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
179 return m
->real16_decl
;
182 return builtin_decl_for_precision (double_built_in
,
183 gfc_real_kinds
[i
].mode_precision
);
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
193 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
194 tree
*argarray
, int nargs
)
196 gfc_actual_arglist
*actual
;
198 gfc_intrinsic_arg
*formal
;
202 formal
= expr
->value
.function
.isym
->formal
;
203 actual
= expr
->value
.function
.actual
;
205 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
206 actual
= actual
->next
,
207 formal
= formal
? formal
->next
: NULL
)
211 /* Skip omitted optional arguments. */
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse
, se
);
222 if (e
->ts
.type
== BT_CHARACTER
)
224 gfc_conv_expr (&argse
, e
);
225 gfc_conv_string_parameter (&argse
);
226 argarray
[curr_arg
++] = argse
.string_length
;
227 gcc_assert (curr_arg
< nargs
);
230 gfc_conv_expr_val (&argse
, e
);
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e
->expr_type
== EXPR_VARIABLE
235 && e
->symtree
->n
.sym
->attr
.optional
238 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
240 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
241 gfc_add_block_to_block (&se
->post
, &argse
.post
);
242 argarray
[curr_arg
] = argse
.expr
;
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
250 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
253 gfc_actual_arglist
*actual
;
255 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
260 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
274 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
280 nargs
= gfc_intrinsic_argument_list_length (expr
);
281 args
= XALLOCAVEC (tree
, nargs
);
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type
= gfc_typenode_for_spec (&expr
->ts
);
287 gcc_assert (expr
->value
.function
.actual
->expr
);
288 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
290 /* Conversion between character kinds involves a call to a library
292 if (expr
->ts
.type
== BT_CHARACTER
)
294 tree fndecl
, var
, addr
, tmp
;
296 if (expr
->ts
.kind
== 1
297 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
298 fndecl
= gfor_fndecl_convert_char4_to_char1
;
299 else if (expr
->ts
.kind
== 4
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
301 fndecl
= gfor_fndecl_convert_char1_to_char4
;
305 /* Create the variable storing the converted value. */
306 type
= gfc_get_pchar_type (expr
->ts
.kind
);
307 var
= gfc_create_var (type
, "str");
308 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs
>= 2);
312 tmp
= build_call_expr_loc (input_location
,
313 fndecl
, 3, addr
, args
[0], args
[1]);
314 gfc_add_expr_to_block (&se
->pre
, tmp
);
316 /* Free the temporary afterwards. */
317 tmp
= gfc_call_free (var
);
318 gfc_add_expr_to_block (&se
->post
, tmp
);
321 se
->string_length
= args
[0];
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
329 && expr
->ts
.type
!= BT_COMPLEX
)
333 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
334 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
338 se
->expr
= convert (type
, args
[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
354 argtype
= TREE_TYPE (arg
);
355 arg
= gfc_evaluate_now (arg
, pblock
);
357 intval
= convert (type
, arg
);
358 intval
= gfc_evaluate_now (intval
, pblock
);
360 tmp
= convert (argtype
, intval
);
361 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
362 boolean_type_node
, tmp
, arg
);
364 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
365 intval
, build_int_cst (type
, 1));
366 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg
, tree restype
)
379 int argprec
, resprec
;
381 argtype
= TREE_TYPE (arg
);
382 argprec
= TYPE_PRECISION (argtype
);
383 resprec
= TYPE_PRECISION (restype
);
385 /* Depending on the type of the result, choose the long int intrinsic
386 (lround family) or long long intrinsic (llround). We might also
387 need to convert the result afterwards. */
388 if (resprec
<= LONG_TYPE_SIZE
)
390 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
395 /* Now, depending on the argument type, we choose between intrinsics. */
397 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
399 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, 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 tmp
, func_0
, func_1
, func_2
, func_cabs
, func_frexp
;
625 tree func_lround
, func_llround
, func_scalbn
, func_cpow
;
627 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
629 /* type (*) (void) */
630 func_0
= build_function_type (float128_type_node
, void_list_node
);
631 /* type (*) (type) */
632 tmp
= tree_cons (NULL_TREE
, float128_type_node
, void_list_node
);
633 func_1
= build_function_type (float128_type_node
, tmp
);
634 /* long (*) (type) */
635 func_lround
= build_function_type (long_integer_type_node
, tmp
);
636 /* long long (*) (type) */
637 func_llround
= build_function_type (long_long_integer_type_node
, tmp
);
638 /* type (*) (type, type) */
639 tmp
= tree_cons (NULL_TREE
, float128_type_node
, tmp
);
640 func_2
= build_function_type (float128_type_node
, tmp
);
641 /* type (*) (type, &int) */
642 tmp
= tree_cons (NULL_TREE
, float128_type_node
, void_list_node
);
643 tmp
= tree_cons (NULL_TREE
, build_pointer_type (integer_type_node
), tmp
);
644 func_frexp
= build_function_type (float128_type_node
, tmp
);
645 /* type (*) (type, int) */
646 tmp
= tree_cons (NULL_TREE
, float128_type_node
, void_list_node
);
647 tmp
= tree_cons (NULL_TREE
, integer_type_node
, tmp
);
648 func_scalbn
= build_function_type (float128_type_node
, tmp
);
649 /* type (*) (complex type) */
650 tmp
= tree_cons (NULL_TREE
, complex_float128_type_node
, void_list_node
);
651 func_cabs
= build_function_type (float128_type_node
, tmp
);
652 /* complex type (*) (complex type, complex type) */
653 tmp
= tree_cons (NULL_TREE
, complex_float128_type_node
, tmp
);
654 func_cpow
= build_function_type (complex_float128_type_node
, tmp
);
656 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
657 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
658 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
660 /* Only these built-ins are actually needed here. These are used directly
661 from the code, when calling builtin_decl_for_precision() or
662 builtin_decl_for_float_type(). The others are all constructed by
663 gfc_get_intrinsic_lib_fndecl(). */
664 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
665 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
667 #include "mathbuiltins.def"
671 #undef DEFINE_MATH_BUILTIN
672 #undef DEFINE_MATH_BUILTIN_C
676 /* Add GCC builtin functions. */
677 for (m
= gfc_intrinsic_map
;
678 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
680 if (m
->float_built_in
!= END_BUILTINS
)
681 m
->real4_decl
= built_in_decls
[m
->float_built_in
];
682 if (m
->complex_float_built_in
!= END_BUILTINS
)
683 m
->complex4_decl
= built_in_decls
[m
->complex_float_built_in
];
684 if (m
->double_built_in
!= END_BUILTINS
)
685 m
->real8_decl
= built_in_decls
[m
->double_built_in
];
686 if (m
->complex_double_built_in
!= END_BUILTINS
)
687 m
->complex8_decl
= built_in_decls
[m
->complex_double_built_in
];
689 /* If real(kind=10) exists, it is always long double. */
690 if (m
->long_double_built_in
!= END_BUILTINS
)
691 m
->real10_decl
= built_in_decls
[m
->long_double_built_in
];
692 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
693 m
->complex10_decl
= built_in_decls
[m
->complex_long_double_built_in
];
695 if (!gfc_real16_is_float128
)
697 if (m
->long_double_built_in
!= END_BUILTINS
)
698 m
->real16_decl
= built_in_decls
[m
->long_double_built_in
];
699 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
700 m
->complex16_decl
= built_in_decls
[m
->complex_long_double_built_in
];
702 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
704 /* Quad-precision function calls are constructed when first
705 needed by builtin_decl_for_precision(), except for those
706 that will be used directly (define by OTHER_BUILTIN). */
707 m
->real16_decl
= quad_decls
[m
->double_built_in
];
709 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
711 /* Same thing for the complex ones. */
712 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
718 /* Create a fndecl for a simple intrinsic library function. */
721 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
726 gfc_actual_arglist
*actual
;
729 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
732 if (ts
->type
== BT_REAL
)
737 pdecl
= &m
->real4_decl
;
740 pdecl
= &m
->real8_decl
;
743 pdecl
= &m
->real10_decl
;
746 pdecl
= &m
->real16_decl
;
752 else if (ts
->type
== BT_COMPLEX
)
754 gcc_assert (m
->complex_available
);
759 pdecl
= &m
->complex4_decl
;
762 pdecl
= &m
->complex8_decl
;
765 pdecl
= &m
->complex10_decl
;
768 pdecl
= &m
->complex16_decl
;
782 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
783 if (gfc_real_kinds
[n
].c_float
)
784 snprintf (name
, sizeof (name
), "%s%s%s",
785 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
786 else if (gfc_real_kinds
[n
].c_double
)
787 snprintf (name
, sizeof (name
), "%s%s",
788 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
789 else if (gfc_real_kinds
[n
].c_long_double
)
790 snprintf (name
, sizeof (name
), "%s%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
792 else if (gfc_real_kinds
[n
].c_float128
)
793 snprintf (name
, sizeof (name
), "%s%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
800 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
801 ts
->type
== BT_COMPLEX
? 'c' : 'r',
805 argtypes
= NULL_TREE
;
806 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
808 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
809 argtypes
= gfc_chainon_list (argtypes
, type
);
811 argtypes
= chainon (argtypes
, void_list_node
);
812 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
813 fndecl
= build_decl (input_location
,
814 FUNCTION_DECL
, get_identifier (name
), type
);
816 /* Mark the decl as external. */
817 DECL_EXTERNAL (fndecl
) = 1;
818 TREE_PUBLIC (fndecl
) = 1;
820 /* Mark it __attribute__((const)), if possible. */
821 TREE_READONLY (fndecl
) = m
->is_constant
;
823 rest_of_decl_compilation (fndecl
, 1, 0);
830 /* Convert an intrinsic function into an external or builtin call. */
833 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
835 gfc_intrinsic_map_t
*m
;
839 unsigned int num_args
;
842 id
= expr
->value
.function
.isym
->id
;
843 /* Find the entry for this function. */
844 for (m
= gfc_intrinsic_map
;
845 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
851 if (m
->id
== GFC_ISYM_NONE
)
853 internal_error ("Intrinsic function %s(%d) not recognized",
854 expr
->value
.function
.name
, id
);
857 /* Get the decl and generate the call. */
858 num_args
= gfc_intrinsic_argument_list_length (expr
);
859 args
= XALLOCAVEC (tree
, num_args
);
861 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
862 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
863 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
865 fndecl
= build_addr (fndecl
, current_function_decl
);
866 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
870 /* If bounds-checking is enabled, create code to verify at runtime that the
871 string lengths for both expressions are the same (needed for e.g. MERGE).
872 If bounds-checking is not enabled, does nothing. */
875 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
876 tree a
, tree b
, stmtblock_t
* target
)
881 /* If bounds-checking is disabled, do nothing. */
882 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
885 /* Compare the two string lengths. */
886 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
888 /* Output the runtime-check. */
889 name
= gfc_build_cstring_const (intr_name
);
890 name
= gfc_build_addr_expr (pchar_type_node
, name
);
891 gfc_trans_runtime_check (true, false, cond
, target
, where
,
892 "Unequal character lengths (%ld/%ld) in %s",
893 fold_convert (long_integer_type_node
, a
),
894 fold_convert (long_integer_type_node
, b
), name
);
898 /* The EXPONENT(s) intrinsic function is translated into
905 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
907 tree arg
, type
, res
, tmp
, frexp
;
909 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
910 expr
->value
.function
.actual
->expr
->ts
.kind
);
912 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
914 res
= gfc_create_var (integer_type_node
, NULL
);
915 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
916 gfc_build_addr_expr (NULL_TREE
, res
));
917 gfc_add_expr_to_block (&se
->pre
, tmp
);
919 type
= gfc_typenode_for_spec (&expr
->ts
);
920 se
->expr
= fold_convert (type
, res
);
923 /* Evaluate a single upper or lower bound. */
924 /* TODO: bound intrinsic generates way too much unnecessary code. */
927 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
929 gfc_actual_arglist
*arg
;
930 gfc_actual_arglist
*arg2
;
935 tree cond
, cond1
, cond3
, cond4
, size
;
942 arg
= expr
->value
.function
.actual
;
947 /* Create an implicit second parameter from the loop variable. */
948 gcc_assert (!arg2
->expr
);
949 gcc_assert (se
->loop
->dimen
== 1);
950 gcc_assert (se
->ss
->expr
== expr
);
951 gfc_advance_se_ss_chain (se
);
952 bound
= se
->loop
->loopvar
[0];
953 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
954 gfc_array_index_type
, bound
,
959 /* use the passed argument. */
960 gcc_assert (arg
->next
->expr
);
961 gfc_init_se (&argse
, NULL
);
962 gfc_conv_expr_type (&argse
, arg
->next
->expr
, gfc_array_index_type
);
963 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
965 /* Convert from one based to zero based. */
966 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
967 gfc_array_index_type
, bound
,
971 /* TODO: don't re-evaluate the descriptor on each iteration. */
972 /* Get a descriptor for the first parameter. */
973 ss
= gfc_walk_expr (arg
->expr
);
974 gcc_assert (ss
!= gfc_ss_terminator
);
975 gfc_init_se (&argse
, NULL
);
976 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
977 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
978 gfc_add_block_to_block (&se
->post
, &argse
.post
);
982 if (INTEGER_CST_P (bound
))
986 hi
= TREE_INT_CST_HIGH (bound
);
987 low
= TREE_INT_CST_LOW (bound
);
988 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
989 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
990 "dimension index", upper
? "UBOUND" : "LBOUND",
995 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
997 bound
= gfc_evaluate_now (bound
, &se
->pre
);
998 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
999 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1000 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1001 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1003 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1004 boolean_type_node
, cond
, tmp
);
1005 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1010 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1011 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1013 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1015 /* 13.14.53: Result value for LBOUND
1017 Case (i): For an array section or for an array expression other than a
1018 whole array or array structure component, LBOUND(ARRAY, DIM)
1019 has the value 1. For a whole array or array structure
1020 component, LBOUND(ARRAY, DIM) has the value:
1021 (a) equal to the lower bound for subscript DIM of ARRAY if
1022 dimension DIM of ARRAY does not have extent zero
1023 or if ARRAY is an assumed-size array of rank DIM,
1026 13.14.113: Result value for UBOUND
1028 Case (i): For an array section or for an array expression other than a
1029 whole array or array structure component, UBOUND(ARRAY, DIM)
1030 has the value equal to the number of elements in the given
1031 dimension; otherwise, it has a value equal to the upper bound
1032 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1033 not have size zero and has value zero if dimension DIM has
1038 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1040 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1042 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1043 stride
, gfc_index_zero_node
);
1044 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1045 boolean_type_node
, cond3
, cond1
);
1046 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1047 stride
, gfc_index_zero_node
);
1052 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1053 boolean_type_node
, cond3
, cond4
);
1054 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1055 gfc_index_one_node
, lbound
);
1056 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1057 boolean_type_node
, cond4
, cond5
);
1059 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1060 boolean_type_node
, cond
, cond5
);
1062 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1063 gfc_array_index_type
, cond
,
1064 ubound
, gfc_index_zero_node
);
1068 if (as
->type
== AS_ASSUMED_SIZE
)
1069 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1070 bound
, build_int_cst (TREE_TYPE (bound
),
1071 arg
->expr
->rank
- 1));
1073 cond
= boolean_false_node
;
1075 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1076 boolean_type_node
, cond3
, cond4
);
1077 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1078 boolean_type_node
, cond
, cond1
);
1080 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1081 gfc_array_index_type
, cond
,
1082 lbound
, gfc_index_one_node
);
1089 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1090 gfc_array_index_type
, ubound
, lbound
);
1091 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1092 gfc_array_index_type
, size
,
1093 gfc_index_one_node
);
1094 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1095 gfc_array_index_type
, se
->expr
,
1096 gfc_index_zero_node
);
1099 se
->expr
= gfc_index_one_node
;
1102 type
= gfc_typenode_for_spec (&expr
->ts
);
1103 se
->expr
= convert (type
, se
->expr
);
1108 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1112 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1114 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1118 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1123 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1124 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1133 /* Create a complex value from one or two real components. */
1136 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1142 unsigned int num_args
;
1144 num_args
= gfc_intrinsic_argument_list_length (expr
);
1145 args
= XALLOCAVEC (tree
, num_args
);
1147 type
= gfc_typenode_for_spec (&expr
->ts
);
1148 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1149 real
= convert (TREE_TYPE (type
), args
[0]);
1151 imag
= convert (TREE_TYPE (type
), args
[1]);
1152 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1154 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1155 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1156 imag
= convert (TREE_TYPE (type
), imag
);
1159 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1161 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1164 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1165 MODULO(A, P) = A - FLOOR (A / P) * P */
1166 /* TODO: MOD(x, 0) */
1169 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1181 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1183 switch (expr
->ts
.type
)
1186 /* Integer case is easy, we've got a builtin op. */
1187 type
= TREE_TYPE (args
[0]);
1190 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
1193 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
1199 /* Check if we have a builtin fmod. */
1200 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1202 /* Use it if it exists. */
1203 if (fmod
!= NULL_TREE
)
1205 tmp
= build_addr (fmod
, current_function_decl
);
1206 se
->expr
= build_call_array_loc (input_location
,
1207 TREE_TYPE (TREE_TYPE (fmod
)),
1213 type
= TREE_TYPE (args
[0]);
1215 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1216 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1219 modulo = arg - floor (arg/arg2) * arg2, so
1220 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1222 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1223 thereby avoiding another division and retaining the accuracy
1224 of the builtin function. */
1225 if (fmod
!= NULL_TREE
&& modulo
)
1227 tree zero
= gfc_build_const (type
, integer_zero_node
);
1228 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1229 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1231 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1233 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1234 boolean_type_node
, test
, test2
);
1235 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1237 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1238 boolean_type_node
, test
, test2
);
1239 test
= gfc_evaluate_now (test
, &se
->pre
);
1240 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1241 fold_build2_loc (input_location
, PLUS_EXPR
,
1242 type
, tmp
, args
[1]), tmp
);
1246 /* If we do not have a built_in fmod, the calculation is going to
1247 have to be done longhand. */
1248 tmp
= fold_build2_loc (input_location
, RDIV_EXPR
, type
, args
[0], args
[1]);
1250 /* Test if the value is too large to handle sensibly. */
1251 gfc_set_model_kind (expr
->ts
.kind
);
1253 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1254 ikind
= expr
->ts
.kind
;
1257 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1258 ikind
= gfc_max_integer_kind
;
1260 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1261 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1262 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1265 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1266 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1267 test
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1269 test2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1270 boolean_type_node
, test
, test2
);
1272 itype
= gfc_get_int_type (ikind
);
1274 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1276 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1277 tmp
= convert (type
, tmp
);
1278 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
, tmp
,
1280 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, tmp
, args
[1]);
1281 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0],
1291 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1292 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1293 where the right shifts are logical (i.e. 0's are shifted in).
1294 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1295 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1297 DSHIFTL(I,J,BITSIZE) = J
1299 DSHIFTR(I,J,BITSIZE) = I. */
1302 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
1304 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
1305 tree args
[3], cond
, tmp
;
1308 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
1310 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
1311 type
= TREE_TYPE (args
[0]);
1312 bitsize
= TYPE_PRECISION (type
);
1313 utype
= unsigned_type_for (type
);
1314 stype
= TREE_TYPE (args
[2]);
1316 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
1317 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
1318 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
1320 /* The generic case. */
1321 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
1322 build_int_cst (stype
, bitsize
), shift
);
1323 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
1324 arg1
, dshiftl
? shift
: tmp
);
1326 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
1327 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
1328 right
= fold_convert (type
, right
);
1330 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
1332 /* Special cases. */
1333 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1334 build_int_cst (stype
, 0));
1335 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1336 dshiftl
? arg1
: arg2
, res
);
1338 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1339 build_int_cst (stype
, bitsize
));
1340 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1341 dshiftl
? arg2
: arg1
, res
);
1347 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1350 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1358 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1359 type
= TREE_TYPE (args
[0]);
1361 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
1362 val
= gfc_evaluate_now (val
, &se
->pre
);
1364 zero
= gfc_build_const (type
, integer_zero_node
);
1365 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
1366 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
1370 /* SIGN(A, B) is absolute value of A times sign of B.
1371 The real value versions use library functions to ensure the correct
1372 handling of negative zero. Integer case implemented as:
1373 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1377 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1383 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1384 if (expr
->ts
.type
== BT_REAL
)
1388 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1389 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1391 /* We explicitly have to ignore the minus sign. We do so by using
1392 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1393 if (!gfc_option
.flag_sign_zero
1394 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1397 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1398 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1400 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1401 TREE_TYPE (args
[0]), cond
,
1402 build_call_expr_loc (input_location
, abs
, 1,
1404 build_call_expr_loc (input_location
, tmp
, 2,
1408 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1413 /* Having excluded floating point types, we know we are now dealing
1414 with signed integer types. */
1415 type
= TREE_TYPE (args
[0]);
1417 /* Args[0] is used multiple times below. */
1418 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1420 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1421 the signs of A and B are the same, and of all ones if they differ. */
1422 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1423 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
1424 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1425 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1427 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1428 is all ones (i.e. -1). */
1429 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
1430 fold_build2_loc (input_location
, PLUS_EXPR
,
1431 type
, args
[0], tmp
), tmp
);
1435 /* Test for the presence of an optional argument. */
1438 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1442 arg
= expr
->value
.function
.actual
->expr
;
1443 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1444 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1445 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
1449 /* Calculate the double precision product of two single precision values. */
1452 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1457 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1459 /* Convert the args to double precision before multiplying. */
1460 type
= gfc_typenode_for_spec (&expr
->ts
);
1461 args
[0] = convert (type
, args
[0]);
1462 args
[1] = convert (type
, args
[1]);
1463 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
1468 /* Return a length one character string containing an ascii character. */
1471 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1476 unsigned int num_args
;
1478 num_args
= gfc_intrinsic_argument_list_length (expr
);
1479 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
1481 type
= gfc_get_char_type (expr
->ts
.kind
);
1482 var
= gfc_create_var (type
, "char");
1484 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
1485 gfc_add_modify (&se
->pre
, var
, arg
[0]);
1486 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1487 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
1492 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1500 unsigned int num_args
;
1502 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1503 args
= XALLOCAVEC (tree
, num_args
);
1505 var
= gfc_create_var (pchar_type_node
, "pstr");
1506 len
= gfc_create_var (gfc_get_int_type (8), "len");
1508 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1509 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1510 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1512 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
1513 tmp
= build_call_array_loc (input_location
,
1514 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
1515 fndecl
, num_args
, args
);
1516 gfc_add_expr_to_block (&se
->pre
, tmp
);
1518 /* Free the temporary afterwards, if necessary. */
1519 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1520 len
, build_int_cst (TREE_TYPE (len
), 0));
1521 tmp
= gfc_call_free (var
);
1522 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1523 gfc_add_expr_to_block (&se
->post
, tmp
);
1526 se
->string_length
= len
;
1531 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1539 unsigned int num_args
;
1541 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1542 args
= XALLOCAVEC (tree
, num_args
);
1544 var
= gfc_create_var (pchar_type_node
, "pstr");
1545 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1547 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1548 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1549 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1551 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
1552 tmp
= build_call_array_loc (input_location
,
1553 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
1554 fndecl
, num_args
, args
);
1555 gfc_add_expr_to_block (&se
->pre
, tmp
);
1557 /* Free the temporary afterwards, if necessary. */
1558 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1559 len
, build_int_cst (TREE_TYPE (len
), 0));
1560 tmp
= gfc_call_free (var
);
1561 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1562 gfc_add_expr_to_block (&se
->post
, tmp
);
1565 se
->string_length
= len
;
1569 /* Return a character string containing the tty name. */
1572 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1580 unsigned int num_args
;
1582 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1583 args
= XALLOCAVEC (tree
, num_args
);
1585 var
= gfc_create_var (pchar_type_node
, "pstr");
1586 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1588 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1589 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1590 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1592 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
1593 tmp
= build_call_array_loc (input_location
,
1594 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
1595 fndecl
, num_args
, args
);
1596 gfc_add_expr_to_block (&se
->pre
, tmp
);
1598 /* Free the temporary afterwards, if necessary. */
1599 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1600 len
, build_int_cst (TREE_TYPE (len
), 0));
1601 tmp
= gfc_call_free (var
);
1602 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1603 gfc_add_expr_to_block (&se
->post
, tmp
);
1606 se
->string_length
= len
;
1610 /* Get the minimum/maximum value of all the parameters.
1611 minmax (a1, a2, a3, ...)
1614 if (a2 .op. mvar || isnan(mvar))
1616 if (a3 .op. mvar || isnan(mvar))
1623 /* TODO: Mismatching types can occur when specific names are used.
1624 These should be handled during resolution. */
1626 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1634 gfc_actual_arglist
*argexpr
;
1635 unsigned int i
, nargs
;
1637 nargs
= gfc_intrinsic_argument_list_length (expr
);
1638 args
= XALLOCAVEC (tree
, nargs
);
1640 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
1641 type
= gfc_typenode_for_spec (&expr
->ts
);
1643 argexpr
= expr
->value
.function
.actual
;
1644 if (TREE_TYPE (args
[0]) != type
)
1645 args
[0] = convert (type
, args
[0]);
1646 /* Only evaluate the argument once. */
1647 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
1648 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1650 mvar
= gfc_create_var (type
, "M");
1651 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
1652 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
1658 /* Handle absent optional arguments by ignoring the comparison. */
1659 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
1660 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
1661 && TREE_CODE (val
) == INDIRECT_REF
)
1662 cond
= fold_build2_loc (input_location
,
1663 NE_EXPR
, boolean_type_node
,
1664 TREE_OPERAND (val
, 0),
1665 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
1670 /* Only evaluate the argument once. */
1671 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1672 val
= gfc_evaluate_now (val
, &se
->pre
);
1675 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1677 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
1678 convert (type
, val
), mvar
);
1680 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1681 __builtin_isnan might be made dependent on that module being loaded,
1682 to help performance of programs that don't rely on IEEE semantics. */
1683 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
1685 isnan
= build_call_expr_loc (input_location
,
1686 built_in_decls
[BUILT_IN_ISNAN
], 1, mvar
);
1687 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1688 boolean_type_node
, tmp
,
1689 fold_convert (boolean_type_node
, isnan
));
1691 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
1692 build_empty_stmt (input_location
));
1694 if (cond
!= NULL_TREE
)
1695 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1696 build_empty_stmt (input_location
));
1698 gfc_add_expr_to_block (&se
->pre
, tmp
);
1699 argexpr
= argexpr
->next
;
1705 /* Generate library calls for MIN and MAX intrinsics for character
1708 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
1711 tree var
, len
, fndecl
, tmp
, cond
, function
;
1714 nargs
= gfc_intrinsic_argument_list_length (expr
);
1715 args
= XALLOCAVEC (tree
, nargs
+ 4);
1716 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
1718 /* Create the result variables. */
1719 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1720 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
1721 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
1722 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
1723 args
[2] = build_int_cst (NULL_TREE
, op
);
1724 args
[3] = build_int_cst (NULL_TREE
, nargs
/ 2);
1726 if (expr
->ts
.kind
== 1)
1727 function
= gfor_fndecl_string_minmax
;
1728 else if (expr
->ts
.kind
== 4)
1729 function
= gfor_fndecl_string_minmax_char4
;
1733 /* Make the function call. */
1734 fndecl
= build_addr (function
, current_function_decl
);
1735 tmp
= build_call_array_loc (input_location
,
1736 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
1738 gfc_add_expr_to_block (&se
->pre
, tmp
);
1740 /* Free the temporary afterwards, if necessary. */
1741 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1742 len
, build_int_cst (TREE_TYPE (len
), 0));
1743 tmp
= gfc_call_free (var
);
1744 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1745 gfc_add_expr_to_block (&se
->post
, tmp
);
1748 se
->string_length
= len
;
1752 /* Create a symbol node for this intrinsic. The symbol from the frontend
1753 has the generic name. */
1756 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1760 /* TODO: Add symbols for intrinsic function to the global namespace. */
1761 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1762 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1765 sym
->attr
.external
= 1;
1766 sym
->attr
.function
= 1;
1767 sym
->attr
.always_explicit
= 1;
1768 sym
->attr
.proc
= PROC_INTRINSIC
;
1769 sym
->attr
.flavor
= FL_PROCEDURE
;
1773 sym
->attr
.dimension
= 1;
1774 sym
->as
= gfc_get_array_spec ();
1775 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1776 sym
->as
->rank
= expr
->rank
;
1779 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
1784 /* Generate a call to an external intrinsic function. */
1786 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1789 VEC(tree
,gc
) *append_args
;
1791 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1794 gcc_assert (expr
->rank
> 0);
1796 gcc_assert (expr
->rank
== 0);
1798 sym
= gfc_get_symbol_for_expr (expr
);
1800 /* Calls to libgfortran_matmul need to be appended special arguments,
1801 to be able to call the BLAS ?gemm functions if required and possible. */
1803 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
1804 && sym
->ts
.type
!= BT_LOGICAL
)
1806 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
1808 if (gfc_option
.flag_external_blas
1809 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
1810 && (sym
->ts
.kind
== gfc_default_real_kind
1811 || sym
->ts
.kind
== gfc_default_double_kind
))
1815 if (sym
->ts
.type
== BT_REAL
)
1817 if (sym
->ts
.kind
== gfc_default_real_kind
)
1818 gemm_fndecl
= gfor_fndecl_sgemm
;
1820 gemm_fndecl
= gfor_fndecl_dgemm
;
1824 if (sym
->ts
.kind
== gfc_default_real_kind
)
1825 gemm_fndecl
= gfor_fndecl_cgemm
;
1827 gemm_fndecl
= gfor_fndecl_zgemm
;
1830 append_args
= VEC_alloc (tree
, gc
, 3);
1831 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 1));
1832 VEC_quick_push (tree
, append_args
,
1833 build_int_cst (cint
, gfc_option
.blas_matmul_limit
));
1834 VEC_quick_push (tree
, append_args
,
1835 gfc_build_addr_expr (NULL_TREE
, gemm_fndecl
));
1839 append_args
= VEC_alloc (tree
, gc
, 3);
1840 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
1841 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
1842 VEC_quick_push (tree
, append_args
, null_pointer_node
);
1846 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
1851 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1871 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1880 gfc_actual_arglist
*actual
;
1887 gfc_conv_intrinsic_funcall (se
, expr
);
1891 actual
= expr
->value
.function
.actual
;
1892 type
= gfc_typenode_for_spec (&expr
->ts
);
1893 /* Initialize the result. */
1894 resvar
= gfc_create_var (type
, "test");
1896 tmp
= convert (type
, boolean_true_node
);
1898 tmp
= convert (type
, boolean_false_node
);
1899 gfc_add_modify (&se
->pre
, resvar
, tmp
);
1901 /* Walk the arguments. */
1902 arrayss
= gfc_walk_expr (actual
->expr
);
1903 gcc_assert (arrayss
!= gfc_ss_terminator
);
1905 /* Initialize the scalarizer. */
1906 gfc_init_loopinfo (&loop
);
1907 exit_label
= gfc_build_label_decl (NULL_TREE
);
1908 TREE_USED (exit_label
) = 1;
1909 gfc_add_ss_to_loop (&loop
, arrayss
);
1911 /* Initialize the loop. */
1912 gfc_conv_ss_startstride (&loop
);
1913 gfc_conv_loop_setup (&loop
, &expr
->where
);
1915 gfc_mark_ss_chain_used (arrayss
, 1);
1916 /* Generate the loop body. */
1917 gfc_start_scalarized_body (&loop
, &body
);
1919 /* If the condition matches then set the return value. */
1920 gfc_start_block (&block
);
1922 tmp
= convert (type
, boolean_false_node
);
1924 tmp
= convert (type
, boolean_true_node
);
1925 gfc_add_modify (&block
, resvar
, tmp
);
1927 /* And break out of the loop. */
1928 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1929 gfc_add_expr_to_block (&block
, tmp
);
1931 found
= gfc_finish_block (&block
);
1933 /* Check this element. */
1934 gfc_init_se (&arrayse
, NULL
);
1935 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
1936 arrayse
.ss
= arrayss
;
1937 gfc_conv_expr_val (&arrayse
, actual
->expr
);
1939 gfc_add_block_to_block (&body
, &arrayse
.pre
);
1940 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
1941 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
1942 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
1943 gfc_add_expr_to_block (&body
, tmp
);
1944 gfc_add_block_to_block (&body
, &arrayse
.post
);
1946 gfc_trans_scalarizing_loops (&loop
, &body
);
1948 /* Add the exit label. */
1949 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1950 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1952 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
1953 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
1954 gfc_cleanup_loop (&loop
);
1959 /* COUNT(A) = Number of true elements in A. */
1961 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
1968 gfc_actual_arglist
*actual
;
1974 gfc_conv_intrinsic_funcall (se
, expr
);
1978 actual
= expr
->value
.function
.actual
;
1980 type
= gfc_typenode_for_spec (&expr
->ts
);
1981 /* Initialize the result. */
1982 resvar
= gfc_create_var (type
, "count");
1983 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
1985 /* Walk the arguments. */
1986 arrayss
= gfc_walk_expr (actual
->expr
);
1987 gcc_assert (arrayss
!= gfc_ss_terminator
);
1989 /* Initialize the scalarizer. */
1990 gfc_init_loopinfo (&loop
);
1991 gfc_add_ss_to_loop (&loop
, arrayss
);
1993 /* Initialize the loop. */
1994 gfc_conv_ss_startstride (&loop
);
1995 gfc_conv_loop_setup (&loop
, &expr
->where
);
1997 gfc_mark_ss_chain_used (arrayss
, 1);
1998 /* Generate the loop body. */
1999 gfc_start_scalarized_body (&loop
, &body
);
2001 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2002 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2003 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2005 gfc_init_se (&arrayse
, NULL
);
2006 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2007 arrayse
.ss
= arrayss
;
2008 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2009 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2010 build_empty_stmt (input_location
));
2012 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2013 gfc_add_expr_to_block (&body
, tmp
);
2014 gfc_add_block_to_block (&body
, &arrayse
.post
);
2016 gfc_trans_scalarizing_loops (&loop
, &body
);
2018 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2019 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2020 gfc_cleanup_loop (&loop
);
2025 /* Inline implementation of the sum and product intrinsics. */
2027 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2031 tree scale
= NULL_TREE
;
2037 gfc_actual_arglist
*actual
;
2042 gfc_expr
*arrayexpr
;
2047 gfc_conv_intrinsic_funcall (se
, expr
);
2051 type
= gfc_typenode_for_spec (&expr
->ts
);
2052 /* Initialize the result. */
2053 resvar
= gfc_create_var (type
, "val");
2058 scale
= gfc_create_var (type
, "scale");
2059 gfc_add_modify (&se
->pre
, scale
,
2060 gfc_build_const (type
, integer_one_node
));
2061 tmp
= gfc_build_const (type
, integer_zero_node
);
2063 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2064 tmp
= gfc_build_const (type
, integer_zero_node
);
2065 else if (op
== NE_EXPR
)
2067 tmp
= convert (type
, boolean_false_node
);
2068 else if (op
== BIT_AND_EXPR
)
2069 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2070 type
, integer_one_node
));
2072 tmp
= gfc_build_const (type
, integer_one_node
);
2074 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2076 /* Walk the arguments. */
2077 actual
= expr
->value
.function
.actual
;
2078 arrayexpr
= actual
->expr
;
2079 arrayss
= gfc_walk_expr (arrayexpr
);
2080 gcc_assert (arrayss
!= gfc_ss_terminator
);
2082 if (op
== NE_EXPR
|| norm2
)
2083 /* PARITY and NORM2. */
2087 actual
= actual
->next
->next
;
2088 gcc_assert (actual
);
2089 maskexpr
= actual
->expr
;
2092 if (maskexpr
&& maskexpr
->rank
!= 0)
2094 maskss
= gfc_walk_expr (maskexpr
);
2095 gcc_assert (maskss
!= gfc_ss_terminator
);
2100 /* Initialize the scalarizer. */
2101 gfc_init_loopinfo (&loop
);
2102 gfc_add_ss_to_loop (&loop
, arrayss
);
2104 gfc_add_ss_to_loop (&loop
, maskss
);
2106 /* Initialize the loop. */
2107 gfc_conv_ss_startstride (&loop
);
2108 gfc_conv_loop_setup (&loop
, &expr
->where
);
2110 gfc_mark_ss_chain_used (arrayss
, 1);
2112 gfc_mark_ss_chain_used (maskss
, 1);
2113 /* Generate the loop body. */
2114 gfc_start_scalarized_body (&loop
, &body
);
2116 /* If we have a mask, only add this element if the mask is set. */
2119 gfc_init_se (&maskse
, NULL
);
2120 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2122 gfc_conv_expr_val (&maskse
, maskexpr
);
2123 gfc_add_block_to_block (&body
, &maskse
.pre
);
2125 gfc_start_block (&block
);
2128 gfc_init_block (&block
);
2130 /* Do the actual summation/product. */
2131 gfc_init_se (&arrayse
, NULL
);
2132 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2133 arrayse
.ss
= arrayss
;
2134 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2135 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2145 result = 1.0 + result * val * val;
2151 result += val * val;
2154 tree res1
, res2
, cond
, absX
, val
;
2155 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
2157 gfc_init_block (&ifblock1
);
2159 absX
= gfc_create_var (type
, "absX");
2160 gfc_add_modify (&ifblock1
, absX
,
2161 fold_build1_loc (input_location
, ABS_EXPR
, type
,
2163 val
= gfc_create_var (type
, "val");
2164 gfc_add_expr_to_block (&ifblock1
, val
);
2166 gfc_init_block (&ifblock2
);
2167 gfc_add_modify (&ifblock2
, val
,
2168 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
2170 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2171 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
2172 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
2173 gfc_build_const (type
, integer_one_node
));
2174 gfc_add_modify (&ifblock2
, resvar
, res1
);
2175 gfc_add_modify (&ifblock2
, scale
, absX
);
2176 res1
= gfc_finish_block (&ifblock2
);
2178 gfc_init_block (&ifblock3
);
2179 gfc_add_modify (&ifblock3
, val
,
2180 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
2182 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2183 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
2184 gfc_add_modify (&ifblock3
, resvar
, res2
);
2185 res2
= gfc_finish_block (&ifblock3
);
2187 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2189 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
2190 gfc_add_expr_to_block (&ifblock1
, tmp
);
2191 tmp
= gfc_finish_block (&ifblock1
);
2193 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2195 gfc_build_const (type
, integer_zero_node
));
2197 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2198 gfc_add_expr_to_block (&block
, tmp
);
2202 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
2203 gfc_add_modify (&block
, resvar
, tmp
);
2206 gfc_add_block_to_block (&block
, &arrayse
.post
);
2210 /* We enclose the above in if (mask) {...} . */
2212 tmp
= gfc_finish_block (&block
);
2213 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2214 build_empty_stmt (input_location
));
2217 tmp
= gfc_finish_block (&block
);
2218 gfc_add_expr_to_block (&body
, tmp
);
2220 gfc_trans_scalarizing_loops (&loop
, &body
);
2222 /* For a scalar mask, enclose the loop in an if statement. */
2223 if (maskexpr
&& maskss
== NULL
)
2225 gfc_init_se (&maskse
, NULL
);
2226 gfc_conv_expr_val (&maskse
, maskexpr
);
2227 gfc_init_block (&block
);
2228 gfc_add_block_to_block (&block
, &loop
.pre
);
2229 gfc_add_block_to_block (&block
, &loop
.post
);
2230 tmp
= gfc_finish_block (&block
);
2232 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2233 build_empty_stmt (input_location
));
2234 gfc_add_expr_to_block (&block
, tmp
);
2235 gfc_add_block_to_block (&se
->pre
, &block
);
2239 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2240 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2243 gfc_cleanup_loop (&loop
);
2247 /* result = scale * sqrt(result). */
2249 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
2250 resvar
= build_call_expr_loc (input_location
,
2252 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
2259 /* Inline implementation of the dot_product intrinsic. This function
2260 is based on gfc_conv_intrinsic_arith (the previous function). */
2262 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2270 gfc_actual_arglist
*actual
;
2271 gfc_ss
*arrayss1
, *arrayss2
;
2272 gfc_se arrayse1
, arrayse2
;
2273 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2275 type
= gfc_typenode_for_spec (&expr
->ts
);
2277 /* Initialize the result. */
2278 resvar
= gfc_create_var (type
, "val");
2279 if (expr
->ts
.type
== BT_LOGICAL
)
2280 tmp
= build_int_cst (type
, 0);
2282 tmp
= gfc_build_const (type
, integer_zero_node
);
2284 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2286 /* Walk argument #1. */
2287 actual
= expr
->value
.function
.actual
;
2288 arrayexpr1
= actual
->expr
;
2289 arrayss1
= gfc_walk_expr (arrayexpr1
);
2290 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2292 /* Walk argument #2. */
2293 actual
= actual
->next
;
2294 arrayexpr2
= actual
->expr
;
2295 arrayss2
= gfc_walk_expr (arrayexpr2
);
2296 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2298 /* Initialize the scalarizer. */
2299 gfc_init_loopinfo (&loop
);
2300 gfc_add_ss_to_loop (&loop
, arrayss1
);
2301 gfc_add_ss_to_loop (&loop
, arrayss2
);
2303 /* Initialize the loop. */
2304 gfc_conv_ss_startstride (&loop
);
2305 gfc_conv_loop_setup (&loop
, &expr
->where
);
2307 gfc_mark_ss_chain_used (arrayss1
, 1);
2308 gfc_mark_ss_chain_used (arrayss2
, 1);
2310 /* Generate the loop body. */
2311 gfc_start_scalarized_body (&loop
, &body
);
2312 gfc_init_block (&block
);
2314 /* Make the tree expression for [conjg(]array1[)]. */
2315 gfc_init_se (&arrayse1
, NULL
);
2316 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2317 arrayse1
.ss
= arrayss1
;
2318 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2319 if (expr
->ts
.type
== BT_COMPLEX
)
2320 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
2322 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2324 /* Make the tree expression for array2. */
2325 gfc_init_se (&arrayse2
, NULL
);
2326 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2327 arrayse2
.ss
= arrayss2
;
2328 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2329 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2331 /* Do the actual product and sum. */
2332 if (expr
->ts
.type
== BT_LOGICAL
)
2334 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
2335 arrayse1
.expr
, arrayse2
.expr
);
2336 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2340 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
2342 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
2344 gfc_add_modify (&block
, resvar
, tmp
);
2346 /* Finish up the loop block and the loop. */
2347 tmp
= gfc_finish_block (&block
);
2348 gfc_add_expr_to_block (&body
, tmp
);
2350 gfc_trans_scalarizing_loops (&loop
, &body
);
2351 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2352 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2353 gfc_cleanup_loop (&loop
);
2359 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2360 we need to handle. For performance reasons we sometimes create two
2361 loops instead of one, where the second one is much simpler.
2362 Examples for minloc intrinsic:
2363 1) Result is an array, a call is generated
2364 2) Array mask is used and NaNs need to be supported:
2370 if (pos == 0) pos = S + (1 - from);
2371 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2378 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2382 3) NaNs need to be supported, but it is known at compile time or cheaply
2383 at runtime whether array is nonempty or not:
2388 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2391 if (from <= to) pos = 1;
2395 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2399 4) NaNs aren't supported, array mask is used:
2400 limit = infinities_supported ? Infinity : huge (limit);
2404 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2410 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2414 5) Same without array mask:
2415 limit = infinities_supported ? Infinity : huge (limit);
2416 pos = (from <= to) ? 1 : 0;
2419 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2422 For 3) and 5), if mask is scalar, this all goes into a conditional,
2423 setting pos = 0; in the else branch. */
2426 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2430 stmtblock_t ifblock
;
2431 stmtblock_t elseblock
;
2442 gfc_actual_arglist
*actual
;
2447 gfc_expr
*arrayexpr
;
2454 gfc_conv_intrinsic_funcall (se
, expr
);
2458 /* Initialize the result. */
2459 pos
= gfc_create_var (gfc_array_index_type
, "pos");
2460 offset
= gfc_create_var (gfc_array_index_type
, "offset");
2461 type
= gfc_typenode_for_spec (&expr
->ts
);
2463 /* Walk the arguments. */
2464 actual
= expr
->value
.function
.actual
;
2465 arrayexpr
= actual
->expr
;
2466 arrayss
= gfc_walk_expr (arrayexpr
);
2467 gcc_assert (arrayss
!= gfc_ss_terminator
);
2469 actual
= actual
->next
->next
;
2470 gcc_assert (actual
);
2471 maskexpr
= actual
->expr
;
2473 if (maskexpr
&& maskexpr
->rank
!= 0)
2475 maskss
= gfc_walk_expr (maskexpr
);
2476 gcc_assert (maskss
!= gfc_ss_terminator
);
2481 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
2483 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
2485 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
2486 boolean_type_node
, nonempty
,
2487 gfc_index_zero_node
);
2492 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
2493 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
2494 switch (arrayexpr
->ts
.type
)
2497 if (HONOR_INFINITIES (DECL_MODE (limit
)))
2499 REAL_VALUE_TYPE real
;
2501 tmp
= build_real (TREE_TYPE (limit
), real
);
2504 tmp
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
2505 arrayexpr
->ts
.kind
, 0);
2509 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
2510 arrayexpr
->ts
.kind
);
2517 /* We start with the most negative possible value for MAXLOC, and the most
2518 positive possible value for MINLOC. The most negative possible value is
2519 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2520 possible value is HUGE in both cases. */
2522 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2523 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2524 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2525 build_int_cst (type
, 1));
2527 gfc_add_modify (&se
->pre
, limit
, tmp
);
2529 /* Initialize the scalarizer. */
2530 gfc_init_loopinfo (&loop
);
2531 gfc_add_ss_to_loop (&loop
, arrayss
);
2533 gfc_add_ss_to_loop (&loop
, maskss
);
2535 /* Initialize the loop. */
2536 gfc_conv_ss_startstride (&loop
);
2537 gfc_conv_loop_setup (&loop
, &expr
->where
);
2539 gcc_assert (loop
.dimen
== 1);
2540 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
2541 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
2542 loop
.from
[0], loop
.to
[0]);
2546 /* Initialize the position to zero, following Fortran 2003. We are free
2547 to do this because Fortran 95 allows the result of an entirely false
2548 mask to be processor dependent. If we know at compile time the array
2549 is non-empty and no MASK is used, we can initialize to 1 to simplify
2551 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
2552 gfc_add_modify (&loop
.pre
, pos
,
2553 fold_build3_loc (input_location
, COND_EXPR
,
2554 gfc_array_index_type
,
2555 nonempty
, gfc_index_one_node
,
2556 gfc_index_zero_node
));
2559 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
2560 lab1
= gfc_build_label_decl (NULL_TREE
);
2561 TREE_USED (lab1
) = 1;
2562 lab2
= gfc_build_label_decl (NULL_TREE
);
2563 TREE_USED (lab2
) = 1;
2566 gfc_mark_ss_chain_used (arrayss
, 1);
2568 gfc_mark_ss_chain_used (maskss
, 1);
2569 /* Generate the loop body. */
2570 gfc_start_scalarized_body (&loop
, &body
);
2572 /* If we have a mask, only check this element if the mask is set. */
2575 gfc_init_se (&maskse
, NULL
);
2576 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2578 gfc_conv_expr_val (&maskse
, maskexpr
);
2579 gfc_add_block_to_block (&body
, &maskse
.pre
);
2581 gfc_start_block (&block
);
2584 gfc_init_block (&block
);
2586 /* Compare with the current limit. */
2587 gfc_init_se (&arrayse
, NULL
);
2588 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2589 arrayse
.ss
= arrayss
;
2590 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2591 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2593 /* We do the following if this is a more extreme value. */
2594 gfc_start_block (&ifblock
);
2596 /* Assign the value to the limit... */
2597 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2599 /* Remember where we are. An offset must be added to the loop
2600 counter to obtain the required position. */
2602 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2603 gfc_index_one_node
, loop
.from
[0]);
2605 tmp
= gfc_index_one_node
;
2607 gfc_add_modify (&block
, offset
, tmp
);
2609 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
2611 stmtblock_t ifblock2
;
2614 gfc_start_block (&ifblock2
);
2615 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
2616 loop
.loopvar
[0], offset
);
2617 gfc_add_modify (&ifblock2
, pos
, tmp
);
2618 ifbody2
= gfc_finish_block (&ifblock2
);
2619 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
2620 gfc_index_zero_node
);
2621 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
2622 build_empty_stmt (input_location
));
2623 gfc_add_expr_to_block (&block
, tmp
);
2626 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
2627 loop
.loopvar
[0], offset
);
2628 gfc_add_modify (&ifblock
, pos
, tmp
);
2631 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
2633 ifbody
= gfc_finish_block (&ifblock
);
2635 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
2638 cond
= fold_build2_loc (input_location
,
2639 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
2640 boolean_type_node
, arrayse
.expr
, limit
);
2642 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2643 arrayse
.expr
, limit
);
2645 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
2646 build_empty_stmt (input_location
));
2648 gfc_add_expr_to_block (&block
, ifbody
);
2652 /* We enclose the above in if (mask) {...}. */
2653 tmp
= gfc_finish_block (&block
);
2655 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2656 build_empty_stmt (input_location
));
2659 tmp
= gfc_finish_block (&block
);
2660 gfc_add_expr_to_block (&body
, tmp
);
2664 gfc_trans_scalarized_loop_end (&loop
, 0, &body
);
2666 if (HONOR_NANS (DECL_MODE (limit
)))
2668 if (nonempty
!= NULL
)
2670 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
2671 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
2672 build_empty_stmt (input_location
));
2673 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
2677 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
2678 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
2679 gfc_start_block (&body
);
2681 /* If we have a mask, only check this element if the mask is set. */
2684 gfc_init_se (&maskse
, NULL
);
2685 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2687 gfc_conv_expr_val (&maskse
, maskexpr
);
2688 gfc_add_block_to_block (&body
, &maskse
.pre
);
2690 gfc_start_block (&block
);
2693 gfc_init_block (&block
);
2695 /* Compare with the current limit. */
2696 gfc_init_se (&arrayse
, NULL
);
2697 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2698 arrayse
.ss
= arrayss
;
2699 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2700 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2702 /* We do the following if this is a more extreme value. */
2703 gfc_start_block (&ifblock
);
2705 /* Assign the value to the limit... */
2706 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2708 /* Remember where we are. An offset must be added to the loop
2709 counter to obtain the required position. */
2711 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2712 gfc_index_one_node
, loop
.from
[0]);
2714 tmp
= gfc_index_one_node
;
2716 gfc_add_modify (&block
, offset
, tmp
);
2718 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
2719 loop
.loopvar
[0], offset
);
2720 gfc_add_modify (&ifblock
, pos
, tmp
);
2722 ifbody
= gfc_finish_block (&ifblock
);
2724 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2725 arrayse
.expr
, limit
);
2727 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
2728 build_empty_stmt (input_location
));
2729 gfc_add_expr_to_block (&block
, tmp
);
2733 /* We enclose the above in if (mask) {...}. */
2734 tmp
= gfc_finish_block (&block
);
2736 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2737 build_empty_stmt (input_location
));
2740 tmp
= gfc_finish_block (&block
);
2741 gfc_add_expr_to_block (&body
, tmp
);
2742 /* Avoid initializing loopvar[0] again, it should be left where
2743 it finished by the first loop. */
2744 loop
.from
[0] = loop
.loopvar
[0];
2747 gfc_trans_scalarizing_loops (&loop
, &body
);
2750 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
2752 /* For a scalar mask, enclose the loop in an if statement. */
2753 if (maskexpr
&& maskss
== NULL
)
2755 gfc_init_se (&maskse
, NULL
);
2756 gfc_conv_expr_val (&maskse
, maskexpr
);
2757 gfc_init_block (&block
);
2758 gfc_add_block_to_block (&block
, &loop
.pre
);
2759 gfc_add_block_to_block (&block
, &loop
.post
);
2760 tmp
= gfc_finish_block (&block
);
2762 /* For the else part of the scalar mask, just initialize
2763 the pos variable the same way as above. */
2765 gfc_init_block (&elseblock
);
2766 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
2767 elsetmp
= gfc_finish_block (&elseblock
);
2769 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
2770 gfc_add_expr_to_block (&block
, tmp
);
2771 gfc_add_block_to_block (&se
->pre
, &block
);
2775 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2776 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2778 gfc_cleanup_loop (&loop
);
2780 se
->expr
= convert (type
, pos
);
2783 /* Emit code for minval or maxval intrinsic. There are many different cases
2784 we need to handle. For performance reasons we sometimes create two
2785 loops instead of one, where the second one is much simpler.
2786 Examples for minval intrinsic:
2787 1) Result is an array, a call is generated
2788 2) Array mask is used and NaNs need to be supported, rank 1:
2793 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2796 limit = nonempty ? NaN : huge (limit);
2798 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2799 3) NaNs need to be supported, but it is known at compile time or cheaply
2800 at runtime whether array is nonempty or not, rank 1:
2803 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2804 limit = (from <= to) ? NaN : huge (limit);
2806 while (S <= to) { limit = min (a[S], limit); S++; }
2807 4) Array mask is used and NaNs need to be supported, rank > 1:
2816 if (fast) limit = min (a[S1][S2], limit);
2819 if (a[S1][S2] <= limit) {
2830 limit = nonempty ? NaN : huge (limit);
2831 5) NaNs need to be supported, but it is known at compile time or cheaply
2832 at runtime whether array is nonempty or not, rank > 1:
2839 if (fast) limit = min (a[S1][S2], limit);
2841 if (a[S1][S2] <= limit) {
2851 limit = (nonempty_array) ? NaN : huge (limit);
2852 6) NaNs aren't supported, but infinities are. Array mask is used:
2857 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2860 limit = nonempty ? limit : huge (limit);
2861 7) Same without array mask:
2864 while (S <= to) { limit = min (a[S], limit); S++; }
2865 limit = (from <= to) ? limit : huge (limit);
2866 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2867 limit = huge (limit);
2869 while (S <= to) { limit = min (a[S], limit); S++); }
2871 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2872 with array mask instead).
2873 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2874 setting limit = huge (limit); in the else branch. */
2877 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2887 tree huge_cst
= NULL
, nan_cst
= NULL
;
2889 stmtblock_t block
, block2
;
2891 gfc_actual_arglist
*actual
;
2896 gfc_expr
*arrayexpr
;
2902 gfc_conv_intrinsic_funcall (se
, expr
);
2906 type
= gfc_typenode_for_spec (&expr
->ts
);
2907 /* Initialize the result. */
2908 limit
= gfc_create_var (type
, "limit");
2909 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
2910 switch (expr
->ts
.type
)
2913 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
2915 if (HONOR_INFINITIES (DECL_MODE (limit
)))
2917 REAL_VALUE_TYPE real
;
2919 tmp
= build_real (type
, real
);
2923 if (HONOR_NANS (DECL_MODE (limit
)))
2925 REAL_VALUE_TYPE real
;
2926 real_nan (&real
, "", 1, DECL_MODE (limit
));
2927 nan_cst
= build_real (type
, real
);
2932 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
2939 /* We start with the most negative possible value for MAXVAL, and the most
2940 positive possible value for MINVAL. The most negative possible value is
2941 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2942 possible value is HUGE in both cases. */
2945 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2947 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
2948 TREE_TYPE (huge_cst
), huge_cst
);
2951 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2952 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
2953 tmp
, build_int_cst (type
, 1));
2955 gfc_add_modify (&se
->pre
, limit
, tmp
);
2957 /* Walk the arguments. */
2958 actual
= expr
->value
.function
.actual
;
2959 arrayexpr
= actual
->expr
;
2960 arrayss
= gfc_walk_expr (arrayexpr
);
2961 gcc_assert (arrayss
!= gfc_ss_terminator
);
2963 actual
= actual
->next
->next
;
2964 gcc_assert (actual
);
2965 maskexpr
= actual
->expr
;
2967 if (maskexpr
&& maskexpr
->rank
!= 0)
2969 maskss
= gfc_walk_expr (maskexpr
);
2970 gcc_assert (maskss
!= gfc_ss_terminator
);
2975 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
2977 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
2979 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
2980 boolean_type_node
, nonempty
,
2981 gfc_index_zero_node
);
2986 /* Initialize the scalarizer. */
2987 gfc_init_loopinfo (&loop
);
2988 gfc_add_ss_to_loop (&loop
, arrayss
);
2990 gfc_add_ss_to_loop (&loop
, maskss
);
2992 /* Initialize the loop. */
2993 gfc_conv_ss_startstride (&loop
);
2994 gfc_conv_loop_setup (&loop
, &expr
->where
);
2996 if (nonempty
== NULL
&& maskss
== NULL
2997 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
2998 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
2999 loop
.from
[0], loop
.to
[0]);
3000 nonempty_var
= NULL
;
3001 if (nonempty
== NULL
3002 && (HONOR_INFINITIES (DECL_MODE (limit
))
3003 || HONOR_NANS (DECL_MODE (limit
))))
3005 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3006 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3007 nonempty
= nonempty_var
;
3011 if (HONOR_NANS (DECL_MODE (limit
)))
3013 if (loop
.dimen
== 1)
3015 lab
= gfc_build_label_decl (NULL_TREE
);
3016 TREE_USED (lab
) = 1;
3020 fast
= gfc_create_var (boolean_type_node
, "fast");
3021 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3025 gfc_mark_ss_chain_used (arrayss
, 1);
3027 gfc_mark_ss_chain_used (maskss
, 1);
3028 /* Generate the loop body. */
3029 gfc_start_scalarized_body (&loop
, &body
);
3031 /* If we have a mask, only add this element if the mask is set. */
3034 gfc_init_se (&maskse
, NULL
);
3035 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3037 gfc_conv_expr_val (&maskse
, maskexpr
);
3038 gfc_add_block_to_block (&body
, &maskse
.pre
);
3040 gfc_start_block (&block
);
3043 gfc_init_block (&block
);
3045 /* Compare with the current limit. */
3046 gfc_init_se (&arrayse
, NULL
);
3047 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3048 arrayse
.ss
= arrayss
;
3049 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3050 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3052 gfc_init_block (&block2
);
3055 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3057 if (HONOR_NANS (DECL_MODE (limit
)))
3059 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3060 boolean_type_node
, arrayse
.expr
, limit
);
3062 ifbody
= build1_v (GOTO_EXPR
, lab
);
3065 stmtblock_t ifblock
;
3067 gfc_init_block (&ifblock
);
3068 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3069 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3070 ifbody
= gfc_finish_block (&ifblock
);
3072 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3073 build_empty_stmt (input_location
));
3074 gfc_add_expr_to_block (&block2
, tmp
);
3078 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3080 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3082 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3083 arrayse
.expr
, limit
);
3084 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3085 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3086 build_empty_stmt (input_location
));
3087 gfc_add_expr_to_block (&block2
, tmp
);
3091 tmp
= fold_build2_loc (input_location
,
3092 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3093 type
, arrayse
.expr
, limit
);
3094 gfc_add_modify (&block2
, limit
, tmp
);
3100 tree elsebody
= gfc_finish_block (&block2
);
3102 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3104 if (HONOR_NANS (DECL_MODE (limit
))
3105 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3107 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3108 arrayse
.expr
, limit
);
3109 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3110 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3111 build_empty_stmt (input_location
));
3115 tmp
= fold_build2_loc (input_location
,
3116 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3117 type
, arrayse
.expr
, limit
);
3118 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3120 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3121 gfc_add_expr_to_block (&block
, tmp
);
3124 gfc_add_block_to_block (&block
, &block2
);
3126 gfc_add_block_to_block (&block
, &arrayse
.post
);
3128 tmp
= gfc_finish_block (&block
);
3130 /* We enclose the above in if (mask) {...}. */
3131 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3132 build_empty_stmt (input_location
));
3133 gfc_add_expr_to_block (&body
, tmp
);
3137 gfc_trans_scalarized_loop_end (&loop
, 0, &body
);
3139 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3141 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
3142 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
3144 gfc_start_block (&body
);
3146 /* If we have a mask, only add this element if the mask is set. */
3149 gfc_init_se (&maskse
, NULL
);
3150 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3152 gfc_conv_expr_val (&maskse
, maskexpr
);
3153 gfc_add_block_to_block (&body
, &maskse
.pre
);
3155 gfc_start_block (&block
);
3158 gfc_init_block (&block
);
3160 /* Compare with the current limit. */
3161 gfc_init_se (&arrayse
, NULL
);
3162 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3163 arrayse
.ss
= arrayss
;
3164 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3165 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3167 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3169 if (HONOR_NANS (DECL_MODE (limit
))
3170 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3172 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3173 arrayse
.expr
, limit
);
3174 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3175 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3176 build_empty_stmt (input_location
));
3177 gfc_add_expr_to_block (&block
, tmp
);
3181 tmp
= fold_build2_loc (input_location
,
3182 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3183 type
, arrayse
.expr
, limit
);
3184 gfc_add_modify (&block
, limit
, tmp
);
3187 gfc_add_block_to_block (&block
, &arrayse
.post
);
3189 tmp
= gfc_finish_block (&block
);
3191 /* We enclose the above in if (mask) {...}. */
3192 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3193 build_empty_stmt (input_location
));
3194 gfc_add_expr_to_block (&body
, tmp
);
3195 /* Avoid initializing loopvar[0] again, it should be left where
3196 it finished by the first loop. */
3197 loop
.from
[0] = loop
.loopvar
[0];
3199 gfc_trans_scalarizing_loops (&loop
, &body
);
3203 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3205 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3206 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
3208 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3210 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
3212 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
3214 gfc_add_modify (&loop
.pre
, limit
, tmp
);
3217 /* For a scalar mask, enclose the loop in an if statement. */
3218 if (maskexpr
&& maskss
== NULL
)
3222 gfc_init_se (&maskse
, NULL
);
3223 gfc_conv_expr_val (&maskse
, maskexpr
);
3224 gfc_init_block (&block
);
3225 gfc_add_block_to_block (&block
, &loop
.pre
);
3226 gfc_add_block_to_block (&block
, &loop
.post
);
3227 tmp
= gfc_finish_block (&block
);
3229 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3230 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
3232 else_stmt
= build_empty_stmt (input_location
);
3233 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
3234 gfc_add_expr_to_block (&block
, tmp
);
3235 gfc_add_block_to_block (&se
->pre
, &block
);
3239 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3240 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3243 gfc_cleanup_loop (&loop
);
3248 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3250 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
3256 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3257 type
= TREE_TYPE (args
[0]);
3259 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3260 build_int_cst (type
, 1), args
[1]);
3261 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
3262 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
3263 build_int_cst (type
, 0));
3264 type
= gfc_typenode_for_spec (&expr
->ts
);
3265 se
->expr
= convert (type
, tmp
);
3269 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3271 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3275 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3277 /* Convert both arguments to the unsigned type of the same size. */
3278 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
3279 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
3281 /* If they have unequal type size, convert to the larger one. */
3282 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
3283 > TYPE_PRECISION (TREE_TYPE (args
[1])))
3284 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
3285 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
3286 > TYPE_PRECISION (TREE_TYPE (args
[0])))
3287 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
3289 /* Now, we compare them. */
3290 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3295 /* Generate code to perform the specified operation. */
3297 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3301 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3302 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
3308 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
3312 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3313 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3314 TREE_TYPE (arg
), arg
);
3317 /* Set or clear a single bit. */
3319 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
3326 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3327 type
= TREE_TYPE (args
[0]);
3329 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3330 build_int_cst (type
, 1), args
[1]);
3336 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
3338 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
3341 /* Extract a sequence of bits.
3342 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3344 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
3351 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3352 type
= TREE_TYPE (args
[0]);
3354 mask
= build_int_cst (type
, -1);
3355 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
3356 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
3358 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
3360 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
3364 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
3367 tree args
[2], type
, num_bits
, cond
;
3369 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3371 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3372 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3373 type
= TREE_TYPE (args
[0]);
3376 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
3378 gcc_assert (right_shift
);
3380 se
->expr
= fold_build2_loc (input_location
,
3381 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
3382 TREE_TYPE (args
[0]), args
[0], args
[1]);
3385 se
->expr
= fold_convert (type
, se
->expr
);
3387 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3388 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3390 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
3391 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
3394 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3395 build_int_cst (type
, 0), se
->expr
);
3398 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3400 : ((shift >= 0) ? i << shift : i >> -shift)
3401 where all shifts are logical shifts. */
3403 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
3415 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3417 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3418 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3420 type
= TREE_TYPE (args
[0]);
3421 utype
= unsigned_type_for (type
);
3423 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
3426 /* Left shift if positive. */
3427 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
3429 /* Right shift if negative.
3430 We convert to an unsigned type because we want a logical shift.
3431 The standard doesn't define the case of shifting negative
3432 numbers, and we try to be compatible with other compilers, most
3433 notably g77, here. */
3434 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
3435 utype
, convert (utype
, args
[0]), width
));
3437 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
3438 build_int_cst (TREE_TYPE (args
[1]), 0));
3439 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
3441 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3442 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3444 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
3445 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
3447 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3448 build_int_cst (type
, 0), tmp
);
3452 /* Circular shift. AKA rotate or barrel shift. */
3455 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
3463 unsigned int num_args
;
3465 num_args
= gfc_intrinsic_argument_list_length (expr
);
3466 args
= XALLOCAVEC (tree
, num_args
);
3468 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3472 /* Use a library function for the 3 parameter version. */
3473 tree int4type
= gfc_get_int_type (4);
3475 type
= TREE_TYPE (args
[0]);
3476 /* We convert the first argument to at least 4 bytes, and
3477 convert back afterwards. This removes the need for library
3478 functions for all argument sizes, and function will be
3479 aligned to at least 32 bits, so there's no loss. */
3480 if (expr
->ts
.kind
< 4)
3481 args
[0] = convert (int4type
, args
[0]);
3483 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3484 need loads of library functions. They cannot have values >
3485 BIT_SIZE (I) so the conversion is safe. */
3486 args
[1] = convert (int4type
, args
[1]);
3487 args
[2] = convert (int4type
, args
[2]);
3489 switch (expr
->ts
.kind
)
3494 tmp
= gfor_fndecl_math_ishftc4
;
3497 tmp
= gfor_fndecl_math_ishftc8
;
3500 tmp
= gfor_fndecl_math_ishftc16
;
3505 se
->expr
= build_call_expr_loc (input_location
,
3506 tmp
, 3, args
[0], args
[1], args
[2]);
3507 /* Convert the result back to the original type, if we extended
3508 the first argument's width above. */
3509 if (expr
->ts
.kind
< 4)
3510 se
->expr
= convert (type
, se
->expr
);
3514 type
= TREE_TYPE (args
[0]);
3516 /* Evaluate arguments only once. */
3517 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3518 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3520 /* Rotate left if positive. */
3521 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
3523 /* Rotate right if negative. */
3524 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
3526 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
3528 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
3529 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
3531 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
3533 /* Do nothing if shift == 0. */
3534 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
3536 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
3541 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3542 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3544 The conditional expression is necessary because the result of LEADZ(0)
3545 is defined, but the result of __builtin_clz(0) is undefined for most
3548 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3549 difference in bit size between the argument of LEADZ and the C int. */
3552 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
3564 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3565 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
3567 /* Which variant of __builtin_clz* should we call? */
3568 if (argsize
<= INT_TYPE_SIZE
)
3570 arg_type
= unsigned_type_node
;
3571 func
= built_in_decls
[BUILT_IN_CLZ
];
3573 else if (argsize
<= LONG_TYPE_SIZE
)
3575 arg_type
= long_unsigned_type_node
;
3576 func
= built_in_decls
[BUILT_IN_CLZL
];
3578 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
3580 arg_type
= long_long_unsigned_type_node
;
3581 func
= built_in_decls
[BUILT_IN_CLZLL
];
3585 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
3586 arg_type
= gfc_build_uint_type (argsize
);
3590 /* Convert the actual argument twice: first, to the unsigned type of the
3591 same size; then, to the proper argument type for the built-in
3592 function. But the return type is of the default INTEGER kind. */
3593 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
3594 arg
= fold_convert (arg_type
, arg
);
3595 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3596 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
3598 /* Compute LEADZ for the case i .ne. 0. */
3601 s
= TYPE_PRECISION (arg_type
) - argsize
;
3602 tmp
= fold_convert (result_type
,
3603 build_call_expr_loc (input_location
, func
,
3605 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
3606 tmp
, build_int_cst (result_type
, s
));
3610 /* We end up here if the argument type is larger than 'long long'.
3611 We generate this code:
3613 if (x & (ULL_MAX << ULL_SIZE) != 0)
3614 return clzll ((unsigned long long) (x >> ULLSIZE));
3616 return ULL_SIZE + clzll ((unsigned long long) x);
3617 where ULL_MAX is the largest value that a ULL_MAX can hold
3618 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
3619 is the bit-size of the long long type (64 in this example). */
3620 tree ullsize
, ullmax
, tmp1
, tmp2
;
3622 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
3623 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3624 long_long_unsigned_type_node
,
3625 build_int_cst (long_long_unsigned_type_node
,
3628 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
3629 fold_convert (arg_type
, ullmax
), ullsize
);
3630 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
3632 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3633 cond
, build_int_cst (arg_type
, 0));
3635 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
3637 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
3638 tmp1
= fold_convert (result_type
,
3639 build_call_expr_loc (input_location
,
3640 built_in_decls
[BUILT_IN_CLZLL
],
3643 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
3644 tmp2
= fold_convert (result_type
,
3645 build_call_expr_loc (input_location
,
3646 built_in_decls
[BUILT_IN_CLZLL
],
3648 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
3651 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
3655 /* Build BIT_SIZE. */
3656 bit_size
= build_int_cst (result_type
, argsize
);
3658 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3659 arg
, build_int_cst (arg_type
, 0));
3660 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
3665 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3667 The conditional expression is necessary because the result of TRAILZ(0)
3668 is defined, but the result of __builtin_ctz(0) is undefined for most
3672 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
3683 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3684 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
3686 /* Which variant of __builtin_ctz* should we call? */
3687 if (argsize
<= INT_TYPE_SIZE
)
3689 arg_type
= unsigned_type_node
;
3690 func
= built_in_decls
[BUILT_IN_CTZ
];
3692 else if (argsize
<= LONG_TYPE_SIZE
)
3694 arg_type
= long_unsigned_type_node
;
3695 func
= built_in_decls
[BUILT_IN_CTZL
];
3697 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
3699 arg_type
= long_long_unsigned_type_node
;
3700 func
= built_in_decls
[BUILT_IN_CTZLL
];
3704 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
3705 arg_type
= gfc_build_uint_type (argsize
);
3709 /* Convert the actual argument twice: first, to the unsigned type of the
3710 same size; then, to the proper argument type for the built-in
3711 function. But the return type is of the default INTEGER kind. */
3712 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
3713 arg
= fold_convert (arg_type
, arg
);
3714 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3715 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
3717 /* Compute TRAILZ for the case i .ne. 0. */
3719 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
3723 /* We end up here if the argument type is larger than 'long long'.
3724 We generate this code:
3726 if ((x & ULL_MAX) == 0)
3727 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
3729 return ctzll ((unsigned long long) x);
3731 where ULL_MAX is the largest value that a ULL_MAX can hold
3732 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
3733 is the bit-size of the long long type (64 in this example). */
3734 tree ullsize
, ullmax
, tmp1
, tmp2
;
3736 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
3737 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3738 long_long_unsigned_type_node
,
3739 build_int_cst (long_long_unsigned_type_node
, 0));
3741 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
3742 fold_convert (arg_type
, ullmax
));
3743 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
3744 build_int_cst (arg_type
, 0));
3746 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
3748 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
3749 tmp1
= fold_convert (result_type
,
3750 build_call_expr_loc (input_location
,
3751 built_in_decls
[BUILT_IN_CTZLL
],
3753 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
3756 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
3757 tmp2
= fold_convert (result_type
,
3758 build_call_expr_loc (input_location
,
3759 built_in_decls
[BUILT_IN_CTZLL
],
3762 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
3766 /* Build BIT_SIZE. */
3767 bit_size
= build_int_cst (result_type
, argsize
);
3769 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3770 arg
, build_int_cst (arg_type
, 0));
3771 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
3775 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
3776 for types larger than "long long", we call the long long built-in for
3777 the lower and higher bits and combine the result. */
3780 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
3788 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3789 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
3790 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
3792 /* Which variant of the builtin should we call? */
3793 if (argsize
<= INT_TYPE_SIZE
)
3795 arg_type
= unsigned_type_node
;
3796 func
= built_in_decls
[parity
? BUILT_IN_PARITY
: BUILT_IN_POPCOUNT
];
3798 else if (argsize
<= LONG_TYPE_SIZE
)
3800 arg_type
= long_unsigned_type_node
;
3801 func
= built_in_decls
[parity
? BUILT_IN_PARITYL
: BUILT_IN_POPCOUNTL
];
3803 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
3805 arg_type
= long_long_unsigned_type_node
;
3806 func
= built_in_decls
[parity
? BUILT_IN_PARITYLL
: BUILT_IN_POPCOUNTLL
];
3810 /* Our argument type is larger than 'long long', which mean none
3811 of the POPCOUNT builtins covers it. We thus call the 'long long'
3812 variant multiple times, and add the results. */
3813 tree utype
, arg2
, call1
, call2
;
3815 /* For now, we only cover the case where argsize is twice as large
3817 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
3819 func
= built_in_decls
[parity
? BUILT_IN_PARITYLL
: BUILT_IN_POPCOUNTLL
];
3821 /* Convert it to an integer, and store into a variable. */
3822 utype
= gfc_build_uint_type (argsize
);
3823 arg
= fold_convert (utype
, arg
);
3824 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3826 /* Call the builtin twice. */
3827 call1
= build_call_expr_loc (input_location
, func
, 1,
3828 fold_convert (long_long_unsigned_type_node
,
3831 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
3832 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
3833 call2
= build_call_expr_loc (input_location
, func
, 1,
3834 fold_convert (long_long_unsigned_type_node
,
3837 /* Combine the results. */
3839 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
3842 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
3848 /* Convert the actual argument twice: first, to the unsigned type of the
3849 same size; then, to the proper argument type for the built-in
3851 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
3852 arg
= fold_convert (arg_type
, arg
);
3854 se
->expr
= fold_convert (result_type
,
3855 build_call_expr_loc (input_location
, func
, 1, arg
));
3859 /* Process an intrinsic with unspecified argument-types that has an optional
3860 argument (which could be of type character), e.g. EOSHIFT. For those, we
3861 need to append the string length of the optional argument if it is not
3862 present and the type is really character.
3863 primary specifies the position (starting at 1) of the non-optional argument
3864 specifying the type and optional gives the position of the optional
3865 argument in the arglist. */
3868 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
3869 unsigned primary
, unsigned optional
)
3871 gfc_actual_arglist
* prim_arg
;
3872 gfc_actual_arglist
* opt_arg
;
3874 gfc_actual_arglist
* arg
;
3876 VEC(tree
,gc
) *append_args
;
3878 /* Find the two arguments given as position. */
3882 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3886 if (cur_pos
== primary
)
3888 if (cur_pos
== optional
)
3891 if (cur_pos
>= primary
&& cur_pos
>= optional
)
3894 gcc_assert (prim_arg
);
3895 gcc_assert (prim_arg
->expr
);
3896 gcc_assert (opt_arg
);
3898 /* If we do have type CHARACTER and the optional argument is really absent,
3899 append a dummy 0 as string length. */
3901 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
3905 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
3906 append_args
= VEC_alloc (tree
, gc
, 1);
3907 VEC_quick_push (tree
, append_args
, dummy
);
3910 /* Build the call itself. */
3911 sym
= gfc_get_symbol_for_expr (expr
);
3912 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3918 /* The length of a character string. */
3920 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
3930 gcc_assert (!se
->ss
);
3932 arg
= expr
->value
.function
.actual
->expr
;
3934 type
= gfc_typenode_for_spec (&expr
->ts
);
3935 switch (arg
->expr_type
)
3938 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
3942 /* Obtain the string length from the function used by
3943 trans-array.c(gfc_trans_array_constructor). */
3945 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
3949 if (arg
->ref
== NULL
3950 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
3952 /* This doesn't catch all cases.
3953 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3954 and the surrounding thread. */
3955 sym
= arg
->symtree
->n
.sym
;
3956 decl
= gfc_get_symbol_decl (sym
);
3957 if (decl
== current_function_decl
&& sym
->attr
.function
3958 && (sym
->result
== sym
))
3959 decl
= gfc_get_fake_result_decl (sym
, 0);
3961 len
= sym
->ts
.u
.cl
->backend_decl
;
3966 /* Otherwise fall through. */
3969 /* Anybody stupid enough to do this deserves inefficient code. */
3970 ss
= gfc_walk_expr (arg
);
3971 gfc_init_se (&argse
, se
);
3972 if (ss
== gfc_ss_terminator
)
3973 gfc_conv_expr (&argse
, arg
);
3975 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
3976 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
3977 gfc_add_block_to_block (&se
->post
, &argse
.post
);
3978 len
= argse
.string_length
;
3981 se
->expr
= convert (type
, len
);
3984 /* The length of a character string not including trailing blanks. */
3986 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
3988 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
3989 tree args
[2], type
, fndecl
;
3991 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3992 type
= gfc_typenode_for_spec (&expr
->ts
);
3995 fndecl
= gfor_fndecl_string_len_trim
;
3997 fndecl
= gfor_fndecl_string_len_trim_char4
;
4001 se
->expr
= build_call_expr_loc (input_location
,
4002 fndecl
, 2, args
[0], args
[1]);
4003 se
->expr
= convert (type
, se
->expr
);
4007 /* Returns the starting position of a substring within a string. */
4010 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4013 tree logical4_type_node
= gfc_get_logical_type (4);
4017 unsigned int num_args
;
4019 args
= XALLOCAVEC (tree
, 5);
4021 /* Get number of arguments; characters count double due to the
4022 string length argument. Kind= is not passed to the library
4023 and thus ignored. */
4024 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4029 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4030 type
= gfc_typenode_for_spec (&expr
->ts
);
4033 args
[4] = build_int_cst (logical4_type_node
, 0);
4035 args
[4] = convert (logical4_type_node
, args
[4]);
4037 fndecl
= build_addr (function
, current_function_decl
);
4038 se
->expr
= build_call_array_loc (input_location
,
4039 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4041 se
->expr
= convert (type
, se
->expr
);
4045 /* The ascii value for a single character. */
4047 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4049 tree args
[2], type
, pchartype
;
4051 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4052 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
4053 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
4054 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
4055 type
= gfc_typenode_for_spec (&expr
->ts
);
4057 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4059 se
->expr
= convert (type
, se
->expr
);
4063 /* Intrinsic ISNAN calls __builtin_isnan. */
4066 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
4070 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4071 se
->expr
= build_call_expr_loc (input_location
,
4072 built_in_decls
[BUILT_IN_ISNAN
], 1, arg
);
4073 STRIP_TYPE_NOPS (se
->expr
);
4074 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4078 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4079 their argument against a constant integer value. */
4082 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
4086 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4087 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
4088 gfc_typenode_for_spec (&expr
->ts
),
4089 arg
, build_int_cst (TREE_TYPE (arg
), value
));
4094 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4097 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
4105 unsigned int num_args
;
4107 num_args
= gfc_intrinsic_argument_list_length (expr
);
4108 args
= XALLOCAVEC (tree
, num_args
);
4110 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4111 if (expr
->ts
.type
!= BT_CHARACTER
)
4119 /* We do the same as in the non-character case, but the argument
4120 list is different because of the string length arguments. We
4121 also have to set the string length for the result. */
4128 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
4130 se
->string_length
= len
;
4132 type
= TREE_TYPE (tsource
);
4133 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
4134 fold_convert (type
, fsource
));
4138 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4141 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
4143 tree args
[3], mask
, type
;
4145 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4146 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
4148 type
= TREE_TYPE (args
[0]);
4149 gcc_assert (TREE_TYPE (args
[1]) == type
);
4150 gcc_assert (TREE_TYPE (mask
) == type
);
4152 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
4153 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
4154 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4156 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
4161 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4162 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4165 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
4167 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
4170 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4171 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4173 type
= gfc_get_int_type (expr
->ts
.kind
);
4174 utype
= unsigned_type_for (type
);
4176 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
4177 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
4179 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
4180 build_int_cst (utype
, 0));
4184 /* Left-justified mask. */
4185 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
4187 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4188 fold_convert (utype
, res
));
4190 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4191 smaller than type width. */
4192 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4193 build_int_cst (TREE_TYPE (arg
), 0));
4194 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
4195 build_int_cst (utype
, 0), res
);
4199 /* Right-justified mask. */
4200 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4201 fold_convert (utype
, arg
));
4202 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
4204 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4205 strictly smaller than type width. */
4206 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4208 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
4209 cond
, allones
, res
);
4212 se
->expr
= fold_convert (type
, res
);
4216 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4218 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
4220 tree arg
, type
, tmp
, frexp
;
4222 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4224 type
= gfc_typenode_for_spec (&expr
->ts
);
4225 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4226 tmp
= gfc_create_var (integer_type_node
, NULL
);
4227 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
4228 fold_convert (type
, arg
),
4229 gfc_build_addr_expr (NULL_TREE
, tmp
));
4230 se
->expr
= fold_convert (type
, se
->expr
);
4234 /* NEAREST (s, dir) is translated into
4235 tmp = copysign (HUGE_VAL, dir);
4236 return nextafter (s, tmp);
4239 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
4241 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
4243 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
4244 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
4245 huge_val
= gfc_builtin_decl_for_float_kind (BUILT_IN_HUGE_VAL
, expr
->ts
.kind
);
4247 type
= gfc_typenode_for_spec (&expr
->ts
);
4248 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4249 tmp
= build_call_expr_loc (input_location
, copysign
, 2,
4250 build_call_expr_loc (input_location
, huge_val
, 0),
4251 fold_convert (type
, args
[1]));
4252 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
4253 fold_convert (type
, args
[0]), tmp
);
4254 se
->expr
= fold_convert (type
, se
->expr
);
4258 /* SPACING (s) is translated into
4266 e = MAX_EXPR (e, emin);
4267 res = scalbn (1., e);
4271 where prec is the precision of s, gfc_real_kinds[k].digits,
4272 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4273 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4276 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
4278 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
4279 tree cond
, tmp
, frexp
, scalbn
;
4283 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4284 prec
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].digits
);
4285 emin
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].min_exponent
- 1);
4286 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
4288 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4289 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4291 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4292 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4294 type
= gfc_typenode_for_spec (&expr
->ts
);
4295 e
= gfc_create_var (integer_type_node
, NULL
);
4296 res
= gfc_create_var (type
, NULL
);
4299 /* Build the block for s /= 0. */
4300 gfc_start_block (&block
);
4301 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4302 gfc_build_addr_expr (NULL_TREE
, e
));
4303 gfc_add_expr_to_block (&block
, tmp
);
4305 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
4307 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
4308 integer_type_node
, tmp
, emin
));
4310 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
4311 build_real_from_int_cst (type
, integer_one_node
), e
);
4312 gfc_add_modify (&block
, res
, tmp
);
4314 /* Finish by building the IF statement. */
4315 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4316 build_real_from_int_cst (type
, integer_zero_node
));
4317 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
4318 gfc_finish_block (&block
));
4320 gfc_add_expr_to_block (&se
->pre
, tmp
);
4325 /* RRSPACING (s) is translated into
4332 x = scalbn (x, precision - e);
4336 where precision is gfc_real_kinds[k].digits. */
4339 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
4341 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
4345 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4346 prec
= gfc_real_kinds
[k
].digits
;
4348 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4349 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4350 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
4352 type
= gfc_typenode_for_spec (&expr
->ts
);
4353 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4354 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4356 e
= gfc_create_var (integer_type_node
, NULL
);
4357 x
= gfc_create_var (type
, NULL
);
4358 gfc_add_modify (&se
->pre
, x
,
4359 build_call_expr_loc (input_location
, fabs
, 1, arg
));
4362 gfc_start_block (&block
);
4363 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4364 gfc_build_addr_expr (NULL_TREE
, e
));
4365 gfc_add_expr_to_block (&block
, tmp
);
4367 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
4368 build_int_cst (NULL_TREE
, prec
), e
);
4369 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
4370 gfc_add_modify (&block
, x
, tmp
);
4371 stmt
= gfc_finish_block (&block
);
4373 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
4374 build_real_from_int_cst (type
, integer_zero_node
));
4375 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
4376 gfc_add_expr_to_block (&se
->pre
, tmp
);
4378 se
->expr
= fold_convert (type
, x
);
4382 /* SCALE (s, i) is translated into scalbn (s, i). */
4384 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
4386 tree args
[2], type
, scalbn
;
4388 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4390 type
= gfc_typenode_for_spec (&expr
->ts
);
4391 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4392 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
4393 fold_convert (type
, args
[0]),
4394 fold_convert (integer_type_node
, args
[1]));
4395 se
->expr
= fold_convert (type
, se
->expr
);
4399 /* SET_EXPONENT (s, i) is translated into
4400 scalbn (frexp (s, &dummy_int), i). */
4402 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
4404 tree args
[2], type
, tmp
, frexp
, scalbn
;
4406 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4407 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4409 type
= gfc_typenode_for_spec (&expr
->ts
);
4410 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4412 tmp
= gfc_create_var (integer_type_node
, NULL
);
4413 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
4414 fold_convert (type
, args
[0]),
4415 gfc_build_addr_expr (NULL_TREE
, tmp
));
4416 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
4417 fold_convert (integer_type_node
, args
[1]));
4418 se
->expr
= fold_convert (type
, se
->expr
);
4423 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
4425 gfc_actual_arglist
*actual
;
4433 gfc_init_se (&argse
, NULL
);
4434 actual
= expr
->value
.function
.actual
;
4436 ss
= gfc_walk_expr (actual
->expr
);
4437 gcc_assert (ss
!= gfc_ss_terminator
);
4438 argse
.want_pointer
= 1;
4439 argse
.data_not_needed
= 1;
4440 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
4441 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4442 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4443 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
4445 /* Build the call to size0. */
4446 fncall0
= build_call_expr_loc (input_location
,
4447 gfor_fndecl_size0
, 1, arg1
);
4449 actual
= actual
->next
;
4453 gfc_init_se (&argse
, NULL
);
4454 gfc_conv_expr_type (&argse
, actual
->expr
,
4455 gfc_array_index_type
);
4456 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4458 /* Unusually, for an intrinsic, size does not exclude
4459 an optional arg2, so we must test for it. */
4460 if (actual
->expr
->expr_type
== EXPR_VARIABLE
4461 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
4462 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
4465 /* Build the call to size1. */
4466 fncall1
= build_call_expr_loc (input_location
,
4467 gfor_fndecl_size1
, 2,
4470 gfc_init_se (&argse
, NULL
);
4471 argse
.want_pointer
= 1;
4472 argse
.data_not_needed
= 1;
4473 gfc_conv_expr (&argse
, actual
->expr
);
4474 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4475 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4476 argse
.expr
, null_pointer_node
);
4477 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4478 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
4479 pvoid_type_node
, tmp
, fncall1
, fncall0
);
4483 se
->expr
= NULL_TREE
;
4484 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
4485 gfc_array_index_type
,
4486 argse
.expr
, gfc_index_one_node
);
4489 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
4491 argse
.expr
= gfc_index_zero_node
;
4492 se
->expr
= NULL_TREE
;
4497 if (se
->expr
== NULL_TREE
)
4499 tree ubound
, lbound
;
4501 arg1
= build_fold_indirect_ref_loc (input_location
,
4503 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
4504 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
4505 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
4506 gfc_array_index_type
, ubound
, lbound
);
4507 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
4508 gfc_array_index_type
,
4509 se
->expr
, gfc_index_one_node
);
4510 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
4511 gfc_array_index_type
, se
->expr
,
4512 gfc_index_zero_node
);
4515 type
= gfc_typenode_for_spec (&expr
->ts
);
4516 se
->expr
= convert (type
, se
->expr
);
4520 /* Helper function to compute the size of a character variable,
4521 excluding the terminating null characters. The result has
4522 gfc_array_index_type type. */
4525 size_of_string_in_bytes (int kind
, tree string_length
)
4528 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
4530 bytesize
= build_int_cst (gfc_array_index_type
,
4531 gfc_character_kinds
[i
].bit_size
/ 8);
4533 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4535 fold_convert (gfc_array_index_type
, string_length
));
4540 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
4552 arg
= expr
->value
.function
.actual
->expr
;
4554 gfc_init_se (&argse
, NULL
);
4555 ss
= gfc_walk_expr (arg
);
4557 if (ss
== gfc_ss_terminator
)
4559 if (arg
->ts
.type
== BT_CLASS
)
4560 gfc_add_component_ref (arg
, "$data");
4562 gfc_conv_expr_reference (&argse
, arg
);
4564 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4567 /* Obtain the source word length. */
4568 if (arg
->ts
.type
== BT_CHARACTER
)
4569 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
4570 argse
.string_length
);
4572 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
4576 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
4577 argse
.want_pointer
= 0;
4578 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
4579 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4581 /* Obtain the argument's word length. */
4582 if (arg
->ts
.type
== BT_CHARACTER
)
4583 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
4585 tmp
= fold_convert (gfc_array_index_type
,
4586 size_in_bytes (type
));
4587 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
4589 /* Obtain the size of the array in bytes. */
4590 for (n
= 0; n
< arg
->rank
; n
++)
4593 idx
= gfc_rank_cst
[n
];
4594 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
4595 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
4596 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4597 gfc_array_index_type
, upper
, lower
);
4598 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4599 gfc_array_index_type
, tmp
, gfc_index_one_node
);
4600 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4601 gfc_array_index_type
, tmp
, source_bytes
);
4602 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
4604 se
->expr
= source_bytes
;
4607 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4612 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
4617 tree type
, result_type
, tmp
;
4619 arg
= expr
->value
.function
.actual
->expr
;
4620 gfc_init_se (&eight
, NULL
);
4621 gfc_conv_expr (&eight
, gfc_get_int_expr (expr
->ts
.kind
, NULL
, 8));
4623 gfc_init_se (&argse
, NULL
);
4624 ss
= gfc_walk_expr (arg
);
4625 result_type
= gfc_get_int_type (expr
->ts
.kind
);
4627 if (ss
== gfc_ss_terminator
)
4629 if (arg
->ts
.type
== BT_CLASS
)
4631 gfc_add_component_ref (arg
, "$vptr");
4632 gfc_add_component_ref (arg
, "$size");
4633 gfc_conv_expr (&argse
, arg
);
4634 tmp
= fold_convert (result_type
, argse
.expr
);
4638 gfc_conv_expr_reference (&argse
, arg
);
4639 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4644 argse
.want_pointer
= 0;
4645 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
4646 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4649 /* Obtain the argument's word length. */
4650 if (arg
->ts
.type
== BT_CHARACTER
)
4651 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
4653 tmp
= fold_convert (result_type
, size_in_bytes (type
));
4656 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
4658 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4662 /* Intrinsic string comparison functions. */
4665 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4669 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
4672 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
4673 expr
->value
.function
.actual
->expr
->ts
.kind
,
4675 se
->expr
= fold_build2_loc (input_location
, op
,
4676 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
4677 build_int_cst (TREE_TYPE (se
->expr
), 0));
4680 /* Generate a call to the adjustl/adjustr library function. */
4682 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
4690 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
4693 type
= TREE_TYPE (args
[2]);
4694 var
= gfc_conv_string_tmp (se
, type
, len
);
4697 tmp
= build_call_expr_loc (input_location
,
4698 fndecl
, 3, args
[0], args
[1], args
[2]);
4699 gfc_add_expr_to_block (&se
->pre
, tmp
);
4701 se
->string_length
= len
;
4705 /* Generate code for the TRANSFER intrinsic:
4707 DEST = TRANSFER (SOURCE, MOLD)
4709 typeof<DEST> = typeof<MOLD>
4714 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
4716 typeof<DEST> = typeof<MOLD>
4718 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
4719 sizeof (DEST(0) * SIZE). */
4721 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
4737 gfc_actual_arglist
*arg
;
4747 info
= &se
->ss
->data
.info
;
4749 /* Convert SOURCE. The output from this stage is:-
4750 source_bytes = length of the source in bytes
4751 source = pointer to the source data. */
4752 arg
= expr
->value
.function
.actual
;
4754 /* Ensure double transfer through LOGICAL preserves all
4756 if (arg
->expr
->expr_type
== EXPR_FUNCTION
4757 && arg
->expr
->value
.function
.esym
== NULL
4758 && arg
->expr
->value
.function
.isym
!= NULL
4759 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
4760 && arg
->expr
->ts
.type
== BT_LOGICAL
4761 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
4762 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
4764 gfc_init_se (&argse
, NULL
);
4765 ss
= gfc_walk_expr (arg
->expr
);
4767 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
4769 /* Obtain the pointer to source and the length of source in bytes. */
4770 if (ss
== gfc_ss_terminator
)
4772 gfc_conv_expr_reference (&argse
, arg
->expr
);
4773 source
= argse
.expr
;
4775 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4778 /* Obtain the source word length. */
4779 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
4780 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
4781 argse
.string_length
);
4783 tmp
= fold_convert (gfc_array_index_type
,
4784 size_in_bytes (source_type
));
4788 argse
.want_pointer
= 0;
4789 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
4790 source
= gfc_conv_descriptor_data_get (argse
.expr
);
4791 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4793 /* Repack the source if not a full variable array. */
4794 if (arg
->expr
->expr_type
== EXPR_VARIABLE
4795 && arg
->expr
->ref
->u
.ar
.type
!= AR_FULL
)
4797 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
4799 if (gfc_option
.warn_array_temp
)
4800 gfc_warning ("Creating array temporary at %L", &expr
->where
);
4802 source
= build_call_expr_loc (input_location
,
4803 gfor_fndecl_in_pack
, 1, tmp
);
4804 source
= gfc_evaluate_now (source
, &argse
.pre
);
4806 /* Free the temporary. */
4807 gfc_start_block (&block
);
4808 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
4809 gfc_add_expr_to_block (&block
, tmp
);
4810 stmt
= gfc_finish_block (&block
);
4812 /* Clean up if it was repacked. */
4813 gfc_init_block (&block
);
4814 tmp
= gfc_conv_array_data (argse
.expr
);
4815 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4817 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
4818 build_empty_stmt (input_location
));
4819 gfc_add_expr_to_block (&block
, tmp
);
4820 gfc_add_block_to_block (&block
, &se
->post
);
4821 gfc_init_block (&se
->post
);
4822 gfc_add_block_to_block (&se
->post
, &block
);
4825 /* Obtain the source word length. */
4826 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
4827 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
4828 argse
.string_length
);
4830 tmp
= fold_convert (gfc_array_index_type
,
4831 size_in_bytes (source_type
));
4833 /* Obtain the size of the array in bytes. */
4834 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
4835 for (n
= 0; n
< arg
->expr
->rank
; n
++)
4838 idx
= gfc_rank_cst
[n
];
4839 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
4840 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
4841 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
4842 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4843 gfc_array_index_type
, upper
, lower
);
4844 gfc_add_modify (&argse
.pre
, extent
, tmp
);
4845 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4846 gfc_array_index_type
, extent
,
4847 gfc_index_one_node
);
4848 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4849 gfc_array_index_type
, tmp
, source_bytes
);
4853 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
4854 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4855 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4857 /* Now convert MOLD. The outputs are:
4858 mold_type = the TREE type of MOLD
4859 dest_word_len = destination word length in bytes. */
4862 gfc_init_se (&argse
, NULL
);
4863 ss
= gfc_walk_expr (arg
->expr
);
4865 scalar_mold
= arg
->expr
->rank
== 0;
4867 if (ss
== gfc_ss_terminator
)
4869 gfc_conv_expr_reference (&argse
, arg
->expr
);
4870 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4875 gfc_init_se (&argse
, NULL
);
4876 argse
.want_pointer
= 0;
4877 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
4878 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4881 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4882 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4884 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
4886 /* If this TRANSFER is nested in another TRANSFER, use a type
4887 that preserves all bits. */
4888 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
4889 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
4892 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
4894 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
4895 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
4898 tmp
= fold_convert (gfc_array_index_type
,
4899 size_in_bytes (mold_type
));
4901 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
4902 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
4904 /* Finally convert SIZE, if it is present. */
4906 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
4910 gfc_init_se (&argse
, NULL
);
4911 gfc_conv_expr_reference (&argse
, arg
->expr
);
4912 tmp
= convert (gfc_array_index_type
,
4913 build_fold_indirect_ref_loc (input_location
,
4915 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4916 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4921 /* Separate array and scalar results. */
4922 if (scalar_mold
&& tmp
== NULL_TREE
)
4923 goto scalar_transfer
;
4925 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
4926 if (tmp
!= NULL_TREE
)
4927 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4928 tmp
, dest_word_len
);
4932 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
4933 gfc_add_modify (&se
->pre
, size_words
,
4934 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
4935 gfc_array_index_type
,
4936 size_bytes
, dest_word_len
));
4938 /* Evaluate the bounds of the result. If the loop range exists, we have
4939 to check if it is too large. If so, we modify loop->to be consistent
4940 with min(size, size(source)). Otherwise, size is made consistent with
4941 the loop range, so that the right number of bytes is transferred.*/
4942 n
= se
->loop
->order
[0];
4943 if (se
->loop
->to
[n
] != NULL_TREE
)
4945 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4946 se
->loop
->to
[n
], se
->loop
->from
[n
]);
4947 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4948 tmp
, gfc_index_one_node
);
4949 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
4951 gfc_add_modify (&se
->pre
, size_words
, tmp
);
4952 gfc_add_modify (&se
->pre
, size_bytes
,
4953 fold_build2_loc (input_location
, MULT_EXPR
,
4954 gfc_array_index_type
,
4955 size_words
, dest_word_len
));
4956 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4957 size_words
, se
->loop
->from
[n
]);
4958 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4959 upper
, gfc_index_one_node
);
4963 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4964 size_words
, gfc_index_one_node
);
4965 se
->loop
->from
[n
] = gfc_index_zero_node
;
4968 se
->loop
->to
[n
] = upper
;
4970 /* Build a destination descriptor, using the pointer, source, as the
4972 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
4973 info
, mold_type
, NULL_TREE
, false, true, false,
4976 /* Cast the pointer to the result. */
4977 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
4978 tmp
= fold_convert (pvoid_type_node
, tmp
);
4980 /* Use memcpy to do the transfer. */
4981 tmp
= build_call_expr_loc (input_location
,
4982 built_in_decls
[BUILT_IN_MEMCPY
],
4985 fold_convert (pvoid_type_node
, source
),
4986 fold_build2_loc (input_location
, MIN_EXPR
,
4987 gfc_array_index_type
,
4988 size_bytes
, source_bytes
));
4989 gfc_add_expr_to_block (&se
->pre
, tmp
);
4991 se
->expr
= info
->descriptor
;
4992 if (expr
->ts
.type
== BT_CHARACTER
)
4993 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
4997 /* Deal with scalar results. */
4999 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5000 dest_word_len
, source_bytes
);
5001 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5002 extent
, gfc_index_zero_node
);
5004 if (expr
->ts
.type
== BT_CHARACTER
)
5009 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5010 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5013 /* If source is longer than the destination, use a pointer to
5014 the source directly. */
5015 gfc_init_block (&block
);
5016 gfc_add_modify (&block
, tmpdecl
, ptr
);
5017 direct
= gfc_finish_block (&block
);
5019 /* Otherwise, allocate a string with the length of the destination
5020 and copy the source into it. */
5021 gfc_init_block (&block
);
5022 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5023 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5024 gfc_add_modify (&block
, tmpdecl
,
5025 fold_convert (TREE_TYPE (ptr
), tmp
));
5026 tmp
= build_call_expr_loc (input_location
,
5027 built_in_decls
[BUILT_IN_MEMCPY
], 3,
5028 fold_convert (pvoid_type_node
, tmpdecl
),
5029 fold_convert (pvoid_type_node
, ptr
),
5031 gfc_add_expr_to_block (&block
, tmp
);
5032 indirect
= gfc_finish_block (&block
);
5034 /* Wrap it up with the condition. */
5035 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5036 dest_word_len
, source_bytes
);
5037 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5038 gfc_add_expr_to_block (&se
->pre
, tmp
);
5041 se
->string_length
= dest_word_len
;
5045 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5047 ptr
= convert (build_pointer_type (mold_type
), source
);
5049 /* Use memcpy to do the transfer. */
5050 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5051 tmp
= build_call_expr_loc (input_location
,
5052 built_in_decls
[BUILT_IN_MEMCPY
], 3,
5053 fold_convert (pvoid_type_node
, tmp
),
5054 fold_convert (pvoid_type_node
, ptr
),
5056 gfc_add_expr_to_block (&se
->pre
, tmp
);
5063 /* Generate code for the ALLOCATED intrinsic.
5064 Generate inline code that directly check the address of the argument. */
5067 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5069 gfc_actual_arglist
*arg1
;
5074 gfc_init_se (&arg1se
, NULL
);
5075 arg1
= expr
->value
.function
.actual
;
5076 ss1
= gfc_walk_expr (arg1
->expr
);
5078 if (ss1
== gfc_ss_terminator
)
5080 /* Allocatable scalar. */
5081 arg1se
.want_pointer
= 1;
5082 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5083 gfc_add_component_ref (arg1
->expr
, "$data");
5084 gfc_conv_expr (&arg1se
, arg1
->expr
);
5089 /* Allocatable array. */
5090 arg1se
.descriptor_only
= 1;
5091 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5092 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5095 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5096 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5097 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5101 /* Generate code for the ASSOCIATED intrinsic.
5102 If both POINTER and TARGET are arrays, generate a call to library function
5103 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5104 In other cases, generate inline code that directly compare the address of
5105 POINTER with the address of TARGET. */
5108 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
5110 gfc_actual_arglist
*arg1
;
5111 gfc_actual_arglist
*arg2
;
5116 tree nonzero_charlen
;
5117 tree nonzero_arraylen
;
5120 gfc_init_se (&arg1se
, NULL
);
5121 gfc_init_se (&arg2se
, NULL
);
5122 arg1
= expr
->value
.function
.actual
;
5123 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5124 gfc_add_component_ref (arg1
->expr
, "$data");
5126 ss1
= gfc_walk_expr (arg1
->expr
);
5130 /* No optional target. */
5131 if (ss1
== gfc_ss_terminator
)
5133 /* A pointer to a scalar. */
5134 arg1se
.want_pointer
= 1;
5135 gfc_conv_expr (&arg1se
, arg1
->expr
);
5140 /* A pointer to an array. */
5141 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5142 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5144 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5145 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5146 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
5147 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
5152 /* An optional target. */
5153 if (arg2
->expr
->ts
.type
== BT_CLASS
)
5154 gfc_add_component_ref (arg2
->expr
, "$data");
5155 ss2
= gfc_walk_expr (arg2
->expr
);
5157 nonzero_charlen
= NULL_TREE
;
5158 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
5159 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
5161 arg1
->expr
->ts
.u
.cl
->backend_decl
,
5164 if (ss1
== gfc_ss_terminator
)
5166 /* A pointer to a scalar. */
5167 gcc_assert (ss2
== gfc_ss_terminator
);
5168 arg1se
.want_pointer
= 1;
5169 gfc_conv_expr (&arg1se
, arg1
->expr
);
5170 arg2se
.want_pointer
= 1;
5171 gfc_conv_expr (&arg2se
, arg2
->expr
);
5172 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5173 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5174 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5175 arg1se
.expr
, arg2se
.expr
);
5176 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5177 arg1se
.expr
, null_pointer_node
);
5178 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5179 boolean_type_node
, tmp
, tmp2
);
5183 /* An array pointer of zero length is not associated if target is
5185 arg1se
.descriptor_only
= 1;
5186 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
5187 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
,
5188 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
5189 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
5190 boolean_type_node
, tmp
,
5191 build_int_cst (TREE_TYPE (tmp
), 0));
5193 /* A pointer to an array, call library function _gfor_associated. */
5194 gcc_assert (ss2
!= gfc_ss_terminator
);
5195 arg1se
.want_pointer
= 1;
5196 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5198 arg2se
.want_pointer
= 1;
5199 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
5200 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
5201 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
5202 se
->expr
= build_call_expr_loc (input_location
,
5203 gfor_fndecl_associated
, 2,
5204 arg1se
.expr
, arg2se
.expr
);
5205 se
->expr
= convert (boolean_type_node
, se
->expr
);
5206 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5207 boolean_type_node
, se
->expr
,
5211 /* If target is present zero character length pointers cannot
5213 if (nonzero_charlen
!= NULL_TREE
)
5214 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5216 se
->expr
, nonzero_charlen
);
5219 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5223 /* Generate code for the SAME_TYPE_AS intrinsic.
5224 Generate inline code that directly checks the vindices. */
5227 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
5233 gfc_init_se (&se1
, NULL
);
5234 gfc_init_se (&se2
, NULL
);
5236 a
= expr
->value
.function
.actual
->expr
;
5237 b
= expr
->value
.function
.actual
->next
->expr
;
5239 if (a
->ts
.type
== BT_CLASS
)
5241 gfc_add_component_ref (a
, "$vptr");
5242 gfc_add_component_ref (a
, "$hash");
5244 else if (a
->ts
.type
== BT_DERIVED
)
5245 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5246 a
->ts
.u
.derived
->hash_value
);
5248 if (b
->ts
.type
== BT_CLASS
)
5250 gfc_add_component_ref (b
, "$vptr");
5251 gfc_add_component_ref (b
, "$hash");
5253 else if (b
->ts
.type
== BT_DERIVED
)
5254 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5255 b
->ts
.u
.derived
->hash_value
);
5257 gfc_conv_expr (&se1
, a
);
5258 gfc_conv_expr (&se2
, b
);
5260 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5261 se1
.expr
, fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
5262 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5266 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
5269 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
5273 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5274 se
->expr
= build_call_expr_loc (input_location
,
5275 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
5276 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5280 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
5283 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
5287 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5289 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5290 type
= gfc_get_int_type (4);
5291 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
5293 /* Convert it to the required type. */
5294 type
= gfc_typenode_for_spec (&expr
->ts
);
5295 se
->expr
= build_call_expr_loc (input_location
,
5296 gfor_fndecl_si_kind
, 1, arg
);
5297 se
->expr
= fold_convert (type
, se
->expr
);
5301 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
5304 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
5306 gfc_actual_arglist
*actual
;
5309 VEC(tree
,gc
) *args
= NULL
;
5311 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
5313 gfc_init_se (&argse
, se
);
5315 /* Pass a NULL pointer for an absent arg. */
5316 if (actual
->expr
== NULL
)
5317 argse
.expr
= null_pointer_node
;
5323 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
5325 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
5326 ts
.type
= BT_INTEGER
;
5327 ts
.kind
= gfc_c_int_kind
;
5328 gfc_convert_type (actual
->expr
, &ts
, 2);
5330 gfc_conv_expr_reference (&argse
, actual
->expr
);
5333 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5334 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5335 VEC_safe_push (tree
, gc
, args
, argse
.expr
);
5338 /* Convert it to the required type. */
5339 type
= gfc_typenode_for_spec (&expr
->ts
);
5340 se
->expr
= build_call_expr_loc_vec (input_location
,
5341 gfor_fndecl_sr_kind
, args
);
5342 se
->expr
= fold_convert (type
, se
->expr
);
5346 /* Generate code for TRIM (A) intrinsic function. */
5349 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
5359 unsigned int num_args
;
5361 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
5362 args
= XALLOCAVEC (tree
, num_args
);
5364 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
5365 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
5366 len
= gfc_create_var (gfc_charlen_type_node
, "len");
5368 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
5369 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
5372 if (expr
->ts
.kind
== 1)
5373 function
= gfor_fndecl_string_trim
;
5374 else if (expr
->ts
.kind
== 4)
5375 function
= gfor_fndecl_string_trim_char4
;
5379 fndecl
= build_addr (function
, current_function_decl
);
5380 tmp
= build_call_array_loc (input_location
,
5381 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
5383 gfc_add_expr_to_block (&se
->pre
, tmp
);
5385 /* Free the temporary afterwards, if necessary. */
5386 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
5387 len
, build_int_cst (TREE_TYPE (len
), 0));
5388 tmp
= gfc_call_free (var
);
5389 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
5390 gfc_add_expr_to_block (&se
->post
, tmp
);
5393 se
->string_length
= len
;
5397 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
5400 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
5402 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
5403 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
5405 stmtblock_t block
, body
;
5408 /* We store in charsize the size of a character. */
5409 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
5410 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
5412 /* Get the arguments. */
5413 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5414 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
5416 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
5417 ncopies_type
= TREE_TYPE (ncopies
);
5419 /* Check that NCOPIES is not negative. */
5420 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
5421 build_int_cst (ncopies_type
, 0));
5422 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
5423 "Argument NCOPIES of REPEAT intrinsic is negative "
5424 "(its value is %lld)",
5425 fold_convert (long_integer_type_node
, ncopies
));
5427 /* If the source length is zero, any non negative value of NCOPIES
5428 is valid, and nothing happens. */
5429 n
= gfc_create_var (ncopies_type
, "ncopies");
5430 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
5431 build_int_cst (size_type_node
, 0));
5432 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
5433 build_int_cst (ncopies_type
, 0), ncopies
);
5434 gfc_add_modify (&se
->pre
, n
, tmp
);
5437 /* Check that ncopies is not too large: ncopies should be less than
5438 (or equal to) MAX / slen, where MAX is the maximal integer of
5439 the gfc_charlen_type_node type. If slen == 0, we need a special
5440 case to avoid the division by zero. */
5441 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5442 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
5443 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
5444 fold_convert (size_type_node
, max
), slen
);
5445 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
5446 ? size_type_node
: ncopies_type
;
5447 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
5448 fold_convert (largest
, ncopies
),
5449 fold_convert (largest
, max
));
5450 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
5451 build_int_cst (size_type_node
, 0));
5452 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
5453 boolean_false_node
, cond
);
5454 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
5455 "Argument NCOPIES of REPEAT intrinsic is too large");
5457 /* Compute the destination length. */
5458 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
5459 fold_convert (gfc_charlen_type_node
, slen
),
5460 fold_convert (gfc_charlen_type_node
, ncopies
));
5461 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
5462 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
5464 /* Generate the code to do the repeat operation:
5465 for (i = 0; i < ncopies; i++)
5466 memmove (dest + (i * slen * size), src, slen*size); */
5467 gfc_start_block (&block
);
5468 count
= gfc_create_var (ncopies_type
, "count");
5469 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
5470 exit_label
= gfc_build_label_decl (NULL_TREE
);
5472 /* Start the loop body. */
5473 gfc_start_block (&body
);
5475 /* Exit the loop if count >= ncopies. */
5476 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
5478 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5479 TREE_USED (exit_label
) = 1;
5480 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5481 build_empty_stmt (input_location
));
5482 gfc_add_expr_to_block (&body
, tmp
);
5484 /* Call memmove (dest + (i*slen*size), src, slen*size). */
5485 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
5486 fold_convert (gfc_charlen_type_node
, slen
),
5487 fold_convert (gfc_charlen_type_node
, count
));
5488 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
5489 tmp
, fold_convert (gfc_charlen_type_node
, size
));
5490 tmp
= fold_build2_loc (input_location
, POINTER_PLUS_EXPR
, pvoid_type_node
,
5491 fold_convert (pvoid_type_node
, dest
),
5492 fold_convert (sizetype
, tmp
));
5493 tmp
= build_call_expr_loc (input_location
,
5494 built_in_decls
[BUILT_IN_MEMMOVE
], 3, tmp
, src
,
5495 fold_build2_loc (input_location
, MULT_EXPR
,
5496 size_type_node
, slen
,
5497 fold_convert (size_type_node
,
5499 gfc_add_expr_to_block (&body
, tmp
);
5501 /* Increment count. */
5502 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
5503 count
, build_int_cst (TREE_TYPE (count
), 1));
5504 gfc_add_modify (&body
, count
, tmp
);
5506 /* Build the loop. */
5507 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
5508 gfc_add_expr_to_block (&block
, tmp
);
5510 /* Add the exit label. */
5511 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5512 gfc_add_expr_to_block (&block
, tmp
);
5514 /* Finish the block. */
5515 tmp
= gfc_finish_block (&block
);
5516 gfc_add_expr_to_block (&se
->pre
, tmp
);
5518 /* Set the result value. */
5520 se
->string_length
= dlen
;
5524 /* Generate code for the IARGC intrinsic. */
5527 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
5533 /* Call the library function. This always returns an INTEGER(4). */
5534 fndecl
= gfor_fndecl_iargc
;
5535 tmp
= build_call_expr_loc (input_location
,
5538 /* Convert it to the required type. */
5539 type
= gfc_typenode_for_spec (&expr
->ts
);
5540 tmp
= fold_convert (type
, tmp
);
5546 /* The loc intrinsic returns the address of its argument as
5547 gfc_index_integer_kind integer. */
5550 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
5556 gcc_assert (!se
->ss
);
5558 arg_expr
= expr
->value
.function
.actual
->expr
;
5559 ss
= gfc_walk_expr (arg_expr
);
5560 if (ss
== gfc_ss_terminator
)
5561 gfc_conv_expr_reference (se
, arg_expr
);
5563 gfc_conv_array_parameter (se
, arg_expr
, ss
, true, NULL
, NULL
, NULL
);
5564 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
5566 /* Create a temporary variable for loc return value. Without this,
5567 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
5568 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
5569 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
5570 se
->expr
= temp_var
;
5573 /* Generate code for an intrinsic function. Some map directly to library
5574 calls, others get special handling. In some cases the name of the function
5575 used depends on the type specifiers. */
5578 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
5584 name
= &expr
->value
.function
.name
[2];
5586 if (expr
->rank
> 0 && !expr
->inline_noncopying_intrinsic
)
5588 lib
= gfc_is_intrinsic_libcall (expr
);
5592 se
->ignore_optional
= 1;
5594 switch (expr
->value
.function
.isym
->id
)
5596 case GFC_ISYM_EOSHIFT
:
5598 case GFC_ISYM_RESHAPE
:
5599 /* For all of those the first argument specifies the type and the
5600 third is optional. */
5601 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
5605 gfc_conv_intrinsic_funcall (se
, expr
);
5613 switch (expr
->value
.function
.isym
->id
)
5618 case GFC_ISYM_REPEAT
:
5619 gfc_conv_intrinsic_repeat (se
, expr
);
5623 gfc_conv_intrinsic_trim (se
, expr
);
5626 case GFC_ISYM_SC_KIND
:
5627 gfc_conv_intrinsic_sc_kind (se
, expr
);
5630 case GFC_ISYM_SI_KIND
:
5631 gfc_conv_intrinsic_si_kind (se
, expr
);
5634 case GFC_ISYM_SR_KIND
:
5635 gfc_conv_intrinsic_sr_kind (se
, expr
);
5638 case GFC_ISYM_EXPONENT
:
5639 gfc_conv_intrinsic_exponent (se
, expr
);
5643 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5645 fndecl
= gfor_fndecl_string_scan
;
5647 fndecl
= gfor_fndecl_string_scan_char4
;
5651 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
5654 case GFC_ISYM_VERIFY
:
5655 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5657 fndecl
= gfor_fndecl_string_verify
;
5659 fndecl
= gfor_fndecl_string_verify_char4
;
5663 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
5666 case GFC_ISYM_ALLOCATED
:
5667 gfc_conv_allocated (se
, expr
);
5670 case GFC_ISYM_ASSOCIATED
:
5671 gfc_conv_associated(se
, expr
);
5674 case GFC_ISYM_SAME_TYPE_AS
:
5675 gfc_conv_same_type_as (se
, expr
);
5679 gfc_conv_intrinsic_abs (se
, expr
);
5682 case GFC_ISYM_ADJUSTL
:
5683 if (expr
->ts
.kind
== 1)
5684 fndecl
= gfor_fndecl_adjustl
;
5685 else if (expr
->ts
.kind
== 4)
5686 fndecl
= gfor_fndecl_adjustl_char4
;
5690 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
5693 case GFC_ISYM_ADJUSTR
:
5694 if (expr
->ts
.kind
== 1)
5695 fndecl
= gfor_fndecl_adjustr
;
5696 else if (expr
->ts
.kind
== 4)
5697 fndecl
= gfor_fndecl_adjustr_char4
;
5701 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
5704 case GFC_ISYM_AIMAG
:
5705 gfc_conv_intrinsic_imagpart (se
, expr
);
5709 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
5713 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
5716 case GFC_ISYM_ANINT
:
5717 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
5721 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
5725 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
5728 case GFC_ISYM_BTEST
:
5729 gfc_conv_intrinsic_btest (se
, expr
);
5733 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
5737 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
5741 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
5745 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
5748 case GFC_ISYM_ACHAR
:
5750 gfc_conv_intrinsic_char (se
, expr
);
5753 case GFC_ISYM_CONVERSION
:
5755 case GFC_ISYM_LOGICAL
:
5757 gfc_conv_intrinsic_conversion (se
, expr
);
5760 /* Integer conversions are handled separately to make sure we get the
5761 correct rounding mode. */
5766 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
5770 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
5773 case GFC_ISYM_CEILING
:
5774 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
5777 case GFC_ISYM_FLOOR
:
5778 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
5782 gfc_conv_intrinsic_mod (se
, expr
, 0);
5785 case GFC_ISYM_MODULO
:
5786 gfc_conv_intrinsic_mod (se
, expr
, 1);
5789 case GFC_ISYM_CMPLX
:
5790 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
5793 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
5794 gfc_conv_intrinsic_iargc (se
, expr
);
5797 case GFC_ISYM_COMPLEX
:
5798 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
5801 case GFC_ISYM_CONJG
:
5802 gfc_conv_intrinsic_conjg (se
, expr
);
5805 case GFC_ISYM_COUNT
:
5806 gfc_conv_intrinsic_count (se
, expr
);
5809 case GFC_ISYM_CTIME
:
5810 gfc_conv_intrinsic_ctime (se
, expr
);
5814 gfc_conv_intrinsic_dim (se
, expr
);
5817 case GFC_ISYM_DOT_PRODUCT
:
5818 gfc_conv_intrinsic_dot_product (se
, expr
);
5821 case GFC_ISYM_DPROD
:
5822 gfc_conv_intrinsic_dprod (se
, expr
);
5825 case GFC_ISYM_DSHIFTL
:
5826 gfc_conv_intrinsic_dshift (se
, expr
, true);
5829 case GFC_ISYM_DSHIFTR
:
5830 gfc_conv_intrinsic_dshift (se
, expr
, false);
5833 case GFC_ISYM_FDATE
:
5834 gfc_conv_intrinsic_fdate (se
, expr
);
5837 case GFC_ISYM_FRACTION
:
5838 gfc_conv_intrinsic_fraction (se
, expr
);
5842 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
5846 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
5850 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
5853 case GFC_ISYM_IBCLR
:
5854 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
5857 case GFC_ISYM_IBITS
:
5858 gfc_conv_intrinsic_ibits (se
, expr
);
5861 case GFC_ISYM_IBSET
:
5862 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
5865 case GFC_ISYM_IACHAR
:
5866 case GFC_ISYM_ICHAR
:
5867 /* We assume ASCII character sequence. */
5868 gfc_conv_intrinsic_ichar (se
, expr
);
5871 case GFC_ISYM_IARGC
:
5872 gfc_conv_intrinsic_iargc (se
, expr
);
5876 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
5879 case GFC_ISYM_INDEX
:
5880 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5882 fndecl
= gfor_fndecl_string_index
;
5884 fndecl
= gfor_fndecl_string_index_char4
;
5888 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
5892 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
5895 case GFC_ISYM_IPARITY
:
5896 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
5899 case GFC_ISYM_IS_IOSTAT_END
:
5900 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
5903 case GFC_ISYM_IS_IOSTAT_EOR
:
5904 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
5907 case GFC_ISYM_ISNAN
:
5908 gfc_conv_intrinsic_isnan (se
, expr
);
5911 case GFC_ISYM_LSHIFT
:
5912 gfc_conv_intrinsic_shift (se
, expr
, false, false);
5915 case GFC_ISYM_RSHIFT
:
5916 gfc_conv_intrinsic_shift (se
, expr
, true, true);
5919 case GFC_ISYM_SHIFTA
:
5920 gfc_conv_intrinsic_shift (se
, expr
, true, true);
5923 case GFC_ISYM_SHIFTL
:
5924 gfc_conv_intrinsic_shift (se
, expr
, false, false);
5927 case GFC_ISYM_SHIFTR
:
5928 gfc_conv_intrinsic_shift (se
, expr
, true, false);
5931 case GFC_ISYM_ISHFT
:
5932 gfc_conv_intrinsic_ishft (se
, expr
);
5935 case GFC_ISYM_ISHFTC
:
5936 gfc_conv_intrinsic_ishftc (se
, expr
);
5939 case GFC_ISYM_LEADZ
:
5940 gfc_conv_intrinsic_leadz (se
, expr
);
5943 case GFC_ISYM_TRAILZ
:
5944 gfc_conv_intrinsic_trailz (se
, expr
);
5947 case GFC_ISYM_POPCNT
:
5948 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
5951 case GFC_ISYM_POPPAR
:
5952 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
5955 case GFC_ISYM_LBOUND
:
5956 gfc_conv_intrinsic_bound (se
, expr
, 0);
5959 case GFC_ISYM_TRANSPOSE
:
5960 if (se
->ss
&& se
->ss
->useflags
)
5962 gfc_conv_tmp_array_ref (se
);
5963 gfc_advance_se_ss_chain (se
);
5966 gfc_conv_array_transpose (se
, expr
->value
.function
.actual
->expr
);
5970 gfc_conv_intrinsic_len (se
, expr
);
5973 case GFC_ISYM_LEN_TRIM
:
5974 gfc_conv_intrinsic_len_trim (se
, expr
);
5978 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
5982 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
5986 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
5990 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
5993 case GFC_ISYM_MASKL
:
5994 gfc_conv_intrinsic_mask (se
, expr
, 1);
5997 case GFC_ISYM_MASKR
:
5998 gfc_conv_intrinsic_mask (se
, expr
, 0);
6002 if (expr
->ts
.type
== BT_CHARACTER
)
6003 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
6005 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
6008 case GFC_ISYM_MAXLOC
:
6009 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
6012 case GFC_ISYM_MAXVAL
:
6013 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
6016 case GFC_ISYM_MERGE
:
6017 gfc_conv_intrinsic_merge (se
, expr
);
6020 case GFC_ISYM_MERGE_BITS
:
6021 gfc_conv_intrinsic_merge_bits (se
, expr
);
6025 if (expr
->ts
.type
== BT_CHARACTER
)
6026 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
6028 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
6031 case GFC_ISYM_MINLOC
:
6032 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
6035 case GFC_ISYM_MINVAL
:
6036 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
6039 case GFC_ISYM_NEAREST
:
6040 gfc_conv_intrinsic_nearest (se
, expr
);
6043 case GFC_ISYM_NORM2
:
6044 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
6048 gfc_conv_intrinsic_not (se
, expr
);
6052 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6055 case GFC_ISYM_PARITY
:
6056 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
6059 case GFC_ISYM_PRESENT
:
6060 gfc_conv_intrinsic_present (se
, expr
);
6063 case GFC_ISYM_PRODUCT
:
6064 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
6067 case GFC_ISYM_RRSPACING
:
6068 gfc_conv_intrinsic_rrspacing (se
, expr
);
6071 case GFC_ISYM_SET_EXPONENT
:
6072 gfc_conv_intrinsic_set_exponent (se
, expr
);
6075 case GFC_ISYM_SCALE
:
6076 gfc_conv_intrinsic_scale (se
, expr
);
6080 gfc_conv_intrinsic_sign (se
, expr
);
6084 gfc_conv_intrinsic_size (se
, expr
);
6087 case GFC_ISYM_SIZEOF
:
6088 case GFC_ISYM_C_SIZEOF
:
6089 gfc_conv_intrinsic_sizeof (se
, expr
);
6092 case GFC_ISYM_STORAGE_SIZE
:
6093 gfc_conv_intrinsic_storage_size (se
, expr
);
6096 case GFC_ISYM_SPACING
:
6097 gfc_conv_intrinsic_spacing (se
, expr
);
6101 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
6104 case GFC_ISYM_TRANSFER
:
6105 if (se
->ss
&& se
->ss
->useflags
)
6107 /* Access the previously obtained result. */
6108 gfc_conv_tmp_array_ref (se
);
6109 gfc_advance_se_ss_chain (se
);
6112 gfc_conv_intrinsic_transfer (se
, expr
);
6115 case GFC_ISYM_TTYNAM
:
6116 gfc_conv_intrinsic_ttynam (se
, expr
);
6119 case GFC_ISYM_UBOUND
:
6120 gfc_conv_intrinsic_bound (se
, expr
, 1);
6124 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6128 gfc_conv_intrinsic_loc (se
, expr
);
6131 case GFC_ISYM_ACCESS
:
6132 case GFC_ISYM_CHDIR
:
6133 case GFC_ISYM_CHMOD
:
6134 case GFC_ISYM_DTIME
:
6135 case GFC_ISYM_ETIME
:
6136 case GFC_ISYM_EXTENDS_TYPE_OF
:
6138 case GFC_ISYM_FGETC
:
6141 case GFC_ISYM_FPUTC
:
6142 case GFC_ISYM_FSTAT
:
6143 case GFC_ISYM_FTELL
:
6144 case GFC_ISYM_GETCWD
:
6145 case GFC_ISYM_GETGID
:
6146 case GFC_ISYM_GETPID
:
6147 case GFC_ISYM_GETUID
:
6148 case GFC_ISYM_HOSTNM
:
6150 case GFC_ISYM_IERRNO
:
6151 case GFC_ISYM_IRAND
:
6152 case GFC_ISYM_ISATTY
:
6155 case GFC_ISYM_LSTAT
:
6156 case GFC_ISYM_MALLOC
:
6157 case GFC_ISYM_MATMUL
:
6158 case GFC_ISYM_MCLOCK
:
6159 case GFC_ISYM_MCLOCK8
:
6161 case GFC_ISYM_RENAME
:
6162 case GFC_ISYM_SECOND
:
6163 case GFC_ISYM_SECNDS
:
6164 case GFC_ISYM_SIGNAL
:
6166 case GFC_ISYM_SYMLNK
:
6167 case GFC_ISYM_SYSTEM
:
6169 case GFC_ISYM_TIME8
:
6170 case GFC_ISYM_UMASK
:
6171 case GFC_ISYM_UNLINK
:
6173 gfc_conv_intrinsic_funcall (se
, expr
);
6176 case GFC_ISYM_EOSHIFT
:
6178 case GFC_ISYM_RESHAPE
:
6179 /* For those, expr->rank should always be >0 and thus the if above the
6180 switch should have matched. */
6185 gfc_conv_intrinsic_lib_function (se
, expr
);
6191 /* This generates code to execute before entering the scalarization loop.
6192 Currently does nothing. */
6195 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
6197 switch (ss
->expr
->value
.function
.isym
->id
)
6199 case GFC_ISYM_UBOUND
:
6200 case GFC_ISYM_LBOUND
:
6209 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
6210 inside the scalarization loop. */
6213 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
6217 /* The two argument version returns a scalar. */
6218 if (expr
->value
.function
.actual
->next
->expr
)
6221 newss
= gfc_get_ss ();
6222 newss
->type
= GFC_SS_INTRINSIC
;
6225 newss
->data
.info
.dimen
= 1;
6231 /* Walk an intrinsic array libcall. */
6234 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
6238 gcc_assert (expr
->rank
> 0);
6240 newss
= gfc_get_ss ();
6241 newss
->type
= GFC_SS_FUNCTION
;
6244 newss
->data
.info
.dimen
= expr
->rank
;
6250 /* Returns nonzero if the specified intrinsic function call maps directly to
6251 an external library call. Should only be used for functions that return
6255 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
6257 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
6258 gcc_assert (expr
->rank
> 0);
6260 switch (expr
->value
.function
.isym
->id
)
6264 case GFC_ISYM_COUNT
:
6268 case GFC_ISYM_IPARITY
:
6269 case GFC_ISYM_MATMUL
:
6270 case GFC_ISYM_MAXLOC
:
6271 case GFC_ISYM_MAXVAL
:
6272 case GFC_ISYM_MINLOC
:
6273 case GFC_ISYM_MINVAL
:
6274 case GFC_ISYM_NORM2
:
6275 case GFC_ISYM_PARITY
:
6276 case GFC_ISYM_PRODUCT
:
6278 case GFC_ISYM_SHAPE
:
6279 case GFC_ISYM_SPREAD
:
6280 case GFC_ISYM_TRANSPOSE
:
6282 /* Ignore absent optional parameters. */
6285 case GFC_ISYM_RESHAPE
:
6286 case GFC_ISYM_CSHIFT
:
6287 case GFC_ISYM_EOSHIFT
:
6289 case GFC_ISYM_UNPACK
:
6290 /* Pass absent optional parameters. */
6298 /* Walk an intrinsic function. */
6300 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
6301 gfc_intrinsic_sym
* isym
)
6305 if (isym
->elemental
)
6306 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
, GFC_SS_SCALAR
);
6308 if (expr
->rank
== 0)
6311 if (gfc_is_intrinsic_libcall (expr
))
6312 return gfc_walk_intrinsic_libfunc (ss
, expr
);
6314 /* Special cases. */
6317 case GFC_ISYM_LBOUND
:
6318 case GFC_ISYM_UBOUND
:
6319 return gfc_walk_intrinsic_bound (ss
, expr
);
6321 case GFC_ISYM_TRANSFER
:
6322 return gfc_walk_intrinsic_libfunc (ss
, expr
);
6325 /* This probably meant someone forgot to add an intrinsic to the above
6326 list(s) when they implemented it, or something's gone horribly
6334 gfc_conv_intrinsic_move_alloc (gfc_code
*code
)
6336 if (code
->ext
.actual
->expr
->rank
== 0)
6338 /* Scalar arguments: Generate pointer assignments. */
6339 gfc_expr
*from
, *to
;
6343 from
= code
->ext
.actual
->expr
;
6344 to
= code
->ext
.actual
->next
->expr
;
6346 gfc_start_block (&block
);
6348 if (to
->ts
.type
== BT_CLASS
)
6349 tmp
= gfc_trans_class_assign (to
, from
, EXEC_POINTER_ASSIGN
);
6351 tmp
= gfc_trans_pointer_assignment (to
, from
);
6352 gfc_add_expr_to_block (&block
, tmp
);
6354 if (from
->ts
.type
== BT_CLASS
)
6355 tmp
= gfc_trans_class_assign (from
, gfc_get_null_expr (NULL
),
6356 EXEC_POINTER_ASSIGN
);
6358 tmp
= gfc_trans_pointer_assignment (from
,
6359 gfc_get_null_expr (NULL
));
6360 gfc_add_expr_to_block (&block
, tmp
);
6362 return gfc_finish_block (&block
);
6365 /* Array arguments: Generate library code. */
6366 return gfc_trans_call (code
, false, NULL_TREE
, NULL_TREE
, false);
6370 #include "gt-fortran-trans-intrinsic.h"