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 int i
= END_BUILTINS
;
144 gfc_intrinsic_map_t
*m
;
145 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
148 if (precision
== TYPE_PRECISION (float_type_node
))
149 i
= m
->float_built_in
;
150 else if (precision
== TYPE_PRECISION (double_type_node
))
151 i
= m
->double_built_in
;
152 else if (precision
== TYPE_PRECISION (long_double_type_node
))
153 i
= m
->long_double_built_in
;
154 else if (precision
== TYPE_PRECISION (float128_type_node
))
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m
->real16_decl
;
161 return (i
== END_BUILTINS
? NULL_TREE
: built_in_decls
[i
]);
166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
169 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
171 if (gfc_real_kinds
[i
].c_float128
)
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t
*m
;
176 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
179 return m
->real16_decl
;
182 return builtin_decl_for_precision (double_built_in
,
183 gfc_real_kinds
[i
].mode_precision
);
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
193 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
194 tree
*argarray
, int nargs
)
196 gfc_actual_arglist
*actual
;
198 gfc_intrinsic_arg
*formal
;
202 formal
= expr
->value
.function
.isym
->formal
;
203 actual
= expr
->value
.function
.actual
;
205 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
206 actual
= actual
->next
,
207 formal
= formal
? formal
->next
: NULL
)
211 /* Skip omitted optional arguments. */
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse
, se
);
222 if (e
->ts
.type
== BT_CHARACTER
)
224 gfc_conv_expr (&argse
, e
);
225 gfc_conv_string_parameter (&argse
);
226 argarray
[curr_arg
++] = argse
.string_length
;
227 gcc_assert (curr_arg
< nargs
);
230 gfc_conv_expr_val (&argse
, e
);
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e
->expr_type
== EXPR_VARIABLE
235 && e
->symtree
->n
.sym
->attr
.optional
238 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
240 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
241 gfc_add_block_to_block (&se
->post
, &argse
.post
);
242 argarray
[curr_arg
] = argse
.expr
;
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
250 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
253 gfc_actual_arglist
*actual
;
255 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
260 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
274 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
280 nargs
= gfc_intrinsic_argument_list_length (expr
);
281 args
= XALLOCAVEC (tree
, nargs
);
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type
= gfc_typenode_for_spec (&expr
->ts
);
287 gcc_assert (expr
->value
.function
.actual
->expr
);
288 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
290 /* Conversion between character kinds involves a call to a library
292 if (expr
->ts
.type
== BT_CHARACTER
)
294 tree fndecl
, var
, addr
, tmp
;
296 if (expr
->ts
.kind
== 1
297 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
298 fndecl
= gfor_fndecl_convert_char4_to_char1
;
299 else if (expr
->ts
.kind
== 4
300 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
301 fndecl
= gfor_fndecl_convert_char1_to_char4
;
305 /* Create the variable storing the converted value. */
306 type
= gfc_get_pchar_type (expr
->ts
.kind
);
307 var
= gfc_create_var (type
, "str");
308 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs
>= 2);
312 tmp
= build_call_expr_loc (input_location
,
313 fndecl
, 3, addr
, args
[0], args
[1]);
314 gfc_add_expr_to_block (&se
->pre
, tmp
);
316 /* Free the temporary afterwards. */
317 tmp
= gfc_call_free (var
);
318 gfc_add_expr_to_block (&se
->post
, tmp
);
321 se
->string_length
= args
[0];
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
329 && expr
->ts
.type
!= BT_COMPLEX
)
333 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
334 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
338 se
->expr
= convert (type
, args
[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
354 argtype
= TREE_TYPE (arg
);
355 arg
= gfc_evaluate_now (arg
, pblock
);
357 intval
= convert (type
, arg
);
358 intval
= gfc_evaluate_now (intval
, pblock
);
360 tmp
= convert (argtype
, intval
);
361 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
362 boolean_type_node
, tmp
, arg
);
364 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
365 intval
, build_int_cst (type
, 1));
366 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg
, tree restype
)
379 int argprec
, resprec
;
381 argtype
= TREE_TYPE (arg
);
382 argprec
= TYPE_PRECISION (argtype
);
383 resprec
= TYPE_PRECISION (restype
);
385 /* Depending on the type of the result, choose the long int intrinsic
386 (lround family) or long long intrinsic (llround). We might also
387 need to convert the result afterwards. */
388 if (resprec
<= LONG_TYPE_SIZE
)
390 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
395 /* Now, depending on the argument type, we choose between intrinsics. */
397 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
399 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
401 return fold_convert (restype
, build_call_expr_loc (input_location
,
406 /* Convert a real to an integer using a specific rounding mode.
407 Ideally we would just build the corresponding GENERIC node,
408 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
411 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
412 enum rounding_mode op
)
417 return build_fixbound_expr (pblock
, arg
, type
, 0);
421 return build_fixbound_expr (pblock
, arg
, type
, 1);
425 return build_round_expr (arg
, type
);
429 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
438 /* Round a real value using the specified rounding mode.
439 We use a temporary integer of that same kind size as the result.
440 Values larger than those that can be represented by this kind are
441 unchanged, as they will not be accurate enough to represent the
443 huge = HUGE (KIND (a))
444 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
448 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
460 kind
= expr
->ts
.kind
;
461 nargs
= gfc_intrinsic_argument_list_length (expr
);
464 /* We have builtin functions for some cases. */
468 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
472 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
479 /* Evaluate the argument. */
480 gcc_assert (expr
->value
.function
.actual
->expr
);
481 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
483 /* Use a builtin function if one exists. */
484 if (decl
!= NULL_TREE
)
486 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
490 /* This code is probably redundant, but we'll keep it lying around just
492 type
= gfc_typenode_for_spec (&expr
->ts
);
493 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
495 /* Test if the value is too large to handle sensibly. */
496 gfc_set_model_kind (kind
);
498 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
499 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
500 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
501 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
504 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
505 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
506 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
508 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
510 itype
= gfc_get_int_type (kind
);
512 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
513 tmp
= convert (type
, tmp
);
514 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
520 /* Convert to an integer using the specified rounding mode. */
523 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
529 nargs
= gfc_intrinsic_argument_list_length (expr
);
530 args
= XALLOCAVEC (tree
, nargs
);
532 /* Evaluate the argument, we process all arguments even though we only
533 use the first one for code generation purposes. */
534 type
= gfc_typenode_for_spec (&expr
->ts
);
535 gcc_assert (expr
->value
.function
.actual
->expr
);
536 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
538 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
540 /* Conversion to a different integer kind. */
541 se
->expr
= convert (type
, args
[0]);
545 /* Conversion from complex to non-complex involves taking the real
546 component of the value. */
547 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
548 && expr
->ts
.type
!= BT_COMPLEX
)
552 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
553 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
557 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
562 /* Get the imaginary component of a value. */
565 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
569 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
570 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
571 TREE_TYPE (TREE_TYPE (arg
)), arg
);
575 /* Get the complex conjugate of a value. */
578 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
582 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
583 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
589 define_quad_builtin (const char *name
, tree type
, bool is_const
)
592 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
595 /* Mark the decl as external. */
596 DECL_EXTERNAL (fndecl
) = 1;
597 TREE_PUBLIC (fndecl
) = 1;
599 /* Mark it __attribute__((const)). */
600 TREE_READONLY (fndecl
) = is_const
;
602 rest_of_decl_compilation (fndecl
, 1, 0);
609 /* Initialize function decls for library functions. The external functions
610 are created as required. Builtin functions are added here. */
613 gfc_build_intrinsic_lib_fndecls (void)
615 gfc_intrinsic_map_t
*m
;
616 tree quad_decls
[END_BUILTINS
+ 1];
618 if (gfc_real16_is_float128
)
620 /* If we have soft-float types, we create the decls for their
621 C99-like library functions. For now, we only handle __float128
622 q-suffixed functions. */
624 tree 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
= built_in_decls
[m
->float_built_in
];
683 if (m
->complex_float_built_in
!= END_BUILTINS
)
684 m
->complex4_decl
= built_in_decls
[m
->complex_float_built_in
];
685 if (m
->double_built_in
!= END_BUILTINS
)
686 m
->real8_decl
= built_in_decls
[m
->double_built_in
];
687 if (m
->complex_double_built_in
!= END_BUILTINS
)
688 m
->complex8_decl
= built_in_decls
[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
= built_in_decls
[m
->long_double_built_in
];
693 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
694 m
->complex10_decl
= built_in_decls
[m
->complex_long_double_built_in
];
696 if (!gfc_real16_is_float128
)
698 if (m
->long_double_built_in
!= END_BUILTINS
)
699 m
->real16_decl
= built_in_decls
[m
->long_double_built_in
];
700 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
701 m
->complex16_decl
= built_in_decls
[m
->complex_long_double_built_in
];
703 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
705 /* Quad-precision function calls are constructed when first
706 needed by builtin_decl_for_precision(), except for those
707 that will be used directly (define by OTHER_BUILTIN). */
708 m
->real16_decl
= quad_decls
[m
->double_built_in
];
710 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
712 /* Same thing for the complex ones. */
713 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
719 /* Create a fndecl for a simple intrinsic library function. */
722 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
727 gfc_actual_arglist
*actual
;
730 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
733 if (ts
->type
== BT_REAL
)
738 pdecl
= &m
->real4_decl
;
741 pdecl
= &m
->real8_decl
;
744 pdecl
= &m
->real10_decl
;
747 pdecl
= &m
->real16_decl
;
753 else if (ts
->type
== BT_COMPLEX
)
755 gcc_assert (m
->complex_available
);
760 pdecl
= &m
->complex4_decl
;
763 pdecl
= &m
->complex8_decl
;
766 pdecl
= &m
->complex10_decl
;
769 pdecl
= &m
->complex16_decl
;
783 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
784 if (gfc_real_kinds
[n
].c_float
)
785 snprintf (name
, sizeof (name
), "%s%s%s",
786 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
787 else if (gfc_real_kinds
[n
].c_double
)
788 snprintf (name
, sizeof (name
), "%s%s",
789 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
790 else if (gfc_real_kinds
[n
].c_long_double
)
791 snprintf (name
, sizeof (name
), "%s%s%s",
792 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
793 else if (gfc_real_kinds
[n
].c_float128
)
794 snprintf (name
, sizeof (name
), "%s%s%s",
795 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
801 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
802 ts
->type
== BT_COMPLEX
? 'c' : 'r',
806 argtypes
= NULL_TREE
;
807 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
809 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
810 argtypes
= gfc_chainon_list (argtypes
, type
);
812 argtypes
= chainon (argtypes
, void_list_node
);
813 type
= build_function_type (gfc_typenode_for_spec (ts
), argtypes
);
814 fndecl
= build_decl (input_location
,
815 FUNCTION_DECL
, get_identifier (name
), type
);
817 /* Mark the decl as external. */
818 DECL_EXTERNAL (fndecl
) = 1;
819 TREE_PUBLIC (fndecl
) = 1;
821 /* Mark it __attribute__((const)), if possible. */
822 TREE_READONLY (fndecl
) = m
->is_constant
;
824 rest_of_decl_compilation (fndecl
, 1, 0);
831 /* Convert an intrinsic function into an external or builtin call. */
834 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
836 gfc_intrinsic_map_t
*m
;
840 unsigned int num_args
;
843 id
= expr
->value
.function
.isym
->id
;
844 /* Find the entry for this function. */
845 for (m
= gfc_intrinsic_map
;
846 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
852 if (m
->id
== GFC_ISYM_NONE
)
854 internal_error ("Intrinsic function %s(%d) not recognized",
855 expr
->value
.function
.name
, id
);
858 /* Get the decl and generate the call. */
859 num_args
= gfc_intrinsic_argument_list_length (expr
);
860 args
= XALLOCAVEC (tree
, num_args
);
862 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
863 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
864 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
866 fndecl
= build_addr (fndecl
, current_function_decl
);
867 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
871 /* If bounds-checking is enabled, create code to verify at runtime that the
872 string lengths for both expressions are the same (needed for e.g. MERGE).
873 If bounds-checking is not enabled, does nothing. */
876 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
877 tree a
, tree b
, stmtblock_t
* target
)
882 /* If bounds-checking is disabled, do nothing. */
883 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
886 /* Compare the two string lengths. */
887 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
889 /* Output the runtime-check. */
890 name
= gfc_build_cstring_const (intr_name
);
891 name
= gfc_build_addr_expr (pchar_type_node
, name
);
892 gfc_trans_runtime_check (true, false, cond
, target
, where
,
893 "Unequal character lengths (%ld/%ld) in %s",
894 fold_convert (long_integer_type_node
, a
),
895 fold_convert (long_integer_type_node
, b
), name
);
899 /* The EXPONENT(s) intrinsic function is translated into
906 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
908 tree arg
, type
, res
, tmp
, frexp
;
910 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
911 expr
->value
.function
.actual
->expr
->ts
.kind
);
913 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
915 res
= gfc_create_var (integer_type_node
, NULL
);
916 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
917 gfc_build_addr_expr (NULL_TREE
, res
));
918 gfc_add_expr_to_block (&se
->pre
, tmp
);
920 type
= gfc_typenode_for_spec (&expr
->ts
);
921 se
->expr
= fold_convert (type
, res
);
925 trans_this_image (gfc_se
* se
, gfc_expr
*expr ATTRIBUTE_UNUSED
)
927 gfc_init_coarray_decl ();
928 se
->expr
= gfort_gvar_caf_this_image
;
932 trans_num_images (gfc_se
* se
)
934 gfc_init_coarray_decl ();
935 se
->expr
= gfort_gvar_caf_num_images
;
939 /* Evaluate a single upper or lower bound. */
940 /* TODO: bound intrinsic generates way too much unnecessary code. */
943 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
945 gfc_actual_arglist
*arg
;
946 gfc_actual_arglist
*arg2
;
951 tree cond
, cond1
, cond3
, cond4
, size
;
958 arg
= expr
->value
.function
.actual
;
963 /* Create an implicit second parameter from the loop variable. */
964 gcc_assert (!arg2
->expr
);
965 gcc_assert (se
->loop
->dimen
== 1);
966 gcc_assert (se
->ss
->expr
== expr
);
967 gfc_advance_se_ss_chain (se
);
968 bound
= se
->loop
->loopvar
[0];
969 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
970 gfc_array_index_type
, bound
,
975 /* use the passed argument. */
976 gcc_assert (arg2
->expr
);
977 gfc_init_se (&argse
, NULL
);
978 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
979 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
981 /* Convert from one based to zero based. */
982 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
983 gfc_array_index_type
, bound
,
987 /* TODO: don't re-evaluate the descriptor on each iteration. */
988 /* Get a descriptor for the first parameter. */
989 ss
= gfc_walk_expr (arg
->expr
);
990 gcc_assert (ss
!= gfc_ss_terminator
);
991 gfc_init_se (&argse
, NULL
);
992 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
993 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
994 gfc_add_block_to_block (&se
->post
, &argse
.post
);
998 if (INTEGER_CST_P (bound
))
1002 hi
= TREE_INT_CST_HIGH (bound
);
1003 low
= TREE_INT_CST_LOW (bound
);
1004 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
1005 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1006 "dimension index", upper
? "UBOUND" : "LBOUND",
1011 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1013 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1014 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1015 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1016 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1017 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1019 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1020 boolean_type_node
, cond
, tmp
);
1021 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1026 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1027 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1029 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1031 /* 13.14.53: Result value for LBOUND
1033 Case (i): For an array section or for an array expression other than a
1034 whole array or array structure component, LBOUND(ARRAY, DIM)
1035 has the value 1. For a whole array or array structure
1036 component, LBOUND(ARRAY, DIM) has the value:
1037 (a) equal to the lower bound for subscript DIM of ARRAY if
1038 dimension DIM of ARRAY does not have extent zero
1039 or if ARRAY is an assumed-size array of rank DIM,
1042 13.14.113: Result value for UBOUND
1044 Case (i): For an array section or for an array expression other than a
1045 whole array or array structure component, UBOUND(ARRAY, DIM)
1046 has the value equal to the number of elements in the given
1047 dimension; otherwise, it has a value equal to the upper bound
1048 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1049 not have size zero and has value zero if dimension DIM has
1054 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1056 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1058 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1059 stride
, gfc_index_zero_node
);
1060 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1061 boolean_type_node
, cond3
, cond1
);
1062 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1063 stride
, gfc_index_zero_node
);
1068 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1069 boolean_type_node
, cond3
, cond4
);
1070 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1071 gfc_index_one_node
, lbound
);
1072 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1073 boolean_type_node
, cond4
, cond5
);
1075 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1076 boolean_type_node
, cond
, cond5
);
1078 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1079 gfc_array_index_type
, cond
,
1080 ubound
, gfc_index_zero_node
);
1084 if (as
->type
== AS_ASSUMED_SIZE
)
1085 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1086 bound
, build_int_cst (TREE_TYPE (bound
),
1087 arg
->expr
->rank
- 1));
1089 cond
= boolean_false_node
;
1091 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1092 boolean_type_node
, cond3
, cond4
);
1093 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1094 boolean_type_node
, cond
, cond1
);
1096 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1097 gfc_array_index_type
, cond
,
1098 lbound
, gfc_index_one_node
);
1105 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1106 gfc_array_index_type
, ubound
, lbound
);
1107 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1108 gfc_array_index_type
, size
,
1109 gfc_index_one_node
);
1110 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1111 gfc_array_index_type
, se
->expr
,
1112 gfc_index_zero_node
);
1115 se
->expr
= gfc_index_one_node
;
1118 type
= gfc_typenode_for_spec (&expr
->ts
);
1119 se
->expr
= convert (type
, se
->expr
);
1124 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
1126 gfc_actual_arglist
*arg
;
1127 gfc_actual_arglist
*arg2
;
1130 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
1134 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
1135 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
1136 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
1138 arg
= expr
->value
.function
.actual
;
1141 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
1142 corank
= gfc_get_corank (arg
->expr
);
1144 ss
= gfc_walk_expr (arg
->expr
);
1145 gcc_assert (ss
!= gfc_ss_terminator
);
1146 ss
->data
.info
.codimen
= corank
;
1147 gfc_init_se (&argse
, NULL
);
1149 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
1150 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1151 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1159 /* Create an implicit second parameter from the loop variable. */
1160 gcc_assert (!arg2
->expr
);
1161 gcc_assert (corank
> 0);
1162 gcc_assert (se
->loop
->dimen
== 1);
1163 gcc_assert (se
->ss
->expr
== expr
);
1165 mpz_init_set_ui (mpz_rank
, arg
->expr
->rank
);
1166 tree_rank
= gfc_conv_mpz_to_tree (mpz_rank
, gfc_index_integer_kind
);
1168 bound
= se
->loop
->loopvar
[0];
1169 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1170 bound
, se
->ss
->data
.info
.delta
[0]);
1171 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1173 gfc_advance_se_ss_chain (se
);
1177 /* use the passed argument. */
1178 gcc_assert (arg2
->expr
);
1179 gfc_init_se (&argse
, NULL
);
1180 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1181 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1184 if (INTEGER_CST_P (bound
))
1188 hi
= TREE_INT_CST_HIGH (bound
);
1189 low
= TREE_INT_CST_LOW (bound
);
1190 if (hi
|| low
< 1 || low
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
1191 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1192 "dimension index", expr
->value
.function
.isym
->name
,
1195 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1197 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1198 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1199 bound
, build_int_cst (TREE_TYPE (bound
), 1));
1200 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1201 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1203 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1204 boolean_type_node
, cond
, tmp
);
1205 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1210 /* Substract 1 to get to zero based and add dimensions. */
1211 switch (arg
->expr
->rank
)
1214 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1215 gfc_array_index_type
, bound
,
1216 gfc_index_one_node
);
1220 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1221 gfc_array_index_type
, bound
,
1222 gfc_rank_cst
[arg
->expr
->rank
- 1]);
1226 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1228 /* Handle UCOBOUND with special handling of the last codimension. */
1229 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
1231 /* Last codimension: For -fcoarray=single just return
1232 the lcobound - otherwise add
1233 ceiling (real (num_images ()) / real (size)) - 1
1234 = (num_images () + size - 1) / size - 1
1235 = (num_images - 1) / size(),
1236 where size is the product of the extend of all but the last
1239 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
1243 gfc_init_coarray_decl ();
1244 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
1246 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1247 gfc_array_index_type
,
1248 gfort_gvar_caf_num_images
,
1249 build_int_cst (gfc_array_index_type
, 1));
1250 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1251 gfc_array_index_type
, tmp
,
1252 fold_convert (gfc_array_index_type
, cosize
));
1253 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1254 gfc_array_index_type
, resbound
, tmp
);
1256 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
1258 /* ubound = lbound + num_images() - 1. */
1259 gfc_init_coarray_decl ();
1260 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1261 gfc_array_index_type
,
1262 gfort_gvar_caf_num_images
,
1263 build_int_cst (gfc_array_index_type
, 1));
1264 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1265 gfc_array_index_type
, resbound
, tmp
);
1270 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1272 build_int_cst (TREE_TYPE (bound
),
1273 arg
->expr
->rank
+ corank
- 1));
1275 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1276 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1277 gfc_array_index_type
, cond
,
1278 resbound
, resbound2
);
1281 se
->expr
= resbound
;
1284 se
->expr
= resbound
;
1286 type
= gfc_typenode_for_spec (&expr
->ts
);
1287 se
->expr
= convert (type
, se
->expr
);
1292 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1296 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1298 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1302 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1307 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1308 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1317 /* Create a complex value from one or two real components. */
1320 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1326 unsigned int num_args
;
1328 num_args
= gfc_intrinsic_argument_list_length (expr
);
1329 args
= XALLOCAVEC (tree
, num_args
);
1331 type
= gfc_typenode_for_spec (&expr
->ts
);
1332 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1333 real
= convert (TREE_TYPE (type
), args
[0]);
1335 imag
= convert (TREE_TYPE (type
), args
[1]);
1336 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1338 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1339 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1340 imag
= convert (TREE_TYPE (type
), imag
);
1343 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1345 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1348 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1349 MODULO(A, P) = A - FLOOR (A / P) * P */
1350 /* TODO: MOD(x, 0) */
1353 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1365 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1367 switch (expr
->ts
.type
)
1370 /* Integer case is easy, we've got a builtin op. */
1371 type
= TREE_TYPE (args
[0]);
1374 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
1377 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
1383 /* Check if we have a builtin fmod. */
1384 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1386 /* Use it if it exists. */
1387 if (fmod
!= NULL_TREE
)
1389 tmp
= build_addr (fmod
, current_function_decl
);
1390 se
->expr
= build_call_array_loc (input_location
,
1391 TREE_TYPE (TREE_TYPE (fmod
)),
1397 type
= TREE_TYPE (args
[0]);
1399 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1400 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1403 modulo = arg - floor (arg/arg2) * arg2, so
1404 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1406 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1407 thereby avoiding another division and retaining the accuracy
1408 of the builtin function. */
1409 if (fmod
!= NULL_TREE
&& modulo
)
1411 tree zero
= gfc_build_const (type
, integer_zero_node
);
1412 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1413 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1415 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1417 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1418 boolean_type_node
, test
, test2
);
1419 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1421 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1422 boolean_type_node
, test
, test2
);
1423 test
= gfc_evaluate_now (test
, &se
->pre
);
1424 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1425 fold_build2_loc (input_location
, PLUS_EXPR
,
1426 type
, tmp
, args
[1]), tmp
);
1430 /* If we do not have a built_in fmod, the calculation is going to
1431 have to be done longhand. */
1432 tmp
= fold_build2_loc (input_location
, RDIV_EXPR
, type
, args
[0], args
[1]);
1434 /* Test if the value is too large to handle sensibly. */
1435 gfc_set_model_kind (expr
->ts
.kind
);
1437 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1438 ikind
= expr
->ts
.kind
;
1441 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1442 ikind
= gfc_max_integer_kind
;
1444 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1445 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1446 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1449 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1450 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1451 test
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1453 test2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1454 boolean_type_node
, test
, test2
);
1456 itype
= gfc_get_int_type (ikind
);
1458 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1460 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1461 tmp
= convert (type
, tmp
);
1462 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
, tmp
,
1464 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, tmp
, args
[1]);
1465 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0],
1475 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1476 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1477 where the right shifts are logical (i.e. 0's are shifted in).
1478 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1479 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1481 DSHIFTL(I,J,BITSIZE) = J
1483 DSHIFTR(I,J,BITSIZE) = I. */
1486 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
1488 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
1489 tree args
[3], cond
, tmp
;
1492 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
1494 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
1495 type
= TREE_TYPE (args
[0]);
1496 bitsize
= TYPE_PRECISION (type
);
1497 utype
= unsigned_type_for (type
);
1498 stype
= TREE_TYPE (args
[2]);
1500 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
1501 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
1502 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
1504 /* The generic case. */
1505 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
1506 build_int_cst (stype
, bitsize
), shift
);
1507 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
1508 arg1
, dshiftl
? shift
: tmp
);
1510 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
1511 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
1512 right
= fold_convert (type
, right
);
1514 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
1516 /* Special cases. */
1517 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1518 build_int_cst (stype
, 0));
1519 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1520 dshiftl
? arg1
: arg2
, res
);
1522 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1523 build_int_cst (stype
, bitsize
));
1524 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1525 dshiftl
? arg2
: arg1
, res
);
1531 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1534 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1542 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1543 type
= TREE_TYPE (args
[0]);
1545 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
1546 val
= gfc_evaluate_now (val
, &se
->pre
);
1548 zero
= gfc_build_const (type
, integer_zero_node
);
1549 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
1550 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
1554 /* SIGN(A, B) is absolute value of A times sign of B.
1555 The real value versions use library functions to ensure the correct
1556 handling of negative zero. Integer case implemented as:
1557 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1561 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1567 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1568 if (expr
->ts
.type
== BT_REAL
)
1572 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1573 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1575 /* We explicitly have to ignore the minus sign. We do so by using
1576 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1577 if (!gfc_option
.flag_sign_zero
1578 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1581 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1582 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1584 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1585 TREE_TYPE (args
[0]), cond
,
1586 build_call_expr_loc (input_location
, abs
, 1,
1588 build_call_expr_loc (input_location
, tmp
, 2,
1592 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1597 /* Having excluded floating point types, we know we are now dealing
1598 with signed integer types. */
1599 type
= TREE_TYPE (args
[0]);
1601 /* Args[0] is used multiple times below. */
1602 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1604 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1605 the signs of A and B are the same, and of all ones if they differ. */
1606 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1607 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
1608 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1609 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1611 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1612 is all ones (i.e. -1). */
1613 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
1614 fold_build2_loc (input_location
, PLUS_EXPR
,
1615 type
, args
[0], tmp
), tmp
);
1619 /* Test for the presence of an optional argument. */
1622 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
1626 arg
= expr
->value
.function
.actual
->expr
;
1627 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
1628 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1629 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
1633 /* Calculate the double precision product of two single precision values. */
1636 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
1641 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1643 /* Convert the args to double precision before multiplying. */
1644 type
= gfc_typenode_for_spec (&expr
->ts
);
1645 args
[0] = convert (type
, args
[0]);
1646 args
[1] = convert (type
, args
[1]);
1647 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
1652 /* Return a length one character string containing an ascii character. */
1655 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
1660 unsigned int num_args
;
1662 num_args
= gfc_intrinsic_argument_list_length (expr
);
1663 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
1665 type
= gfc_get_char_type (expr
->ts
.kind
);
1666 var
= gfc_create_var (type
, "char");
1668 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
1669 gfc_add_modify (&se
->pre
, var
, arg
[0]);
1670 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
1671 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
1676 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
1684 unsigned int num_args
;
1686 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1687 args
= XALLOCAVEC (tree
, num_args
);
1689 var
= gfc_create_var (pchar_type_node
, "pstr");
1690 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1692 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1693 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1694 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1696 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
1697 tmp
= build_call_array_loc (input_location
,
1698 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
1699 fndecl
, num_args
, args
);
1700 gfc_add_expr_to_block (&se
->pre
, tmp
);
1702 /* Free the temporary afterwards, if necessary. */
1703 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1704 len
, build_int_cst (TREE_TYPE (len
), 0));
1705 tmp
= gfc_call_free (var
);
1706 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1707 gfc_add_expr_to_block (&se
->post
, tmp
);
1710 se
->string_length
= len
;
1715 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
1723 unsigned int num_args
;
1725 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1726 args
= XALLOCAVEC (tree
, num_args
);
1728 var
= gfc_create_var (pchar_type_node
, "pstr");
1729 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1731 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1732 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1733 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1735 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
1736 tmp
= build_call_array_loc (input_location
,
1737 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
1738 fndecl
, num_args
, args
);
1739 gfc_add_expr_to_block (&se
->pre
, tmp
);
1741 /* Free the temporary afterwards, if necessary. */
1742 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1743 len
, build_int_cst (TREE_TYPE (len
), 0));
1744 tmp
= gfc_call_free (var
);
1745 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1746 gfc_add_expr_to_block (&se
->post
, tmp
);
1749 se
->string_length
= len
;
1753 /* Return a character string containing the tty name. */
1756 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
1764 unsigned int num_args
;
1766 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
1767 args
= XALLOCAVEC (tree
, num_args
);
1769 var
= gfc_create_var (pchar_type_node
, "pstr");
1770 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1772 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
1773 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
1774 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
1776 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
1777 tmp
= build_call_array_loc (input_location
,
1778 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
1779 fndecl
, num_args
, args
);
1780 gfc_add_expr_to_block (&se
->pre
, tmp
);
1782 /* Free the temporary afterwards, if necessary. */
1783 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1784 len
, build_int_cst (TREE_TYPE (len
), 0));
1785 tmp
= gfc_call_free (var
);
1786 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1787 gfc_add_expr_to_block (&se
->post
, tmp
);
1790 se
->string_length
= len
;
1794 /* Get the minimum/maximum value of all the parameters.
1795 minmax (a1, a2, a3, ...)
1798 if (a2 .op. mvar || isnan(mvar))
1800 if (a3 .op. mvar || isnan(mvar))
1807 /* TODO: Mismatching types can occur when specific names are used.
1808 These should be handled during resolution. */
1810 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
1818 gfc_actual_arglist
*argexpr
;
1819 unsigned int i
, nargs
;
1821 nargs
= gfc_intrinsic_argument_list_length (expr
);
1822 args
= XALLOCAVEC (tree
, nargs
);
1824 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
1825 type
= gfc_typenode_for_spec (&expr
->ts
);
1827 argexpr
= expr
->value
.function
.actual
;
1828 if (TREE_TYPE (args
[0]) != type
)
1829 args
[0] = convert (type
, args
[0]);
1830 /* Only evaluate the argument once. */
1831 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
1832 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1834 mvar
= gfc_create_var (type
, "M");
1835 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
1836 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
1842 /* Handle absent optional arguments by ignoring the comparison. */
1843 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
1844 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
1845 && TREE_CODE (val
) == INDIRECT_REF
)
1846 cond
= fold_build2_loc (input_location
,
1847 NE_EXPR
, boolean_type_node
,
1848 TREE_OPERAND (val
, 0),
1849 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
1854 /* Only evaluate the argument once. */
1855 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
1856 val
= gfc_evaluate_now (val
, &se
->pre
);
1859 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
1861 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
1862 convert (type
, val
), mvar
);
1864 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1865 __builtin_isnan might be made dependent on that module being loaded,
1866 to help performance of programs that don't rely on IEEE semantics. */
1867 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
1869 isnan
= build_call_expr_loc (input_location
,
1870 built_in_decls
[BUILT_IN_ISNAN
], 1, mvar
);
1871 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1872 boolean_type_node
, tmp
,
1873 fold_convert (boolean_type_node
, isnan
));
1875 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
1876 build_empty_stmt (input_location
));
1878 if (cond
!= NULL_TREE
)
1879 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1880 build_empty_stmt (input_location
));
1882 gfc_add_expr_to_block (&se
->pre
, tmp
);
1883 argexpr
= argexpr
->next
;
1889 /* Generate library calls for MIN and MAX intrinsics for character
1892 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
1895 tree var
, len
, fndecl
, tmp
, cond
, function
;
1898 nargs
= gfc_intrinsic_argument_list_length (expr
);
1899 args
= XALLOCAVEC (tree
, nargs
+ 4);
1900 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
1902 /* Create the result variables. */
1903 len
= gfc_create_var (gfc_charlen_type_node
, "len");
1904 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
1905 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
1906 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
1907 args
[2] = build_int_cst (NULL_TREE
, op
);
1908 args
[3] = build_int_cst (NULL_TREE
, nargs
/ 2);
1910 if (expr
->ts
.kind
== 1)
1911 function
= gfor_fndecl_string_minmax
;
1912 else if (expr
->ts
.kind
== 4)
1913 function
= gfor_fndecl_string_minmax_char4
;
1917 /* Make the function call. */
1918 fndecl
= build_addr (function
, current_function_decl
);
1919 tmp
= build_call_array_loc (input_location
,
1920 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
1922 gfc_add_expr_to_block (&se
->pre
, tmp
);
1924 /* Free the temporary afterwards, if necessary. */
1925 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1926 len
, build_int_cst (TREE_TYPE (len
), 0));
1927 tmp
= gfc_call_free (var
);
1928 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
1929 gfc_add_expr_to_block (&se
->post
, tmp
);
1932 se
->string_length
= len
;
1936 /* Create a symbol node for this intrinsic. The symbol from the frontend
1937 has the generic name. */
1940 gfc_get_symbol_for_expr (gfc_expr
* expr
)
1944 /* TODO: Add symbols for intrinsic function to the global namespace. */
1945 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
1946 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
1949 sym
->attr
.external
= 1;
1950 sym
->attr
.function
= 1;
1951 sym
->attr
.always_explicit
= 1;
1952 sym
->attr
.proc
= PROC_INTRINSIC
;
1953 sym
->attr
.flavor
= FL_PROCEDURE
;
1957 sym
->attr
.dimension
= 1;
1958 sym
->as
= gfc_get_array_spec ();
1959 sym
->as
->type
= AS_ASSUMED_SHAPE
;
1960 sym
->as
->rank
= expr
->rank
;
1963 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
1968 /* Generate a call to an external intrinsic function. */
1970 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
1973 VEC(tree
,gc
) *append_args
;
1975 gcc_assert (!se
->ss
|| se
->ss
->expr
== expr
);
1978 gcc_assert (expr
->rank
> 0);
1980 gcc_assert (expr
->rank
== 0);
1982 sym
= gfc_get_symbol_for_expr (expr
);
1984 /* Calls to libgfortran_matmul need to be appended special arguments,
1985 to be able to call the BLAS ?gemm functions if required and possible. */
1987 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
1988 && sym
->ts
.type
!= BT_LOGICAL
)
1990 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
1992 if (gfc_option
.flag_external_blas
1993 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
1994 && (sym
->ts
.kind
== gfc_default_real_kind
1995 || sym
->ts
.kind
== gfc_default_double_kind
))
1999 if (sym
->ts
.type
== BT_REAL
)
2001 if (sym
->ts
.kind
== gfc_default_real_kind
)
2002 gemm_fndecl
= gfor_fndecl_sgemm
;
2004 gemm_fndecl
= gfor_fndecl_dgemm
;
2008 if (sym
->ts
.kind
== gfc_default_real_kind
)
2009 gemm_fndecl
= gfor_fndecl_cgemm
;
2011 gemm_fndecl
= gfor_fndecl_zgemm
;
2014 append_args
= VEC_alloc (tree
, gc
, 3);
2015 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 1));
2016 VEC_quick_push (tree
, append_args
,
2017 build_int_cst (cint
, gfc_option
.blas_matmul_limit
));
2018 VEC_quick_push (tree
, append_args
,
2019 gfc_build_addr_expr (NULL_TREE
, gemm_fndecl
));
2023 append_args
= VEC_alloc (tree
, gc
, 3);
2024 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
2025 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
2026 VEC_quick_push (tree
, append_args
, null_pointer_node
);
2030 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
2032 gfc_free_symbol (sym
);
2035 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2055 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2064 gfc_actual_arglist
*actual
;
2071 gfc_conv_intrinsic_funcall (se
, expr
);
2075 actual
= expr
->value
.function
.actual
;
2076 type
= gfc_typenode_for_spec (&expr
->ts
);
2077 /* Initialize the result. */
2078 resvar
= gfc_create_var (type
, "test");
2080 tmp
= convert (type
, boolean_true_node
);
2082 tmp
= convert (type
, boolean_false_node
);
2083 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2085 /* Walk the arguments. */
2086 arrayss
= gfc_walk_expr (actual
->expr
);
2087 gcc_assert (arrayss
!= gfc_ss_terminator
);
2089 /* Initialize the scalarizer. */
2090 gfc_init_loopinfo (&loop
);
2091 exit_label
= gfc_build_label_decl (NULL_TREE
);
2092 TREE_USED (exit_label
) = 1;
2093 gfc_add_ss_to_loop (&loop
, arrayss
);
2095 /* Initialize the loop. */
2096 gfc_conv_ss_startstride (&loop
);
2097 gfc_conv_loop_setup (&loop
, &expr
->where
);
2099 gfc_mark_ss_chain_used (arrayss
, 1);
2100 /* Generate the loop body. */
2101 gfc_start_scalarized_body (&loop
, &body
);
2103 /* If the condition matches then set the return value. */
2104 gfc_start_block (&block
);
2106 tmp
= convert (type
, boolean_false_node
);
2108 tmp
= convert (type
, boolean_true_node
);
2109 gfc_add_modify (&block
, resvar
, tmp
);
2111 /* And break out of the loop. */
2112 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2113 gfc_add_expr_to_block (&block
, tmp
);
2115 found
= gfc_finish_block (&block
);
2117 /* Check this element. */
2118 gfc_init_se (&arrayse
, NULL
);
2119 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2120 arrayse
.ss
= arrayss
;
2121 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2123 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2124 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
2125 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
2126 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
2127 gfc_add_expr_to_block (&body
, tmp
);
2128 gfc_add_block_to_block (&body
, &arrayse
.post
);
2130 gfc_trans_scalarizing_loops (&loop
, &body
);
2132 /* Add the exit label. */
2133 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2134 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2136 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2137 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2138 gfc_cleanup_loop (&loop
);
2143 /* COUNT(A) = Number of true elements in A. */
2145 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
2152 gfc_actual_arglist
*actual
;
2158 gfc_conv_intrinsic_funcall (se
, expr
);
2162 actual
= expr
->value
.function
.actual
;
2164 type
= gfc_typenode_for_spec (&expr
->ts
);
2165 /* Initialize the result. */
2166 resvar
= gfc_create_var (type
, "count");
2167 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
2169 /* Walk the arguments. */
2170 arrayss
= gfc_walk_expr (actual
->expr
);
2171 gcc_assert (arrayss
!= gfc_ss_terminator
);
2173 /* Initialize the scalarizer. */
2174 gfc_init_loopinfo (&loop
);
2175 gfc_add_ss_to_loop (&loop
, arrayss
);
2177 /* Initialize the loop. */
2178 gfc_conv_ss_startstride (&loop
);
2179 gfc_conv_loop_setup (&loop
, &expr
->where
);
2181 gfc_mark_ss_chain_used (arrayss
, 1);
2182 /* Generate the loop body. */
2183 gfc_start_scalarized_body (&loop
, &body
);
2185 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2186 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2187 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2189 gfc_init_se (&arrayse
, NULL
);
2190 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2191 arrayse
.ss
= arrayss
;
2192 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2193 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2194 build_empty_stmt (input_location
));
2196 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2197 gfc_add_expr_to_block (&body
, tmp
);
2198 gfc_add_block_to_block (&body
, &arrayse
.post
);
2200 gfc_trans_scalarizing_loops (&loop
, &body
);
2202 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2203 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2204 gfc_cleanup_loop (&loop
);
2209 /* Inline implementation of the sum and product intrinsics. */
2211 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2215 tree scale
= NULL_TREE
;
2221 gfc_actual_arglist
*actual
;
2226 gfc_expr
*arrayexpr
;
2231 gfc_conv_intrinsic_funcall (se
, expr
);
2235 type
= gfc_typenode_for_spec (&expr
->ts
);
2236 /* Initialize the result. */
2237 resvar
= gfc_create_var (type
, "val");
2242 scale
= gfc_create_var (type
, "scale");
2243 gfc_add_modify (&se
->pre
, scale
,
2244 gfc_build_const (type
, integer_one_node
));
2245 tmp
= gfc_build_const (type
, integer_zero_node
);
2247 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2248 tmp
= gfc_build_const (type
, integer_zero_node
);
2249 else if (op
== NE_EXPR
)
2251 tmp
= convert (type
, boolean_false_node
);
2252 else if (op
== BIT_AND_EXPR
)
2253 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2254 type
, integer_one_node
));
2256 tmp
= gfc_build_const (type
, integer_one_node
);
2258 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2260 /* Walk the arguments. */
2261 actual
= expr
->value
.function
.actual
;
2262 arrayexpr
= actual
->expr
;
2263 arrayss
= gfc_walk_expr (arrayexpr
);
2264 gcc_assert (arrayss
!= gfc_ss_terminator
);
2266 if (op
== NE_EXPR
|| norm2
)
2267 /* PARITY and NORM2. */
2271 actual
= actual
->next
->next
;
2272 gcc_assert (actual
);
2273 maskexpr
= actual
->expr
;
2276 if (maskexpr
&& maskexpr
->rank
!= 0)
2278 maskss
= gfc_walk_expr (maskexpr
);
2279 gcc_assert (maskss
!= gfc_ss_terminator
);
2284 /* Initialize the scalarizer. */
2285 gfc_init_loopinfo (&loop
);
2286 gfc_add_ss_to_loop (&loop
, arrayss
);
2288 gfc_add_ss_to_loop (&loop
, maskss
);
2290 /* Initialize the loop. */
2291 gfc_conv_ss_startstride (&loop
);
2292 gfc_conv_loop_setup (&loop
, &expr
->where
);
2294 gfc_mark_ss_chain_used (arrayss
, 1);
2296 gfc_mark_ss_chain_used (maskss
, 1);
2297 /* Generate the loop body. */
2298 gfc_start_scalarized_body (&loop
, &body
);
2300 /* If we have a mask, only add this element if the mask is set. */
2303 gfc_init_se (&maskse
, NULL
);
2304 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2306 gfc_conv_expr_val (&maskse
, maskexpr
);
2307 gfc_add_block_to_block (&body
, &maskse
.pre
);
2309 gfc_start_block (&block
);
2312 gfc_init_block (&block
);
2314 /* Do the actual summation/product. */
2315 gfc_init_se (&arrayse
, NULL
);
2316 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2317 arrayse
.ss
= arrayss
;
2318 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2319 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2329 result = 1.0 + result * val * val;
2335 result += val * val;
2338 tree res1
, res2
, cond
, absX
, val
;
2339 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
2341 gfc_init_block (&ifblock1
);
2343 absX
= gfc_create_var (type
, "absX");
2344 gfc_add_modify (&ifblock1
, absX
,
2345 fold_build1_loc (input_location
, ABS_EXPR
, type
,
2347 val
= gfc_create_var (type
, "val");
2348 gfc_add_expr_to_block (&ifblock1
, val
);
2350 gfc_init_block (&ifblock2
);
2351 gfc_add_modify (&ifblock2
, val
,
2352 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
2354 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2355 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
2356 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
2357 gfc_build_const (type
, integer_one_node
));
2358 gfc_add_modify (&ifblock2
, resvar
, res1
);
2359 gfc_add_modify (&ifblock2
, scale
, absX
);
2360 res1
= gfc_finish_block (&ifblock2
);
2362 gfc_init_block (&ifblock3
);
2363 gfc_add_modify (&ifblock3
, val
,
2364 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
2366 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2367 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
2368 gfc_add_modify (&ifblock3
, resvar
, res2
);
2369 res2
= gfc_finish_block (&ifblock3
);
2371 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2373 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
2374 gfc_add_expr_to_block (&ifblock1
, tmp
);
2375 tmp
= gfc_finish_block (&ifblock1
);
2377 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2379 gfc_build_const (type
, integer_zero_node
));
2381 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2382 gfc_add_expr_to_block (&block
, tmp
);
2386 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
2387 gfc_add_modify (&block
, resvar
, tmp
);
2390 gfc_add_block_to_block (&block
, &arrayse
.post
);
2394 /* We enclose the above in if (mask) {...} . */
2396 tmp
= gfc_finish_block (&block
);
2397 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2398 build_empty_stmt (input_location
));
2401 tmp
= gfc_finish_block (&block
);
2402 gfc_add_expr_to_block (&body
, tmp
);
2404 gfc_trans_scalarizing_loops (&loop
, &body
);
2406 /* For a scalar mask, enclose the loop in an if statement. */
2407 if (maskexpr
&& maskss
== NULL
)
2409 gfc_init_se (&maskse
, NULL
);
2410 gfc_conv_expr_val (&maskse
, maskexpr
);
2411 gfc_init_block (&block
);
2412 gfc_add_block_to_block (&block
, &loop
.pre
);
2413 gfc_add_block_to_block (&block
, &loop
.post
);
2414 tmp
= gfc_finish_block (&block
);
2416 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2417 build_empty_stmt (input_location
));
2418 gfc_add_expr_to_block (&block
, tmp
);
2419 gfc_add_block_to_block (&se
->pre
, &block
);
2423 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2424 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2427 gfc_cleanup_loop (&loop
);
2431 /* result = scale * sqrt(result). */
2433 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
2434 resvar
= build_call_expr_loc (input_location
,
2436 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
2443 /* Inline implementation of the dot_product intrinsic. This function
2444 is based on gfc_conv_intrinsic_arith (the previous function). */
2446 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2454 gfc_actual_arglist
*actual
;
2455 gfc_ss
*arrayss1
, *arrayss2
;
2456 gfc_se arrayse1
, arrayse2
;
2457 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2459 type
= gfc_typenode_for_spec (&expr
->ts
);
2461 /* Initialize the result. */
2462 resvar
= gfc_create_var (type
, "val");
2463 if (expr
->ts
.type
== BT_LOGICAL
)
2464 tmp
= build_int_cst (type
, 0);
2466 tmp
= gfc_build_const (type
, integer_zero_node
);
2468 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2470 /* Walk argument #1. */
2471 actual
= expr
->value
.function
.actual
;
2472 arrayexpr1
= actual
->expr
;
2473 arrayss1
= gfc_walk_expr (arrayexpr1
);
2474 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2476 /* Walk argument #2. */
2477 actual
= actual
->next
;
2478 arrayexpr2
= actual
->expr
;
2479 arrayss2
= gfc_walk_expr (arrayexpr2
);
2480 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2482 /* Initialize the scalarizer. */
2483 gfc_init_loopinfo (&loop
);
2484 gfc_add_ss_to_loop (&loop
, arrayss1
);
2485 gfc_add_ss_to_loop (&loop
, arrayss2
);
2487 /* Initialize the loop. */
2488 gfc_conv_ss_startstride (&loop
);
2489 gfc_conv_loop_setup (&loop
, &expr
->where
);
2491 gfc_mark_ss_chain_used (arrayss1
, 1);
2492 gfc_mark_ss_chain_used (arrayss2
, 1);
2494 /* Generate the loop body. */
2495 gfc_start_scalarized_body (&loop
, &body
);
2496 gfc_init_block (&block
);
2498 /* Make the tree expression for [conjg(]array1[)]. */
2499 gfc_init_se (&arrayse1
, NULL
);
2500 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2501 arrayse1
.ss
= arrayss1
;
2502 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2503 if (expr
->ts
.type
== BT_COMPLEX
)
2504 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
2506 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2508 /* Make the tree expression for array2. */
2509 gfc_init_se (&arrayse2
, NULL
);
2510 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2511 arrayse2
.ss
= arrayss2
;
2512 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2513 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2515 /* Do the actual product and sum. */
2516 if (expr
->ts
.type
== BT_LOGICAL
)
2518 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
2519 arrayse1
.expr
, arrayse2
.expr
);
2520 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2524 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
2526 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
2528 gfc_add_modify (&block
, resvar
, tmp
);
2530 /* Finish up the loop block and the loop. */
2531 tmp
= gfc_finish_block (&block
);
2532 gfc_add_expr_to_block (&body
, tmp
);
2534 gfc_trans_scalarizing_loops (&loop
, &body
);
2535 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2536 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2537 gfc_cleanup_loop (&loop
);
2543 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2544 we need to handle. For performance reasons we sometimes create two
2545 loops instead of one, where the second one is much simpler.
2546 Examples for minloc intrinsic:
2547 1) Result is an array, a call is generated
2548 2) Array mask is used and NaNs need to be supported:
2554 if (pos == 0) pos = S + (1 - from);
2555 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2562 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2566 3) NaNs need to be supported, but it is known at compile time or cheaply
2567 at runtime whether array is nonempty or not:
2572 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2575 if (from <= to) pos = 1;
2579 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2583 4) NaNs aren't supported, array mask is used:
2584 limit = infinities_supported ? Infinity : huge (limit);
2588 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2594 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2598 5) Same without array mask:
2599 limit = infinities_supported ? Infinity : huge (limit);
2600 pos = (from <= to) ? 1 : 0;
2603 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2606 For 3) and 5), if mask is scalar, this all goes into a conditional,
2607 setting pos = 0; in the else branch. */
2610 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2614 stmtblock_t ifblock
;
2615 stmtblock_t elseblock
;
2626 gfc_actual_arglist
*actual
;
2631 gfc_expr
*arrayexpr
;
2638 gfc_conv_intrinsic_funcall (se
, expr
);
2642 /* Initialize the result. */
2643 pos
= gfc_create_var (gfc_array_index_type
, "pos");
2644 offset
= gfc_create_var (gfc_array_index_type
, "offset");
2645 type
= gfc_typenode_for_spec (&expr
->ts
);
2647 /* Walk the arguments. */
2648 actual
= expr
->value
.function
.actual
;
2649 arrayexpr
= actual
->expr
;
2650 arrayss
= gfc_walk_expr (arrayexpr
);
2651 gcc_assert (arrayss
!= gfc_ss_terminator
);
2653 actual
= actual
->next
->next
;
2654 gcc_assert (actual
);
2655 maskexpr
= actual
->expr
;
2657 if (maskexpr
&& maskexpr
->rank
!= 0)
2659 maskss
= gfc_walk_expr (maskexpr
);
2660 gcc_assert (maskss
!= gfc_ss_terminator
);
2665 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
2667 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
2669 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
2670 boolean_type_node
, nonempty
,
2671 gfc_index_zero_node
);
2676 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
2677 switch (arrayexpr
->ts
.type
)
2680 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
2684 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
2685 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
2686 arrayexpr
->ts
.kind
);
2693 /* We start with the most negative possible value for MAXLOC, and the most
2694 positive possible value for MINLOC. The most negative possible value is
2695 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2696 possible value is HUGE in both cases. */
2698 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
2699 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
2700 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
2701 build_int_cst (type
, 1));
2703 gfc_add_modify (&se
->pre
, limit
, tmp
);
2705 /* Initialize the scalarizer. */
2706 gfc_init_loopinfo (&loop
);
2707 gfc_add_ss_to_loop (&loop
, arrayss
);
2709 gfc_add_ss_to_loop (&loop
, maskss
);
2711 /* Initialize the loop. */
2712 gfc_conv_ss_startstride (&loop
);
2713 gfc_conv_loop_setup (&loop
, &expr
->where
);
2715 gcc_assert (loop
.dimen
== 1);
2716 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
2717 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
2718 loop
.from
[0], loop
.to
[0]);
2722 /* Initialize the position to zero, following Fortran 2003. We are free
2723 to do this because Fortran 95 allows the result of an entirely false
2724 mask to be processor dependent. If we know at compile time the array
2725 is non-empty and no MASK is used, we can initialize to 1 to simplify
2727 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
2728 gfc_add_modify (&loop
.pre
, pos
,
2729 fold_build3_loc (input_location
, COND_EXPR
,
2730 gfc_array_index_type
,
2731 nonempty
, gfc_index_one_node
,
2732 gfc_index_zero_node
));
2735 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
2736 lab1
= gfc_build_label_decl (NULL_TREE
);
2737 TREE_USED (lab1
) = 1;
2738 lab2
= gfc_build_label_decl (NULL_TREE
);
2739 TREE_USED (lab2
) = 1;
2742 gfc_mark_ss_chain_used (arrayss
, 1);
2744 gfc_mark_ss_chain_used (maskss
, 1);
2745 /* Generate the loop body. */
2746 gfc_start_scalarized_body (&loop
, &body
);
2748 /* If we have a mask, only check this element if the mask is set. */
2751 gfc_init_se (&maskse
, NULL
);
2752 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2754 gfc_conv_expr_val (&maskse
, maskexpr
);
2755 gfc_add_block_to_block (&body
, &maskse
.pre
);
2757 gfc_start_block (&block
);
2760 gfc_init_block (&block
);
2762 /* Compare with the current limit. */
2763 gfc_init_se (&arrayse
, NULL
);
2764 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2765 arrayse
.ss
= arrayss
;
2766 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2767 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2769 /* We do the following if this is a more extreme value. */
2770 gfc_start_block (&ifblock
);
2772 /* Assign the value to the limit... */
2773 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2775 /* Remember where we are. An offset must be added to the loop
2776 counter to obtain the required position. */
2778 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2779 gfc_index_one_node
, loop
.from
[0]);
2781 tmp
= gfc_index_one_node
;
2783 gfc_add_modify (&block
, offset
, tmp
);
2785 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
2787 stmtblock_t ifblock2
;
2790 gfc_start_block (&ifblock2
);
2791 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
2792 loop
.loopvar
[0], offset
);
2793 gfc_add_modify (&ifblock2
, pos
, tmp
);
2794 ifbody2
= gfc_finish_block (&ifblock2
);
2795 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
2796 gfc_index_zero_node
);
2797 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
2798 build_empty_stmt (input_location
));
2799 gfc_add_expr_to_block (&block
, tmp
);
2802 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
2803 loop
.loopvar
[0], offset
);
2804 gfc_add_modify (&ifblock
, pos
, tmp
);
2807 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
2809 ifbody
= gfc_finish_block (&ifblock
);
2811 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
2814 cond
= fold_build2_loc (input_location
,
2815 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
2816 boolean_type_node
, arrayse
.expr
, limit
);
2818 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2819 arrayse
.expr
, limit
);
2821 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
2822 build_empty_stmt (input_location
));
2824 gfc_add_expr_to_block (&block
, ifbody
);
2828 /* We enclose the above in if (mask) {...}. */
2829 tmp
= gfc_finish_block (&block
);
2831 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2832 build_empty_stmt (input_location
));
2835 tmp
= gfc_finish_block (&block
);
2836 gfc_add_expr_to_block (&body
, tmp
);
2840 gfc_trans_scalarized_loop_end (&loop
, 0, &body
);
2842 if (HONOR_NANS (DECL_MODE (limit
)))
2844 if (nonempty
!= NULL
)
2846 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
2847 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
2848 build_empty_stmt (input_location
));
2849 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
2853 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
2854 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
2855 gfc_start_block (&body
);
2857 /* If we have a mask, only check this element if the mask is set. */
2860 gfc_init_se (&maskse
, NULL
);
2861 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
2863 gfc_conv_expr_val (&maskse
, maskexpr
);
2864 gfc_add_block_to_block (&body
, &maskse
.pre
);
2866 gfc_start_block (&block
);
2869 gfc_init_block (&block
);
2871 /* Compare with the current limit. */
2872 gfc_init_se (&arrayse
, NULL
);
2873 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2874 arrayse
.ss
= arrayss
;
2875 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2876 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2878 /* We do the following if this is a more extreme value. */
2879 gfc_start_block (&ifblock
);
2881 /* Assign the value to the limit... */
2882 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
2884 /* Remember where we are. An offset must be added to the loop
2885 counter to obtain the required position. */
2887 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2888 gfc_index_one_node
, loop
.from
[0]);
2890 tmp
= gfc_index_one_node
;
2892 gfc_add_modify (&block
, offset
, tmp
);
2894 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
2895 loop
.loopvar
[0], offset
);
2896 gfc_add_modify (&ifblock
, pos
, tmp
);
2898 ifbody
= gfc_finish_block (&ifblock
);
2900 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2901 arrayse
.expr
, limit
);
2903 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
2904 build_empty_stmt (input_location
));
2905 gfc_add_expr_to_block (&block
, tmp
);
2909 /* We enclose the above in if (mask) {...}. */
2910 tmp
= gfc_finish_block (&block
);
2912 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2913 build_empty_stmt (input_location
));
2916 tmp
= gfc_finish_block (&block
);
2917 gfc_add_expr_to_block (&body
, tmp
);
2918 /* Avoid initializing loopvar[0] again, it should be left where
2919 it finished by the first loop. */
2920 loop
.from
[0] = loop
.loopvar
[0];
2923 gfc_trans_scalarizing_loops (&loop
, &body
);
2926 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
2928 /* For a scalar mask, enclose the loop in an if statement. */
2929 if (maskexpr
&& maskss
== NULL
)
2931 gfc_init_se (&maskse
, NULL
);
2932 gfc_conv_expr_val (&maskse
, maskexpr
);
2933 gfc_init_block (&block
);
2934 gfc_add_block_to_block (&block
, &loop
.pre
);
2935 gfc_add_block_to_block (&block
, &loop
.post
);
2936 tmp
= gfc_finish_block (&block
);
2938 /* For the else part of the scalar mask, just initialize
2939 the pos variable the same way as above. */
2941 gfc_init_block (&elseblock
);
2942 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
2943 elsetmp
= gfc_finish_block (&elseblock
);
2945 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
2946 gfc_add_expr_to_block (&block
, tmp
);
2947 gfc_add_block_to_block (&se
->pre
, &block
);
2951 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2952 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2954 gfc_cleanup_loop (&loop
);
2956 se
->expr
= convert (type
, pos
);
2959 /* Emit code for minval or maxval intrinsic. There are many different cases
2960 we need to handle. For performance reasons we sometimes create two
2961 loops instead of one, where the second one is much simpler.
2962 Examples for minval intrinsic:
2963 1) Result is an array, a call is generated
2964 2) Array mask is used and NaNs need to be supported, rank 1:
2969 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2972 limit = nonempty ? NaN : huge (limit);
2974 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2975 3) NaNs need to be supported, but it is known at compile time or cheaply
2976 at runtime whether array is nonempty or not, rank 1:
2979 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2980 limit = (from <= to) ? NaN : huge (limit);
2982 while (S <= to) { limit = min (a[S], limit); S++; }
2983 4) Array mask is used and NaNs need to be supported, rank > 1:
2992 if (fast) limit = min (a[S1][S2], limit);
2995 if (a[S1][S2] <= limit) {
3006 limit = nonempty ? NaN : huge (limit);
3007 5) NaNs need to be supported, but it is known at compile time or cheaply
3008 at runtime whether array is nonempty or not, rank > 1:
3015 if (fast) limit = min (a[S1][S2], limit);
3017 if (a[S1][S2] <= limit) {
3027 limit = (nonempty_array) ? NaN : huge (limit);
3028 6) NaNs aren't supported, but infinities are. Array mask is used:
3033 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3036 limit = nonempty ? limit : huge (limit);
3037 7) Same without array mask:
3040 while (S <= to) { limit = min (a[S], limit); S++; }
3041 limit = (from <= to) ? limit : huge (limit);
3042 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3043 limit = huge (limit);
3045 while (S <= to) { limit = min (a[S], limit); S++); }
3047 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3048 with array mask instead).
3049 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3050 setting limit = huge (limit); in the else branch. */
3053 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3063 tree huge_cst
= NULL
, nan_cst
= NULL
;
3065 stmtblock_t block
, block2
;
3067 gfc_actual_arglist
*actual
;
3072 gfc_expr
*arrayexpr
;
3078 gfc_conv_intrinsic_funcall (se
, expr
);
3082 type
= gfc_typenode_for_spec (&expr
->ts
);
3083 /* Initialize the result. */
3084 limit
= gfc_create_var (type
, "limit");
3085 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
3086 switch (expr
->ts
.type
)
3089 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
3091 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3093 REAL_VALUE_TYPE real
;
3095 tmp
= build_real (type
, real
);
3099 if (HONOR_NANS (DECL_MODE (limit
)))
3101 REAL_VALUE_TYPE real
;
3102 real_nan (&real
, "", 1, DECL_MODE (limit
));
3103 nan_cst
= build_real (type
, real
);
3108 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
3115 /* We start with the most negative possible value for MAXVAL, and the most
3116 positive possible value for MINVAL. The most negative possible value is
3117 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3118 possible value is HUGE in both cases. */
3121 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3123 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
3124 TREE_TYPE (huge_cst
), huge_cst
);
3127 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3128 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
3129 tmp
, build_int_cst (type
, 1));
3131 gfc_add_modify (&se
->pre
, limit
, tmp
);
3133 /* Walk the arguments. */
3134 actual
= expr
->value
.function
.actual
;
3135 arrayexpr
= actual
->expr
;
3136 arrayss
= gfc_walk_expr (arrayexpr
);
3137 gcc_assert (arrayss
!= gfc_ss_terminator
);
3139 actual
= actual
->next
->next
;
3140 gcc_assert (actual
);
3141 maskexpr
= actual
->expr
;
3143 if (maskexpr
&& maskexpr
->rank
!= 0)
3145 maskss
= gfc_walk_expr (maskexpr
);
3146 gcc_assert (maskss
!= gfc_ss_terminator
);
3151 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3153 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3155 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3156 boolean_type_node
, nonempty
,
3157 gfc_index_zero_node
);
3162 /* Initialize the scalarizer. */
3163 gfc_init_loopinfo (&loop
);
3164 gfc_add_ss_to_loop (&loop
, arrayss
);
3166 gfc_add_ss_to_loop (&loop
, maskss
);
3168 /* Initialize the loop. */
3169 gfc_conv_ss_startstride (&loop
);
3170 gfc_conv_loop_setup (&loop
, &expr
->where
);
3172 if (nonempty
== NULL
&& maskss
== NULL
3173 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
3174 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3175 loop
.from
[0], loop
.to
[0]);
3176 nonempty_var
= NULL
;
3177 if (nonempty
== NULL
3178 && (HONOR_INFINITIES (DECL_MODE (limit
))
3179 || HONOR_NANS (DECL_MODE (limit
))))
3181 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3182 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3183 nonempty
= nonempty_var
;
3187 if (HONOR_NANS (DECL_MODE (limit
)))
3189 if (loop
.dimen
== 1)
3191 lab
= gfc_build_label_decl (NULL_TREE
);
3192 TREE_USED (lab
) = 1;
3196 fast
= gfc_create_var (boolean_type_node
, "fast");
3197 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3201 gfc_mark_ss_chain_used (arrayss
, 1);
3203 gfc_mark_ss_chain_used (maskss
, 1);
3204 /* Generate the loop body. */
3205 gfc_start_scalarized_body (&loop
, &body
);
3207 /* If we have a mask, only add this element if the mask is set. */
3210 gfc_init_se (&maskse
, NULL
);
3211 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3213 gfc_conv_expr_val (&maskse
, maskexpr
);
3214 gfc_add_block_to_block (&body
, &maskse
.pre
);
3216 gfc_start_block (&block
);
3219 gfc_init_block (&block
);
3221 /* Compare with the current limit. */
3222 gfc_init_se (&arrayse
, NULL
);
3223 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3224 arrayse
.ss
= arrayss
;
3225 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3226 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3228 gfc_init_block (&block2
);
3231 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3233 if (HONOR_NANS (DECL_MODE (limit
)))
3235 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3236 boolean_type_node
, arrayse
.expr
, limit
);
3238 ifbody
= build1_v (GOTO_EXPR
, lab
);
3241 stmtblock_t ifblock
;
3243 gfc_init_block (&ifblock
);
3244 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3245 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3246 ifbody
= gfc_finish_block (&ifblock
);
3248 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3249 build_empty_stmt (input_location
));
3250 gfc_add_expr_to_block (&block2
, tmp
);
3254 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3256 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3258 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3259 arrayse
.expr
, limit
);
3260 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3261 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3262 build_empty_stmt (input_location
));
3263 gfc_add_expr_to_block (&block2
, tmp
);
3267 tmp
= fold_build2_loc (input_location
,
3268 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3269 type
, arrayse
.expr
, limit
);
3270 gfc_add_modify (&block2
, limit
, tmp
);
3276 tree elsebody
= gfc_finish_block (&block2
);
3278 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3280 if (HONOR_NANS (DECL_MODE (limit
))
3281 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3283 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3284 arrayse
.expr
, limit
);
3285 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3286 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3287 build_empty_stmt (input_location
));
3291 tmp
= fold_build2_loc (input_location
,
3292 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3293 type
, arrayse
.expr
, limit
);
3294 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3296 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3297 gfc_add_expr_to_block (&block
, tmp
);
3300 gfc_add_block_to_block (&block
, &block2
);
3302 gfc_add_block_to_block (&block
, &arrayse
.post
);
3304 tmp
= gfc_finish_block (&block
);
3306 /* We enclose the above in if (mask) {...}. */
3307 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3308 build_empty_stmt (input_location
));
3309 gfc_add_expr_to_block (&body
, tmp
);
3313 gfc_trans_scalarized_loop_end (&loop
, 0, &body
);
3315 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3317 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
3318 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
3320 gfc_start_block (&body
);
3322 /* If we have a mask, only add this element if the mask is set. */
3325 gfc_init_se (&maskse
, NULL
);
3326 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3328 gfc_conv_expr_val (&maskse
, maskexpr
);
3329 gfc_add_block_to_block (&body
, &maskse
.pre
);
3331 gfc_start_block (&block
);
3334 gfc_init_block (&block
);
3336 /* Compare with the current limit. */
3337 gfc_init_se (&arrayse
, NULL
);
3338 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3339 arrayse
.ss
= arrayss
;
3340 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3341 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3343 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3345 if (HONOR_NANS (DECL_MODE (limit
))
3346 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3348 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3349 arrayse
.expr
, limit
);
3350 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3351 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3352 build_empty_stmt (input_location
));
3353 gfc_add_expr_to_block (&block
, tmp
);
3357 tmp
= fold_build2_loc (input_location
,
3358 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3359 type
, arrayse
.expr
, limit
);
3360 gfc_add_modify (&block
, limit
, tmp
);
3363 gfc_add_block_to_block (&block
, &arrayse
.post
);
3365 tmp
= gfc_finish_block (&block
);
3367 /* We enclose the above in if (mask) {...}. */
3368 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3369 build_empty_stmt (input_location
));
3370 gfc_add_expr_to_block (&body
, tmp
);
3371 /* Avoid initializing loopvar[0] again, it should be left where
3372 it finished by the first loop. */
3373 loop
.from
[0] = loop
.loopvar
[0];
3375 gfc_trans_scalarizing_loops (&loop
, &body
);
3379 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3381 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3382 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
3384 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3386 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
3388 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
3390 gfc_add_modify (&loop
.pre
, limit
, tmp
);
3393 /* For a scalar mask, enclose the loop in an if statement. */
3394 if (maskexpr
&& maskss
== NULL
)
3398 gfc_init_se (&maskse
, NULL
);
3399 gfc_conv_expr_val (&maskse
, maskexpr
);
3400 gfc_init_block (&block
);
3401 gfc_add_block_to_block (&block
, &loop
.pre
);
3402 gfc_add_block_to_block (&block
, &loop
.post
);
3403 tmp
= gfc_finish_block (&block
);
3405 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3406 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
3408 else_stmt
= build_empty_stmt (input_location
);
3409 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
3410 gfc_add_expr_to_block (&block
, tmp
);
3411 gfc_add_block_to_block (&se
->pre
, &block
);
3415 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3416 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3419 gfc_cleanup_loop (&loop
);
3424 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3426 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
3432 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3433 type
= TREE_TYPE (args
[0]);
3435 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3436 build_int_cst (type
, 1), args
[1]);
3437 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
3438 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
3439 build_int_cst (type
, 0));
3440 type
= gfc_typenode_for_spec (&expr
->ts
);
3441 se
->expr
= convert (type
, tmp
);
3445 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3447 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3451 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3453 /* Convert both arguments to the unsigned type of the same size. */
3454 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
3455 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
3457 /* If they have unequal type size, convert to the larger one. */
3458 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
3459 > TYPE_PRECISION (TREE_TYPE (args
[1])))
3460 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
3461 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
3462 > TYPE_PRECISION (TREE_TYPE (args
[0])))
3463 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
3465 /* Now, we compare them. */
3466 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3471 /* Generate code to perform the specified operation. */
3473 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3477 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3478 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
3484 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
3488 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3489 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3490 TREE_TYPE (arg
), arg
);
3493 /* Set or clear a single bit. */
3495 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
3502 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3503 type
= TREE_TYPE (args
[0]);
3505 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3506 build_int_cst (type
, 1), args
[1]);
3512 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
3514 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
3517 /* Extract a sequence of bits.
3518 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3520 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
3527 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3528 type
= TREE_TYPE (args
[0]);
3530 mask
= build_int_cst (type
, -1);
3531 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
3532 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
3534 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
3536 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
3540 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
3543 tree args
[2], type
, num_bits
, cond
;
3545 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3547 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3548 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3549 type
= TREE_TYPE (args
[0]);
3552 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
3554 gcc_assert (right_shift
);
3556 se
->expr
= fold_build2_loc (input_location
,
3557 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
3558 TREE_TYPE (args
[0]), args
[0], args
[1]);
3561 se
->expr
= fold_convert (type
, se
->expr
);
3563 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3564 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3566 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
3567 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
3570 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3571 build_int_cst (type
, 0), se
->expr
);
3574 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3576 : ((shift >= 0) ? i << shift : i >> -shift)
3577 where all shifts are logical shifts. */
3579 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
3591 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3593 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3594 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3596 type
= TREE_TYPE (args
[0]);
3597 utype
= unsigned_type_for (type
);
3599 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
3602 /* Left shift if positive. */
3603 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
3605 /* Right shift if negative.
3606 We convert to an unsigned type because we want a logical shift.
3607 The standard doesn't define the case of shifting negative
3608 numbers, and we try to be compatible with other compilers, most
3609 notably g77, here. */
3610 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
3611 utype
, convert (utype
, args
[0]), width
));
3613 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
3614 build_int_cst (TREE_TYPE (args
[1]), 0));
3615 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
3617 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3618 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3620 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
3621 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
3623 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
3624 build_int_cst (type
, 0), tmp
);
3628 /* Circular shift. AKA rotate or barrel shift. */
3631 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
3639 unsigned int num_args
;
3641 num_args
= gfc_intrinsic_argument_list_length (expr
);
3642 args
= XALLOCAVEC (tree
, num_args
);
3644 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
3648 /* Use a library function for the 3 parameter version. */
3649 tree int4type
= gfc_get_int_type (4);
3651 type
= TREE_TYPE (args
[0]);
3652 /* We convert the first argument to at least 4 bytes, and
3653 convert back afterwards. This removes the need for library
3654 functions for all argument sizes, and function will be
3655 aligned to at least 32 bits, so there's no loss. */
3656 if (expr
->ts
.kind
< 4)
3657 args
[0] = convert (int4type
, args
[0]);
3659 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3660 need loads of library functions. They cannot have values >
3661 BIT_SIZE (I) so the conversion is safe. */
3662 args
[1] = convert (int4type
, args
[1]);
3663 args
[2] = convert (int4type
, args
[2]);
3665 switch (expr
->ts
.kind
)
3670 tmp
= gfor_fndecl_math_ishftc4
;
3673 tmp
= gfor_fndecl_math_ishftc8
;
3676 tmp
= gfor_fndecl_math_ishftc16
;
3681 se
->expr
= build_call_expr_loc (input_location
,
3682 tmp
, 3, args
[0], args
[1], args
[2]);
3683 /* Convert the result back to the original type, if we extended
3684 the first argument's width above. */
3685 if (expr
->ts
.kind
< 4)
3686 se
->expr
= convert (type
, se
->expr
);
3690 type
= TREE_TYPE (args
[0]);
3692 /* Evaluate arguments only once. */
3693 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3694 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3696 /* Rotate left if positive. */
3697 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
3699 /* Rotate right if negative. */
3700 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
3702 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
3704 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
3705 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
3707 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
3709 /* Do nothing if shift == 0. */
3710 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
3712 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
3717 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3718 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3720 The conditional expression is necessary because the result of LEADZ(0)
3721 is defined, but the result of __builtin_clz(0) is undefined for most
3724 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3725 difference in bit size between the argument of LEADZ and the C int. */
3728 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
3740 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3741 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
3743 /* Which variant of __builtin_clz* should we call? */
3744 if (argsize
<= INT_TYPE_SIZE
)
3746 arg_type
= unsigned_type_node
;
3747 func
= built_in_decls
[BUILT_IN_CLZ
];
3749 else if (argsize
<= LONG_TYPE_SIZE
)
3751 arg_type
= long_unsigned_type_node
;
3752 func
= built_in_decls
[BUILT_IN_CLZL
];
3754 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
3756 arg_type
= long_long_unsigned_type_node
;
3757 func
= built_in_decls
[BUILT_IN_CLZLL
];
3761 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
3762 arg_type
= gfc_build_uint_type (argsize
);
3766 /* Convert the actual argument twice: first, to the unsigned type of the
3767 same size; then, to the proper argument type for the built-in
3768 function. But the return type is of the default INTEGER kind. */
3769 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
3770 arg
= fold_convert (arg_type
, arg
);
3771 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3772 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
3774 /* Compute LEADZ for the case i .ne. 0. */
3777 s
= TYPE_PRECISION (arg_type
) - argsize
;
3778 tmp
= fold_convert (result_type
,
3779 build_call_expr_loc (input_location
, func
,
3781 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
3782 tmp
, build_int_cst (result_type
, s
));
3786 /* We end up here if the argument type is larger than 'long long'.
3787 We generate this code:
3789 if (x & (ULL_MAX << ULL_SIZE) != 0)
3790 return clzll ((unsigned long long) (x >> ULLSIZE));
3792 return ULL_SIZE + clzll ((unsigned long long) x);
3793 where ULL_MAX is the largest value that a ULL_MAX can hold
3794 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
3795 is the bit-size of the long long type (64 in this example). */
3796 tree ullsize
, ullmax
, tmp1
, tmp2
;
3798 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
3799 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3800 long_long_unsigned_type_node
,
3801 build_int_cst (long_long_unsigned_type_node
,
3804 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
3805 fold_convert (arg_type
, ullmax
), ullsize
);
3806 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
3808 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3809 cond
, build_int_cst (arg_type
, 0));
3811 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
3813 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
3814 tmp1
= fold_convert (result_type
,
3815 build_call_expr_loc (input_location
,
3816 built_in_decls
[BUILT_IN_CLZLL
],
3819 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
3820 tmp2
= fold_convert (result_type
,
3821 build_call_expr_loc (input_location
,
3822 built_in_decls
[BUILT_IN_CLZLL
],
3824 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
3827 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
3831 /* Build BIT_SIZE. */
3832 bit_size
= build_int_cst (result_type
, argsize
);
3834 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3835 arg
, build_int_cst (arg_type
, 0));
3836 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
3841 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3843 The conditional expression is necessary because the result of TRAILZ(0)
3844 is defined, but the result of __builtin_ctz(0) is undefined for most
3848 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
3859 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3860 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
3862 /* Which variant of __builtin_ctz* should we call? */
3863 if (argsize
<= INT_TYPE_SIZE
)
3865 arg_type
= unsigned_type_node
;
3866 func
= built_in_decls
[BUILT_IN_CTZ
];
3868 else if (argsize
<= LONG_TYPE_SIZE
)
3870 arg_type
= long_unsigned_type_node
;
3871 func
= built_in_decls
[BUILT_IN_CTZL
];
3873 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
3875 arg_type
= long_long_unsigned_type_node
;
3876 func
= built_in_decls
[BUILT_IN_CTZLL
];
3880 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
3881 arg_type
= gfc_build_uint_type (argsize
);
3885 /* Convert the actual argument twice: first, to the unsigned type of the
3886 same size; then, to the proper argument type for the built-in
3887 function. But the return type is of the default INTEGER kind. */
3888 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
3889 arg
= fold_convert (arg_type
, arg
);
3890 arg
= gfc_evaluate_now (arg
, &se
->pre
);
3891 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
3893 /* Compute TRAILZ for the case i .ne. 0. */
3895 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
3899 /* We end up here if the argument type is larger than 'long long'.
3900 We generate this code:
3902 if ((x & ULL_MAX) == 0)
3903 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
3905 return ctzll ((unsigned long long) x);
3907 where ULL_MAX is the largest value that a ULL_MAX can hold
3908 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
3909 is the bit-size of the long long type (64 in this example). */
3910 tree ullsize
, ullmax
, tmp1
, tmp2
;
3912 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
3913 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3914 long_long_unsigned_type_node
,
3915 build_int_cst (long_long_unsigned_type_node
, 0));
3917 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
3918 fold_convert (arg_type
, ullmax
));
3919 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
3920 build_int_cst (arg_type
, 0));
3922 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
3924 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
3925 tmp1
= fold_convert (result_type
,
3926 build_call_expr_loc (input_location
,
3927 built_in_decls
[BUILT_IN_CTZLL
],
3929 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
3932 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
3933 tmp2
= fold_convert (result_type
,
3934 build_call_expr_loc (input_location
,
3935 built_in_decls
[BUILT_IN_CTZLL
],
3938 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
3942 /* Build BIT_SIZE. */
3943 bit_size
= build_int_cst (result_type
, argsize
);
3945 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3946 arg
, build_int_cst (arg_type
, 0));
3947 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
3951 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
3952 for types larger than "long long", we call the long long built-in for
3953 the lower and higher bits and combine the result. */
3956 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
3964 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3965 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
3966 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
3968 /* Which variant of the builtin should we call? */
3969 if (argsize
<= INT_TYPE_SIZE
)
3971 arg_type
= unsigned_type_node
;
3972 func
= built_in_decls
[parity
? BUILT_IN_PARITY
: BUILT_IN_POPCOUNT
];
3974 else if (argsize
<= LONG_TYPE_SIZE
)
3976 arg_type
= long_unsigned_type_node
;
3977 func
= built_in_decls
[parity
? BUILT_IN_PARITYL
: BUILT_IN_POPCOUNTL
];
3979 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
3981 arg_type
= long_long_unsigned_type_node
;
3982 func
= built_in_decls
[parity
? BUILT_IN_PARITYLL
: BUILT_IN_POPCOUNTLL
];
3986 /* Our argument type is larger than 'long long', which mean none
3987 of the POPCOUNT builtins covers it. We thus call the 'long long'
3988 variant multiple times, and add the results. */
3989 tree utype
, arg2
, call1
, call2
;
3991 /* For now, we only cover the case where argsize is twice as large
3993 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
3995 func
= built_in_decls
[parity
? BUILT_IN_PARITYLL
: BUILT_IN_POPCOUNTLL
];
3997 /* Convert it to an integer, and store into a variable. */
3998 utype
= gfc_build_uint_type (argsize
);
3999 arg
= fold_convert (utype
, arg
);
4000 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4002 /* Call the builtin twice. */
4003 call1
= build_call_expr_loc (input_location
, func
, 1,
4004 fold_convert (long_long_unsigned_type_node
,
4007 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
4008 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
4009 call2
= build_call_expr_loc (input_location
, func
, 1,
4010 fold_convert (long_long_unsigned_type_node
,
4013 /* Combine the results. */
4015 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
4018 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4024 /* Convert the actual argument twice: first, to the unsigned type of the
4025 same size; then, to the proper argument type for the built-in
4027 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4028 arg
= fold_convert (arg_type
, arg
);
4030 se
->expr
= fold_convert (result_type
,
4031 build_call_expr_loc (input_location
, func
, 1, arg
));
4035 /* Process an intrinsic with unspecified argument-types that has an optional
4036 argument (which could be of type character), e.g. EOSHIFT. For those, we
4037 need to append the string length of the optional argument if it is not
4038 present and the type is really character.
4039 primary specifies the position (starting at 1) of the non-optional argument
4040 specifying the type and optional gives the position of the optional
4041 argument in the arglist. */
4044 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
4045 unsigned primary
, unsigned optional
)
4047 gfc_actual_arglist
* prim_arg
;
4048 gfc_actual_arglist
* opt_arg
;
4050 gfc_actual_arglist
* arg
;
4052 VEC(tree
,gc
) *append_args
;
4054 /* Find the two arguments given as position. */
4058 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4062 if (cur_pos
== primary
)
4064 if (cur_pos
== optional
)
4067 if (cur_pos
>= primary
&& cur_pos
>= optional
)
4070 gcc_assert (prim_arg
);
4071 gcc_assert (prim_arg
->expr
);
4072 gcc_assert (opt_arg
);
4074 /* If we do have type CHARACTER and the optional argument is really absent,
4075 append a dummy 0 as string length. */
4077 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
4081 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
4082 append_args
= VEC_alloc (tree
, gc
, 1);
4083 VEC_quick_push (tree
, append_args
, dummy
);
4086 /* Build the call itself. */
4087 sym
= gfc_get_symbol_for_expr (expr
);
4088 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4094 /* The length of a character string. */
4096 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
4106 gcc_assert (!se
->ss
);
4108 arg
= expr
->value
.function
.actual
->expr
;
4110 type
= gfc_typenode_for_spec (&expr
->ts
);
4111 switch (arg
->expr_type
)
4114 len
= build_int_cst (NULL_TREE
, arg
->value
.character
.length
);
4118 /* Obtain the string length from the function used by
4119 trans-array.c(gfc_trans_array_constructor). */
4121 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
4125 if (arg
->ref
== NULL
4126 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
4128 /* This doesn't catch all cases.
4129 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4130 and the surrounding thread. */
4131 sym
= arg
->symtree
->n
.sym
;
4132 decl
= gfc_get_symbol_decl (sym
);
4133 if (decl
== current_function_decl
&& sym
->attr
.function
4134 && (sym
->result
== sym
))
4135 decl
= gfc_get_fake_result_decl (sym
, 0);
4137 len
= sym
->ts
.u
.cl
->backend_decl
;
4142 /* Otherwise fall through. */
4145 /* Anybody stupid enough to do this deserves inefficient code. */
4146 ss
= gfc_walk_expr (arg
);
4147 gfc_init_se (&argse
, se
);
4148 if (ss
== gfc_ss_terminator
)
4149 gfc_conv_expr (&argse
, arg
);
4151 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
4152 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4153 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4154 len
= argse
.string_length
;
4157 se
->expr
= convert (type
, len
);
4160 /* The length of a character string not including trailing blanks. */
4162 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
4164 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4165 tree args
[2], type
, fndecl
;
4167 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4168 type
= gfc_typenode_for_spec (&expr
->ts
);
4171 fndecl
= gfor_fndecl_string_len_trim
;
4173 fndecl
= gfor_fndecl_string_len_trim_char4
;
4177 se
->expr
= build_call_expr_loc (input_location
,
4178 fndecl
, 2, args
[0], args
[1]);
4179 se
->expr
= convert (type
, se
->expr
);
4183 /* Returns the starting position of a substring within a string. */
4186 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4189 tree logical4_type_node
= gfc_get_logical_type (4);
4193 unsigned int num_args
;
4195 args
= XALLOCAVEC (tree
, 5);
4197 /* Get number of arguments; characters count double due to the
4198 string length argument. Kind= is not passed to the library
4199 and thus ignored. */
4200 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4205 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4206 type
= gfc_typenode_for_spec (&expr
->ts
);
4209 args
[4] = build_int_cst (logical4_type_node
, 0);
4211 args
[4] = convert (logical4_type_node
, args
[4]);
4213 fndecl
= build_addr (function
, current_function_decl
);
4214 se
->expr
= build_call_array_loc (input_location
,
4215 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4217 se
->expr
= convert (type
, se
->expr
);
4221 /* The ascii value for a single character. */
4223 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4225 tree args
[2], type
, pchartype
;
4227 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4228 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
4229 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
4230 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
4231 type
= gfc_typenode_for_spec (&expr
->ts
);
4233 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4235 se
->expr
= convert (type
, se
->expr
);
4239 /* Intrinsic ISNAN calls __builtin_isnan. */
4242 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
4246 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4247 se
->expr
= build_call_expr_loc (input_location
,
4248 built_in_decls
[BUILT_IN_ISNAN
], 1, arg
);
4249 STRIP_TYPE_NOPS (se
->expr
);
4250 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4254 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4255 their argument against a constant integer value. */
4258 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
4262 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4263 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
4264 gfc_typenode_for_spec (&expr
->ts
),
4265 arg
, build_int_cst (TREE_TYPE (arg
), value
));
4270 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4273 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
4281 unsigned int num_args
;
4283 num_args
= gfc_intrinsic_argument_list_length (expr
);
4284 args
= XALLOCAVEC (tree
, num_args
);
4286 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4287 if (expr
->ts
.type
!= BT_CHARACTER
)
4295 /* We do the same as in the non-character case, but the argument
4296 list is different because of the string length arguments. We
4297 also have to set the string length for the result. */
4304 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
4306 se
->string_length
= len
;
4308 type
= TREE_TYPE (tsource
);
4309 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
4310 fold_convert (type
, fsource
));
4314 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4317 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
4319 tree args
[3], mask
, type
;
4321 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4322 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
4324 type
= TREE_TYPE (args
[0]);
4325 gcc_assert (TREE_TYPE (args
[1]) == type
);
4326 gcc_assert (TREE_TYPE (mask
) == type
);
4328 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
4329 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
4330 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4332 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
4337 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4338 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4341 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
4343 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
4346 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4347 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4349 type
= gfc_get_int_type (expr
->ts
.kind
);
4350 utype
= unsigned_type_for (type
);
4352 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
4353 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
4355 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
4356 build_int_cst (utype
, 0));
4360 /* Left-justified mask. */
4361 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
4363 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4364 fold_convert (utype
, res
));
4366 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4367 smaller than type width. */
4368 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4369 build_int_cst (TREE_TYPE (arg
), 0));
4370 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
4371 build_int_cst (utype
, 0), res
);
4375 /* Right-justified mask. */
4376 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4377 fold_convert (utype
, arg
));
4378 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
4380 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4381 strictly smaller than type width. */
4382 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4384 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
4385 cond
, allones
, res
);
4388 se
->expr
= fold_convert (type
, res
);
4392 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4394 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
4396 tree arg
, type
, tmp
, frexp
;
4398 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4400 type
= gfc_typenode_for_spec (&expr
->ts
);
4401 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4402 tmp
= gfc_create_var (integer_type_node
, NULL
);
4403 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
4404 fold_convert (type
, arg
),
4405 gfc_build_addr_expr (NULL_TREE
, tmp
));
4406 se
->expr
= fold_convert (type
, se
->expr
);
4410 /* NEAREST (s, dir) is translated into
4411 tmp = copysign (HUGE_VAL, dir);
4412 return nextafter (s, tmp);
4415 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
4417 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
4419 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
4420 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
4422 type
= gfc_typenode_for_spec (&expr
->ts
);
4423 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4425 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
4426 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
4427 fold_convert (type
, args
[1]));
4428 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
4429 fold_convert (type
, args
[0]), tmp
);
4430 se
->expr
= fold_convert (type
, se
->expr
);
4434 /* SPACING (s) is translated into
4442 e = MAX_EXPR (e, emin);
4443 res = scalbn (1., e);
4447 where prec is the precision of s, gfc_real_kinds[k].digits,
4448 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4449 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4452 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
4454 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
4455 tree cond
, tmp
, frexp
, scalbn
;
4459 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4460 prec
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].digits
);
4461 emin
= build_int_cst (NULL_TREE
, gfc_real_kinds
[k
].min_exponent
- 1);
4462 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
4464 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4465 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4467 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4468 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4470 type
= gfc_typenode_for_spec (&expr
->ts
);
4471 e
= gfc_create_var (integer_type_node
, NULL
);
4472 res
= gfc_create_var (type
, NULL
);
4475 /* Build the block for s /= 0. */
4476 gfc_start_block (&block
);
4477 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4478 gfc_build_addr_expr (NULL_TREE
, e
));
4479 gfc_add_expr_to_block (&block
, tmp
);
4481 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
4483 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
4484 integer_type_node
, tmp
, emin
));
4486 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
4487 build_real_from_int_cst (type
, integer_one_node
), e
);
4488 gfc_add_modify (&block
, res
, tmp
);
4490 /* Finish by building the IF statement. */
4491 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4492 build_real_from_int_cst (type
, integer_zero_node
));
4493 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
4494 gfc_finish_block (&block
));
4496 gfc_add_expr_to_block (&se
->pre
, tmp
);
4501 /* RRSPACING (s) is translated into
4508 x = scalbn (x, precision - e);
4512 where precision is gfc_real_kinds[k].digits. */
4515 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
4517 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
4521 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4522 prec
= gfc_real_kinds
[k
].digits
;
4524 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4525 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4526 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
4528 type
= gfc_typenode_for_spec (&expr
->ts
);
4529 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4530 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4532 e
= gfc_create_var (integer_type_node
, NULL
);
4533 x
= gfc_create_var (type
, NULL
);
4534 gfc_add_modify (&se
->pre
, x
,
4535 build_call_expr_loc (input_location
, fabs
, 1, arg
));
4538 gfc_start_block (&block
);
4539 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4540 gfc_build_addr_expr (NULL_TREE
, e
));
4541 gfc_add_expr_to_block (&block
, tmp
);
4543 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
4544 build_int_cst (NULL_TREE
, prec
), e
);
4545 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
4546 gfc_add_modify (&block
, x
, tmp
);
4547 stmt
= gfc_finish_block (&block
);
4549 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
4550 build_real_from_int_cst (type
, integer_zero_node
));
4551 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
4552 gfc_add_expr_to_block (&se
->pre
, tmp
);
4554 se
->expr
= fold_convert (type
, x
);
4558 /* SCALE (s, i) is translated into scalbn (s, i). */
4560 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
4562 tree args
[2], type
, scalbn
;
4564 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4566 type
= gfc_typenode_for_spec (&expr
->ts
);
4567 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4568 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
4569 fold_convert (type
, args
[0]),
4570 fold_convert (integer_type_node
, args
[1]));
4571 se
->expr
= fold_convert (type
, se
->expr
);
4575 /* SET_EXPONENT (s, i) is translated into
4576 scalbn (frexp (s, &dummy_int), i). */
4578 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
4580 tree args
[2], type
, tmp
, frexp
, scalbn
;
4582 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4583 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4585 type
= gfc_typenode_for_spec (&expr
->ts
);
4586 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4588 tmp
= gfc_create_var (integer_type_node
, NULL
);
4589 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
4590 fold_convert (type
, args
[0]),
4591 gfc_build_addr_expr (NULL_TREE
, tmp
));
4592 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
4593 fold_convert (integer_type_node
, args
[1]));
4594 se
->expr
= fold_convert (type
, se
->expr
);
4599 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
4601 gfc_actual_arglist
*actual
;
4609 gfc_init_se (&argse
, NULL
);
4610 actual
= expr
->value
.function
.actual
;
4612 ss
= gfc_walk_expr (actual
->expr
);
4613 gcc_assert (ss
!= gfc_ss_terminator
);
4614 argse
.want_pointer
= 1;
4615 argse
.data_not_needed
= 1;
4616 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
4617 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4618 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4619 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
4621 /* Build the call to size0. */
4622 fncall0
= build_call_expr_loc (input_location
,
4623 gfor_fndecl_size0
, 1, arg1
);
4625 actual
= actual
->next
;
4629 gfc_init_se (&argse
, NULL
);
4630 gfc_conv_expr_type (&argse
, actual
->expr
,
4631 gfc_array_index_type
);
4632 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4634 /* Unusually, for an intrinsic, size does not exclude
4635 an optional arg2, so we must test for it. */
4636 if (actual
->expr
->expr_type
== EXPR_VARIABLE
4637 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
4638 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
4641 /* Build the call to size1. */
4642 fncall1
= build_call_expr_loc (input_location
,
4643 gfor_fndecl_size1
, 2,
4646 gfc_init_se (&argse
, NULL
);
4647 argse
.want_pointer
= 1;
4648 argse
.data_not_needed
= 1;
4649 gfc_conv_expr (&argse
, actual
->expr
);
4650 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4651 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4652 argse
.expr
, null_pointer_node
);
4653 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4654 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
4655 pvoid_type_node
, tmp
, fncall1
, fncall0
);
4659 se
->expr
= NULL_TREE
;
4660 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
4661 gfc_array_index_type
,
4662 argse
.expr
, gfc_index_one_node
);
4665 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
4667 argse
.expr
= gfc_index_zero_node
;
4668 se
->expr
= NULL_TREE
;
4673 if (se
->expr
== NULL_TREE
)
4675 tree ubound
, lbound
;
4677 arg1
= build_fold_indirect_ref_loc (input_location
,
4679 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
4680 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
4681 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
4682 gfc_array_index_type
, ubound
, lbound
);
4683 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
4684 gfc_array_index_type
,
4685 se
->expr
, gfc_index_one_node
);
4686 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
4687 gfc_array_index_type
, se
->expr
,
4688 gfc_index_zero_node
);
4691 type
= gfc_typenode_for_spec (&expr
->ts
);
4692 se
->expr
= convert (type
, se
->expr
);
4696 /* Helper function to compute the size of a character variable,
4697 excluding the terminating null characters. The result has
4698 gfc_array_index_type type. */
4701 size_of_string_in_bytes (int kind
, tree string_length
)
4704 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
4706 bytesize
= build_int_cst (gfc_array_index_type
,
4707 gfc_character_kinds
[i
].bit_size
/ 8);
4709 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4711 fold_convert (gfc_array_index_type
, string_length
));
4716 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
4728 arg
= expr
->value
.function
.actual
->expr
;
4730 gfc_init_se (&argse
, NULL
);
4731 ss
= gfc_walk_expr (arg
);
4733 if (ss
== gfc_ss_terminator
)
4735 if (arg
->ts
.type
== BT_CLASS
)
4736 gfc_add_data_component (arg
);
4738 gfc_conv_expr_reference (&argse
, arg
);
4740 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4743 /* Obtain the source word length. */
4744 if (arg
->ts
.type
== BT_CHARACTER
)
4745 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
4746 argse
.string_length
);
4748 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
4752 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
4753 argse
.want_pointer
= 0;
4754 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
4755 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4757 /* Obtain the argument's word length. */
4758 if (arg
->ts
.type
== BT_CHARACTER
)
4759 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
4761 tmp
= fold_convert (gfc_array_index_type
,
4762 size_in_bytes (type
));
4763 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
4765 /* Obtain the size of the array in bytes. */
4766 for (n
= 0; n
< arg
->rank
; n
++)
4769 idx
= gfc_rank_cst
[n
];
4770 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
4771 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
4772 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4773 gfc_array_index_type
, upper
, lower
);
4774 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4775 gfc_array_index_type
, tmp
, gfc_index_one_node
);
4776 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
4777 gfc_array_index_type
, tmp
, source_bytes
);
4778 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
4780 se
->expr
= source_bytes
;
4783 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4788 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
4793 tree type
, result_type
, tmp
;
4795 arg
= expr
->value
.function
.actual
->expr
;
4796 gfc_init_se (&eight
, NULL
);
4797 gfc_conv_expr (&eight
, gfc_get_int_expr (expr
->ts
.kind
, NULL
, 8));
4799 gfc_init_se (&argse
, NULL
);
4800 ss
= gfc_walk_expr (arg
);
4801 result_type
= gfc_get_int_type (expr
->ts
.kind
);
4803 if (ss
== gfc_ss_terminator
)
4805 if (arg
->ts
.type
== BT_CLASS
)
4807 gfc_add_vptr_component (arg
);
4808 gfc_add_size_component (arg
);
4809 gfc_conv_expr (&argse
, arg
);
4810 tmp
= fold_convert (result_type
, argse
.expr
);
4814 gfc_conv_expr_reference (&argse
, arg
);
4815 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4820 argse
.want_pointer
= 0;
4821 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
4822 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4825 /* Obtain the argument's word length. */
4826 if (arg
->ts
.type
== BT_CHARACTER
)
4827 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
4829 tmp
= fold_convert (result_type
, size_in_bytes (type
));
4832 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
4834 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4838 /* Intrinsic string comparison functions. */
4841 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
4845 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
4848 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
4849 expr
->value
.function
.actual
->expr
->ts
.kind
,
4851 se
->expr
= fold_build2_loc (input_location
, op
,
4852 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
4853 build_int_cst (TREE_TYPE (se
->expr
), 0));
4856 /* Generate a call to the adjustl/adjustr library function. */
4858 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
4866 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
4869 type
= TREE_TYPE (args
[2]);
4870 var
= gfc_conv_string_tmp (se
, type
, len
);
4873 tmp
= build_call_expr_loc (input_location
,
4874 fndecl
, 3, args
[0], args
[1], args
[2]);
4875 gfc_add_expr_to_block (&se
->pre
, tmp
);
4877 se
->string_length
= len
;
4881 /* Generate code for the TRANSFER intrinsic:
4883 DEST = TRANSFER (SOURCE, MOLD)
4885 typeof<DEST> = typeof<MOLD>
4890 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
4892 typeof<DEST> = typeof<MOLD>
4894 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
4895 sizeof (DEST(0) * SIZE). */
4897 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
4913 gfc_actual_arglist
*arg
;
4923 info
= &se
->ss
->data
.info
;
4925 /* Convert SOURCE. The output from this stage is:-
4926 source_bytes = length of the source in bytes
4927 source = pointer to the source data. */
4928 arg
= expr
->value
.function
.actual
;
4930 /* Ensure double transfer through LOGICAL preserves all
4932 if (arg
->expr
->expr_type
== EXPR_FUNCTION
4933 && arg
->expr
->value
.function
.esym
== NULL
4934 && arg
->expr
->value
.function
.isym
!= NULL
4935 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
4936 && arg
->expr
->ts
.type
== BT_LOGICAL
4937 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
4938 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
4940 gfc_init_se (&argse
, NULL
);
4941 ss
= gfc_walk_expr (arg
->expr
);
4943 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
4945 /* Obtain the pointer to source and the length of source in bytes. */
4946 if (ss
== gfc_ss_terminator
)
4948 gfc_conv_expr_reference (&argse
, arg
->expr
);
4949 source
= argse
.expr
;
4951 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
4954 /* Obtain the source word length. */
4955 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
4956 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
4957 argse
.string_length
);
4959 tmp
= fold_convert (gfc_array_index_type
,
4960 size_in_bytes (source_type
));
4964 argse
.want_pointer
= 0;
4965 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
4966 source
= gfc_conv_descriptor_data_get (argse
.expr
);
4967 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
4969 /* Repack the source if not a full variable array. */
4970 if (arg
->expr
->expr_type
== EXPR_VARIABLE
4971 && arg
->expr
->ref
->u
.ar
.type
!= AR_FULL
)
4973 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
4975 if (gfc_option
.warn_array_temp
)
4976 gfc_warning ("Creating array temporary at %L", &expr
->where
);
4978 source
= build_call_expr_loc (input_location
,
4979 gfor_fndecl_in_pack
, 1, tmp
);
4980 source
= gfc_evaluate_now (source
, &argse
.pre
);
4982 /* Free the temporary. */
4983 gfc_start_block (&block
);
4984 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
4985 gfc_add_expr_to_block (&block
, tmp
);
4986 stmt
= gfc_finish_block (&block
);
4988 /* Clean up if it was repacked. */
4989 gfc_init_block (&block
);
4990 tmp
= gfc_conv_array_data (argse
.expr
);
4991 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4993 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
4994 build_empty_stmt (input_location
));
4995 gfc_add_expr_to_block (&block
, tmp
);
4996 gfc_add_block_to_block (&block
, &se
->post
);
4997 gfc_init_block (&se
->post
);
4998 gfc_add_block_to_block (&se
->post
, &block
);
5001 /* Obtain the source word length. */
5002 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5003 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5004 argse
.string_length
);
5006 tmp
= fold_convert (gfc_array_index_type
,
5007 size_in_bytes (source_type
));
5009 /* Obtain the size of the array in bytes. */
5010 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
5011 for (n
= 0; n
< arg
->expr
->rank
; n
++)
5014 idx
= gfc_rank_cst
[n
];
5015 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5016 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5017 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5018 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5019 gfc_array_index_type
, upper
, lower
);
5020 gfc_add_modify (&argse
.pre
, extent
, tmp
);
5021 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5022 gfc_array_index_type
, extent
,
5023 gfc_index_one_node
);
5024 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5025 gfc_array_index_type
, tmp
, source_bytes
);
5029 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5030 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5031 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5033 /* Now convert MOLD. The outputs are:
5034 mold_type = the TREE type of MOLD
5035 dest_word_len = destination word length in bytes. */
5038 gfc_init_se (&argse
, NULL
);
5039 ss
= gfc_walk_expr (arg
->expr
);
5041 scalar_mold
= arg
->expr
->rank
== 0;
5043 if (ss
== gfc_ss_terminator
)
5045 gfc_conv_expr_reference (&argse
, arg
->expr
);
5046 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5051 gfc_init_se (&argse
, NULL
);
5052 argse
.want_pointer
= 0;
5053 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
5054 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5057 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5058 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5060 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
5062 /* If this TRANSFER is nested in another TRANSFER, use a type
5063 that preserves all bits. */
5064 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
5065 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
5068 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5070 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
5071 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
5074 tmp
= fold_convert (gfc_array_index_type
,
5075 size_in_bytes (mold_type
));
5077 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
5078 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
5080 /* Finally convert SIZE, if it is present. */
5082 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
5086 gfc_init_se (&argse
, NULL
);
5087 gfc_conv_expr_reference (&argse
, arg
->expr
);
5088 tmp
= convert (gfc_array_index_type
,
5089 build_fold_indirect_ref_loc (input_location
,
5091 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5092 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5097 /* Separate array and scalar results. */
5098 if (scalar_mold
&& tmp
== NULL_TREE
)
5099 goto scalar_transfer
;
5101 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5102 if (tmp
!= NULL_TREE
)
5103 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5104 tmp
, dest_word_len
);
5108 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
5109 gfc_add_modify (&se
->pre
, size_words
,
5110 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
5111 gfc_array_index_type
,
5112 size_bytes
, dest_word_len
));
5114 /* Evaluate the bounds of the result. If the loop range exists, we have
5115 to check if it is too large. If so, we modify loop->to be consistent
5116 with min(size, size(source)). Otherwise, size is made consistent with
5117 the loop range, so that the right number of bytes is transferred.*/
5118 n
= se
->loop
->order
[0];
5119 if (se
->loop
->to
[n
] != NULL_TREE
)
5121 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5122 se
->loop
->to
[n
], se
->loop
->from
[n
]);
5123 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5124 tmp
, gfc_index_one_node
);
5125 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5127 gfc_add_modify (&se
->pre
, size_words
, tmp
);
5128 gfc_add_modify (&se
->pre
, size_bytes
,
5129 fold_build2_loc (input_location
, MULT_EXPR
,
5130 gfc_array_index_type
,
5131 size_words
, dest_word_len
));
5132 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5133 size_words
, se
->loop
->from
[n
]);
5134 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5135 upper
, gfc_index_one_node
);
5139 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5140 size_words
, gfc_index_one_node
);
5141 se
->loop
->from
[n
] = gfc_index_zero_node
;
5144 se
->loop
->to
[n
] = upper
;
5146 /* Build a destination descriptor, using the pointer, source, as the
5148 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
,
5149 info
, mold_type
, NULL_TREE
, false, true, false,
5152 /* Cast the pointer to the result. */
5153 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5154 tmp
= fold_convert (pvoid_type_node
, tmp
);
5156 /* Use memcpy to do the transfer. */
5157 tmp
= build_call_expr_loc (input_location
,
5158 built_in_decls
[BUILT_IN_MEMCPY
],
5161 fold_convert (pvoid_type_node
, source
),
5162 fold_build2_loc (input_location
, MIN_EXPR
,
5163 gfc_array_index_type
,
5164 size_bytes
, source_bytes
));
5165 gfc_add_expr_to_block (&se
->pre
, tmp
);
5167 se
->expr
= info
->descriptor
;
5168 if (expr
->ts
.type
== BT_CHARACTER
)
5169 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5173 /* Deal with scalar results. */
5175 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5176 dest_word_len
, source_bytes
);
5177 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5178 extent
, gfc_index_zero_node
);
5180 if (expr
->ts
.type
== BT_CHARACTER
)
5185 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5186 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5189 /* If source is longer than the destination, use a pointer to
5190 the source directly. */
5191 gfc_init_block (&block
);
5192 gfc_add_modify (&block
, tmpdecl
, ptr
);
5193 direct
= gfc_finish_block (&block
);
5195 /* Otherwise, allocate a string with the length of the destination
5196 and copy the source into it. */
5197 gfc_init_block (&block
);
5198 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5199 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5200 gfc_add_modify (&block
, tmpdecl
,
5201 fold_convert (TREE_TYPE (ptr
), tmp
));
5202 tmp
= build_call_expr_loc (input_location
,
5203 built_in_decls
[BUILT_IN_MEMCPY
], 3,
5204 fold_convert (pvoid_type_node
, tmpdecl
),
5205 fold_convert (pvoid_type_node
, ptr
),
5207 gfc_add_expr_to_block (&block
, tmp
);
5208 indirect
= gfc_finish_block (&block
);
5210 /* Wrap it up with the condition. */
5211 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5212 dest_word_len
, source_bytes
);
5213 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5214 gfc_add_expr_to_block (&se
->pre
, tmp
);
5217 se
->string_length
= dest_word_len
;
5221 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5223 ptr
= convert (build_pointer_type (mold_type
), source
);
5225 /* Use memcpy to do the transfer. */
5226 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5227 tmp
= build_call_expr_loc (input_location
,
5228 built_in_decls
[BUILT_IN_MEMCPY
], 3,
5229 fold_convert (pvoid_type_node
, tmp
),
5230 fold_convert (pvoid_type_node
, ptr
),
5232 gfc_add_expr_to_block (&se
->pre
, tmp
);
5239 /* Generate code for the ALLOCATED intrinsic.
5240 Generate inline code that directly check the address of the argument. */
5243 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5245 gfc_actual_arglist
*arg1
;
5250 gfc_init_se (&arg1se
, NULL
);
5251 arg1
= expr
->value
.function
.actual
;
5252 ss1
= gfc_walk_expr (arg1
->expr
);
5254 if (ss1
== gfc_ss_terminator
)
5256 /* Allocatable scalar. */
5257 arg1se
.want_pointer
= 1;
5258 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5259 gfc_add_data_component (arg1
->expr
);
5260 gfc_conv_expr (&arg1se
, arg1
->expr
);
5265 /* Allocatable array. */
5266 arg1se
.descriptor_only
= 1;
5267 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5268 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5271 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5272 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5273 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5277 /* Generate code for the ASSOCIATED intrinsic.
5278 If both POINTER and TARGET are arrays, generate a call to library function
5279 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5280 In other cases, generate inline code that directly compare the address of
5281 POINTER with the address of TARGET. */
5284 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
5286 gfc_actual_arglist
*arg1
;
5287 gfc_actual_arglist
*arg2
;
5292 tree nonzero_charlen
;
5293 tree nonzero_arraylen
;
5296 gfc_init_se (&arg1se
, NULL
);
5297 gfc_init_se (&arg2se
, NULL
);
5298 arg1
= expr
->value
.function
.actual
;
5299 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5300 gfc_add_data_component (arg1
->expr
);
5302 ss1
= gfc_walk_expr (arg1
->expr
);
5306 /* No optional target. */
5307 if (ss1
== gfc_ss_terminator
)
5309 /* A pointer to a scalar. */
5310 arg1se
.want_pointer
= 1;
5311 gfc_conv_expr (&arg1se
, arg1
->expr
);
5316 /* A pointer to an array. */
5317 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5318 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5320 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5321 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5322 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
5323 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
5328 /* An optional target. */
5329 if (arg2
->expr
->ts
.type
== BT_CLASS
)
5330 gfc_add_data_component (arg2
->expr
);
5331 ss2
= gfc_walk_expr (arg2
->expr
);
5333 nonzero_charlen
= NULL_TREE
;
5334 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
5335 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
5337 arg1
->expr
->ts
.u
.cl
->backend_decl
,
5340 if (ss1
== gfc_ss_terminator
)
5342 /* A pointer to a scalar. */
5343 gcc_assert (ss2
== gfc_ss_terminator
);
5344 arg1se
.want_pointer
= 1;
5345 gfc_conv_expr (&arg1se
, arg1
->expr
);
5346 arg2se
.want_pointer
= 1;
5347 gfc_conv_expr (&arg2se
, arg2
->expr
);
5348 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5349 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5350 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5351 arg1se
.expr
, arg2se
.expr
);
5352 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5353 arg1se
.expr
, null_pointer_node
);
5354 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5355 boolean_type_node
, tmp
, tmp2
);
5359 /* An array pointer of zero length is not associated if target is
5361 arg1se
.descriptor_only
= 1;
5362 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
5363 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
,
5364 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
5365 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
5366 boolean_type_node
, tmp
,
5367 build_int_cst (TREE_TYPE (tmp
), 0));
5369 /* A pointer to an array, call library function _gfor_associated. */
5370 gcc_assert (ss2
!= gfc_ss_terminator
);
5371 arg1se
.want_pointer
= 1;
5372 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5374 arg2se
.want_pointer
= 1;
5375 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
5376 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
5377 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
5378 se
->expr
= build_call_expr_loc (input_location
,
5379 gfor_fndecl_associated
, 2,
5380 arg1se
.expr
, arg2se
.expr
);
5381 se
->expr
= convert (boolean_type_node
, se
->expr
);
5382 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5383 boolean_type_node
, se
->expr
,
5387 /* If target is present zero character length pointers cannot
5389 if (nonzero_charlen
!= NULL_TREE
)
5390 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5392 se
->expr
, nonzero_charlen
);
5395 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5399 /* Generate code for the SAME_TYPE_AS intrinsic.
5400 Generate inline code that directly checks the vindices. */
5403 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
5409 gfc_init_se (&se1
, NULL
);
5410 gfc_init_se (&se2
, NULL
);
5412 a
= expr
->value
.function
.actual
->expr
;
5413 b
= expr
->value
.function
.actual
->next
->expr
;
5415 if (a
->ts
.type
== BT_CLASS
)
5417 gfc_add_vptr_component (a
);
5418 gfc_add_hash_component (a
);
5420 else if (a
->ts
.type
== BT_DERIVED
)
5421 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5422 a
->ts
.u
.derived
->hash_value
);
5424 if (b
->ts
.type
== BT_CLASS
)
5426 gfc_add_vptr_component (b
);
5427 gfc_add_hash_component (b
);
5429 else if (b
->ts
.type
== BT_DERIVED
)
5430 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5431 b
->ts
.u
.derived
->hash_value
);
5433 gfc_conv_expr (&se1
, a
);
5434 gfc_conv_expr (&se2
, b
);
5436 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5437 se1
.expr
, fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
5438 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5442 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
5445 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
5449 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5450 se
->expr
= build_call_expr_loc (input_location
,
5451 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
5452 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5456 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
5459 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
5463 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5465 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5466 type
= gfc_get_int_type (4);
5467 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
5469 /* Convert it to the required type. */
5470 type
= gfc_typenode_for_spec (&expr
->ts
);
5471 se
->expr
= build_call_expr_loc (input_location
,
5472 gfor_fndecl_si_kind
, 1, arg
);
5473 se
->expr
= fold_convert (type
, se
->expr
);
5477 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
5480 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
5482 gfc_actual_arglist
*actual
;
5485 VEC(tree
,gc
) *args
= NULL
;
5487 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
5489 gfc_init_se (&argse
, se
);
5491 /* Pass a NULL pointer for an absent arg. */
5492 if (actual
->expr
== NULL
)
5493 argse
.expr
= null_pointer_node
;
5499 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
5501 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
5502 ts
.type
= BT_INTEGER
;
5503 ts
.kind
= gfc_c_int_kind
;
5504 gfc_convert_type (actual
->expr
, &ts
, 2);
5506 gfc_conv_expr_reference (&argse
, actual
->expr
);
5509 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5510 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5511 VEC_safe_push (tree
, gc
, args
, argse
.expr
);
5514 /* Convert it to the required type. */
5515 type
= gfc_typenode_for_spec (&expr
->ts
);
5516 se
->expr
= build_call_expr_loc_vec (input_location
,
5517 gfor_fndecl_sr_kind
, args
);
5518 se
->expr
= fold_convert (type
, se
->expr
);
5522 /* Generate code for TRIM (A) intrinsic function. */
5525 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
5535 unsigned int num_args
;
5537 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
5538 args
= XALLOCAVEC (tree
, num_args
);
5540 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
5541 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
5542 len
= gfc_create_var (gfc_charlen_type_node
, "len");
5544 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
5545 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
5548 if (expr
->ts
.kind
== 1)
5549 function
= gfor_fndecl_string_trim
;
5550 else if (expr
->ts
.kind
== 4)
5551 function
= gfor_fndecl_string_trim_char4
;
5555 fndecl
= build_addr (function
, current_function_decl
);
5556 tmp
= build_call_array_loc (input_location
,
5557 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
5559 gfc_add_expr_to_block (&se
->pre
, tmp
);
5561 /* Free the temporary afterwards, if necessary. */
5562 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
5563 len
, build_int_cst (TREE_TYPE (len
), 0));
5564 tmp
= gfc_call_free (var
);
5565 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
5566 gfc_add_expr_to_block (&se
->post
, tmp
);
5569 se
->string_length
= len
;
5573 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
5576 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
5578 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
5579 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
5581 stmtblock_t block
, body
;
5584 /* We store in charsize the size of a character. */
5585 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
5586 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
5588 /* Get the arguments. */
5589 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
5590 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
5592 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
5593 ncopies_type
= TREE_TYPE (ncopies
);
5595 /* Check that NCOPIES is not negative. */
5596 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
5597 build_int_cst (ncopies_type
, 0));
5598 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
5599 "Argument NCOPIES of REPEAT intrinsic is negative "
5600 "(its value is %lld)",
5601 fold_convert (long_integer_type_node
, ncopies
));
5603 /* If the source length is zero, any non negative value of NCOPIES
5604 is valid, and nothing happens. */
5605 n
= gfc_create_var (ncopies_type
, "ncopies");
5606 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
5607 build_int_cst (size_type_node
, 0));
5608 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
5609 build_int_cst (ncopies_type
, 0), ncopies
);
5610 gfc_add_modify (&se
->pre
, n
, tmp
);
5613 /* Check that ncopies is not too large: ncopies should be less than
5614 (or equal to) MAX / slen, where MAX is the maximal integer of
5615 the gfc_charlen_type_node type. If slen == 0, we need a special
5616 case to avoid the division by zero. */
5617 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5618 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
5619 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
5620 fold_convert (size_type_node
, max
), slen
);
5621 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
5622 ? size_type_node
: ncopies_type
;
5623 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
5624 fold_convert (largest
, ncopies
),
5625 fold_convert (largest
, max
));
5626 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
5627 build_int_cst (size_type_node
, 0));
5628 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
5629 boolean_false_node
, cond
);
5630 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
5631 "Argument NCOPIES of REPEAT intrinsic is too large");
5633 /* Compute the destination length. */
5634 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
5635 fold_convert (gfc_charlen_type_node
, slen
),
5636 fold_convert (gfc_charlen_type_node
, ncopies
));
5637 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
5638 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
5640 /* Generate the code to do the repeat operation:
5641 for (i = 0; i < ncopies; i++)
5642 memmove (dest + (i * slen * size), src, slen*size); */
5643 gfc_start_block (&block
);
5644 count
= gfc_create_var (ncopies_type
, "count");
5645 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
5646 exit_label
= gfc_build_label_decl (NULL_TREE
);
5648 /* Start the loop body. */
5649 gfc_start_block (&body
);
5651 /* Exit the loop if count >= ncopies. */
5652 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
5654 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5655 TREE_USED (exit_label
) = 1;
5656 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5657 build_empty_stmt (input_location
));
5658 gfc_add_expr_to_block (&body
, tmp
);
5660 /* Call memmove (dest + (i*slen*size), src, slen*size). */
5661 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
5662 fold_convert (gfc_charlen_type_node
, slen
),
5663 fold_convert (gfc_charlen_type_node
, count
));
5664 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
5665 tmp
, fold_convert (gfc_charlen_type_node
, size
));
5666 tmp
= fold_build2_loc (input_location
, POINTER_PLUS_EXPR
, pvoid_type_node
,
5667 fold_convert (pvoid_type_node
, dest
),
5668 fold_convert (sizetype
, tmp
));
5669 tmp
= build_call_expr_loc (input_location
,
5670 built_in_decls
[BUILT_IN_MEMMOVE
], 3, tmp
, src
,
5671 fold_build2_loc (input_location
, MULT_EXPR
,
5672 size_type_node
, slen
,
5673 fold_convert (size_type_node
,
5675 gfc_add_expr_to_block (&body
, tmp
);
5677 /* Increment count. */
5678 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
5679 count
, build_int_cst (TREE_TYPE (count
), 1));
5680 gfc_add_modify (&body
, count
, tmp
);
5682 /* Build the loop. */
5683 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
5684 gfc_add_expr_to_block (&block
, tmp
);
5686 /* Add the exit label. */
5687 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5688 gfc_add_expr_to_block (&block
, tmp
);
5690 /* Finish the block. */
5691 tmp
= gfc_finish_block (&block
);
5692 gfc_add_expr_to_block (&se
->pre
, tmp
);
5694 /* Set the result value. */
5696 se
->string_length
= dlen
;
5700 /* Generate code for the IARGC intrinsic. */
5703 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
5709 /* Call the library function. This always returns an INTEGER(4). */
5710 fndecl
= gfor_fndecl_iargc
;
5711 tmp
= build_call_expr_loc (input_location
,
5714 /* Convert it to the required type. */
5715 type
= gfc_typenode_for_spec (&expr
->ts
);
5716 tmp
= fold_convert (type
, tmp
);
5722 /* The loc intrinsic returns the address of its argument as
5723 gfc_index_integer_kind integer. */
5726 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
5732 gcc_assert (!se
->ss
);
5734 arg_expr
= expr
->value
.function
.actual
->expr
;
5735 ss
= gfc_walk_expr (arg_expr
);
5736 if (ss
== gfc_ss_terminator
)
5737 gfc_conv_expr_reference (se
, arg_expr
);
5739 gfc_conv_array_parameter (se
, arg_expr
, ss
, true, NULL
, NULL
, NULL
);
5740 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
5742 /* Create a temporary variable for loc return value. Without this,
5743 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
5744 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
5745 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
5746 se
->expr
= temp_var
;
5749 /* Generate code for an intrinsic function. Some map directly to library
5750 calls, others get special handling. In some cases the name of the function
5751 used depends on the type specifiers. */
5754 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
5760 name
= &expr
->value
.function
.name
[2];
5764 lib
= gfc_is_intrinsic_libcall (expr
);
5768 se
->ignore_optional
= 1;
5770 switch (expr
->value
.function
.isym
->id
)
5772 case GFC_ISYM_EOSHIFT
:
5774 case GFC_ISYM_RESHAPE
:
5775 /* For all of those the first argument specifies the type and the
5776 third is optional. */
5777 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
5781 gfc_conv_intrinsic_funcall (se
, expr
);
5789 switch (expr
->value
.function
.isym
->id
)
5794 case GFC_ISYM_REPEAT
:
5795 gfc_conv_intrinsic_repeat (se
, expr
);
5799 gfc_conv_intrinsic_trim (se
, expr
);
5802 case GFC_ISYM_SC_KIND
:
5803 gfc_conv_intrinsic_sc_kind (se
, expr
);
5806 case GFC_ISYM_SI_KIND
:
5807 gfc_conv_intrinsic_si_kind (se
, expr
);
5810 case GFC_ISYM_SR_KIND
:
5811 gfc_conv_intrinsic_sr_kind (se
, expr
);
5814 case GFC_ISYM_EXPONENT
:
5815 gfc_conv_intrinsic_exponent (se
, expr
);
5819 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5821 fndecl
= gfor_fndecl_string_scan
;
5823 fndecl
= gfor_fndecl_string_scan_char4
;
5827 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
5830 case GFC_ISYM_VERIFY
:
5831 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
5833 fndecl
= gfor_fndecl_string_verify
;
5835 fndecl
= gfor_fndecl_string_verify_char4
;
5839 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
5842 case GFC_ISYM_ALLOCATED
:
5843 gfc_conv_allocated (se
, expr
);
5846 case GFC_ISYM_ASSOCIATED
:
5847 gfc_conv_associated(se
, expr
);
5850 case GFC_ISYM_SAME_TYPE_AS
:
5851 gfc_conv_same_type_as (se
, expr
);
5855 gfc_conv_intrinsic_abs (se
, expr
);
5858 case GFC_ISYM_ADJUSTL
:
5859 if (expr
->ts
.kind
== 1)
5860 fndecl
= gfor_fndecl_adjustl
;
5861 else if (expr
->ts
.kind
== 4)
5862 fndecl
= gfor_fndecl_adjustl_char4
;
5866 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
5869 case GFC_ISYM_ADJUSTR
:
5870 if (expr
->ts
.kind
== 1)
5871 fndecl
= gfor_fndecl_adjustr
;
5872 else if (expr
->ts
.kind
== 4)
5873 fndecl
= gfor_fndecl_adjustr_char4
;
5877 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
5880 case GFC_ISYM_AIMAG
:
5881 gfc_conv_intrinsic_imagpart (se
, expr
);
5885 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
5889 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
5892 case GFC_ISYM_ANINT
:
5893 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
5897 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
5901 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
5904 case GFC_ISYM_BTEST
:
5905 gfc_conv_intrinsic_btest (se
, expr
);
5909 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
5913 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
5917 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
5921 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
5924 case GFC_ISYM_ACHAR
:
5926 gfc_conv_intrinsic_char (se
, expr
);
5929 case GFC_ISYM_CONVERSION
:
5931 case GFC_ISYM_LOGICAL
:
5933 gfc_conv_intrinsic_conversion (se
, expr
);
5936 /* Integer conversions are handled separately to make sure we get the
5937 correct rounding mode. */
5942 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
5946 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
5949 case GFC_ISYM_CEILING
:
5950 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
5953 case GFC_ISYM_FLOOR
:
5954 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
5958 gfc_conv_intrinsic_mod (se
, expr
, 0);
5961 case GFC_ISYM_MODULO
:
5962 gfc_conv_intrinsic_mod (se
, expr
, 1);
5965 case GFC_ISYM_CMPLX
:
5966 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
5969 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
5970 gfc_conv_intrinsic_iargc (se
, expr
);
5973 case GFC_ISYM_COMPLEX
:
5974 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
5977 case GFC_ISYM_CONJG
:
5978 gfc_conv_intrinsic_conjg (se
, expr
);
5981 case GFC_ISYM_COUNT
:
5982 gfc_conv_intrinsic_count (se
, expr
);
5985 case GFC_ISYM_CTIME
:
5986 gfc_conv_intrinsic_ctime (se
, expr
);
5990 gfc_conv_intrinsic_dim (se
, expr
);
5993 case GFC_ISYM_DOT_PRODUCT
:
5994 gfc_conv_intrinsic_dot_product (se
, expr
);
5997 case GFC_ISYM_DPROD
:
5998 gfc_conv_intrinsic_dprod (se
, expr
);
6001 case GFC_ISYM_DSHIFTL
:
6002 gfc_conv_intrinsic_dshift (se
, expr
, true);
6005 case GFC_ISYM_DSHIFTR
:
6006 gfc_conv_intrinsic_dshift (se
, expr
, false);
6009 case GFC_ISYM_FDATE
:
6010 gfc_conv_intrinsic_fdate (se
, expr
);
6013 case GFC_ISYM_FRACTION
:
6014 gfc_conv_intrinsic_fraction (se
, expr
);
6018 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
6022 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6026 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
6029 case GFC_ISYM_IBCLR
:
6030 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
6033 case GFC_ISYM_IBITS
:
6034 gfc_conv_intrinsic_ibits (se
, expr
);
6037 case GFC_ISYM_IBSET
:
6038 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
6041 case GFC_ISYM_IACHAR
:
6042 case GFC_ISYM_ICHAR
:
6043 /* We assume ASCII character sequence. */
6044 gfc_conv_intrinsic_ichar (se
, expr
);
6047 case GFC_ISYM_IARGC
:
6048 gfc_conv_intrinsic_iargc (se
, expr
);
6052 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6055 case GFC_ISYM_INDEX
:
6056 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6058 fndecl
= gfor_fndecl_string_index
;
6060 fndecl
= gfor_fndecl_string_index_char4
;
6064 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6068 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6071 case GFC_ISYM_IPARITY
:
6072 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
6075 case GFC_ISYM_IS_IOSTAT_END
:
6076 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
6079 case GFC_ISYM_IS_IOSTAT_EOR
:
6080 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
6083 case GFC_ISYM_ISNAN
:
6084 gfc_conv_intrinsic_isnan (se
, expr
);
6087 case GFC_ISYM_LSHIFT
:
6088 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6091 case GFC_ISYM_RSHIFT
:
6092 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6095 case GFC_ISYM_SHIFTA
:
6096 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6099 case GFC_ISYM_SHIFTL
:
6100 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6103 case GFC_ISYM_SHIFTR
:
6104 gfc_conv_intrinsic_shift (se
, expr
, true, false);
6107 case GFC_ISYM_ISHFT
:
6108 gfc_conv_intrinsic_ishft (se
, expr
);
6111 case GFC_ISYM_ISHFTC
:
6112 gfc_conv_intrinsic_ishftc (se
, expr
);
6115 case GFC_ISYM_LEADZ
:
6116 gfc_conv_intrinsic_leadz (se
, expr
);
6119 case GFC_ISYM_TRAILZ
:
6120 gfc_conv_intrinsic_trailz (se
, expr
);
6123 case GFC_ISYM_POPCNT
:
6124 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
6127 case GFC_ISYM_POPPAR
:
6128 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
6131 case GFC_ISYM_LBOUND
:
6132 gfc_conv_intrinsic_bound (se
, expr
, 0);
6135 case GFC_ISYM_LCOBOUND
:
6136 conv_intrinsic_cobound (se
, expr
);
6139 case GFC_ISYM_TRANSPOSE
:
6140 /* The scalarizer has already been set up for reversed dimension access
6141 order ; now we just get the argument value normally. */
6142 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
6146 gfc_conv_intrinsic_len (se
, expr
);
6149 case GFC_ISYM_LEN_TRIM
:
6150 gfc_conv_intrinsic_len_trim (se
, expr
);
6154 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
6158 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
6162 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
6166 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
6169 case GFC_ISYM_MASKL
:
6170 gfc_conv_intrinsic_mask (se
, expr
, 1);
6173 case GFC_ISYM_MASKR
:
6174 gfc_conv_intrinsic_mask (se
, expr
, 0);
6178 if (expr
->ts
.type
== BT_CHARACTER
)
6179 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
6181 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
6184 case GFC_ISYM_MAXLOC
:
6185 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
6188 case GFC_ISYM_MAXVAL
:
6189 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
6192 case GFC_ISYM_MERGE
:
6193 gfc_conv_intrinsic_merge (se
, expr
);
6196 case GFC_ISYM_MERGE_BITS
:
6197 gfc_conv_intrinsic_merge_bits (se
, expr
);
6201 if (expr
->ts
.type
== BT_CHARACTER
)
6202 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
6204 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
6207 case GFC_ISYM_MINLOC
:
6208 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
6211 case GFC_ISYM_MINVAL
:
6212 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
6215 case GFC_ISYM_NEAREST
:
6216 gfc_conv_intrinsic_nearest (se
, expr
);
6219 case GFC_ISYM_NORM2
:
6220 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
6224 gfc_conv_intrinsic_not (se
, expr
);
6228 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6231 case GFC_ISYM_PARITY
:
6232 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
6235 case GFC_ISYM_PRESENT
:
6236 gfc_conv_intrinsic_present (se
, expr
);
6239 case GFC_ISYM_PRODUCT
:
6240 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
6243 case GFC_ISYM_RRSPACING
:
6244 gfc_conv_intrinsic_rrspacing (se
, expr
);
6247 case GFC_ISYM_SET_EXPONENT
:
6248 gfc_conv_intrinsic_set_exponent (se
, expr
);
6251 case GFC_ISYM_SCALE
:
6252 gfc_conv_intrinsic_scale (se
, expr
);
6256 gfc_conv_intrinsic_sign (se
, expr
);
6260 gfc_conv_intrinsic_size (se
, expr
);
6263 case GFC_ISYM_SIZEOF
:
6264 case GFC_ISYM_C_SIZEOF
:
6265 gfc_conv_intrinsic_sizeof (se
, expr
);
6268 case GFC_ISYM_STORAGE_SIZE
:
6269 gfc_conv_intrinsic_storage_size (se
, expr
);
6272 case GFC_ISYM_SPACING
:
6273 gfc_conv_intrinsic_spacing (se
, expr
);
6277 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
6280 case GFC_ISYM_TRANSFER
:
6281 if (se
->ss
&& se
->ss
->useflags
)
6282 /* Access the previously obtained result. */
6283 gfc_conv_tmp_array_ref (se
);
6285 gfc_conv_intrinsic_transfer (se
, expr
);
6288 case GFC_ISYM_TTYNAM
:
6289 gfc_conv_intrinsic_ttynam (se
, expr
);
6292 case GFC_ISYM_UBOUND
:
6293 gfc_conv_intrinsic_bound (se
, expr
, 1);
6296 case GFC_ISYM_UCOBOUND
:
6297 conv_intrinsic_cobound (se
, expr
);
6301 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6305 gfc_conv_intrinsic_loc (se
, expr
);
6308 case GFC_ISYM_THIS_IMAGE
:
6309 if (expr
->value
.function
.actual
->expr
)
6310 conv_intrinsic_cobound (se
, expr
);
6312 trans_this_image (se
, expr
);
6315 case GFC_ISYM_NUM_IMAGES
:
6316 trans_num_images (se
);
6319 case GFC_ISYM_ACCESS
:
6320 case GFC_ISYM_CHDIR
:
6321 case GFC_ISYM_CHMOD
:
6322 case GFC_ISYM_DTIME
:
6323 case GFC_ISYM_ETIME
:
6324 case GFC_ISYM_EXTENDS_TYPE_OF
:
6326 case GFC_ISYM_FGETC
:
6329 case GFC_ISYM_FPUTC
:
6330 case GFC_ISYM_FSTAT
:
6331 case GFC_ISYM_FTELL
:
6332 case GFC_ISYM_GETCWD
:
6333 case GFC_ISYM_GETGID
:
6334 case GFC_ISYM_GETPID
:
6335 case GFC_ISYM_GETUID
:
6336 case GFC_ISYM_HOSTNM
:
6338 case GFC_ISYM_IERRNO
:
6339 case GFC_ISYM_IRAND
:
6340 case GFC_ISYM_ISATTY
:
6343 case GFC_ISYM_LSTAT
:
6344 case GFC_ISYM_MALLOC
:
6345 case GFC_ISYM_MATMUL
:
6346 case GFC_ISYM_MCLOCK
:
6347 case GFC_ISYM_MCLOCK8
:
6349 case GFC_ISYM_RENAME
:
6350 case GFC_ISYM_SECOND
:
6351 case GFC_ISYM_SECNDS
:
6352 case GFC_ISYM_SIGNAL
:
6354 case GFC_ISYM_SYMLNK
:
6355 case GFC_ISYM_SYSTEM
:
6357 case GFC_ISYM_TIME8
:
6358 case GFC_ISYM_UMASK
:
6359 case GFC_ISYM_UNLINK
:
6361 gfc_conv_intrinsic_funcall (se
, expr
);
6364 case GFC_ISYM_EOSHIFT
:
6366 case GFC_ISYM_RESHAPE
:
6367 /* For those, expr->rank should always be >0 and thus the if above the
6368 switch should have matched. */
6373 gfc_conv_intrinsic_lib_function (se
, expr
);
6380 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
6382 gfc_ss
*arg_ss
, *tmp_ss
;
6383 gfc_actual_arglist
*arg
;
6385 arg
= expr
->value
.function
.actual
;
6387 gcc_assert (arg
->expr
);
6389 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
6390 gcc_assert (arg_ss
!= gfc_ss_terminator
);
6392 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
6394 if (tmp_ss
->type
!= GFC_SS_SCALAR
6395 && tmp_ss
->type
!= GFC_SS_REFERENCE
)
6400 info
= &tmp_ss
->data
.info
;
6401 gcc_assert (info
->dimen
== 2);
6403 /* We just invert dimensions. */
6404 tmp_dim
= info
->dim
[0];
6405 info
->dim
[0] = info
->dim
[1];
6406 info
->dim
[1] = tmp_dim
;
6409 /* Stop when tmp_ss points to the last valid element of the chain... */
6410 if (tmp_ss
->next
== gfc_ss_terminator
)
6414 /* ... so that we can attach the rest of the chain to it. */
6422 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
6425 switch (expr
->value
.function
.isym
->id
)
6427 case GFC_ISYM_TRANSPOSE
:
6428 return walk_inline_intrinsic_transpose (ss
, expr
);
6437 /* This generates code to execute before entering the scalarization loop.
6438 Currently does nothing. */
6441 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
6443 switch (ss
->expr
->value
.function
.isym
->id
)
6445 case GFC_ISYM_UBOUND
:
6446 case GFC_ISYM_LBOUND
:
6447 case GFC_ISYM_UCOBOUND
:
6448 case GFC_ISYM_LCOBOUND
:
6449 case GFC_ISYM_THIS_IMAGE
:
6458 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
6459 are expanded into code inside the scalarization loop. */
6462 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
6466 /* The two argument version returns a scalar. */
6467 if (expr
->value
.function
.actual
->next
->expr
)
6470 newss
= gfc_get_ss ();
6471 newss
->type
= GFC_SS_INTRINSIC
;
6474 newss
->data
.info
.dimen
= 1;
6480 /* Walk an intrinsic array libcall. */
6483 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
6488 gcc_assert (expr
->rank
> 0);
6490 newss
= gfc_get_ss ();
6491 newss
->type
= GFC_SS_FUNCTION
;
6494 newss
->data
.info
.dimen
= expr
->rank
;
6495 for (n
= 0; n
< newss
->data
.info
.dimen
; n
++)
6496 newss
->data
.info
.dim
[n
] = n
;
6502 /* Return whether the function call expression EXPR will be expanded
6503 inline by gfc_conv_intrinsic_function. */
6506 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
6508 if (!expr
->value
.function
.isym
)
6511 switch (expr
->value
.function
.isym
->id
)
6513 case GFC_ISYM_TRANSPOSE
:
6522 /* Returns nonzero if the specified intrinsic function call maps directly to
6523 an external library call. Should only be used for functions that return
6527 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
6529 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
6530 gcc_assert (expr
->rank
> 0);
6532 if (gfc_inline_intrinsic_function_p (expr
))
6535 switch (expr
->value
.function
.isym
->id
)
6539 case GFC_ISYM_COUNT
:
6543 case GFC_ISYM_IPARITY
:
6544 case GFC_ISYM_MATMUL
:
6545 case GFC_ISYM_MAXLOC
:
6546 case GFC_ISYM_MAXVAL
:
6547 case GFC_ISYM_MINLOC
:
6548 case GFC_ISYM_MINVAL
:
6549 case GFC_ISYM_NORM2
:
6550 case GFC_ISYM_PARITY
:
6551 case GFC_ISYM_PRODUCT
:
6553 case GFC_ISYM_SHAPE
:
6554 case GFC_ISYM_SPREAD
:
6556 /* Ignore absent optional parameters. */
6559 case GFC_ISYM_RESHAPE
:
6560 case GFC_ISYM_CSHIFT
:
6561 case GFC_ISYM_EOSHIFT
:
6563 case GFC_ISYM_UNPACK
:
6564 /* Pass absent optional parameters. */
6572 /* Walk an intrinsic function. */
6574 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
6575 gfc_intrinsic_sym
* isym
)
6579 if (isym
->elemental
)
6580 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
6583 if (expr
->rank
== 0)
6586 if (gfc_inline_intrinsic_function_p (expr
))
6587 return walk_inline_intrinsic_function (ss
, expr
);
6589 if (gfc_is_intrinsic_libcall (expr
))
6590 return gfc_walk_intrinsic_libfunc (ss
, expr
);
6592 /* Special cases. */
6595 case GFC_ISYM_LBOUND
:
6596 case GFC_ISYM_LCOBOUND
:
6597 case GFC_ISYM_UBOUND
:
6598 case GFC_ISYM_UCOBOUND
:
6599 case GFC_ISYM_THIS_IMAGE
:
6600 return gfc_walk_intrinsic_bound (ss
, expr
);
6602 case GFC_ISYM_TRANSFER
:
6603 return gfc_walk_intrinsic_libfunc (ss
, expr
);
6606 /* This probably meant someone forgot to add an intrinsic to the above
6607 list(s) when they implemented it, or something's gone horribly
6615 gfc_conv_intrinsic_move_alloc (gfc_code
*code
)
6617 if (code
->ext
.actual
->expr
->rank
== 0)
6619 /* Scalar arguments: Generate pointer assignments. */
6620 gfc_expr
*from
, *to
;
6624 from
= code
->ext
.actual
->expr
;
6625 to
= code
->ext
.actual
->next
->expr
;
6627 gfc_start_block (&block
);
6629 if (to
->ts
.type
== BT_CLASS
)
6630 tmp
= gfc_trans_class_assign (to
, from
, EXEC_POINTER_ASSIGN
);
6632 tmp
= gfc_trans_pointer_assignment (to
, from
);
6633 gfc_add_expr_to_block (&block
, tmp
);
6635 if (from
->ts
.type
== BT_CLASS
)
6636 tmp
= gfc_trans_class_assign (from
, gfc_get_null_expr (NULL
),
6637 EXEC_POINTER_ASSIGN
);
6639 tmp
= gfc_trans_pointer_assignment (from
,
6640 gfc_get_null_expr (NULL
));
6641 gfc_add_expr_to_block (&block
, tmp
);
6643 return gfc_finish_block (&block
);
6646 /* Array arguments: Generate library code. */
6647 return gfc_trans_call (code
, false, NULL_TREE
, NULL_TREE
, false);
6651 #include "gt-fortran-trans-intrinsic.h"