1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
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 enum built_in_function i
= END_BUILTINS
;
144 gfc_intrinsic_map_t
*m
;
145 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
148 if (precision
== TYPE_PRECISION (float_type_node
))
149 i
= m
->float_built_in
;
150 else if (precision
== TYPE_PRECISION (double_type_node
))
151 i
= m
->double_built_in
;
152 else if (precision
== TYPE_PRECISION (long_double_type_node
))
153 i
= m
->long_double_built_in
;
154 else if (precision
== TYPE_PRECISION (float128_type_node
))
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m
->real16_decl
;
161 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
169 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
171 if (gfc_real_kinds
[i
].c_float128
)
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t
*m
;
176 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
179 return m
->real16_decl
;
182 return builtin_decl_for_precision (double_built_in
,
183 gfc_real_kinds
[i
].mode_precision
);
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
193 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
194 tree
*argarray
, int nargs
)
196 gfc_actual_arglist
*actual
;
198 gfc_intrinsic_arg
*formal
;
202 formal
= expr
->value
.function
.isym
->formal
;
203 actual
= expr
->value
.function
.actual
;
205 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
206 actual
= actual
->next
,
207 formal
= formal
? formal
->next
: NULL
)
211 /* Skip omitted optional arguments. */
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse
, se
);
222 if (e
->ts
.type
== BT_CHARACTER
)
224 gfc_conv_expr (&argse
, e
);
225 gfc_conv_string_parameter (&argse
);
226 argarray
[curr_arg
++] = argse
.string_length
;
227 gcc_assert (curr_arg
< nargs
);
230 gfc_conv_expr_val (&argse
, e
);
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e
->expr_type
== EXPR_VARIABLE
235 && e
->symtree
->n
.sym
->attr
.optional
238 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
240 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
241 gfc_add_block_to_block (&se
->post
, &argse
.post
);
242 argarray
[curr_arg
] = argse
.expr
;
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
250 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
253 gfc_actual_arglist
*actual
;
255 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
260 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
274 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
280 nargs
= gfc_intrinsic_argument_list_length (expr
);
281 args
= XALLOCAVEC (tree
, nargs
);
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type
= gfc_typenode_for_spec (&expr
->ts
);
287 gcc_assert (expr
->value
.function
.actual
->expr
);
288 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
290 /* Conversion between character kinds involves a call to a library
292 if (expr
->ts
.type
== BT_CHARACTER
)
294 tree fndecl
, var
, addr
, tmp
;
296 if (expr
->ts
.kind
== 1
297 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
298 fndecl
= gfor_fndecl_convert_char4_to_char1
;
299 else if (expr
->ts
.kind
== 4
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
301 fndecl
= gfor_fndecl_convert_char1_to_char4
;
305 /* Create the variable storing the converted value. */
306 type
= gfc_get_pchar_type (expr
->ts
.kind
);
307 var
= gfc_create_var (type
, "str");
308 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs
>= 2);
312 tmp
= build_call_expr_loc (input_location
,
313 fndecl
, 3, addr
, args
[0], args
[1]);
314 gfc_add_expr_to_block (&se
->pre
, tmp
);
316 /* Free the temporary afterwards. */
317 tmp
= gfc_call_free (var
);
318 gfc_add_expr_to_block (&se
->post
, tmp
);
321 se
->string_length
= args
[0];
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
329 && expr
->ts
.type
!= BT_COMPLEX
)
333 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
334 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
338 se
->expr
= convert (type
, args
[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
354 argtype
= TREE_TYPE (arg
);
355 arg
= gfc_evaluate_now (arg
, pblock
);
357 intval
= convert (type
, arg
);
358 intval
= gfc_evaluate_now (intval
, pblock
);
360 tmp
= convert (argtype
, intval
);
361 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
362 boolean_type_node
, tmp
, arg
);
364 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
365 intval
, build_int_cst (type
, 1));
366 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg
, tree restype
)
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 type
, complex_type
, 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
= float128_type_node
;
630 complex_type
= complex_float128_type_node
;
631 /* type (*) (type) */
632 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
633 /* long (*) (type) */
634 func_lround
= build_function_type_list (long_integer_type_node
,
636 /* long long (*) (type) */
637 func_llround
= build_function_type_list (long_long_integer_type_node
,
639 /* type (*) (type, type) */
640 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
641 /* type (*) (type, &int) */
643 = build_function_type_list (type
,
645 build_pointer_type (integer_type_node
),
647 /* type (*) (type, int) */
648 func_scalbn
= build_function_type_list (type
,
649 type
, integer_type_node
, NULL_TREE
);
650 /* type (*) (complex type) */
651 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
652 /* complex type (*) (complex type, complex type) */
654 = build_function_type_list (complex_type
,
655 complex_type
, complex_type
, NULL_TREE
);
657 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
658 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
659 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
661 /* Only these built-ins are actually needed here. These are used directly
662 from the code, when calling builtin_decl_for_precision() or
663 builtin_decl_for_float_type(). The others are all constructed by
664 gfc_get_intrinsic_lib_fndecl(). */
665 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
666 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
668 #include "mathbuiltins.def"
672 #undef DEFINE_MATH_BUILTIN
673 #undef DEFINE_MATH_BUILTIN_C
677 /* Add GCC builtin functions. */
678 for (m
= gfc_intrinsic_map
;
679 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
681 if (m
->float_built_in
!= END_BUILTINS
)
682 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
683 if (m
->complex_float_built_in
!= END_BUILTINS
)
684 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
685 if (m
->double_built_in
!= END_BUILTINS
)
686 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
687 if (m
->complex_double_built_in
!= END_BUILTINS
)
688 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
690 /* If real(kind=10) exists, it is always long double. */
691 if (m
->long_double_built_in
!= END_BUILTINS
)
692 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
693 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
695 = builtin_decl_explicit (m
->complex_long_double_built_in
);
697 if (!gfc_real16_is_float128
)
699 if (m
->long_double_built_in
!= END_BUILTINS
)
700 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
701 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
703 = builtin_decl_explicit (m
->complex_long_double_built_in
);
705 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m
->real16_decl
= quad_decls
[m
->double_built_in
];
712 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
714 /* Same thing for the complex ones. */
715 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
721 /* Create a fndecl for a simple intrinsic library function. */
724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
727 VEC(tree
,gc
) *argtypes
;
729 gfc_actual_arglist
*actual
;
732 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
735 if (ts
->type
== BT_REAL
)
740 pdecl
= &m
->real4_decl
;
743 pdecl
= &m
->real8_decl
;
746 pdecl
= &m
->real10_decl
;
749 pdecl
= &m
->real16_decl
;
755 else if (ts
->type
== BT_COMPLEX
)
757 gcc_assert (m
->complex_available
);
762 pdecl
= &m
->complex4_decl
;
765 pdecl
= &m
->complex8_decl
;
768 pdecl
= &m
->complex10_decl
;
771 pdecl
= &m
->complex16_decl
;
785 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
786 if (gfc_real_kinds
[n
].c_float
)
787 snprintf (name
, sizeof (name
), "%s%s%s",
788 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
789 else if (gfc_real_kinds
[n
].c_double
)
790 snprintf (name
, sizeof (name
), "%s%s",
791 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
792 else if (gfc_real_kinds
[n
].c_long_double
)
793 snprintf (name
, sizeof (name
), "%s%s%s",
794 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
795 else if (gfc_real_kinds
[n
].c_float128
)
796 snprintf (name
, sizeof (name
), "%s%s%s",
797 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
803 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
804 ts
->type
== BT_COMPLEX
? 'c' : 'r',
809 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
811 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
812 VEC_safe_push (tree
, gc
, argtypes
, type
);
814 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
815 fndecl
= build_decl (input_location
,
816 FUNCTION_DECL
, get_identifier (name
), type
);
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl
) = 1;
820 TREE_PUBLIC (fndecl
) = 1;
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl
) = m
->is_constant
;
825 rest_of_decl_compilation (fndecl
, 1, 0);
832 /* Convert an intrinsic function into an external or builtin call. */
835 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
837 gfc_intrinsic_map_t
*m
;
841 unsigned int num_args
;
844 id
= expr
->value
.function
.isym
->id
;
845 /* Find the entry for this function. */
846 for (m
= gfc_intrinsic_map
;
847 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
853 if (m
->id
== GFC_ISYM_NONE
)
855 internal_error ("Intrinsic function %s(%d) not recognized",
856 expr
->value
.function
.name
, id
);
859 /* Get the decl and generate the call. */
860 num_args
= gfc_intrinsic_argument_list_length (expr
);
861 args
= XALLOCAVEC (tree
, num_args
);
863 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
864 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
865 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
867 fndecl
= build_addr (fndecl
, current_function_decl
);
868 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
877 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
878 tree a
, tree b
, stmtblock_t
* target
)
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
887 /* Compare the two string lengths. */
888 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
890 /* Output the runtime-check. */
891 name
= gfc_build_cstring_const (intr_name
);
892 name
= gfc_build_addr_expr (pchar_type_node
, name
);
893 gfc_trans_runtime_check (true, false, cond
, target
, where
,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node
, a
),
896 fold_convert (long_integer_type_node
, b
), name
);
900 /* The EXPONENT(s) intrinsic function is translated into
907 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
909 tree arg
, type
, res
, tmp
, frexp
;
911 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
912 expr
->value
.function
.actual
->expr
->ts
.kind
);
914 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
916 res
= gfc_create_var (integer_type_node
, NULL
);
917 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
918 gfc_build_addr_expr (NULL_TREE
, res
));
919 gfc_add_expr_to_block (&se
->pre
, tmp
);
921 type
= gfc_typenode_for_spec (&expr
->ts
);
922 se
->expr
= fold_convert (type
, res
);
926 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
927 AR_FULL, suitable for the scalarizer. */
930 walk_coarray (gfc_expr
*e
)
934 gcc_assert (gfc_get_corank (e
) > 0);
936 ss
= gfc_walk_expr (e
);
938 /* Fix scalar coarray. */
939 if (ss
== gfc_ss_terminator
)
946 if (ref
->type
== REF_ARRAY
947 && ref
->u
.ar
.codimen
> 0)
953 gcc_assert (ref
!= NULL
);
954 if (ref
->u
.ar
.type
== AR_ELEMENT
)
955 ref
->u
.ar
.type
= AR_SECTION
;
956 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
964 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
967 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
968 lbound
, ubound
, extent
, ml
;
973 /* The case -fcoarray=single is handled elsewhere. */
974 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
976 gfc_init_coarray_decl (false);
978 /* Argument-free version: THIS_IMAGE(). */
979 if (expr
->value
.function
.actual
->expr
== NULL
)
981 se
->expr
= gfort_gvar_caf_this_image
;
985 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
987 type
= gfc_get_int_type (gfc_default_integer_kind
);
988 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
989 rank
= expr
->value
.function
.actual
->expr
->rank
;
991 /* Obtain the descriptor of the COARRAY. */
992 gfc_init_se (&argse
, NULL
);
993 ss
= walk_coarray (expr
->value
.function
.actual
->expr
);
994 gcc_assert (ss
!= gfc_ss_terminator
);
995 argse
.want_coarray
= 1;
996 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
, ss
);
997 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
998 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1003 /* Create an implicit second parameter from the loop variable. */
1004 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
1005 gcc_assert (corank
> 0);
1006 gcc_assert (se
->loop
->dimen
== 1);
1007 gcc_assert (se
->ss
->info
->expr
== expr
);
1009 dim_arg
= se
->loop
->loopvar
[0];
1010 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
1011 gfc_array_index_type
, dim_arg
,
1012 build_int_cst (TREE_TYPE (dim_arg
), 1));
1013 gfc_advance_se_ss_chain (se
);
1017 /* Use the passed DIM= argument. */
1018 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
1019 gfc_init_se (&argse
, NULL
);
1020 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
1021 gfc_array_index_type
);
1022 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1023 dim_arg
= argse
.expr
;
1025 if (INTEGER_CST_P (dim_arg
))
1029 hi
= TREE_INT_CST_HIGH (dim_arg
);
1030 co_dim
= TREE_INT_CST_LOW (dim_arg
);
1031 if (hi
|| co_dim
< 1
1032 || co_dim
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
1033 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1034 "dimension index", expr
->value
.function
.isym
->name
,
1037 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1039 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1040 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1042 build_int_cst (TREE_TYPE (dim_arg
), 1));
1043 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1044 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1046 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1047 boolean_type_node
, cond
, tmp
);
1048 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1053 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1054 one always has a dim_arg argument.
1056 m = this_images() - 1
1059 sub(1) = m + lcobound(corank)
1063 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1066 extent = gfc_extent(i)
1074 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1075 : m + lcobound(corank)
1078 /* this_image () - 1. */
1079 tmp
= fold_convert (type
, gfort_gvar_caf_this_image
);
1080 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, tmp
,
1081 build_int_cst (type
, 1));
1084 /* sub(1) = m + lcobound(corank). */
1085 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1086 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1088 lbound
= fold_convert (type
, lbound
);
1089 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1095 m
= gfc_create_var (type
, NULL
);
1096 ml
= gfc_create_var (type
, NULL
);
1097 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1098 min_var
= gfc_create_var (integer_type_node
, NULL
);
1100 /* m = this_image () - 1. */
1101 gfc_add_modify (&se
->pre
, m
, tmp
);
1103 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1104 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1105 fold_convert (integer_type_node
, dim_arg
),
1106 build_int_cst (integer_type_node
, rank
- 1));
1107 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1108 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1110 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1113 tmp
= build_int_cst (integer_type_node
, rank
);
1114 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1116 exit_label
= gfc_build_label_decl (NULL_TREE
);
1117 TREE_USED (exit_label
) = 1;
1120 gfc_init_block (&loop
);
1123 gfc_add_modify (&loop
, ml
, m
);
1126 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1127 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1128 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1129 extent
= fold_convert (type
, extent
);
1132 gfc_add_modify (&loop
, m
,
1133 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1136 /* Exit condition: if (i >= min_var) goto exit_label. */
1137 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1139 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1140 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1141 build_empty_stmt (input_location
));
1142 gfc_add_expr_to_block (&loop
, tmp
);
1144 /* Increment loop variable: i++. */
1145 gfc_add_modify (&loop
, loop_var
,
1146 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1148 build_int_cst (integer_type_node
, 1)));
1150 /* Making the loop... actually loop! */
1151 tmp
= gfc_finish_block (&loop
);
1152 tmp
= build1_v (LOOP_EXPR
, tmp
);
1153 gfc_add_expr_to_block (&se
->pre
, tmp
);
1155 /* The exit label. */
1156 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1157 gfc_add_expr_to_block (&se
->pre
, tmp
);
1159 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1160 : m + lcobound(corank) */
1162 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1163 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1165 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1166 fold_build2_loc (input_location
, PLUS_EXPR
,
1167 gfc_array_index_type
, dim_arg
,
1168 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1169 lbound
= fold_convert (type
, lbound
);
1171 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1172 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1174 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1176 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1177 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1183 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1185 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1187 gfc_se argse
, subse
;
1189 int rank
, corank
, codim
;
1191 type
= gfc_get_int_type (gfc_default_integer_kind
);
1192 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1193 rank
= expr
->value
.function
.actual
->expr
->rank
;
1195 /* Obtain the descriptor of the COARRAY. */
1196 gfc_init_se (&argse
, NULL
);
1197 ss
= walk_coarray (expr
->value
.function
.actual
->expr
);
1198 gcc_assert (ss
!= gfc_ss_terminator
);
1199 argse
.want_coarray
= 1;
1200 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
, ss
);
1201 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1202 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1205 /* Obtain a handle to the SUB argument. */
1206 gfc_init_se (&subse
, NULL
);
1207 subss
= gfc_walk_expr (expr
->value
.function
.actual
->next
->expr
);
1208 gcc_assert (subss
!= gfc_ss_terminator
);
1209 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
,
1211 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1212 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1213 subdesc
= build_fold_indirect_ref_loc (input_location
,
1214 gfc_conv_descriptor_data_get (subse
.expr
));
1216 /* Fortran 2008 does not require that the values remain in the cobounds,
1217 thus we need explicitly check this - and return 0 if they are exceeded. */
1219 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1220 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1221 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1222 fold_convert (gfc_array_index_type
, tmp
),
1225 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1227 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1228 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1229 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1230 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1231 fold_convert (gfc_array_index_type
, tmp
),
1233 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1234 boolean_type_node
, invalid_bound
, cond
);
1235 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1236 fold_convert (gfc_array_index_type
, tmp
),
1238 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1239 boolean_type_node
, invalid_bound
, cond
);
1242 invalid_bound
= gfc_unlikely (invalid_bound
);
1245 /* See Fortran 2008, C.10 for the following algorithm. */
1247 /* coindex = sub(corank) - lcobound(n). */
1248 coindex
= fold_convert (gfc_array_index_type
,
1249 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1251 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1252 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1253 fold_convert (gfc_array_index_type
, coindex
),
1256 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1258 tree extent
, ubound
;
1260 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1261 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1262 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1263 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1265 /* coindex *= extent. */
1266 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1267 gfc_array_index_type
, coindex
, extent
);
1269 /* coindex += sub(codim). */
1270 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1271 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1272 gfc_array_index_type
, coindex
,
1273 fold_convert (gfc_array_index_type
, tmp
));
1275 /* coindex -= lbound(codim). */
1276 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1277 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1278 gfc_array_index_type
, coindex
, lbound
);
1281 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1282 fold_convert(type
, coindex
),
1283 build_int_cst (type
, 1));
1285 /* Return 0 if "coindex" exceeds num_images(). */
1287 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1288 num_images
= build_int_cst (type
, 1);
1291 gfc_init_coarray_decl (false);
1292 num_images
= gfort_gvar_caf_num_images
;
1295 tmp
= gfc_create_var (type
, NULL
);
1296 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1298 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1300 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1302 fold_convert (boolean_type_node
, invalid_bound
));
1303 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1304 build_int_cst (type
, 0), tmp
);
1309 trans_num_images (gfc_se
* se
)
1311 gfc_init_coarray_decl (false);
1312 se
->expr
= gfort_gvar_caf_num_images
;
1316 /* Evaluate a single upper or lower bound. */
1317 /* TODO: bound intrinsic generates way too much unnecessary code. */
1320 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1322 gfc_actual_arglist
*arg
;
1323 gfc_actual_arglist
*arg2
;
1328 tree cond
, cond1
, cond3
, cond4
, size
;
1333 gfc_array_spec
* as
;
1335 arg
= expr
->value
.function
.actual
;
1340 /* Create an implicit second parameter from the loop variable. */
1341 gcc_assert (!arg2
->expr
);
1342 gcc_assert (se
->loop
->dimen
== 1);
1343 gcc_assert (se
->ss
->info
->expr
== expr
);
1344 gfc_advance_se_ss_chain (se
);
1345 bound
= se
->loop
->loopvar
[0];
1346 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1347 gfc_array_index_type
, bound
,
1352 /* use the passed argument. */
1353 gcc_assert (arg2
->expr
);
1354 gfc_init_se (&argse
, NULL
);
1355 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1356 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1358 /* Convert from one based to zero based. */
1359 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1360 gfc_array_index_type
, bound
,
1361 gfc_index_one_node
);
1364 /* TODO: don't re-evaluate the descriptor on each iteration. */
1365 /* Get a descriptor for the first parameter. */
1366 ss
= gfc_walk_expr (arg
->expr
);
1367 gcc_assert (ss
!= gfc_ss_terminator
);
1368 gfc_init_se (&argse
, NULL
);
1369 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
1370 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1371 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1375 if (INTEGER_CST_P (bound
))
1379 hi
= TREE_INT_CST_HIGH (bound
);
1380 low
= TREE_INT_CST_LOW (bound
);
1381 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
1382 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1383 "dimension index", upper
? "UBOUND" : "LBOUND",
1388 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1390 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1391 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1392 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1393 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1394 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1396 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1397 boolean_type_node
, cond
, tmp
);
1398 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1403 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1404 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1406 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1408 /* 13.14.53: Result value for LBOUND
1410 Case (i): For an array section or for an array expression other than a
1411 whole array or array structure component, LBOUND(ARRAY, DIM)
1412 has the value 1. For a whole array or array structure
1413 component, LBOUND(ARRAY, DIM) has the value:
1414 (a) equal to the lower bound for subscript DIM of ARRAY if
1415 dimension DIM of ARRAY does not have extent zero
1416 or if ARRAY is an assumed-size array of rank DIM,
1419 13.14.113: Result value for UBOUND
1421 Case (i): For an array section or for an array expression other than a
1422 whole array or array structure component, UBOUND(ARRAY, DIM)
1423 has the value equal to the number of elements in the given
1424 dimension; otherwise, it has a value equal to the upper bound
1425 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1426 not have size zero and has value zero if dimension DIM has
1431 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1433 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1435 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1436 stride
, gfc_index_zero_node
);
1437 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1438 boolean_type_node
, cond3
, cond1
);
1439 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1440 stride
, gfc_index_zero_node
);
1445 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1446 boolean_type_node
, cond3
, cond4
);
1447 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1448 gfc_index_one_node
, lbound
);
1449 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1450 boolean_type_node
, cond4
, cond5
);
1452 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1453 boolean_type_node
, cond
, cond5
);
1455 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1456 gfc_array_index_type
, cond
,
1457 ubound
, gfc_index_zero_node
);
1461 if (as
->type
== AS_ASSUMED_SIZE
)
1462 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1463 bound
, build_int_cst (TREE_TYPE (bound
),
1464 arg
->expr
->rank
- 1));
1466 cond
= boolean_false_node
;
1468 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1469 boolean_type_node
, cond3
, cond4
);
1470 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1471 boolean_type_node
, cond
, cond1
);
1473 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1474 gfc_array_index_type
, cond
,
1475 lbound
, gfc_index_one_node
);
1482 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1483 gfc_array_index_type
, ubound
, lbound
);
1484 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1485 gfc_array_index_type
, size
,
1486 gfc_index_one_node
);
1487 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1488 gfc_array_index_type
, se
->expr
,
1489 gfc_index_zero_node
);
1492 se
->expr
= gfc_index_one_node
;
1495 type
= gfc_typenode_for_spec (&expr
->ts
);
1496 se
->expr
= convert (type
, se
->expr
);
1501 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
1503 gfc_actual_arglist
*arg
;
1504 gfc_actual_arglist
*arg2
;
1507 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
1511 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
1512 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
1513 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
1515 arg
= expr
->value
.function
.actual
;
1518 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
1519 corank
= gfc_get_corank (arg
->expr
);
1521 ss
= walk_coarray (arg
->expr
);
1522 gcc_assert (ss
!= gfc_ss_terminator
);
1523 gfc_init_se (&argse
, NULL
);
1524 argse
.want_coarray
= 1;
1526 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
1527 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1528 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1533 /* Create an implicit second parameter from the loop variable. */
1534 gcc_assert (!arg2
->expr
);
1535 gcc_assert (corank
> 0);
1536 gcc_assert (se
->loop
->dimen
== 1);
1537 gcc_assert (se
->ss
->info
->expr
== expr
);
1539 bound
= se
->loop
->loopvar
[0];
1540 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1541 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
1542 gfc_advance_se_ss_chain (se
);
1546 /* use the passed argument. */
1547 gcc_assert (arg2
->expr
);
1548 gfc_init_se (&argse
, NULL
);
1549 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1550 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1553 if (INTEGER_CST_P (bound
))
1557 hi
= TREE_INT_CST_HIGH (bound
);
1558 low
= TREE_INT_CST_LOW (bound
);
1559 if (hi
|| low
< 1 || low
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
1560 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1561 "dimension index", expr
->value
.function
.isym
->name
,
1564 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1566 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1567 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1568 bound
, build_int_cst (TREE_TYPE (bound
), 1));
1569 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1570 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1572 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1573 boolean_type_node
, cond
, tmp
);
1574 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1579 /* Substract 1 to get to zero based and add dimensions. */
1580 switch (arg
->expr
->rank
)
1583 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1584 gfc_array_index_type
, bound
,
1585 gfc_index_one_node
);
1589 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1590 gfc_array_index_type
, bound
,
1591 gfc_rank_cst
[arg
->expr
->rank
- 1]);
1595 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1597 /* Handle UCOBOUND with special handling of the last codimension. */
1598 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
1600 /* Last codimension: For -fcoarray=single just return
1601 the lcobound - otherwise add
1602 ceiling (real (num_images ()) / real (size)) - 1
1603 = (num_images () + size - 1) / size - 1
1604 = (num_images - 1) / size(),
1605 where size is the product of the extent of all but the last
1608 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
1612 gfc_init_coarray_decl (false);
1613 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
1615 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1616 gfc_array_index_type
,
1617 gfort_gvar_caf_num_images
,
1618 build_int_cst (gfc_array_index_type
, 1));
1619 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1620 gfc_array_index_type
, tmp
,
1621 fold_convert (gfc_array_index_type
, cosize
));
1622 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1623 gfc_array_index_type
, resbound
, tmp
);
1625 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
1627 /* ubound = lbound + num_images() - 1. */
1628 gfc_init_coarray_decl (false);
1629 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1630 gfc_array_index_type
,
1631 gfort_gvar_caf_num_images
,
1632 build_int_cst (gfc_array_index_type
, 1));
1633 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1634 gfc_array_index_type
, resbound
, tmp
);
1639 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1641 build_int_cst (TREE_TYPE (bound
),
1642 arg
->expr
->rank
+ corank
- 1));
1644 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1645 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1646 gfc_array_index_type
, cond
,
1647 resbound
, resbound2
);
1650 se
->expr
= resbound
;
1653 se
->expr
= resbound
;
1655 type
= gfc_typenode_for_spec (&expr
->ts
);
1656 se
->expr
= convert (type
, se
->expr
);
1661 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1665 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1667 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1671 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1676 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1677 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1686 /* Create a complex value from one or two real components. */
1689 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1695 unsigned int num_args
;
1697 num_args
= gfc_intrinsic_argument_list_length (expr
);
1698 args
= XALLOCAVEC (tree
, num_args
);
1700 type
= gfc_typenode_for_spec (&expr
->ts
);
1701 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1702 real
= convert (TREE_TYPE (type
), args
[0]);
1704 imag
= convert (TREE_TYPE (type
), args
[1]);
1705 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1707 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1708 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1709 imag
= convert (TREE_TYPE (type
), imag
);
1712 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1714 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1717 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1718 MODULO(A, P) = A - FLOOR (A / P) * P */
1719 /* TODO: MOD(x, 0) */
1722 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1734 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1736 switch (expr
->ts
.type
)
1739 /* Integer case is easy, we've got a builtin op. */
1740 type
= TREE_TYPE (args
[0]);
1743 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
1746 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
1752 /* Check if we have a builtin fmod. */
1753 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1755 /* Use it if it exists. */
1756 if (fmod
!= NULL_TREE
)
1758 tmp
= build_addr (fmod
, current_function_decl
);
1759 se
->expr
= build_call_array_loc (input_location
,
1760 TREE_TYPE (TREE_TYPE (fmod
)),
1766 type
= TREE_TYPE (args
[0]);
1768 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1769 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1772 modulo = arg - floor (arg/arg2) * arg2, so
1773 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1775 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1776 thereby avoiding another division and retaining the accuracy
1777 of the builtin function. */
1778 if (fmod
!= NULL_TREE
&& modulo
)
1780 tree zero
= gfc_build_const (type
, integer_zero_node
);
1781 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1782 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1784 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1786 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1787 boolean_type_node
, test
, test2
);
1788 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1790 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1791 boolean_type_node
, test
, test2
);
1792 test
= gfc_evaluate_now (test
, &se
->pre
);
1793 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1794 fold_build2_loc (input_location
, PLUS_EXPR
,
1795 type
, tmp
, args
[1]), tmp
);
1799 /* If we do not have a built_in fmod, the calculation is going to
1800 have to be done longhand. */
1801 tmp
= fold_build2_loc (input_location
, RDIV_EXPR
, type
, args
[0], args
[1]);
1803 /* Test if the value is too large to handle sensibly. */
1804 gfc_set_model_kind (expr
->ts
.kind
);
1806 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1807 ikind
= expr
->ts
.kind
;
1810 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1811 ikind
= gfc_max_integer_kind
;
1813 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1814 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1815 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1818 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1819 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1820 test
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1822 test2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1823 boolean_type_node
, test
, test2
);
1825 itype
= gfc_get_int_type (ikind
);
1827 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1829 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1830 tmp
= convert (type
, tmp
);
1831 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
, tmp
,
1833 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, tmp
, args
[1]);
1834 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0],
1844 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1845 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1846 where the right shifts are logical (i.e. 0's are shifted in).
1847 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1848 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1850 DSHIFTL(I,J,BITSIZE) = J
1852 DSHIFTR(I,J,BITSIZE) = I. */
1855 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
1857 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
1858 tree args
[3], cond
, tmp
;
1861 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
1863 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
1864 type
= TREE_TYPE (args
[0]);
1865 bitsize
= TYPE_PRECISION (type
);
1866 utype
= unsigned_type_for (type
);
1867 stype
= TREE_TYPE (args
[2]);
1869 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
1870 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
1871 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
1873 /* The generic case. */
1874 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
1875 build_int_cst (stype
, bitsize
), shift
);
1876 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
1877 arg1
, dshiftl
? shift
: tmp
);
1879 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
1880 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
1881 right
= fold_convert (type
, right
);
1883 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
1885 /* Special cases. */
1886 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1887 build_int_cst (stype
, 0));
1888 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1889 dshiftl
? arg1
: arg2
, res
);
1891 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1892 build_int_cst (stype
, bitsize
));
1893 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1894 dshiftl
? arg2
: arg1
, res
);
1900 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1903 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1911 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1912 type
= TREE_TYPE (args
[0]);
1914 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
1915 val
= gfc_evaluate_now (val
, &se
->pre
);
1917 zero
= gfc_build_const (type
, integer_zero_node
);
1918 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
1919 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
1923 /* SIGN(A, B) is absolute value of A times sign of B.
1924 The real value versions use library functions to ensure the correct
1925 handling of negative zero. Integer case implemented as:
1926 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1930 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1936 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1937 if (expr
->ts
.type
== BT_REAL
)
1941 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1942 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1944 /* We explicitly have to ignore the minus sign. We do so by using
1945 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1946 if (!gfc_option
.flag_sign_zero
1947 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1950 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1951 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1953 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1954 TREE_TYPE (args
[0]), cond
,
1955 build_call_expr_loc (input_location
, abs
, 1,
1957 build_call_expr_loc (input_location
, tmp
, 2,
1961 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1966 /* Having excluded floating point types, we know we are now dealing
1967 with signed integer types. */
1968 type
= TREE_TYPE (args
[0]);
1970 /* Args[0] is used multiple times below. */
1971 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1973 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1974 the signs of A and B are the same, and of all ones if they differ. */
1975 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1976 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
1977 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1978 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1980 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1981 is all ones (i.e. -1). */
1982 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
1983 fold_build2_loc (input_location
, PLUS_EXPR
,
1984 type
, args
[0], tmp
), tmp
);
1988 /* Test for the presence of an optional argument. */
1991 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1995 arg
= expr
->value
.function
.actual
->expr
;
1996 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1997 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1998 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2002 /* Calculate the double precision product of two single precision values. */
2005 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2010 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2012 /* Convert the args to double precision before multiplying. */
2013 type
= gfc_typenode_for_spec (&expr
->ts
);
2014 args
[0] = convert (type
, args
[0]);
2015 args
[1] = convert (type
, args
[1]);
2016 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2021 /* Return a length one character string containing an ascii character. */
2024 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2029 unsigned int num_args
;
2031 num_args
= gfc_intrinsic_argument_list_length (expr
);
2032 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2034 type
= gfc_get_char_type (expr
->ts
.kind
);
2035 var
= gfc_create_var (type
, "char");
2037 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2038 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2039 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2040 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2045 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2053 unsigned int num_args
;
2055 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2056 args
= XALLOCAVEC (tree
, num_args
);
2058 var
= gfc_create_var (pchar_type_node
, "pstr");
2059 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2061 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2062 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2063 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2065 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2066 tmp
= build_call_array_loc (input_location
,
2067 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2068 fndecl
, num_args
, args
);
2069 gfc_add_expr_to_block (&se
->pre
, tmp
);
2071 /* Free the temporary afterwards, if necessary. */
2072 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2073 len
, build_int_cst (TREE_TYPE (len
), 0));
2074 tmp
= gfc_call_free (var
);
2075 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2076 gfc_add_expr_to_block (&se
->post
, tmp
);
2079 se
->string_length
= len
;
2084 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2092 unsigned int num_args
;
2094 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2095 args
= XALLOCAVEC (tree
, num_args
);
2097 var
= gfc_create_var (pchar_type_node
, "pstr");
2098 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2100 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2101 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2102 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2104 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2105 tmp
= build_call_array_loc (input_location
,
2106 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2107 fndecl
, num_args
, args
);
2108 gfc_add_expr_to_block (&se
->pre
, tmp
);
2110 /* Free the temporary afterwards, if necessary. */
2111 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2112 len
, build_int_cst (TREE_TYPE (len
), 0));
2113 tmp
= gfc_call_free (var
);
2114 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2115 gfc_add_expr_to_block (&se
->post
, tmp
);
2118 se
->string_length
= len
;
2122 /* Return a character string containing the tty name. */
2125 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2133 unsigned int num_args
;
2135 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2136 args
= XALLOCAVEC (tree
, num_args
);
2138 var
= gfc_create_var (pchar_type_node
, "pstr");
2139 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2141 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2142 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2143 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2145 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2146 tmp
= build_call_array_loc (input_location
,
2147 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2148 fndecl
, num_args
, args
);
2149 gfc_add_expr_to_block (&se
->pre
, tmp
);
2151 /* Free the temporary afterwards, if necessary. */
2152 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2153 len
, build_int_cst (TREE_TYPE (len
), 0));
2154 tmp
= gfc_call_free (var
);
2155 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2156 gfc_add_expr_to_block (&se
->post
, tmp
);
2159 se
->string_length
= len
;
2163 /* Get the minimum/maximum value of all the parameters.
2164 minmax (a1, a2, a3, ...)
2167 if (a2 .op. mvar || isnan(mvar))
2169 if (a3 .op. mvar || isnan(mvar))
2176 /* TODO: Mismatching types can occur when specific names are used.
2177 These should be handled during resolution. */
2179 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2187 gfc_actual_arglist
*argexpr
;
2188 unsigned int i
, nargs
;
2190 nargs
= gfc_intrinsic_argument_list_length (expr
);
2191 args
= XALLOCAVEC (tree
, nargs
);
2193 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2194 type
= gfc_typenode_for_spec (&expr
->ts
);
2196 argexpr
= expr
->value
.function
.actual
;
2197 if (TREE_TYPE (args
[0]) != type
)
2198 args
[0] = convert (type
, args
[0]);
2199 /* Only evaluate the argument once. */
2200 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2201 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2203 mvar
= gfc_create_var (type
, "M");
2204 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2205 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2211 /* Handle absent optional arguments by ignoring the comparison. */
2212 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2213 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2214 && TREE_CODE (val
) == INDIRECT_REF
)
2215 cond
= fold_build2_loc (input_location
,
2216 NE_EXPR
, boolean_type_node
,
2217 TREE_OPERAND (val
, 0),
2218 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2223 /* Only evaluate the argument once. */
2224 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2225 val
= gfc_evaluate_now (val
, &se
->pre
);
2228 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2230 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2231 convert (type
, val
), mvar
);
2233 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2234 __builtin_isnan might be made dependent on that module being loaded,
2235 to help performance of programs that don't rely on IEEE semantics. */
2236 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2238 isnan
= build_call_expr_loc (input_location
,
2239 builtin_decl_explicit (BUILT_IN_ISNAN
),
2241 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2242 boolean_type_node
, tmp
,
2243 fold_convert (boolean_type_node
, isnan
));
2245 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2246 build_empty_stmt (input_location
));
2248 if (cond
!= NULL_TREE
)
2249 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2250 build_empty_stmt (input_location
));
2252 gfc_add_expr_to_block (&se
->pre
, tmp
);
2253 argexpr
= argexpr
->next
;
2259 /* Generate library calls for MIN and MAX intrinsics for character
2262 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2265 tree var
, len
, fndecl
, tmp
, cond
, function
;
2268 nargs
= gfc_intrinsic_argument_list_length (expr
);
2269 args
= XALLOCAVEC (tree
, nargs
+ 4);
2270 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2272 /* Create the result variables. */
2273 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2274 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2275 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2276 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2277 args
[2] = build_int_cst (integer_type_node
, op
);
2278 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2280 if (expr
->ts
.kind
== 1)
2281 function
= gfor_fndecl_string_minmax
;
2282 else if (expr
->ts
.kind
== 4)
2283 function
= gfor_fndecl_string_minmax_char4
;
2287 /* Make the function call. */
2288 fndecl
= build_addr (function
, current_function_decl
);
2289 tmp
= build_call_array_loc (input_location
,
2290 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2292 gfc_add_expr_to_block (&se
->pre
, tmp
);
2294 /* Free the temporary afterwards, if necessary. */
2295 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2296 len
, build_int_cst (TREE_TYPE (len
), 0));
2297 tmp
= gfc_call_free (var
);
2298 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2299 gfc_add_expr_to_block (&se
->post
, tmp
);
2302 se
->string_length
= len
;
2306 /* Create a symbol node for this intrinsic. The symbol from the frontend
2307 has the generic name. */
2310 gfc_get_symbol_for_expr (gfc_expr
* expr
)
2314 /* TODO: Add symbols for intrinsic function to the global namespace. */
2315 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2316 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2319 sym
->attr
.external
= 1;
2320 sym
->attr
.function
= 1;
2321 sym
->attr
.always_explicit
= 1;
2322 sym
->attr
.proc
= PROC_INTRINSIC
;
2323 sym
->attr
.flavor
= FL_PROCEDURE
;
2327 sym
->attr
.dimension
= 1;
2328 sym
->as
= gfc_get_array_spec ();
2329 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2330 sym
->as
->rank
= expr
->rank
;
2333 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
2338 /* Generate a call to an external intrinsic function. */
2340 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2343 VEC(tree
,gc
) *append_args
;
2345 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2348 gcc_assert (expr
->rank
> 0);
2350 gcc_assert (expr
->rank
== 0);
2352 sym
= gfc_get_symbol_for_expr (expr
);
2354 /* Calls to libgfortran_matmul need to be appended special arguments,
2355 to be able to call the BLAS ?gemm functions if required and possible. */
2357 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2358 && sym
->ts
.type
!= BT_LOGICAL
)
2360 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2362 if (gfc_option
.flag_external_blas
2363 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2364 && (sym
->ts
.kind
== gfc_default_real_kind
2365 || sym
->ts
.kind
== gfc_default_double_kind
))
2369 if (sym
->ts
.type
== BT_REAL
)
2371 if (sym
->ts
.kind
== gfc_default_real_kind
)
2372 gemm_fndecl
= gfor_fndecl_sgemm
;
2374 gemm_fndecl
= gfor_fndecl_dgemm
;
2378 if (sym
->ts
.kind
== gfc_default_real_kind
)
2379 gemm_fndecl
= gfor_fndecl_cgemm
;
2381 gemm_fndecl
= gfor_fndecl_zgemm
;
2384 append_args
= VEC_alloc (tree
, gc
, 3);
2385 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 1));
2386 VEC_quick_push (tree
, append_args
,
2387 build_int_cst (cint
, gfc_option
.blas_matmul_limit
));
2388 VEC_quick_push (tree
, append_args
,
2389 gfc_build_addr_expr (NULL_TREE
, gemm_fndecl
));
2393 append_args
= VEC_alloc (tree
, gc
, 3);
2394 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
2395 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
2396 VEC_quick_push (tree
, append_args
, null_pointer_node
);
2400 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
2402 gfc_free_symbol (sym
);
2405 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2425 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2434 gfc_actual_arglist
*actual
;
2441 gfc_conv_intrinsic_funcall (se
, expr
);
2445 actual
= expr
->value
.function
.actual
;
2446 type
= gfc_typenode_for_spec (&expr
->ts
);
2447 /* Initialize the result. */
2448 resvar
= gfc_create_var (type
, "test");
2450 tmp
= convert (type
, boolean_true_node
);
2452 tmp
= convert (type
, boolean_false_node
);
2453 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2455 /* Walk the arguments. */
2456 arrayss
= gfc_walk_expr (actual
->expr
);
2457 gcc_assert (arrayss
!= gfc_ss_terminator
);
2459 /* Initialize the scalarizer. */
2460 gfc_init_loopinfo (&loop
);
2461 exit_label
= gfc_build_label_decl (NULL_TREE
);
2462 TREE_USED (exit_label
) = 1;
2463 gfc_add_ss_to_loop (&loop
, arrayss
);
2465 /* Initialize the loop. */
2466 gfc_conv_ss_startstride (&loop
);
2467 gfc_conv_loop_setup (&loop
, &expr
->where
);
2469 gfc_mark_ss_chain_used (arrayss
, 1);
2470 /* Generate the loop body. */
2471 gfc_start_scalarized_body (&loop
, &body
);
2473 /* If the condition matches then set the return value. */
2474 gfc_start_block (&block
);
2476 tmp
= convert (type
, boolean_false_node
);
2478 tmp
= convert (type
, boolean_true_node
);
2479 gfc_add_modify (&block
, resvar
, tmp
);
2481 /* And break out of the loop. */
2482 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2483 gfc_add_expr_to_block (&block
, tmp
);
2485 found
= gfc_finish_block (&block
);
2487 /* Check this element. */
2488 gfc_init_se (&arrayse
, NULL
);
2489 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2490 arrayse
.ss
= arrayss
;
2491 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2493 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2494 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
2495 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
2496 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
2497 gfc_add_expr_to_block (&body
, tmp
);
2498 gfc_add_block_to_block (&body
, &arrayse
.post
);
2500 gfc_trans_scalarizing_loops (&loop
, &body
);
2502 /* Add the exit label. */
2503 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2504 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2506 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2507 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2508 gfc_cleanup_loop (&loop
);
2513 /* COUNT(A) = Number of true elements in A. */
2515 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
2522 gfc_actual_arglist
*actual
;
2528 gfc_conv_intrinsic_funcall (se
, expr
);
2532 actual
= expr
->value
.function
.actual
;
2534 type
= gfc_typenode_for_spec (&expr
->ts
);
2535 /* Initialize the result. */
2536 resvar
= gfc_create_var (type
, "count");
2537 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
2539 /* Walk the arguments. */
2540 arrayss
= gfc_walk_expr (actual
->expr
);
2541 gcc_assert (arrayss
!= gfc_ss_terminator
);
2543 /* Initialize the scalarizer. */
2544 gfc_init_loopinfo (&loop
);
2545 gfc_add_ss_to_loop (&loop
, arrayss
);
2547 /* Initialize the loop. */
2548 gfc_conv_ss_startstride (&loop
);
2549 gfc_conv_loop_setup (&loop
, &expr
->where
);
2551 gfc_mark_ss_chain_used (arrayss
, 1);
2552 /* Generate the loop body. */
2553 gfc_start_scalarized_body (&loop
, &body
);
2555 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2556 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2557 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2559 gfc_init_se (&arrayse
, NULL
);
2560 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2561 arrayse
.ss
= arrayss
;
2562 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2563 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2564 build_empty_stmt (input_location
));
2566 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2567 gfc_add_expr_to_block (&body
, tmp
);
2568 gfc_add_block_to_block (&body
, &arrayse
.post
);
2570 gfc_trans_scalarizing_loops (&loop
, &body
);
2572 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2573 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2574 gfc_cleanup_loop (&loop
);
2580 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
2581 struct and return the corresponding loopinfo. */
2583 static gfc_loopinfo
*
2584 enter_nested_loop (gfc_se
*se
)
2586 se
->ss
= se
->ss
->nested_ss
;
2587 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
2589 return se
->ss
->loop
;
2593 /* Inline implementation of the sum and product intrinsics. */
2595 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2599 tree scale
= NULL_TREE
;
2604 gfc_loopinfo loop
, *ploop
;
2605 gfc_actual_arglist
*arg_array
, *arg_mask
;
2606 gfc_ss
*arrayss
= NULL
;
2607 gfc_ss
*maskss
= NULL
;
2611 gfc_expr
*arrayexpr
;
2616 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
2622 type
= gfc_typenode_for_spec (&expr
->ts
);
2623 /* Initialize the result. */
2624 resvar
= gfc_create_var (type
, "val");
2629 scale
= gfc_create_var (type
, "scale");
2630 gfc_add_modify (&se
->pre
, scale
,
2631 gfc_build_const (type
, integer_one_node
));
2632 tmp
= gfc_build_const (type
, integer_zero_node
);
2634 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2635 tmp
= gfc_build_const (type
, integer_zero_node
);
2636 else if (op
== NE_EXPR
)
2638 tmp
= convert (type
, boolean_false_node
);
2639 else if (op
== BIT_AND_EXPR
)
2640 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2641 type
, integer_one_node
));
2643 tmp
= gfc_build_const (type
, integer_one_node
);
2645 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2647 arg_array
= expr
->value
.function
.actual
;
2649 arrayexpr
= arg_array
->expr
;
2651 if (op
== NE_EXPR
|| norm2
)
2652 /* PARITY and NORM2. */
2656 arg_mask
= arg_array
->next
->next
;
2657 gcc_assert (arg_mask
!= NULL
);
2658 maskexpr
= arg_mask
->expr
;
2661 if (expr
->rank
== 0)
2663 /* Walk the arguments. */
2664 arrayss
= gfc_walk_expr (arrayexpr
);
2665 gcc_assert (arrayss
!= gfc_ss_terminator
);
2667 if (maskexpr
&& maskexpr
->rank
> 0)
2669 maskss
= gfc_walk_expr (maskexpr
);
2670 gcc_assert (maskss
!= gfc_ss_terminator
);
2675 /* Initialize the scalarizer. */
2676 gfc_init_loopinfo (&loop
);
2677 gfc_add_ss_to_loop (&loop
, arrayss
);
2678 if (maskexpr
&& maskexpr
->rank
> 0)
2679 gfc_add_ss_to_loop (&loop
, maskss
);
2681 /* Initialize the loop. */
2682 gfc_conv_ss_startstride (&loop
);
2683 gfc_conv_loop_setup (&loop
, &expr
->where
);
2685 gfc_mark_ss_chain_used (arrayss
, 1);
2686 if (maskexpr
&& maskexpr
->rank
> 0)
2687 gfc_mark_ss_chain_used (maskss
, 1);
2692 /* All the work has been done in the parent loops. */
2693 ploop
= enter_nested_loop (se
);
2697 /* Generate the loop body. */
2698 gfc_start_scalarized_body (ploop
, &body
);
2700 /* If we have a mask, only add this element if the mask is set. */
2701 if (maskexpr
&& maskexpr
->rank
> 0)
2703 gfc_init_se (&maskse
, parent_se
);
2704 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
2705 if (expr
->rank
== 0)
2707 gfc_conv_expr_val (&maskse
, maskexpr
);
2708 gfc_add_block_to_block (&body
, &maskse
.pre
);
2710 gfc_start_block (&block
);
2713 gfc_init_block (&block
);
2715 /* Do the actual summation/product. */
2716 gfc_init_se (&arrayse
, parent_se
);
2717 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
2718 if (expr
->rank
== 0)
2719 arrayse
.ss
= arrayss
;
2720 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2721 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2731 result = 1.0 + result * val * val;
2737 result += val * val;
2740 tree res1
, res2
, cond
, absX
, val
;
2741 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
2743 gfc_init_block (&ifblock1
);
2745 absX
= gfc_create_var (type
, "absX");
2746 gfc_add_modify (&ifblock1
, absX
,
2747 fold_build1_loc (input_location
, ABS_EXPR
, type
,
2749 val
= gfc_create_var (type
, "val");
2750 gfc_add_expr_to_block (&ifblock1
, val
);
2752 gfc_init_block (&ifblock2
);
2753 gfc_add_modify (&ifblock2
, val
,
2754 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
2756 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2757 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
2758 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
2759 gfc_build_const (type
, integer_one_node
));
2760 gfc_add_modify (&ifblock2
, resvar
, res1
);
2761 gfc_add_modify (&ifblock2
, scale
, absX
);
2762 res1
= gfc_finish_block (&ifblock2
);
2764 gfc_init_block (&ifblock3
);
2765 gfc_add_modify (&ifblock3
, val
,
2766 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
2768 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2769 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
2770 gfc_add_modify (&ifblock3
, resvar
, res2
);
2771 res2
= gfc_finish_block (&ifblock3
);
2773 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2775 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
2776 gfc_add_expr_to_block (&ifblock1
, tmp
);
2777 tmp
= gfc_finish_block (&ifblock1
);
2779 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2781 gfc_build_const (type
, integer_zero_node
));
2783 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2784 gfc_add_expr_to_block (&block
, tmp
);
2788 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
2789 gfc_add_modify (&block
, resvar
, tmp
);
2792 gfc_add_block_to_block (&block
, &arrayse
.post
);
2794 if (maskexpr
&& maskexpr
->rank
> 0)
2796 /* We enclose the above in if (mask) {...} . */
2798 tmp
= gfc_finish_block (&block
);
2799 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2800 build_empty_stmt (input_location
));
2803 tmp
= gfc_finish_block (&block
);
2804 gfc_add_expr_to_block (&body
, tmp
);
2806 gfc_trans_scalarizing_loops (ploop
, &body
);
2808 /* For a scalar mask, enclose the loop in an if statement. */
2809 if (maskexpr
&& maskexpr
->rank
== 0)
2811 gfc_init_block (&block
);
2812 gfc_add_block_to_block (&block
, &ploop
->pre
);
2813 gfc_add_block_to_block (&block
, &ploop
->post
);
2814 tmp
= gfc_finish_block (&block
);
2818 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
2819 build_empty_stmt (input_location
));
2820 gfc_advance_se_ss_chain (se
);
2824 gcc_assert (expr
->rank
== 0);
2825 gfc_init_se (&maskse
, NULL
);
2826 gfc_conv_expr_val (&maskse
, maskexpr
);
2827 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2828 build_empty_stmt (input_location
));
2831 gfc_add_expr_to_block (&block
, tmp
);
2832 gfc_add_block_to_block (&se
->pre
, &block
);
2833 gcc_assert (se
->post
.head
== NULL
);
2837 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
2838 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
2841 if (expr
->rank
== 0)
2842 gfc_cleanup_loop (ploop
);
2846 /* result = scale * sqrt(result). */
2848 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
2849 resvar
= build_call_expr_loc (input_location
,
2851 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
2858 /* Inline implementation of the dot_product intrinsic. This function
2859 is based on gfc_conv_intrinsic_arith (the previous function). */
2861 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2869 gfc_actual_arglist
*actual
;
2870 gfc_ss
*arrayss1
, *arrayss2
;
2871 gfc_se arrayse1
, arrayse2
;
2872 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2874 type
= gfc_typenode_for_spec (&expr
->ts
);
2876 /* Initialize the result. */
2877 resvar
= gfc_create_var (type
, "val");
2878 if (expr
->ts
.type
== BT_LOGICAL
)
2879 tmp
= build_int_cst (type
, 0);
2881 tmp
= gfc_build_const (type
, integer_zero_node
);
2883 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2885 /* Walk argument #1. */
2886 actual
= expr
->value
.function
.actual
;
2887 arrayexpr1
= actual
->expr
;
2888 arrayss1
= gfc_walk_expr (arrayexpr1
);
2889 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2891 /* Walk argument #2. */
2892 actual
= actual
->next
;
2893 arrayexpr2
= actual
->expr
;
2894 arrayss2
= gfc_walk_expr (arrayexpr2
);
2895 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2897 /* Initialize the scalarizer. */
2898 gfc_init_loopinfo (&loop
);
2899 gfc_add_ss_to_loop (&loop
, arrayss1
);
2900 gfc_add_ss_to_loop (&loop
, arrayss2
);
2902 /* Initialize the loop. */
2903 gfc_conv_ss_startstride (&loop
);
2904 gfc_conv_loop_setup (&loop
, &expr
->where
);
2906 gfc_mark_ss_chain_used (arrayss1
, 1);
2907 gfc_mark_ss_chain_used (arrayss2
, 1);
2909 /* Generate the loop body. */
2910 gfc_start_scalarized_body (&loop
, &body
);
2911 gfc_init_block (&block
);
2913 /* Make the tree expression for [conjg(]array1[)]. */
2914 gfc_init_se (&arrayse1
, NULL
);
2915 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2916 arrayse1
.ss
= arrayss1
;
2917 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2918 if (expr
->ts
.type
== BT_COMPLEX
)
2919 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
2921 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2923 /* Make the tree expression for array2. */
2924 gfc_init_se (&arrayse2
, NULL
);
2925 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2926 arrayse2
.ss
= arrayss2
;
2927 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2928 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2930 /* Do the actual product and sum. */
2931 if (expr
->ts
.type
== BT_LOGICAL
)
2933 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
2934 arrayse1
.expr
, arrayse2
.expr
);
2935 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2939 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
2941 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
2943 gfc_add_modify (&block
, resvar
, tmp
);
2945 /* Finish up the loop block and the loop. */
2946 tmp
= gfc_finish_block (&block
);
2947 gfc_add_expr_to_block (&body
, tmp
);
2949 gfc_trans_scalarizing_loops (&loop
, &body
);
2950 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2951 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2952 gfc_cleanup_loop (&loop
);
2958 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2959 we need to handle. For performance reasons we sometimes create two
2960 loops instead of one, where the second one is much simpler.
2961 Examples for minloc intrinsic:
2962 1) Result is an array, a call is generated
2963 2) Array mask is used and NaNs need to be supported:
2969 if (pos == 0) pos = S + (1 - from);
2970 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2977 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2981 3) NaNs need to be supported, but it is known at compile time or cheaply
2982 at runtime whether array is nonempty or not:
2987 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2990 if (from <= to) pos = 1;
2994 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2998 4) NaNs aren't supported, array mask is used:
2999 limit = infinities_supported ? Infinity : huge (limit);
3003 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3009 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3013 5) Same without array mask:
3014 limit = infinities_supported ? Infinity : huge (limit);
3015 pos = (from <= to) ? 1 : 0;
3018 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3021 For 3) and 5), if mask is scalar, this all goes into a conditional,
3022 setting pos = 0; in the else branch. */
3025 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3029 stmtblock_t ifblock
;
3030 stmtblock_t elseblock
;
3041 gfc_actual_arglist
*actual
;
3046 gfc_expr
*arrayexpr
;
3053 gfc_conv_intrinsic_funcall (se
, expr
);
3057 /* Initialize the result. */
3058 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3059 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3060 type
= gfc_typenode_for_spec (&expr
->ts
);
3062 /* Walk the arguments. */
3063 actual
= expr
->value
.function
.actual
;
3064 arrayexpr
= actual
->expr
;
3065 arrayss
= gfc_walk_expr (arrayexpr
);
3066 gcc_assert (arrayss
!= gfc_ss_terminator
);
3068 actual
= actual
->next
->next
;
3069 gcc_assert (actual
);
3070 maskexpr
= actual
->expr
;
3072 if (maskexpr
&& maskexpr
->rank
!= 0)
3074 maskss
= gfc_walk_expr (maskexpr
);
3075 gcc_assert (maskss
!= gfc_ss_terminator
);
3080 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3082 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3084 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3085 boolean_type_node
, nonempty
,
3086 gfc_index_zero_node
);
3091 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3092 switch (arrayexpr
->ts
.type
)
3095 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3099 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3100 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3101 arrayexpr
->ts
.kind
);
3108 /* We start with the most negative possible value for MAXLOC, and the most
3109 positive possible value for MINLOC. The most negative possible value is
3110 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3111 possible value is HUGE in both cases. */
3113 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3114 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3115 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3116 build_int_cst (type
, 1));
3118 gfc_add_modify (&se
->pre
, limit
, tmp
);
3120 /* Initialize the scalarizer. */
3121 gfc_init_loopinfo (&loop
);
3122 gfc_add_ss_to_loop (&loop
, arrayss
);
3124 gfc_add_ss_to_loop (&loop
, maskss
);
3126 /* Initialize the loop. */
3127 gfc_conv_ss_startstride (&loop
);
3129 /* The code generated can have more than one loop in sequence (see the
3130 comment at the function header). This doesn't work well with the
3131 scalarizer, which changes arrays' offset when the scalarization loops
3132 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3133 are currently inlined in the scalar case only (for which loop is of rank
3134 one). As there is no dependency to care about in that case, there is no
3135 temporary, so that we can use the scalarizer temporary code to handle
3136 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3137 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3139 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3140 should eventually go away. We could either create two loops properly,
3141 or find another way to save/restore the array offsets between the two
3142 loops (without conflicting with temporary management), or use a single
3143 loop minmaxloc implementation. See PR 31067. */
3144 loop
.temp_dim
= loop
.dimen
;
3145 gfc_conv_loop_setup (&loop
, &expr
->where
);
3147 gcc_assert (loop
.dimen
== 1);
3148 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3149 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3150 loop
.from
[0], loop
.to
[0]);
3154 /* Initialize the position to zero, following Fortran 2003. We are free
3155 to do this because Fortran 95 allows the result of an entirely false
3156 mask to be processor dependent. If we know at compile time the array
3157 is non-empty and no MASK is used, we can initialize to 1 to simplify
3159 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3160 gfc_add_modify (&loop
.pre
, pos
,
3161 fold_build3_loc (input_location
, COND_EXPR
,
3162 gfc_array_index_type
,
3163 nonempty
, gfc_index_one_node
,
3164 gfc_index_zero_node
));
3167 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3168 lab1
= gfc_build_label_decl (NULL_TREE
);
3169 TREE_USED (lab1
) = 1;
3170 lab2
= gfc_build_label_decl (NULL_TREE
);
3171 TREE_USED (lab2
) = 1;
3174 /* An offset must be added to the loop
3175 counter to obtain the required position. */
3176 gcc_assert (loop
.from
[0]);
3178 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3179 gfc_index_one_node
, loop
.from
[0]);
3180 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3182 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3184 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3185 /* Generate the loop body. */
3186 gfc_start_scalarized_body (&loop
, &body
);
3188 /* If we have a mask, only check this element if the mask is set. */
3191 gfc_init_se (&maskse
, NULL
);
3192 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3194 gfc_conv_expr_val (&maskse
, maskexpr
);
3195 gfc_add_block_to_block (&body
, &maskse
.pre
);
3197 gfc_start_block (&block
);
3200 gfc_init_block (&block
);
3202 /* Compare with the current limit. */
3203 gfc_init_se (&arrayse
, NULL
);
3204 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3205 arrayse
.ss
= arrayss
;
3206 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3207 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3209 /* We do the following if this is a more extreme value. */
3210 gfc_start_block (&ifblock
);
3212 /* Assign the value to the limit... */
3213 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3215 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3217 stmtblock_t ifblock2
;
3220 gfc_start_block (&ifblock2
);
3221 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3222 loop
.loopvar
[0], offset
);
3223 gfc_add_modify (&ifblock2
, pos
, tmp
);
3224 ifbody2
= gfc_finish_block (&ifblock2
);
3225 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3226 gfc_index_zero_node
);
3227 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3228 build_empty_stmt (input_location
));
3229 gfc_add_expr_to_block (&block
, tmp
);
3232 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3233 loop
.loopvar
[0], offset
);
3234 gfc_add_modify (&ifblock
, pos
, tmp
);
3237 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3239 ifbody
= gfc_finish_block (&ifblock
);
3241 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3244 cond
= fold_build2_loc (input_location
,
3245 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3246 boolean_type_node
, arrayse
.expr
, limit
);
3248 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3249 arrayse
.expr
, limit
);
3251 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3252 build_empty_stmt (input_location
));
3254 gfc_add_expr_to_block (&block
, ifbody
);
3258 /* We enclose the above in if (mask) {...}. */
3259 tmp
= gfc_finish_block (&block
);
3261 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3262 build_empty_stmt (input_location
));
3265 tmp
= gfc_finish_block (&block
);
3266 gfc_add_expr_to_block (&body
, tmp
);
3270 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3272 if (HONOR_NANS (DECL_MODE (limit
)))
3274 if (nonempty
!= NULL
)
3276 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3277 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3278 build_empty_stmt (input_location
));
3279 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3283 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3284 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3286 /* If we have a mask, only check this element if the mask is set. */
3289 gfc_init_se (&maskse
, NULL
);
3290 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3292 gfc_conv_expr_val (&maskse
, maskexpr
);
3293 gfc_add_block_to_block (&body
, &maskse
.pre
);
3295 gfc_start_block (&block
);
3298 gfc_init_block (&block
);
3300 /* Compare with the current limit. */
3301 gfc_init_se (&arrayse
, NULL
);
3302 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3303 arrayse
.ss
= arrayss
;
3304 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3305 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3307 /* We do the following if this is a more extreme value. */
3308 gfc_start_block (&ifblock
);
3310 /* Assign the value to the limit... */
3311 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3313 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3314 loop
.loopvar
[0], offset
);
3315 gfc_add_modify (&ifblock
, pos
, tmp
);
3317 ifbody
= gfc_finish_block (&ifblock
);
3319 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3320 arrayse
.expr
, limit
);
3322 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3323 build_empty_stmt (input_location
));
3324 gfc_add_expr_to_block (&block
, tmp
);
3328 /* We enclose the above in if (mask) {...}. */
3329 tmp
= gfc_finish_block (&block
);
3331 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3332 build_empty_stmt (input_location
));
3335 tmp
= gfc_finish_block (&block
);
3336 gfc_add_expr_to_block (&body
, tmp
);
3337 /* Avoid initializing loopvar[0] again, it should be left where
3338 it finished by the first loop. */
3339 loop
.from
[0] = loop
.loopvar
[0];
3342 gfc_trans_scalarizing_loops (&loop
, &body
);
3345 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3347 /* For a scalar mask, enclose the loop in an if statement. */
3348 if (maskexpr
&& maskss
== NULL
)
3350 gfc_init_se (&maskse
, NULL
);
3351 gfc_conv_expr_val (&maskse
, maskexpr
);
3352 gfc_init_block (&block
);
3353 gfc_add_block_to_block (&block
, &loop
.pre
);
3354 gfc_add_block_to_block (&block
, &loop
.post
);
3355 tmp
= gfc_finish_block (&block
);
3357 /* For the else part of the scalar mask, just initialize
3358 the pos variable the same way as above. */
3360 gfc_init_block (&elseblock
);
3361 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3362 elsetmp
= gfc_finish_block (&elseblock
);
3364 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3365 gfc_add_expr_to_block (&block
, tmp
);
3366 gfc_add_block_to_block (&se
->pre
, &block
);
3370 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3371 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3373 gfc_cleanup_loop (&loop
);
3375 se
->expr
= convert (type
, pos
);
3378 /* Emit code for minval or maxval intrinsic. There are many different cases
3379 we need to handle. For performance reasons we sometimes create two
3380 loops instead of one, where the second one is much simpler.
3381 Examples for minval intrinsic:
3382 1) Result is an array, a call is generated
3383 2) Array mask is used and NaNs need to be supported, rank 1:
3388 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3391 limit = nonempty ? NaN : huge (limit);
3393 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3394 3) NaNs need to be supported, but it is known at compile time or cheaply
3395 at runtime whether array is nonempty or not, rank 1:
3398 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3399 limit = (from <= to) ? NaN : huge (limit);
3401 while (S <= to) { limit = min (a[S], limit); S++; }
3402 4) Array mask is used and NaNs need to be supported, rank > 1:
3411 if (fast) limit = min (a[S1][S2], limit);
3414 if (a[S1][S2] <= limit) {
3425 limit = nonempty ? NaN : huge (limit);
3426 5) NaNs need to be supported, but it is known at compile time or cheaply
3427 at runtime whether array is nonempty or not, rank > 1:
3434 if (fast) limit = min (a[S1][S2], limit);
3436 if (a[S1][S2] <= limit) {
3446 limit = (nonempty_array) ? NaN : huge (limit);
3447 6) NaNs aren't supported, but infinities are. Array mask is used:
3452 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3455 limit = nonempty ? limit : huge (limit);
3456 7) Same without array mask:
3459 while (S <= to) { limit = min (a[S], limit); S++; }
3460 limit = (from <= to) ? limit : huge (limit);
3461 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3462 limit = huge (limit);
3464 while (S <= to) { limit = min (a[S], limit); S++); }
3466 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3467 with array mask instead).
3468 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3469 setting limit = huge (limit); in the else branch. */
3472 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3482 tree huge_cst
= NULL
, nan_cst
= NULL
;
3484 stmtblock_t block
, block2
;
3486 gfc_actual_arglist
*actual
;
3491 gfc_expr
*arrayexpr
;
3497 gfc_conv_intrinsic_funcall (se
, expr
);
3501 type
= gfc_typenode_for_spec (&expr
->ts
);
3502 /* Initialize the result. */
3503 limit
= gfc_create_var (type
, "limit");
3504 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
3505 switch (expr
->ts
.type
)
3508 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
3510 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3512 REAL_VALUE_TYPE real
;
3514 tmp
= build_real (type
, real
);
3518 if (HONOR_NANS (DECL_MODE (limit
)))
3520 REAL_VALUE_TYPE real
;
3521 real_nan (&real
, "", 1, DECL_MODE (limit
));
3522 nan_cst
= build_real (type
, real
);
3527 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
3534 /* We start with the most negative possible value for MAXVAL, and the most
3535 positive possible value for MINVAL. The most negative possible value is
3536 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3537 possible value is HUGE in both cases. */
3540 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3542 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
3543 TREE_TYPE (huge_cst
), huge_cst
);
3546 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3547 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
3548 tmp
, build_int_cst (type
, 1));
3550 gfc_add_modify (&se
->pre
, limit
, tmp
);
3552 /* Walk the arguments. */
3553 actual
= expr
->value
.function
.actual
;
3554 arrayexpr
= actual
->expr
;
3555 arrayss
= gfc_walk_expr (arrayexpr
);
3556 gcc_assert (arrayss
!= gfc_ss_terminator
);
3558 actual
= actual
->next
->next
;
3559 gcc_assert (actual
);
3560 maskexpr
= actual
->expr
;
3562 if (maskexpr
&& maskexpr
->rank
!= 0)
3564 maskss
= gfc_walk_expr (maskexpr
);
3565 gcc_assert (maskss
!= gfc_ss_terminator
);
3570 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3572 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3574 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3575 boolean_type_node
, nonempty
,
3576 gfc_index_zero_node
);
3581 /* Initialize the scalarizer. */
3582 gfc_init_loopinfo (&loop
);
3583 gfc_add_ss_to_loop (&loop
, arrayss
);
3585 gfc_add_ss_to_loop (&loop
, maskss
);
3587 /* Initialize the loop. */
3588 gfc_conv_ss_startstride (&loop
);
3590 /* The code generated can have more than one loop in sequence (see the
3591 comment at the function header). This doesn't work well with the
3592 scalarizer, which changes arrays' offset when the scalarization loops
3593 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3594 are currently inlined in the scalar case only. As there is no dependency
3595 to care about in that case, there is no temporary, so that we can use the
3596 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3597 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3598 gfc_trans_scalarized_loop_boundary even later to restore offset.
3599 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3600 should eventually go away. We could either create two loops properly,
3601 or find another way to save/restore the array offsets between the two
3602 loops (without conflicting with temporary management), or use a single
3603 loop minmaxval implementation. See PR 31067. */
3604 loop
.temp_dim
= loop
.dimen
;
3605 gfc_conv_loop_setup (&loop
, &expr
->where
);
3607 if (nonempty
== NULL
&& maskss
== NULL
3608 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
3609 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3610 loop
.from
[0], loop
.to
[0]);
3611 nonempty_var
= NULL
;
3612 if (nonempty
== NULL
3613 && (HONOR_INFINITIES (DECL_MODE (limit
))
3614 || HONOR_NANS (DECL_MODE (limit
))))
3616 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3617 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3618 nonempty
= nonempty_var
;
3622 if (HONOR_NANS (DECL_MODE (limit
)))
3624 if (loop
.dimen
== 1)
3626 lab
= gfc_build_label_decl (NULL_TREE
);
3627 TREE_USED (lab
) = 1;
3631 fast
= gfc_create_var (boolean_type_node
, "fast");
3632 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3636 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
3638 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
3639 /* Generate the loop body. */
3640 gfc_start_scalarized_body (&loop
, &body
);
3642 /* If we have a mask, only add this element if the mask is set. */
3645 gfc_init_se (&maskse
, NULL
);
3646 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3648 gfc_conv_expr_val (&maskse
, maskexpr
);
3649 gfc_add_block_to_block (&body
, &maskse
.pre
);
3651 gfc_start_block (&block
);
3654 gfc_init_block (&block
);
3656 /* Compare with the current limit. */
3657 gfc_init_se (&arrayse
, NULL
);
3658 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3659 arrayse
.ss
= arrayss
;
3660 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3661 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3663 gfc_init_block (&block2
);
3666 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3668 if (HONOR_NANS (DECL_MODE (limit
)))
3670 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3671 boolean_type_node
, arrayse
.expr
, limit
);
3673 ifbody
= build1_v (GOTO_EXPR
, lab
);
3676 stmtblock_t ifblock
;
3678 gfc_init_block (&ifblock
);
3679 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3680 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3681 ifbody
= gfc_finish_block (&ifblock
);
3683 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3684 build_empty_stmt (input_location
));
3685 gfc_add_expr_to_block (&block2
, tmp
);
3689 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3691 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3693 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3694 arrayse
.expr
, limit
);
3695 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3696 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3697 build_empty_stmt (input_location
));
3698 gfc_add_expr_to_block (&block2
, tmp
);
3702 tmp
= fold_build2_loc (input_location
,
3703 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3704 type
, arrayse
.expr
, limit
);
3705 gfc_add_modify (&block2
, limit
, tmp
);
3711 tree elsebody
= gfc_finish_block (&block2
);
3713 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3715 if (HONOR_NANS (DECL_MODE (limit
))
3716 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3718 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3719 arrayse
.expr
, limit
);
3720 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3721 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3722 build_empty_stmt (input_location
));
3726 tmp
= fold_build2_loc (input_location
,
3727 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3728 type
, arrayse
.expr
, limit
);
3729 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3731 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3732 gfc_add_expr_to_block (&block
, tmp
);
3735 gfc_add_block_to_block (&block
, &block2
);
3737 gfc_add_block_to_block (&block
, &arrayse
.post
);
3739 tmp
= gfc_finish_block (&block
);
3741 /* We enclose the above in if (mask) {...}. */
3742 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3743 build_empty_stmt (input_location
));
3744 gfc_add_expr_to_block (&body
, tmp
);
3748 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3750 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3752 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
3753 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
3755 /* If we have a mask, only add this element if the mask is set. */
3758 gfc_init_se (&maskse
, NULL
);
3759 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3761 gfc_conv_expr_val (&maskse
, maskexpr
);
3762 gfc_add_block_to_block (&body
, &maskse
.pre
);
3764 gfc_start_block (&block
);
3767 gfc_init_block (&block
);
3769 /* Compare with the current limit. */
3770 gfc_init_se (&arrayse
, NULL
);
3771 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3772 arrayse
.ss
= arrayss
;
3773 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3774 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3776 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3778 if (HONOR_NANS (DECL_MODE (limit
))
3779 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3781 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3782 arrayse
.expr
, limit
);
3783 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3784 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3785 build_empty_stmt (input_location
));
3786 gfc_add_expr_to_block (&block
, tmp
);
3790 tmp
= fold_build2_loc (input_location
,
3791 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3792 type
, arrayse
.expr
, limit
);
3793 gfc_add_modify (&block
, limit
, tmp
);
3796 gfc_add_block_to_block (&block
, &arrayse
.post
);
3798 tmp
= gfc_finish_block (&block
);
3800 /* We enclose the above in if (mask) {...}. */
3801 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3802 build_empty_stmt (input_location
));
3803 gfc_add_expr_to_block (&body
, tmp
);
3804 /* Avoid initializing loopvar[0] again, it should be left where
3805 it finished by the first loop. */
3806 loop
.from
[0] = loop
.loopvar
[0];
3808 gfc_trans_scalarizing_loops (&loop
, &body
);
3812 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3814 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3815 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
3817 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3819 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
3821 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
3823 gfc_add_modify (&loop
.pre
, limit
, tmp
);
3826 /* For a scalar mask, enclose the loop in an if statement. */
3827 if (maskexpr
&& maskss
== NULL
)
3831 gfc_init_se (&maskse
, NULL
);
3832 gfc_conv_expr_val (&maskse
, maskexpr
);
3833 gfc_init_block (&block
);
3834 gfc_add_block_to_block (&block
, &loop
.pre
);
3835 gfc_add_block_to_block (&block
, &loop
.post
);
3836 tmp
= gfc_finish_block (&block
);
3838 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3839 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
3841 else_stmt
= build_empty_stmt (input_location
);
3842 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
3843 gfc_add_expr_to_block (&block
, tmp
);
3844 gfc_add_block_to_block (&se
->pre
, &block
);
3848 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3849 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3852 gfc_cleanup_loop (&loop
);
3857 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3859 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
3865 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3866 type
= TREE_TYPE (args
[0]);
3868 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3869 build_int_cst (type
, 1), args
[1]);
3870 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
3871 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
3872 build_int_cst (type
, 0));
3873 type
= gfc_typenode_for_spec (&expr
->ts
);
3874 se
->expr
= convert (type
, tmp
);
3878 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3880 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3884 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3886 /* Convert both arguments to the unsigned type of the same size. */
3887 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
3888 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
3890 /* If they have unequal type size, convert to the larger one. */
3891 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
3892 > TYPE_PRECISION (TREE_TYPE (args
[1])))
3893 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
3894 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
3895 > TYPE_PRECISION (TREE_TYPE (args
[0])))
3896 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
3898 /* Now, we compare them. */
3899 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3904 /* Generate code to perform the specified operation. */
3906 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3910 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3911 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
3917 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
3921 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3922 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3923 TREE_TYPE (arg
), arg
);
3926 /* Set or clear a single bit. */
3928 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
3935 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3936 type
= TREE_TYPE (args
[0]);
3938 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3939 build_int_cst (type
, 1), args
[1]);
3945 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
3947 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
3950 /* Extract a sequence of bits.
3951 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3953 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
3960 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3961 type
= TREE_TYPE (args
[0]);
3963 mask
= build_int_cst (type
, -1);
3964 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
3965 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
3967 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
3969 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
3973 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
3976 tree args
[2], type
, num_bits
, cond
;
3978 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3980 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3981 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3982 type
= TREE_TYPE (args
[0]);
3985 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
3987 gcc_assert (right_shift
);
3989 se
->expr
= fold_build2_loc (input_location
,
3990 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
3991 TREE_TYPE (args
[0]), args
[0], args
[1]);
3994 se
->expr
= fold_convert (type
, se
->expr
);
3996 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3997 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3999 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4000 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4003 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4004 build_int_cst (type
, 0), se
->expr
);
4007 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4009 : ((shift >= 0) ? i << shift : i >> -shift)
4010 where all shifts are logical shifts. */
4012 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4024 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4026 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4027 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4029 type
= TREE_TYPE (args
[0]);
4030 utype
= unsigned_type_for (type
);
4032 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4035 /* Left shift if positive. */
4036 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4038 /* Right shift if negative.
4039 We convert to an unsigned type because we want a logical shift.
4040 The standard doesn't define the case of shifting negative
4041 numbers, and we try to be compatible with other compilers, most
4042 notably g77, here. */
4043 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4044 utype
, convert (utype
, args
[0]), width
));
4046 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4047 build_int_cst (TREE_TYPE (args
[1]), 0));
4048 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4050 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4051 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4053 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4054 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4056 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4057 build_int_cst (type
, 0), tmp
);
4061 /* Circular shift. AKA rotate or barrel shift. */
4064 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4072 unsigned int num_args
;
4074 num_args
= gfc_intrinsic_argument_list_length (expr
);
4075 args
= XALLOCAVEC (tree
, num_args
);
4077 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4081 /* Use a library function for the 3 parameter version. */
4082 tree int4type
= gfc_get_int_type (4);
4084 type
= TREE_TYPE (args
[0]);
4085 /* We convert the first argument to at least 4 bytes, and
4086 convert back afterwards. This removes the need for library
4087 functions for all argument sizes, and function will be
4088 aligned to at least 32 bits, so there's no loss. */
4089 if (expr
->ts
.kind
< 4)
4090 args
[0] = convert (int4type
, args
[0]);
4092 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4093 need loads of library functions. They cannot have values >
4094 BIT_SIZE (I) so the conversion is safe. */
4095 args
[1] = convert (int4type
, args
[1]);
4096 args
[2] = convert (int4type
, args
[2]);
4098 switch (expr
->ts
.kind
)
4103 tmp
= gfor_fndecl_math_ishftc4
;
4106 tmp
= gfor_fndecl_math_ishftc8
;
4109 tmp
= gfor_fndecl_math_ishftc16
;
4114 se
->expr
= build_call_expr_loc (input_location
,
4115 tmp
, 3, args
[0], args
[1], args
[2]);
4116 /* Convert the result back to the original type, if we extended
4117 the first argument's width above. */
4118 if (expr
->ts
.kind
< 4)
4119 se
->expr
= convert (type
, se
->expr
);
4123 type
= TREE_TYPE (args
[0]);
4125 /* Evaluate arguments only once. */
4126 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4127 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4129 /* Rotate left if positive. */
4130 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4132 /* Rotate right if negative. */
4133 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4135 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4137 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4138 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4140 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4142 /* Do nothing if shift == 0. */
4143 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4145 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4150 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4151 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4153 The conditional expression is necessary because the result of LEADZ(0)
4154 is defined, but the result of __builtin_clz(0) is undefined for most
4157 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4158 difference in bit size between the argument of LEADZ and the C int. */
4161 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4173 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4174 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4176 /* Which variant of __builtin_clz* should we call? */
4177 if (argsize
<= INT_TYPE_SIZE
)
4179 arg_type
= unsigned_type_node
;
4180 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4182 else if (argsize
<= LONG_TYPE_SIZE
)
4184 arg_type
= long_unsigned_type_node
;
4185 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4187 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4189 arg_type
= long_long_unsigned_type_node
;
4190 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4194 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4195 arg_type
= gfc_build_uint_type (argsize
);
4199 /* Convert the actual argument twice: first, to the unsigned type of the
4200 same size; then, to the proper argument type for the built-in
4201 function. But the return type is of the default INTEGER kind. */
4202 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4203 arg
= fold_convert (arg_type
, arg
);
4204 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4205 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4207 /* Compute LEADZ for the case i .ne. 0. */
4210 s
= TYPE_PRECISION (arg_type
) - argsize
;
4211 tmp
= fold_convert (result_type
,
4212 build_call_expr_loc (input_location
, func
,
4214 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4215 tmp
, build_int_cst (result_type
, s
));
4219 /* We end up here if the argument type is larger than 'long long'.
4220 We generate this code:
4222 if (x & (ULL_MAX << ULL_SIZE) != 0)
4223 return clzll ((unsigned long long) (x >> ULLSIZE));
4225 return ULL_SIZE + clzll ((unsigned long long) x);
4226 where ULL_MAX is the largest value that a ULL_MAX can hold
4227 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4228 is the bit-size of the long long type (64 in this example). */
4229 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4231 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4232 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4233 long_long_unsigned_type_node
,
4234 build_int_cst (long_long_unsigned_type_node
,
4237 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4238 fold_convert (arg_type
, ullmax
), ullsize
);
4239 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4241 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4242 cond
, build_int_cst (arg_type
, 0));
4244 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4246 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4247 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4248 tmp1
= fold_convert (result_type
,
4249 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4251 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4252 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4253 tmp2
= fold_convert (result_type
,
4254 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4255 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4258 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4262 /* Build BIT_SIZE. */
4263 bit_size
= build_int_cst (result_type
, argsize
);
4265 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4266 arg
, build_int_cst (arg_type
, 0));
4267 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4272 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4274 The conditional expression is necessary because the result of TRAILZ(0)
4275 is defined, but the result of __builtin_ctz(0) is undefined for most
4279 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4290 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4291 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4293 /* Which variant of __builtin_ctz* should we call? */
4294 if (argsize
<= INT_TYPE_SIZE
)
4296 arg_type
= unsigned_type_node
;
4297 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4299 else if (argsize
<= LONG_TYPE_SIZE
)
4301 arg_type
= long_unsigned_type_node
;
4302 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4304 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4306 arg_type
= long_long_unsigned_type_node
;
4307 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4311 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4312 arg_type
= gfc_build_uint_type (argsize
);
4316 /* Convert the actual argument twice: first, to the unsigned type of the
4317 same size; then, to the proper argument type for the built-in
4318 function. But the return type is of the default INTEGER kind. */
4319 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4320 arg
= fold_convert (arg_type
, arg
);
4321 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4322 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4324 /* Compute TRAILZ for the case i .ne. 0. */
4326 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4330 /* We end up here if the argument type is larger than 'long long'.
4331 We generate this code:
4333 if ((x & ULL_MAX) == 0)
4334 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4336 return ctzll ((unsigned long long) x);
4338 where ULL_MAX is the largest value that a ULL_MAX can hold
4339 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4340 is the bit-size of the long long type (64 in this example). */
4341 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4343 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4344 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4345 long_long_unsigned_type_node
,
4346 build_int_cst (long_long_unsigned_type_node
, 0));
4348 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4349 fold_convert (arg_type
, ullmax
));
4350 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4351 build_int_cst (arg_type
, 0));
4353 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4355 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4356 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4357 tmp1
= fold_convert (result_type
,
4358 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4359 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4362 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4363 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4364 tmp2
= fold_convert (result_type
,
4365 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4367 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4371 /* Build BIT_SIZE. */
4372 bit_size
= build_int_cst (result_type
, argsize
);
4374 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4375 arg
, build_int_cst (arg_type
, 0));
4376 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4380 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4381 for types larger than "long long", we call the long long built-in for
4382 the lower and higher bits and combine the result. */
4385 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
4393 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4394 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4395 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4397 /* Which variant of the builtin should we call? */
4398 if (argsize
<= INT_TYPE_SIZE
)
4400 arg_type
= unsigned_type_node
;
4401 func
= builtin_decl_explicit (parity
4403 : BUILT_IN_POPCOUNT
);
4405 else if (argsize
<= LONG_TYPE_SIZE
)
4407 arg_type
= long_unsigned_type_node
;
4408 func
= builtin_decl_explicit (parity
4410 : BUILT_IN_POPCOUNTL
);
4412 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4414 arg_type
= long_long_unsigned_type_node
;
4415 func
= builtin_decl_explicit (parity
4417 : BUILT_IN_POPCOUNTLL
);
4421 /* Our argument type is larger than 'long long', which mean none
4422 of the POPCOUNT builtins covers it. We thus call the 'long long'
4423 variant multiple times, and add the results. */
4424 tree utype
, arg2
, call1
, call2
;
4426 /* For now, we only cover the case where argsize is twice as large
4428 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4430 func
= builtin_decl_explicit (parity
4432 : BUILT_IN_POPCOUNTLL
);
4434 /* Convert it to an integer, and store into a variable. */
4435 utype
= gfc_build_uint_type (argsize
);
4436 arg
= fold_convert (utype
, arg
);
4437 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4439 /* Call the builtin twice. */
4440 call1
= build_call_expr_loc (input_location
, func
, 1,
4441 fold_convert (long_long_unsigned_type_node
,
4444 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
4445 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
4446 call2
= build_call_expr_loc (input_location
, func
, 1,
4447 fold_convert (long_long_unsigned_type_node
,
4450 /* Combine the results. */
4452 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
4455 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4461 /* Convert the actual argument twice: first, to the unsigned type of the
4462 same size; then, to the proper argument type for the built-in
4464 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4465 arg
= fold_convert (arg_type
, arg
);
4467 se
->expr
= fold_convert (result_type
,
4468 build_call_expr_loc (input_location
, func
, 1, arg
));
4472 /* Process an intrinsic with unspecified argument-types that has an optional
4473 argument (which could be of type character), e.g. EOSHIFT. For those, we
4474 need to append the string length of the optional argument if it is not
4475 present and the type is really character.
4476 primary specifies the position (starting at 1) of the non-optional argument
4477 specifying the type and optional gives the position of the optional
4478 argument in the arglist. */
4481 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
4482 unsigned primary
, unsigned optional
)
4484 gfc_actual_arglist
* prim_arg
;
4485 gfc_actual_arglist
* opt_arg
;
4487 gfc_actual_arglist
* arg
;
4489 VEC(tree
,gc
) *append_args
;
4491 /* Find the two arguments given as position. */
4495 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4499 if (cur_pos
== primary
)
4501 if (cur_pos
== optional
)
4504 if (cur_pos
>= primary
&& cur_pos
>= optional
)
4507 gcc_assert (prim_arg
);
4508 gcc_assert (prim_arg
->expr
);
4509 gcc_assert (opt_arg
);
4511 /* If we do have type CHARACTER and the optional argument is really absent,
4512 append a dummy 0 as string length. */
4514 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
4518 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
4519 append_args
= VEC_alloc (tree
, gc
, 1);
4520 VEC_quick_push (tree
, append_args
, dummy
);
4523 /* Build the call itself. */
4524 sym
= gfc_get_symbol_for_expr (expr
);
4525 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4531 /* The length of a character string. */
4533 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
4543 gcc_assert (!se
->ss
);
4545 arg
= expr
->value
.function
.actual
->expr
;
4547 type
= gfc_typenode_for_spec (&expr
->ts
);
4548 switch (arg
->expr_type
)
4551 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
4555 /* Obtain the string length from the function used by
4556 trans-array.c(gfc_trans_array_constructor). */
4558 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
4562 if (arg
->ref
== NULL
4563 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
4565 /* This doesn't catch all cases.
4566 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4567 and the surrounding thread. */
4568 sym
= arg
->symtree
->n
.sym
;
4569 decl
= gfc_get_symbol_decl (sym
);
4570 if (decl
== current_function_decl
&& sym
->attr
.function
4571 && (sym
->result
== sym
))
4572 decl
= gfc_get_fake_result_decl (sym
, 0);
4574 len
= sym
->ts
.u
.cl
->backend_decl
;
4579 /* Otherwise fall through. */
4582 /* Anybody stupid enough to do this deserves inefficient code. */
4583 ss
= gfc_walk_expr (arg
);
4584 gfc_init_se (&argse
, se
);
4585 if (ss
== gfc_ss_terminator
)
4586 gfc_conv_expr (&argse
, arg
);
4588 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
4589 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4590 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4591 len
= argse
.string_length
;
4594 se
->expr
= convert (type
, len
);
4597 /* The length of a character string not including trailing blanks. */
4599 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
4601 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4602 tree args
[2], type
, fndecl
;
4604 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4605 type
= gfc_typenode_for_spec (&expr
->ts
);
4608 fndecl
= gfor_fndecl_string_len_trim
;
4610 fndecl
= gfor_fndecl_string_len_trim_char4
;
4614 se
->expr
= build_call_expr_loc (input_location
,
4615 fndecl
, 2, args
[0], args
[1]);
4616 se
->expr
= convert (type
, se
->expr
);
4620 /* Returns the starting position of a substring within a string. */
4623 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4626 tree logical4_type_node
= gfc_get_logical_type (4);
4630 unsigned int num_args
;
4632 args
= XALLOCAVEC (tree
, 5);
4634 /* Get number of arguments; characters count double due to the
4635 string length argument. Kind= is not passed to the library
4636 and thus ignored. */
4637 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4642 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4643 type
= gfc_typenode_for_spec (&expr
->ts
);
4646 args
[4] = build_int_cst (logical4_type_node
, 0);
4648 args
[4] = convert (logical4_type_node
, args
[4]);
4650 fndecl
= build_addr (function
, current_function_decl
);
4651 se
->expr
= build_call_array_loc (input_location
,
4652 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4654 se
->expr
= convert (type
, se
->expr
);
4658 /* The ascii value for a single character. */
4660 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4662 tree args
[2], type
, pchartype
;
4664 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4665 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
4666 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
4667 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
4668 type
= gfc_typenode_for_spec (&expr
->ts
);
4670 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4672 se
->expr
= convert (type
, se
->expr
);
4676 /* Intrinsic ISNAN calls __builtin_isnan. */
4679 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
4683 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4684 se
->expr
= build_call_expr_loc (input_location
,
4685 builtin_decl_explicit (BUILT_IN_ISNAN
),
4687 STRIP_TYPE_NOPS (se
->expr
);
4688 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4692 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4693 their argument against a constant integer value. */
4696 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
4700 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4701 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
4702 gfc_typenode_for_spec (&expr
->ts
),
4703 arg
, build_int_cst (TREE_TYPE (arg
), value
));
4708 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4711 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
4719 unsigned int num_args
;
4721 num_args
= gfc_intrinsic_argument_list_length (expr
);
4722 args
= XALLOCAVEC (tree
, num_args
);
4724 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4725 if (expr
->ts
.type
!= BT_CHARACTER
)
4733 /* We do the same as in the non-character case, but the argument
4734 list is different because of the string length arguments. We
4735 also have to set the string length for the result. */
4742 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
4744 se
->string_length
= len
;
4746 type
= TREE_TYPE (tsource
);
4747 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
4748 fold_convert (type
, fsource
));
4752 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4755 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
4757 tree args
[3], mask
, type
;
4759 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4760 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
4762 type
= TREE_TYPE (args
[0]);
4763 gcc_assert (TREE_TYPE (args
[1]) == type
);
4764 gcc_assert (TREE_TYPE (mask
) == type
);
4766 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
4767 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
4768 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4770 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
4775 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4776 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4779 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
4781 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
4784 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4785 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4787 type
= gfc_get_int_type (expr
->ts
.kind
);
4788 utype
= unsigned_type_for (type
);
4790 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
4791 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
4793 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
4794 build_int_cst (utype
, 0));
4798 /* Left-justified mask. */
4799 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
4801 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4802 fold_convert (utype
, res
));
4804 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4805 smaller than type width. */
4806 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4807 build_int_cst (TREE_TYPE (arg
), 0));
4808 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
4809 build_int_cst (utype
, 0), res
);
4813 /* Right-justified mask. */
4814 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4815 fold_convert (utype
, arg
));
4816 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
4818 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4819 strictly smaller than type width. */
4820 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4822 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
4823 cond
, allones
, res
);
4826 se
->expr
= fold_convert (type
, res
);
4830 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4832 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
4834 tree arg
, type
, tmp
, frexp
;
4836 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4838 type
= gfc_typenode_for_spec (&expr
->ts
);
4839 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4840 tmp
= gfc_create_var (integer_type_node
, NULL
);
4841 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
4842 fold_convert (type
, arg
),
4843 gfc_build_addr_expr (NULL_TREE
, tmp
));
4844 se
->expr
= fold_convert (type
, se
->expr
);
4848 /* NEAREST (s, dir) is translated into
4849 tmp = copysign (HUGE_VAL, dir);
4850 return nextafter (s, tmp);
4853 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
4855 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
4857 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
4858 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
4860 type
= gfc_typenode_for_spec (&expr
->ts
);
4861 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4863 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
4864 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
4865 fold_convert (type
, args
[1]));
4866 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
4867 fold_convert (type
, args
[0]), tmp
);
4868 se
->expr
= fold_convert (type
, se
->expr
);
4872 /* SPACING (s) is translated into
4880 e = MAX_EXPR (e, emin);
4881 res = scalbn (1., e);
4885 where prec is the precision of s, gfc_real_kinds[k].digits,
4886 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4887 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4890 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
4892 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
4893 tree cond
, tmp
, frexp
, scalbn
;
4897 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4898 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
4899 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
4900 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
4902 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4903 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4905 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4906 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4908 type
= gfc_typenode_for_spec (&expr
->ts
);
4909 e
= gfc_create_var (integer_type_node
, NULL
);
4910 res
= gfc_create_var (type
, NULL
);
4913 /* Build the block for s /= 0. */
4914 gfc_start_block (&block
);
4915 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4916 gfc_build_addr_expr (NULL_TREE
, e
));
4917 gfc_add_expr_to_block (&block
, tmp
);
4919 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
4921 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
4922 integer_type_node
, tmp
, emin
));
4924 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
4925 build_real_from_int_cst (type
, integer_one_node
), e
);
4926 gfc_add_modify (&block
, res
, tmp
);
4928 /* Finish by building the IF statement. */
4929 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4930 build_real_from_int_cst (type
, integer_zero_node
));
4931 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
4932 gfc_finish_block (&block
));
4934 gfc_add_expr_to_block (&se
->pre
, tmp
);
4939 /* RRSPACING (s) is translated into
4946 x = scalbn (x, precision - e);
4950 where precision is gfc_real_kinds[k].digits. */
4953 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
4955 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
4959 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4960 prec
= gfc_real_kinds
[k
].digits
;
4962 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4963 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4964 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
4966 type
= gfc_typenode_for_spec (&expr
->ts
);
4967 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4968 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4970 e
= gfc_create_var (integer_type_node
, NULL
);
4971 x
= gfc_create_var (type
, NULL
);
4972 gfc_add_modify (&se
->pre
, x
,
4973 build_call_expr_loc (input_location
, fabs
, 1, arg
));
4976 gfc_start_block (&block
);
4977 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4978 gfc_build_addr_expr (NULL_TREE
, e
));
4979 gfc_add_expr_to_block (&block
, tmp
);
4981 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
4982 build_int_cst (integer_type_node
, prec
), e
);
4983 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
4984 gfc_add_modify (&block
, x
, tmp
);
4985 stmt
= gfc_finish_block (&block
);
4987 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
4988 build_real_from_int_cst (type
, integer_zero_node
));
4989 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
4990 gfc_add_expr_to_block (&se
->pre
, tmp
);
4992 se
->expr
= fold_convert (type
, x
);
4996 /* SCALE (s, i) is translated into scalbn (s, i). */
4998 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5000 tree args
[2], type
, scalbn
;
5002 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5004 type
= gfc_typenode_for_spec (&expr
->ts
);
5005 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5006 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5007 fold_convert (type
, args
[0]),
5008 fold_convert (integer_type_node
, args
[1]));
5009 se
->expr
= fold_convert (type
, se
->expr
);
5013 /* SET_EXPONENT (s, i) is translated into
5014 scalbn (frexp (s, &dummy_int), i). */
5016 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5018 tree args
[2], type
, tmp
, frexp
, scalbn
;
5020 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5021 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5023 type
= gfc_typenode_for_spec (&expr
->ts
);
5024 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5026 tmp
= gfc_create_var (integer_type_node
, NULL
);
5027 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5028 fold_convert (type
, args
[0]),
5029 gfc_build_addr_expr (NULL_TREE
, tmp
));
5030 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5031 fold_convert (integer_type_node
, args
[1]));
5032 se
->expr
= fold_convert (type
, se
->expr
);
5037 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5039 gfc_actual_arglist
*actual
;
5047 gfc_init_se (&argse
, NULL
);
5048 actual
= expr
->value
.function
.actual
;
5050 if (actual
->expr
->ts
.type
== BT_CLASS
)
5051 gfc_add_class_array_ref (actual
->expr
);
5053 ss
= gfc_walk_expr (actual
->expr
);
5054 gcc_assert (ss
!= gfc_ss_terminator
);
5055 argse
.want_pointer
= 1;
5056 argse
.data_not_needed
= 1;
5057 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
5058 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5059 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5060 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5062 /* Build the call to size0. */
5063 fncall0
= build_call_expr_loc (input_location
,
5064 gfor_fndecl_size0
, 1, arg1
);
5066 actual
= actual
->next
;
5070 gfc_init_se (&argse
, NULL
);
5071 gfc_conv_expr_type (&argse
, actual
->expr
,
5072 gfc_array_index_type
);
5073 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5075 /* Unusually, for an intrinsic, size does not exclude
5076 an optional arg2, so we must test for it. */
5077 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5078 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5079 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5082 /* Build the call to size1. */
5083 fncall1
= build_call_expr_loc (input_location
,
5084 gfor_fndecl_size1
, 2,
5087 gfc_init_se (&argse
, NULL
);
5088 argse
.want_pointer
= 1;
5089 argse
.data_not_needed
= 1;
5090 gfc_conv_expr (&argse
, actual
->expr
);
5091 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5092 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5093 argse
.expr
, null_pointer_node
);
5094 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5095 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5096 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5100 se
->expr
= NULL_TREE
;
5101 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5102 gfc_array_index_type
,
5103 argse
.expr
, gfc_index_one_node
);
5106 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5108 argse
.expr
= gfc_index_zero_node
;
5109 se
->expr
= NULL_TREE
;
5114 if (se
->expr
== NULL_TREE
)
5116 tree ubound
, lbound
;
5118 arg1
= build_fold_indirect_ref_loc (input_location
,
5120 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5121 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5122 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5123 gfc_array_index_type
, ubound
, lbound
);
5124 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5125 gfc_array_index_type
,
5126 se
->expr
, gfc_index_one_node
);
5127 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5128 gfc_array_index_type
, se
->expr
,
5129 gfc_index_zero_node
);
5132 type
= gfc_typenode_for_spec (&expr
->ts
);
5133 se
->expr
= convert (type
, se
->expr
);
5137 /* Helper function to compute the size of a character variable,
5138 excluding the terminating null characters. The result has
5139 gfc_array_index_type type. */
5142 size_of_string_in_bytes (int kind
, tree string_length
)
5145 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5147 bytesize
= build_int_cst (gfc_array_index_type
,
5148 gfc_character_kinds
[i
].bit_size
/ 8);
5150 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5152 fold_convert (gfc_array_index_type
, string_length
));
5157 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5169 arg
= expr
->value
.function
.actual
->expr
;
5171 gfc_init_se (&argse
, NULL
);
5172 ss
= gfc_walk_expr (arg
);
5174 if (ss
== gfc_ss_terminator
)
5176 if (arg
->ts
.type
== BT_CLASS
)
5177 gfc_add_data_component (arg
);
5179 gfc_conv_expr_reference (&argse
, arg
);
5181 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5184 /* Obtain the source word length. */
5185 if (arg
->ts
.type
== BT_CHARACTER
)
5186 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
5187 argse
.string_length
);
5189 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
5193 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5194 argse
.want_pointer
= 0;
5195 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
5196 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5198 /* Obtain the argument's word length. */
5199 if (arg
->ts
.type
== BT_CHARACTER
)
5200 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5202 tmp
= fold_convert (gfc_array_index_type
,
5203 size_in_bytes (type
));
5204 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5206 /* Obtain the size of the array in bytes. */
5207 for (n
= 0; n
< arg
->rank
; n
++)
5210 idx
= gfc_rank_cst
[n
];
5211 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5212 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5213 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5214 gfc_array_index_type
, upper
, lower
);
5215 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5216 gfc_array_index_type
, tmp
, gfc_index_one_node
);
5217 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5218 gfc_array_index_type
, tmp
, source_bytes
);
5219 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5221 se
->expr
= source_bytes
;
5224 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5229 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
5234 tree type
, result_type
, tmp
;
5236 arg
= expr
->value
.function
.actual
->expr
;
5237 gfc_init_se (&eight
, NULL
);
5238 gfc_conv_expr (&eight
, gfc_get_int_expr (expr
->ts
.kind
, NULL
, 8));
5240 gfc_init_se (&argse
, NULL
);
5241 ss
= gfc_walk_expr (arg
);
5242 result_type
= gfc_get_int_type (expr
->ts
.kind
);
5244 if (ss
== gfc_ss_terminator
)
5246 if (arg
->ts
.type
== BT_CLASS
)
5248 gfc_add_vptr_component (arg
);
5249 gfc_add_size_component (arg
);
5250 gfc_conv_expr (&argse
, arg
);
5251 tmp
= fold_convert (result_type
, argse
.expr
);
5255 gfc_conv_expr_reference (&argse
, arg
);
5256 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5261 argse
.want_pointer
= 0;
5262 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
5263 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5266 /* Obtain the argument's word length. */
5267 if (arg
->ts
.type
== BT_CHARACTER
)
5268 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5270 tmp
= fold_convert (result_type
, size_in_bytes (type
));
5273 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
5275 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5279 /* Intrinsic string comparison functions. */
5282 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5286 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
5289 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
5290 expr
->value
.function
.actual
->expr
->ts
.kind
,
5292 se
->expr
= fold_build2_loc (input_location
, op
,
5293 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
5294 build_int_cst (TREE_TYPE (se
->expr
), 0));
5297 /* Generate a call to the adjustl/adjustr library function. */
5299 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
5307 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
5310 type
= TREE_TYPE (args
[2]);
5311 var
= gfc_conv_string_tmp (se
, type
, len
);
5314 tmp
= build_call_expr_loc (input_location
,
5315 fndecl
, 3, args
[0], args
[1], args
[2]);
5316 gfc_add_expr_to_block (&se
->pre
, tmp
);
5318 se
->string_length
= len
;
5322 /* Generate code for the TRANSFER intrinsic:
5324 DEST = TRANSFER (SOURCE, MOLD)
5326 typeof<DEST> = typeof<MOLD>
5331 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5333 typeof<DEST> = typeof<MOLD>
5335 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5336 sizeof (DEST(0) * SIZE). */
5338 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
5354 gfc_actual_arglist
*arg
;
5357 gfc_array_info
*info
;
5364 info
= &se
->ss
->info
->data
.array
;
5366 /* Convert SOURCE. The output from this stage is:-
5367 source_bytes = length of the source in bytes
5368 source = pointer to the source data. */
5369 arg
= expr
->value
.function
.actual
;
5371 /* Ensure double transfer through LOGICAL preserves all
5373 if (arg
->expr
->expr_type
== EXPR_FUNCTION
5374 && arg
->expr
->value
.function
.esym
== NULL
5375 && arg
->expr
->value
.function
.isym
!= NULL
5376 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
5377 && arg
->expr
->ts
.type
== BT_LOGICAL
5378 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
5379 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
5381 gfc_init_se (&argse
, NULL
);
5382 ss
= gfc_walk_expr (arg
->expr
);
5384 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5386 /* Obtain the pointer to source and the length of source in bytes. */
5387 if (ss
== gfc_ss_terminator
)
5389 gfc_conv_expr_reference (&argse
, arg
->expr
);
5390 source
= argse
.expr
;
5392 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5395 /* Obtain the source word length. */
5396 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5397 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5398 argse
.string_length
);
5400 tmp
= fold_convert (gfc_array_index_type
,
5401 size_in_bytes (source_type
));
5405 argse
.want_pointer
= 0;
5406 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
5407 source
= gfc_conv_descriptor_data_get (argse
.expr
);
5408 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5410 /* Repack the source if not a full variable array. */
5411 if (arg
->expr
->expr_type
== EXPR_VARIABLE
5412 && arg
->expr
->ref
->u
.ar
.type
!= AR_FULL
)
5414 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
5416 if (gfc_option
.warn_array_temp
)
5417 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5419 source
= build_call_expr_loc (input_location
,
5420 gfor_fndecl_in_pack
, 1, tmp
);
5421 source
= gfc_evaluate_now (source
, &argse
.pre
);
5423 /* Free the temporary. */
5424 gfc_start_block (&block
);
5425 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
5426 gfc_add_expr_to_block (&block
, tmp
);
5427 stmt
= gfc_finish_block (&block
);
5429 /* Clean up if it was repacked. */
5430 gfc_init_block (&block
);
5431 tmp
= gfc_conv_array_data (argse
.expr
);
5432 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5434 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
5435 build_empty_stmt (input_location
));
5436 gfc_add_expr_to_block (&block
, tmp
);
5437 gfc_add_block_to_block (&block
, &se
->post
);
5438 gfc_init_block (&se
->post
);
5439 gfc_add_block_to_block (&se
->post
, &block
);
5442 /* Obtain the source word length. */
5443 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5444 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5445 argse
.string_length
);
5447 tmp
= fold_convert (gfc_array_index_type
,
5448 size_in_bytes (source_type
));
5450 /* Obtain the size of the array in bytes. */
5451 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
5452 for (n
= 0; n
< arg
->expr
->rank
; n
++)
5455 idx
= gfc_rank_cst
[n
];
5456 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5457 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5458 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5459 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5460 gfc_array_index_type
, upper
, lower
);
5461 gfc_add_modify (&argse
.pre
, extent
, tmp
);
5462 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5463 gfc_array_index_type
, extent
,
5464 gfc_index_one_node
);
5465 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5466 gfc_array_index_type
, tmp
, source_bytes
);
5470 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5471 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5472 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5474 /* Now convert MOLD. The outputs are:
5475 mold_type = the TREE type of MOLD
5476 dest_word_len = destination word length in bytes. */
5479 gfc_init_se (&argse
, NULL
);
5480 ss
= gfc_walk_expr (arg
->expr
);
5482 scalar_mold
= arg
->expr
->rank
== 0;
5484 if (ss
== gfc_ss_terminator
)
5486 gfc_conv_expr_reference (&argse
, arg
->expr
);
5487 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5492 gfc_init_se (&argse
, NULL
);
5493 argse
.want_pointer
= 0;
5494 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
5495 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5498 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5499 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5501 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
5503 /* If this TRANSFER is nested in another TRANSFER, use a type
5504 that preserves all bits. */
5505 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
5506 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
5509 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5511 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
5512 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
5515 tmp
= fold_convert (gfc_array_index_type
,
5516 size_in_bytes (mold_type
));
5518 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
5519 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
5521 /* Finally convert SIZE, if it is present. */
5523 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
5527 gfc_init_se (&argse
, NULL
);
5528 gfc_conv_expr_reference (&argse
, arg
->expr
);
5529 tmp
= convert (gfc_array_index_type
,
5530 build_fold_indirect_ref_loc (input_location
,
5532 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5533 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5538 /* Separate array and scalar results. */
5539 if (scalar_mold
&& tmp
== NULL_TREE
)
5540 goto scalar_transfer
;
5542 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5543 if (tmp
!= NULL_TREE
)
5544 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5545 tmp
, dest_word_len
);
5549 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
5550 gfc_add_modify (&se
->pre
, size_words
,
5551 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
5552 gfc_array_index_type
,
5553 size_bytes
, dest_word_len
));
5555 /* Evaluate the bounds of the result. If the loop range exists, we have
5556 to check if it is too large. If so, we modify loop->to be consistent
5557 with min(size, size(source)). Otherwise, size is made consistent with
5558 the loop range, so that the right number of bytes is transferred.*/
5559 n
= se
->loop
->order
[0];
5560 if (se
->loop
->to
[n
] != NULL_TREE
)
5562 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5563 se
->loop
->to
[n
], se
->loop
->from
[n
]);
5564 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5565 tmp
, gfc_index_one_node
);
5566 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5568 gfc_add_modify (&se
->pre
, size_words
, tmp
);
5569 gfc_add_modify (&se
->pre
, size_bytes
,
5570 fold_build2_loc (input_location
, MULT_EXPR
,
5571 gfc_array_index_type
,
5572 size_words
, dest_word_len
));
5573 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5574 size_words
, se
->loop
->from
[n
]);
5575 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5576 upper
, gfc_index_one_node
);
5580 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5581 size_words
, gfc_index_one_node
);
5582 se
->loop
->from
[n
] = gfc_index_zero_node
;
5585 se
->loop
->to
[n
] = upper
;
5587 /* Build a destination descriptor, using the pointer, source, as the
5589 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
5590 NULL_TREE
, false, true, false, &expr
->where
);
5592 /* Cast the pointer to the result. */
5593 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5594 tmp
= fold_convert (pvoid_type_node
, tmp
);
5596 /* Use memcpy to do the transfer. */
5597 tmp
= build_call_expr_loc (input_location
,
5598 builtin_decl_explicit (BUILT_IN_MEMCPY
),
5601 fold_convert (pvoid_type_node
, source
),
5602 fold_build2_loc (input_location
, MIN_EXPR
,
5603 gfc_array_index_type
,
5604 size_bytes
, source_bytes
));
5605 gfc_add_expr_to_block (&se
->pre
, tmp
);
5607 se
->expr
= info
->descriptor
;
5608 if (expr
->ts
.type
== BT_CHARACTER
)
5609 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5613 /* Deal with scalar results. */
5615 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5616 dest_word_len
, source_bytes
);
5617 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5618 extent
, gfc_index_zero_node
);
5620 if (expr
->ts
.type
== BT_CHARACTER
)
5625 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5626 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5629 /* If source is longer than the destination, use a pointer to
5630 the source directly. */
5631 gfc_init_block (&block
);
5632 gfc_add_modify (&block
, tmpdecl
, ptr
);
5633 direct
= gfc_finish_block (&block
);
5635 /* Otherwise, allocate a string with the length of the destination
5636 and copy the source into it. */
5637 gfc_init_block (&block
);
5638 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5639 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5640 gfc_add_modify (&block
, tmpdecl
,
5641 fold_convert (TREE_TYPE (ptr
), tmp
));
5642 tmp
= build_call_expr_loc (input_location
,
5643 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5644 fold_convert (pvoid_type_node
, tmpdecl
),
5645 fold_convert (pvoid_type_node
, ptr
),
5647 gfc_add_expr_to_block (&block
, tmp
);
5648 indirect
= gfc_finish_block (&block
);
5650 /* Wrap it up with the condition. */
5651 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5652 dest_word_len
, source_bytes
);
5653 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5654 gfc_add_expr_to_block (&se
->pre
, tmp
);
5657 se
->string_length
= dest_word_len
;
5661 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5663 ptr
= convert (build_pointer_type (mold_type
), source
);
5665 /* Use memcpy to do the transfer. */
5666 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5667 tmp
= build_call_expr_loc (input_location
,
5668 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5669 fold_convert (pvoid_type_node
, tmp
),
5670 fold_convert (pvoid_type_node
, ptr
),
5672 gfc_add_expr_to_block (&se
->pre
, tmp
);
5679 /* Generate code for the ALLOCATED intrinsic.
5680 Generate inline code that directly check the address of the argument. */
5683 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5685 gfc_actual_arglist
*arg1
;
5690 gfc_init_se (&arg1se
, NULL
);
5691 arg1
= expr
->value
.function
.actual
;
5693 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5695 /* Make sure that class array expressions have both a _data
5696 component reference and an array reference.... */
5697 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
5698 gfc_add_class_array_ref (arg1
->expr
);
5699 /* .... whilst scalars only need the _data component. */
5701 gfc_add_data_component (arg1
->expr
);
5704 ss1
= gfc_walk_expr (arg1
->expr
);
5706 if (ss1
== gfc_ss_terminator
)
5708 /* Allocatable scalar. */
5709 arg1se
.want_pointer
= 1;
5710 gfc_conv_expr (&arg1se
, arg1
->expr
);
5715 /* Allocatable array. */
5716 arg1se
.descriptor_only
= 1;
5717 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5718 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5721 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5722 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5723 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5727 /* Generate code for the ASSOCIATED intrinsic.
5728 If both POINTER and TARGET are arrays, generate a call to library function
5729 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5730 In other cases, generate inline code that directly compare the address of
5731 POINTER with the address of TARGET. */
5734 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
5736 gfc_actual_arglist
*arg1
;
5737 gfc_actual_arglist
*arg2
;
5742 tree nonzero_charlen
;
5743 tree nonzero_arraylen
;
5746 gfc_init_se (&arg1se
, NULL
);
5747 gfc_init_se (&arg2se
, NULL
);
5748 arg1
= expr
->value
.function
.actual
;
5749 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5750 gfc_add_data_component (arg1
->expr
);
5752 ss1
= gfc_walk_expr (arg1
->expr
);
5756 /* No optional target. */
5757 if (ss1
== gfc_ss_terminator
)
5759 /* A pointer to a scalar. */
5760 arg1se
.want_pointer
= 1;
5761 gfc_conv_expr (&arg1se
, arg1
->expr
);
5766 /* A pointer to an array. */
5767 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5768 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5770 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5771 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5772 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
5773 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
5778 /* An optional target. */
5779 if (arg2
->expr
->ts
.type
== BT_CLASS
)
5780 gfc_add_data_component (arg2
->expr
);
5781 ss2
= gfc_walk_expr (arg2
->expr
);
5783 nonzero_charlen
= NULL_TREE
;
5784 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
5785 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
5787 arg1
->expr
->ts
.u
.cl
->backend_decl
,
5790 if (ss1
== gfc_ss_terminator
)
5792 /* A pointer to a scalar. */
5793 gcc_assert (ss2
== gfc_ss_terminator
);
5794 arg1se
.want_pointer
= 1;
5795 gfc_conv_expr (&arg1se
, arg1
->expr
);
5796 arg2se
.want_pointer
= 1;
5797 gfc_conv_expr (&arg2se
, arg2
->expr
);
5798 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5799 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5800 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5801 arg1se
.expr
, arg2se
.expr
);
5802 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5803 arg1se
.expr
, null_pointer_node
);
5804 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5805 boolean_type_node
, tmp
, tmp2
);
5809 /* An array pointer of zero length is not associated if target is
5811 arg1se
.descriptor_only
= 1;
5812 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
5813 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
,
5814 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
5815 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
5816 boolean_type_node
, tmp
,
5817 build_int_cst (TREE_TYPE (tmp
), 0));
5819 /* A pointer to an array, call library function _gfor_associated. */
5820 gcc_assert (ss2
!= gfc_ss_terminator
);
5821 arg1se
.want_pointer
= 1;
5822 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5824 arg2se
.want_pointer
= 1;
5825 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
5826 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
5827 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
5828 se
->expr
= build_call_expr_loc (input_location
,
5829 gfor_fndecl_associated
, 2,
5830 arg1se
.expr
, arg2se
.expr
);
5831 se
->expr
= convert (boolean_type_node
, se
->expr
);
5832 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5833 boolean_type_node
, se
->expr
,
5837 /* If target is present zero character length pointers cannot
5839 if (nonzero_charlen
!= NULL_TREE
)
5840 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5842 se
->expr
, nonzero_charlen
);
5845 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5849 /* Generate code for the SAME_TYPE_AS intrinsic.
5850 Generate inline code that directly checks the vindices. */
5853 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
5859 gfc_init_se (&se1
, NULL
);
5860 gfc_init_se (&se2
, NULL
);
5862 a
= expr
->value
.function
.actual
->expr
;
5863 b
= expr
->value
.function
.actual
->next
->expr
;
5865 if (a
->ts
.type
== BT_CLASS
)
5867 gfc_add_vptr_component (a
);
5868 gfc_add_hash_component (a
);
5870 else if (a
->ts
.type
== BT_DERIVED
)
5871 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5872 a
->ts
.u
.derived
->hash_value
);
5874 if (b
->ts
.type
== BT_CLASS
)
5876 gfc_add_vptr_component (b
);
5877 gfc_add_hash_component (b
);
5879 else if (b
->ts
.type
== BT_DERIVED
)
5880 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5881 b
->ts
.u
.derived
->hash_value
);
5883 gfc_conv_expr (&se1
, a
);
5884 gfc_conv_expr (&se2
, b
);
5886 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5887 se1
.expr
, fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
5888 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5892 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
5895 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
5899 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5900 se
->expr
= build_call_expr_loc (input_location
,
5901 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
5902 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5906 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
5909 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
5913 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5915 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5916 type
= gfc_get_int_type (4);
5917 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
5919 /* Convert it to the required type. */
5920 type
= gfc_typenode_for_spec (&expr
->ts
);
5921 se
->expr
= build_call_expr_loc (input_location
,
5922 gfor_fndecl_si_kind
, 1, arg
);
5923 se
->expr
= fold_convert (type
, se
->expr
);
5927 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
5930 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
5932 gfc_actual_arglist
*actual
;
5935 VEC(tree
,gc
) *args
= NULL
;
5937 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
5939 gfc_init_se (&argse
, se
);
5941 /* Pass a NULL pointer for an absent arg. */
5942 if (actual
->expr
== NULL
)
5943 argse
.expr
= null_pointer_node
;
5949 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
5951 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
5952 ts
.type
= BT_INTEGER
;
5953 ts
.kind
= gfc_c_int_kind
;
5954 gfc_convert_type (actual
->expr
, &ts
, 2);
5956 gfc_conv_expr_reference (&argse
, actual
->expr
);
5959 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5960 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5961 VEC_safe_push (tree
, gc
, args
, argse
.expr
);
5964 /* Convert it to the required type. */
5965 type
= gfc_typenode_for_spec (&expr
->ts
);
5966 se
->expr
= build_call_expr_loc_vec (input_location
,
5967 gfor_fndecl_sr_kind
, args
);
5968 se
->expr
= fold_convert (type
, se
->expr
);
5972 /* Generate code for TRIM (A) intrinsic function. */
5975 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
5985 unsigned int num_args
;
5987 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
5988 args
= XALLOCAVEC (tree
, num_args
);
5990 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
5991 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
5992 len
= gfc_create_var (gfc_charlen_type_node
, "len");
5994 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
5995 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
5998 if (expr
->ts
.kind
== 1)
5999 function
= gfor_fndecl_string_trim
;
6000 else if (expr
->ts
.kind
== 4)
6001 function
= gfor_fndecl_string_trim_char4
;
6005 fndecl
= build_addr (function
, current_function_decl
);
6006 tmp
= build_call_array_loc (input_location
,
6007 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6009 gfc_add_expr_to_block (&se
->pre
, tmp
);
6011 /* Free the temporary afterwards, if necessary. */
6012 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6013 len
, build_int_cst (TREE_TYPE (len
), 0));
6014 tmp
= gfc_call_free (var
);
6015 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6016 gfc_add_expr_to_block (&se
->post
, tmp
);
6019 se
->string_length
= len
;
6023 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6026 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6028 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6029 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6031 stmtblock_t block
, body
;
6034 /* We store in charsize the size of a character. */
6035 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6036 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6038 /* Get the arguments. */
6039 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6040 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6042 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6043 ncopies_type
= TREE_TYPE (ncopies
);
6045 /* Check that NCOPIES is not negative. */
6046 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6047 build_int_cst (ncopies_type
, 0));
6048 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6049 "Argument NCOPIES of REPEAT intrinsic is negative "
6050 "(its value is %ld)",
6051 fold_convert (long_integer_type_node
, ncopies
));
6053 /* If the source length is zero, any non negative value of NCOPIES
6054 is valid, and nothing happens. */
6055 n
= gfc_create_var (ncopies_type
, "ncopies");
6056 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6057 build_int_cst (size_type_node
, 0));
6058 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6059 build_int_cst (ncopies_type
, 0), ncopies
);
6060 gfc_add_modify (&se
->pre
, n
, tmp
);
6063 /* Check that ncopies is not too large: ncopies should be less than
6064 (or equal to) MAX / slen, where MAX is the maximal integer of
6065 the gfc_charlen_type_node type. If slen == 0, we need a special
6066 case to avoid the division by zero. */
6067 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6068 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6069 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6070 fold_convert (size_type_node
, max
), slen
);
6071 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6072 ? size_type_node
: ncopies_type
;
6073 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6074 fold_convert (largest
, ncopies
),
6075 fold_convert (largest
, max
));
6076 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6077 build_int_cst (size_type_node
, 0));
6078 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6079 boolean_false_node
, cond
);
6080 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6081 "Argument NCOPIES of REPEAT intrinsic is too large");
6083 /* Compute the destination length. */
6084 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6085 fold_convert (gfc_charlen_type_node
, slen
),
6086 fold_convert (gfc_charlen_type_node
, ncopies
));
6087 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6088 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6090 /* Generate the code to do the repeat operation:
6091 for (i = 0; i < ncopies; i++)
6092 memmove (dest + (i * slen * size), src, slen*size); */
6093 gfc_start_block (&block
);
6094 count
= gfc_create_var (ncopies_type
, "count");
6095 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6096 exit_label
= gfc_build_label_decl (NULL_TREE
);
6098 /* Start the loop body. */
6099 gfc_start_block (&body
);
6101 /* Exit the loop if count >= ncopies. */
6102 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6104 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6105 TREE_USED (exit_label
) = 1;
6106 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6107 build_empty_stmt (input_location
));
6108 gfc_add_expr_to_block (&body
, tmp
);
6110 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6111 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6112 fold_convert (gfc_charlen_type_node
, slen
),
6113 fold_convert (gfc_charlen_type_node
, count
));
6114 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6115 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6116 tmp
= fold_build_pointer_plus_loc (input_location
,
6117 fold_convert (pvoid_type_node
, dest
), tmp
);
6118 tmp
= build_call_expr_loc (input_location
,
6119 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6121 fold_build2_loc (input_location
, MULT_EXPR
,
6122 size_type_node
, slen
,
6123 fold_convert (size_type_node
,
6125 gfc_add_expr_to_block (&body
, tmp
);
6127 /* Increment count. */
6128 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6129 count
, build_int_cst (TREE_TYPE (count
), 1));
6130 gfc_add_modify (&body
, count
, tmp
);
6132 /* Build the loop. */
6133 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6134 gfc_add_expr_to_block (&block
, tmp
);
6136 /* Add the exit label. */
6137 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6138 gfc_add_expr_to_block (&block
, tmp
);
6140 /* Finish the block. */
6141 tmp
= gfc_finish_block (&block
);
6142 gfc_add_expr_to_block (&se
->pre
, tmp
);
6144 /* Set the result value. */
6146 se
->string_length
= dlen
;
6150 /* Generate code for the IARGC intrinsic. */
6153 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6159 /* Call the library function. This always returns an INTEGER(4). */
6160 fndecl
= gfor_fndecl_iargc
;
6161 tmp
= build_call_expr_loc (input_location
,
6164 /* Convert it to the required type. */
6165 type
= gfc_typenode_for_spec (&expr
->ts
);
6166 tmp
= fold_convert (type
, tmp
);
6172 /* The loc intrinsic returns the address of its argument as
6173 gfc_index_integer_kind integer. */
6176 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
6182 gcc_assert (!se
->ss
);
6184 arg_expr
= expr
->value
.function
.actual
->expr
;
6185 ss
= gfc_walk_expr (arg_expr
);
6186 if (ss
== gfc_ss_terminator
)
6187 gfc_conv_expr_reference (se
, arg_expr
);
6189 gfc_conv_array_parameter (se
, arg_expr
, ss
, true, NULL
, NULL
, NULL
);
6190 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
6192 /* Create a temporary variable for loc return value. Without this,
6193 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6194 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
6195 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
6196 se
->expr
= temp_var
;
6199 /* Generate code for an intrinsic function. Some map directly to library
6200 calls, others get special handling. In some cases the name of the function
6201 used depends on the type specifiers. */
6204 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
6210 name
= &expr
->value
.function
.name
[2];
6214 lib
= gfc_is_intrinsic_libcall (expr
);
6218 se
->ignore_optional
= 1;
6220 switch (expr
->value
.function
.isym
->id
)
6222 case GFC_ISYM_EOSHIFT
:
6224 case GFC_ISYM_RESHAPE
:
6225 /* For all of those the first argument specifies the type and the
6226 third is optional. */
6227 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
6231 gfc_conv_intrinsic_funcall (se
, expr
);
6239 switch (expr
->value
.function
.isym
->id
)
6244 case GFC_ISYM_REPEAT
:
6245 gfc_conv_intrinsic_repeat (se
, expr
);
6249 gfc_conv_intrinsic_trim (se
, expr
);
6252 case GFC_ISYM_SC_KIND
:
6253 gfc_conv_intrinsic_sc_kind (se
, expr
);
6256 case GFC_ISYM_SI_KIND
:
6257 gfc_conv_intrinsic_si_kind (se
, expr
);
6260 case GFC_ISYM_SR_KIND
:
6261 gfc_conv_intrinsic_sr_kind (se
, expr
);
6264 case GFC_ISYM_EXPONENT
:
6265 gfc_conv_intrinsic_exponent (se
, expr
);
6269 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6271 fndecl
= gfor_fndecl_string_scan
;
6273 fndecl
= gfor_fndecl_string_scan_char4
;
6277 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6280 case GFC_ISYM_VERIFY
:
6281 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6283 fndecl
= gfor_fndecl_string_verify
;
6285 fndecl
= gfor_fndecl_string_verify_char4
;
6289 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6292 case GFC_ISYM_ALLOCATED
:
6293 gfc_conv_allocated (se
, expr
);
6296 case GFC_ISYM_ASSOCIATED
:
6297 gfc_conv_associated(se
, expr
);
6300 case GFC_ISYM_SAME_TYPE_AS
:
6301 gfc_conv_same_type_as (se
, expr
);
6305 gfc_conv_intrinsic_abs (se
, expr
);
6308 case GFC_ISYM_ADJUSTL
:
6309 if (expr
->ts
.kind
== 1)
6310 fndecl
= gfor_fndecl_adjustl
;
6311 else if (expr
->ts
.kind
== 4)
6312 fndecl
= gfor_fndecl_adjustl_char4
;
6316 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6319 case GFC_ISYM_ADJUSTR
:
6320 if (expr
->ts
.kind
== 1)
6321 fndecl
= gfor_fndecl_adjustr
;
6322 else if (expr
->ts
.kind
== 4)
6323 fndecl
= gfor_fndecl_adjustr_char4
;
6327 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6330 case GFC_ISYM_AIMAG
:
6331 gfc_conv_intrinsic_imagpart (se
, expr
);
6335 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
6339 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
6342 case GFC_ISYM_ANINT
:
6343 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
6347 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6351 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
6354 case GFC_ISYM_BTEST
:
6355 gfc_conv_intrinsic_btest (se
, expr
);
6359 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
6363 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
6367 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
6371 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
6374 case GFC_ISYM_ACHAR
:
6376 gfc_conv_intrinsic_char (se
, expr
);
6379 case GFC_ISYM_CONVERSION
:
6381 case GFC_ISYM_LOGICAL
:
6383 gfc_conv_intrinsic_conversion (se
, expr
);
6386 /* Integer conversions are handled separately to make sure we get the
6387 correct rounding mode. */
6392 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
6396 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
6399 case GFC_ISYM_CEILING
:
6400 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
6403 case GFC_ISYM_FLOOR
:
6404 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
6408 gfc_conv_intrinsic_mod (se
, expr
, 0);
6411 case GFC_ISYM_MODULO
:
6412 gfc_conv_intrinsic_mod (se
, expr
, 1);
6415 case GFC_ISYM_CMPLX
:
6416 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
6419 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
6420 gfc_conv_intrinsic_iargc (se
, expr
);
6423 case GFC_ISYM_COMPLEX
:
6424 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
6427 case GFC_ISYM_CONJG
:
6428 gfc_conv_intrinsic_conjg (se
, expr
);
6431 case GFC_ISYM_COUNT
:
6432 gfc_conv_intrinsic_count (se
, expr
);
6435 case GFC_ISYM_CTIME
:
6436 gfc_conv_intrinsic_ctime (se
, expr
);
6440 gfc_conv_intrinsic_dim (se
, expr
);
6443 case GFC_ISYM_DOT_PRODUCT
:
6444 gfc_conv_intrinsic_dot_product (se
, expr
);
6447 case GFC_ISYM_DPROD
:
6448 gfc_conv_intrinsic_dprod (se
, expr
);
6451 case GFC_ISYM_DSHIFTL
:
6452 gfc_conv_intrinsic_dshift (se
, expr
, true);
6455 case GFC_ISYM_DSHIFTR
:
6456 gfc_conv_intrinsic_dshift (se
, expr
, false);
6459 case GFC_ISYM_FDATE
:
6460 gfc_conv_intrinsic_fdate (se
, expr
);
6463 case GFC_ISYM_FRACTION
:
6464 gfc_conv_intrinsic_fraction (se
, expr
);
6468 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
6472 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6476 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
6479 case GFC_ISYM_IBCLR
:
6480 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
6483 case GFC_ISYM_IBITS
:
6484 gfc_conv_intrinsic_ibits (se
, expr
);
6487 case GFC_ISYM_IBSET
:
6488 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
6491 case GFC_ISYM_IACHAR
:
6492 case GFC_ISYM_ICHAR
:
6493 /* We assume ASCII character sequence. */
6494 gfc_conv_intrinsic_ichar (se
, expr
);
6497 case GFC_ISYM_IARGC
:
6498 gfc_conv_intrinsic_iargc (se
, expr
);
6502 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6505 case GFC_ISYM_INDEX
:
6506 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6508 fndecl
= gfor_fndecl_string_index
;
6510 fndecl
= gfor_fndecl_string_index_char4
;
6514 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6518 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6521 case GFC_ISYM_IPARITY
:
6522 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
6525 case GFC_ISYM_IS_IOSTAT_END
:
6526 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
6529 case GFC_ISYM_IS_IOSTAT_EOR
:
6530 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
6533 case GFC_ISYM_ISNAN
:
6534 gfc_conv_intrinsic_isnan (se
, expr
);
6537 case GFC_ISYM_LSHIFT
:
6538 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6541 case GFC_ISYM_RSHIFT
:
6542 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6545 case GFC_ISYM_SHIFTA
:
6546 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6549 case GFC_ISYM_SHIFTL
:
6550 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6553 case GFC_ISYM_SHIFTR
:
6554 gfc_conv_intrinsic_shift (se
, expr
, true, false);
6557 case GFC_ISYM_ISHFT
:
6558 gfc_conv_intrinsic_ishft (se
, expr
);
6561 case GFC_ISYM_ISHFTC
:
6562 gfc_conv_intrinsic_ishftc (se
, expr
);
6565 case GFC_ISYM_LEADZ
:
6566 gfc_conv_intrinsic_leadz (se
, expr
);
6569 case GFC_ISYM_TRAILZ
:
6570 gfc_conv_intrinsic_trailz (se
, expr
);
6573 case GFC_ISYM_POPCNT
:
6574 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
6577 case GFC_ISYM_POPPAR
:
6578 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
6581 case GFC_ISYM_LBOUND
:
6582 gfc_conv_intrinsic_bound (se
, expr
, 0);
6585 case GFC_ISYM_LCOBOUND
:
6586 conv_intrinsic_cobound (se
, expr
);
6589 case GFC_ISYM_TRANSPOSE
:
6590 /* The scalarizer has already been set up for reversed dimension access
6591 order ; now we just get the argument value normally. */
6592 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
6596 gfc_conv_intrinsic_len (se
, expr
);
6599 case GFC_ISYM_LEN_TRIM
:
6600 gfc_conv_intrinsic_len_trim (se
, expr
);
6604 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
6608 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
6612 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
6616 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
6619 case GFC_ISYM_MASKL
:
6620 gfc_conv_intrinsic_mask (se
, expr
, 1);
6623 case GFC_ISYM_MASKR
:
6624 gfc_conv_intrinsic_mask (se
, expr
, 0);
6628 if (expr
->ts
.type
== BT_CHARACTER
)
6629 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
6631 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
6634 case GFC_ISYM_MAXLOC
:
6635 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
6638 case GFC_ISYM_MAXVAL
:
6639 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
6642 case GFC_ISYM_MERGE
:
6643 gfc_conv_intrinsic_merge (se
, expr
);
6646 case GFC_ISYM_MERGE_BITS
:
6647 gfc_conv_intrinsic_merge_bits (se
, expr
);
6651 if (expr
->ts
.type
== BT_CHARACTER
)
6652 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
6654 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
6657 case GFC_ISYM_MINLOC
:
6658 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
6661 case GFC_ISYM_MINVAL
:
6662 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
6665 case GFC_ISYM_NEAREST
:
6666 gfc_conv_intrinsic_nearest (se
, expr
);
6669 case GFC_ISYM_NORM2
:
6670 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
6674 gfc_conv_intrinsic_not (se
, expr
);
6678 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6681 case GFC_ISYM_PARITY
:
6682 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
6685 case GFC_ISYM_PRESENT
:
6686 gfc_conv_intrinsic_present (se
, expr
);
6689 case GFC_ISYM_PRODUCT
:
6690 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
6693 case GFC_ISYM_RRSPACING
:
6694 gfc_conv_intrinsic_rrspacing (se
, expr
);
6697 case GFC_ISYM_SET_EXPONENT
:
6698 gfc_conv_intrinsic_set_exponent (se
, expr
);
6701 case GFC_ISYM_SCALE
:
6702 gfc_conv_intrinsic_scale (se
, expr
);
6706 gfc_conv_intrinsic_sign (se
, expr
);
6710 gfc_conv_intrinsic_size (se
, expr
);
6713 case GFC_ISYM_SIZEOF
:
6714 case GFC_ISYM_C_SIZEOF
:
6715 gfc_conv_intrinsic_sizeof (se
, expr
);
6718 case GFC_ISYM_STORAGE_SIZE
:
6719 gfc_conv_intrinsic_storage_size (se
, expr
);
6722 case GFC_ISYM_SPACING
:
6723 gfc_conv_intrinsic_spacing (se
, expr
);
6727 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
6730 case GFC_ISYM_TRANSFER
:
6731 if (se
->ss
&& se
->ss
->info
->useflags
)
6732 /* Access the previously obtained result. */
6733 gfc_conv_tmp_array_ref (se
);
6735 gfc_conv_intrinsic_transfer (se
, expr
);
6738 case GFC_ISYM_TTYNAM
:
6739 gfc_conv_intrinsic_ttynam (se
, expr
);
6742 case GFC_ISYM_UBOUND
:
6743 gfc_conv_intrinsic_bound (se
, expr
, 1);
6746 case GFC_ISYM_UCOBOUND
:
6747 conv_intrinsic_cobound (se
, expr
);
6751 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6755 gfc_conv_intrinsic_loc (se
, expr
);
6758 case GFC_ISYM_THIS_IMAGE
:
6759 /* For num_images() == 1, handle as LCOBOUND. */
6760 if (expr
->value
.function
.actual
->expr
6761 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
6762 conv_intrinsic_cobound (se
, expr
);
6764 trans_this_image (se
, expr
);
6767 case GFC_ISYM_IMAGE_INDEX
:
6768 trans_image_index (se
, expr
);
6771 case GFC_ISYM_NUM_IMAGES
:
6772 trans_num_images (se
);
6775 case GFC_ISYM_ACCESS
:
6776 case GFC_ISYM_CHDIR
:
6777 case GFC_ISYM_CHMOD
:
6778 case GFC_ISYM_DTIME
:
6779 case GFC_ISYM_ETIME
:
6780 case GFC_ISYM_EXTENDS_TYPE_OF
:
6782 case GFC_ISYM_FGETC
:
6785 case GFC_ISYM_FPUTC
:
6786 case GFC_ISYM_FSTAT
:
6787 case GFC_ISYM_FTELL
:
6788 case GFC_ISYM_GETCWD
:
6789 case GFC_ISYM_GETGID
:
6790 case GFC_ISYM_GETPID
:
6791 case GFC_ISYM_GETUID
:
6792 case GFC_ISYM_HOSTNM
:
6794 case GFC_ISYM_IERRNO
:
6795 case GFC_ISYM_IRAND
:
6796 case GFC_ISYM_ISATTY
:
6799 case GFC_ISYM_LSTAT
:
6800 case GFC_ISYM_MALLOC
:
6801 case GFC_ISYM_MATMUL
:
6802 case GFC_ISYM_MCLOCK
:
6803 case GFC_ISYM_MCLOCK8
:
6805 case GFC_ISYM_RENAME
:
6806 case GFC_ISYM_SECOND
:
6807 case GFC_ISYM_SECNDS
:
6808 case GFC_ISYM_SIGNAL
:
6810 case GFC_ISYM_SYMLNK
:
6811 case GFC_ISYM_SYSTEM
:
6813 case GFC_ISYM_TIME8
:
6814 case GFC_ISYM_UMASK
:
6815 case GFC_ISYM_UNLINK
:
6817 gfc_conv_intrinsic_funcall (se
, expr
);
6820 case GFC_ISYM_EOSHIFT
:
6822 case GFC_ISYM_RESHAPE
:
6823 /* For those, expr->rank should always be >0 and thus the if above the
6824 switch should have matched. */
6829 gfc_conv_intrinsic_lib_function (se
, expr
);
6836 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
6838 gfc_ss
*arg_ss
, *tmp_ss
;
6839 gfc_actual_arglist
*arg
;
6841 arg
= expr
->value
.function
.actual
;
6843 gcc_assert (arg
->expr
);
6845 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
6846 gcc_assert (arg_ss
!= gfc_ss_terminator
);
6848 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
6850 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
6851 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
6855 gcc_assert (tmp_ss
->dimen
== 2);
6857 /* We just invert dimensions. */
6858 tmp_dim
= tmp_ss
->dim
[0];
6859 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
6860 tmp_ss
->dim
[1] = tmp_dim
;
6863 /* Stop when tmp_ss points to the last valid element of the chain... */
6864 if (tmp_ss
->next
== gfc_ss_terminator
)
6868 /* ... so that we can attach the rest of the chain to it. */
6875 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
6876 This has the side effect of reversing the nested list, so there is no
6877 need to call gfc_reverse_ss on it (the given list is assumed not to be
6881 nest_loop_dimension (gfc_ss
*ss
, int dim
)
6884 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
6885 gfc_loopinfo
*new_loop
;
6887 gcc_assert (ss
!= gfc_ss_terminator
);
6889 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
6891 new_ss
= gfc_get_ss ();
6892 new_ss
->next
= prev_ss
;
6893 new_ss
->parent
= ss
;
6894 new_ss
->info
= ss
->info
;
6895 new_ss
->info
->refcount
++;
6898 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
6899 && ss
->info
->type
!= GFC_SS_REFERENCE
);
6902 new_ss
->dim
[0] = ss
->dim
[dim
];
6904 gcc_assert (dim
< ss
->dimen
);
6906 ss_dim
= --ss
->dimen
;
6907 for (i
= dim
; i
< ss_dim
; i
++)
6908 ss
->dim
[i
] = ss
->dim
[i
+ 1];
6910 ss
->dim
[ss_dim
] = 0;
6916 ss
->nested_ss
->parent
= new_ss
;
6917 new_ss
->nested_ss
= ss
->nested_ss
;
6919 ss
->nested_ss
= new_ss
;
6922 new_loop
= gfc_get_loopinfo ();
6923 gfc_init_loopinfo (new_loop
);
6925 gcc_assert (prev_ss
!= NULL
);
6926 gcc_assert (prev_ss
!= gfc_ss_terminator
);
6927 gfc_add_ss_to_loop (new_loop
, prev_ss
);
6928 return new_ss
->parent
;
6932 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
6933 is to be inlined. */
6936 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
6938 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
6939 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
6941 bool scalar_mask
= false;
6943 /* The rank of the result will be determined later. */
6944 arg1
= expr
->value
.function
.actual
;
6947 gcc_assert (arg3
!= NULL
);
6949 if (expr
->rank
== 0)
6952 tmp_ss
= gfc_ss_terminator
;
6958 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
6959 if (mask_ss
== tmp_ss
)
6965 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
6966 gcc_assert (array_ss
!= tmp_ss
);
6968 /* Odd thing: If the mask is scalar, it is used by the frontend after
6969 the array (to make an if around the nested loop). Thus it shall
6970 be after array_ss once the gfc_ss list is reversed. */
6972 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
6976 /* "Hide" the dimension on which we will sum in the first arg's scalarization
6978 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
6979 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
6987 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
6990 switch (expr
->value
.function
.isym
->id
)
6992 case GFC_ISYM_PRODUCT
:
6994 return walk_inline_intrinsic_arith (ss
, expr
);
6996 case GFC_ISYM_TRANSPOSE
:
6997 return walk_inline_intrinsic_transpose (ss
, expr
);
7006 /* This generates code to execute before entering the scalarization loop.
7007 Currently does nothing. */
7010 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
7012 switch (ss
->info
->expr
->value
.function
.isym
->id
)
7014 case GFC_ISYM_UBOUND
:
7015 case GFC_ISYM_LBOUND
:
7016 case GFC_ISYM_UCOBOUND
:
7017 case GFC_ISYM_LCOBOUND
:
7018 case GFC_ISYM_THIS_IMAGE
:
7027 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
7028 are expanded into code inside the scalarization loop. */
7031 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
7033 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
7034 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
7036 /* The two argument version returns a scalar. */
7037 if (expr
->value
.function
.actual
->next
->expr
)
7040 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
7044 /* Walk an intrinsic array libcall. */
7047 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
7049 gcc_assert (expr
->rank
> 0);
7050 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
7054 /* Return whether the function call expression EXPR will be expanded
7055 inline by gfc_conv_intrinsic_function. */
7058 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
7060 gfc_actual_arglist
*args
;
7062 if (!expr
->value
.function
.isym
)
7065 switch (expr
->value
.function
.isym
->id
)
7067 case GFC_ISYM_PRODUCT
:
7069 /* Disable inline expansion if code size matters. */
7073 args
= expr
->value
.function
.actual
;
7074 /* We need to be able to subset the SUM argument at compile-time. */
7075 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
7080 case GFC_ISYM_TRANSPOSE
:
7089 /* Returns nonzero if the specified intrinsic function call maps directly to
7090 an external library call. Should only be used for functions that return
7094 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
7096 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
7097 gcc_assert (expr
->rank
> 0);
7099 if (gfc_inline_intrinsic_function_p (expr
))
7102 switch (expr
->value
.function
.isym
->id
)
7106 case GFC_ISYM_COUNT
:
7110 case GFC_ISYM_IPARITY
:
7111 case GFC_ISYM_MATMUL
:
7112 case GFC_ISYM_MAXLOC
:
7113 case GFC_ISYM_MAXVAL
:
7114 case GFC_ISYM_MINLOC
:
7115 case GFC_ISYM_MINVAL
:
7116 case GFC_ISYM_NORM2
:
7117 case GFC_ISYM_PARITY
:
7118 case GFC_ISYM_PRODUCT
:
7120 case GFC_ISYM_SHAPE
:
7121 case GFC_ISYM_SPREAD
:
7123 /* Ignore absent optional parameters. */
7126 case GFC_ISYM_RESHAPE
:
7127 case GFC_ISYM_CSHIFT
:
7128 case GFC_ISYM_EOSHIFT
:
7130 case GFC_ISYM_UNPACK
:
7131 /* Pass absent optional parameters. */
7139 /* Walk an intrinsic function. */
7141 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
7142 gfc_intrinsic_sym
* isym
)
7146 if (isym
->elemental
)
7147 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
7150 if (expr
->rank
== 0)
7153 if (gfc_inline_intrinsic_function_p (expr
))
7154 return walk_inline_intrinsic_function (ss
, expr
);
7156 if (gfc_is_intrinsic_libcall (expr
))
7157 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7159 /* Special cases. */
7162 case GFC_ISYM_LBOUND
:
7163 case GFC_ISYM_LCOBOUND
:
7164 case GFC_ISYM_UBOUND
:
7165 case GFC_ISYM_UCOBOUND
:
7166 case GFC_ISYM_THIS_IMAGE
:
7167 return gfc_walk_intrinsic_bound (ss
, expr
);
7169 case GFC_ISYM_TRANSFER
:
7170 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7173 /* This probably meant someone forgot to add an intrinsic to the above
7174 list(s) when they implemented it, or something's gone horribly
7182 conv_intrinsic_atomic_def (gfc_code
*code
)
7187 gfc_init_se (&atom
, NULL
);
7188 gfc_init_se (&value
, NULL
);
7189 gfc_conv_expr (&atom
, code
->ext
.actual
->expr
);
7190 gfc_conv_expr (&value
, code
->ext
.actual
->next
->expr
);
7192 gfc_init_block (&block
);
7193 gfc_add_modify (&block
, atom
.expr
,
7194 fold_convert (TREE_TYPE (atom
.expr
), value
.expr
));
7195 return gfc_finish_block (&block
);
7200 conv_intrinsic_atomic_ref (gfc_code
*code
)
7205 gfc_init_se (&atom
, NULL
);
7206 gfc_init_se (&value
, NULL
);
7207 gfc_conv_expr (&value
, code
->ext
.actual
->expr
);
7208 gfc_conv_expr (&atom
, code
->ext
.actual
->next
->expr
);
7210 gfc_init_block (&block
);
7211 gfc_add_modify (&block
, value
.expr
,
7212 fold_convert (TREE_TYPE (value
.expr
), atom
.expr
));
7213 return gfc_finish_block (&block
);
7218 conv_intrinsic_move_alloc (gfc_code
*code
)
7221 gfc_expr
*from_expr
, *to_expr
;
7222 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
7223 gfc_se from_se
, to_se
;
7224 gfc_ss
*from_ss
, *to_ss
;
7227 gfc_start_block (&block
);
7229 from_expr
= code
->ext
.actual
->expr
;
7230 to_expr
= code
->ext
.actual
->next
->expr
;
7232 gfc_init_se (&from_se
, NULL
);
7233 gfc_init_se (&to_se
, NULL
);
7235 if (from_expr
->rank
== 0)
7237 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
7238 || to_expr
->ts
.type
== BT_CLASS
);
7239 if (from_expr
->ts
.type
!= BT_CLASS
)
7240 from_expr2
= from_expr
;
7243 from_expr2
= gfc_copy_expr (from_expr
);
7244 gfc_add_data_component (from_expr2
);
7247 if (to_expr
->ts
.type
!= BT_CLASS
)
7251 to_expr2
= gfc_copy_expr (to_expr
);
7252 gfc_add_data_component (to_expr2
);
7255 from_se
.want_pointer
= 1;
7256 to_se
.want_pointer
= 1;
7257 gfc_conv_expr (&from_se
, from_expr2
);
7258 gfc_conv_expr (&to_se
, to_expr2
);
7259 gfc_add_block_to_block (&block
, &from_se
.pre
);
7260 gfc_add_block_to_block (&block
, &to_se
.pre
);
7262 /* Deallocate "to". */
7263 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
7264 to_expr2
, to_expr
->ts
);
7265 gfc_add_expr_to_block (&block
, tmp
);
7267 /* Assign (_data) pointers. */
7268 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7269 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
7271 /* Set "from" to NULL. */
7272 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7273 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
7275 gfc_add_block_to_block (&block
, &from_se
.post
);
7276 gfc_add_block_to_block (&block
, &to_se
.post
);
7279 if (to_expr
->ts
.type
== BT_CLASS
)
7281 gfc_free_expr (to_expr2
);
7282 gfc_init_se (&to_se
, NULL
);
7283 to_se
.want_pointer
= 1;
7284 gfc_add_vptr_component (to_expr
);
7285 gfc_conv_expr (&to_se
, to_expr
);
7287 if (from_expr
->ts
.type
== BT_CLASS
)
7289 gfc_free_expr (from_expr2
);
7290 gfc_init_se (&from_se
, NULL
);
7291 from_se
.want_pointer
= 1;
7292 gfc_add_vptr_component (from_expr
);
7293 gfc_conv_expr (&from_se
, from_expr
);
7299 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7301 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7304 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7305 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7308 return gfc_finish_block (&block
);
7311 /* Update _vptr component. */
7312 if (to_expr
->ts
.type
== BT_CLASS
)
7314 to_se
.want_pointer
= 1;
7315 to_expr2
= gfc_copy_expr (to_expr
);
7316 gfc_add_vptr_component (to_expr2
);
7317 gfc_conv_expr (&to_se
, to_expr2
);
7319 if (from_expr
->ts
.type
== BT_CLASS
)
7321 from_se
.want_pointer
= 1;
7322 from_expr2
= gfc_copy_expr (from_expr
);
7323 gfc_add_vptr_component (from_expr2
);
7324 gfc_conv_expr (&from_se
, from_expr2
);
7330 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7332 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7335 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7336 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7337 gfc_free_expr (to_expr2
);
7338 gfc_init_se (&to_se
, NULL
);
7340 if (from_expr
->ts
.type
== BT_CLASS
)
7342 gfc_free_expr (from_expr2
);
7343 gfc_init_se (&from_se
, NULL
);
7347 /* Deallocate "to". */
7348 to_ss
= gfc_walk_expr (to_expr
);
7349 from_ss
= gfc_walk_expr (from_expr
);
7350 gfc_conv_expr_descriptor (&to_se
, to_expr
, to_ss
);
7351 gfc_conv_expr_descriptor (&from_se
, from_expr
, from_ss
);
7353 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7354 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, true, to_expr
);
7355 gfc_add_expr_to_block (&block
, tmp
);
7357 /* Move the pointer and update the array descriptor data. */
7358 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
7360 /* Set "to" to NULL. */
7361 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
7362 gfc_add_modify_loc (input_location
, &block
, tmp
,
7363 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7365 return gfc_finish_block (&block
);
7370 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
7374 gcc_assert (code
->resolved_isym
);
7376 switch (code
->resolved_isym
->id
)
7378 case GFC_ISYM_MOVE_ALLOC
:
7379 res
= conv_intrinsic_move_alloc (code
);
7382 case GFC_ISYM_ATOMIC_DEF
:
7383 res
= conv_intrinsic_atomic_def (code
);
7386 case GFC_ISYM_ATOMIC_REF
:
7387 res
= conv_intrinsic_atomic_ref (code
);
7398 #include "gt-fortran-trans-intrinsic.h"