1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
28 #include "coretypes.h"
29 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "diagnostic-core.h" /* For internal_error. */
33 #include "toplev.h" /* For rest_of_decl_compilation. */
37 #include "intrinsic.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
46 /* This maps fortran intrinsic math functions to external library or GCC
48 typedef struct GTY(()) gfc_intrinsic_map_t
{
49 /* The explicit enum is required to work around inadequacies in the
50 garbage collection/gengtype parsing mechanism. */
53 /* Enum value from the "language-independent", aka C-centric, part
54 of gcc, or END_BUILTINS of no such value set. */
55 enum built_in_function float_built_in
;
56 enum built_in_function double_built_in
;
57 enum built_in_function long_double_built_in
;
58 enum built_in_function complex_float_built_in
;
59 enum built_in_function complex_double_built_in
;
60 enum built_in_function complex_long_double_built_in
;
62 /* True if the naming pattern is to prepend "c" for complex and
63 append "f" for kind=4. False if the naming pattern is to
64 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
67 /* True if a complex version of the function exists. */
68 bool complex_available
;
70 /* True if the function should be marked const. */
73 /* The base library name of this function. */
76 /* Cache decls created for the various operand types. */
88 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
89 defines complex variants of all of the entries in mathbuiltins.def
91 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
92 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
93 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
94 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
95 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
97 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
98 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
99 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
100 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
101 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
103 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
104 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
106 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
107 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
109 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
110 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
111 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
112 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
113 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
115 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map
[] =
117 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
118 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
119 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
120 #include "mathbuiltins.def"
122 /* Functions in libgfortran. */
123 LIB_FUNCTION (ERFC_SCALED
, "erfc_scaled", false),
126 LIB_FUNCTION (NONE
, NULL
, false)
131 #undef DEFINE_MATH_BUILTIN
132 #undef DEFINE_MATH_BUILTIN_C
135 enum rounding_mode
{ RND_ROUND
, RND_TRUNC
, RND_CEIL
, RND_FLOOR
};
138 /* Find the correct variant of a given builtin from its argument. */
140 builtin_decl_for_precision (enum built_in_function base_built_in
,
143 enum built_in_function i
= END_BUILTINS
;
145 gfc_intrinsic_map_t
*m
;
146 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= base_built_in
; m
++)
149 if (precision
== TYPE_PRECISION (float_type_node
))
150 i
= m
->float_built_in
;
151 else if (precision
== TYPE_PRECISION (double_type_node
))
152 i
= m
->double_built_in
;
153 else if (precision
== TYPE_PRECISION (long_double_type_node
))
154 i
= m
->long_double_built_in
;
155 else if (precision
== TYPE_PRECISION (float128_type_node
))
157 /* Special treatment, because it is not exactly a built-in, but
158 a library function. */
159 return m
->real16_decl
;
162 return (i
== END_BUILTINS
? NULL_TREE
: builtin_decl_explicit (i
));
167 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in
,
170 int i
= gfc_validate_kind (BT_REAL
, kind
, false);
172 if (gfc_real_kinds
[i
].c_float128
)
174 /* For __float128, the story is a bit different, because we return
175 a decl to a library function rather than a built-in. */
176 gfc_intrinsic_map_t
*m
;
177 for (m
= gfc_intrinsic_map
; m
->double_built_in
!= double_built_in
; m
++)
180 return m
->real16_decl
;
183 return builtin_decl_for_precision (double_built_in
,
184 gfc_real_kinds
[i
].mode_precision
);
188 /* Evaluate the arguments to an intrinsic function. The value
189 of NARGS may be less than the actual number of arguments in EXPR
190 to allow optional "KIND" arguments that are not included in the
191 generated code to be ignored. */
194 gfc_conv_intrinsic_function_args (gfc_se
*se
, gfc_expr
*expr
,
195 tree
*argarray
, int nargs
)
197 gfc_actual_arglist
*actual
;
199 gfc_intrinsic_arg
*formal
;
203 formal
= expr
->value
.function
.isym
->formal
;
204 actual
= expr
->value
.function
.actual
;
206 for (curr_arg
= 0; curr_arg
< nargs
; curr_arg
++,
207 actual
= actual
->next
,
208 formal
= formal
? formal
->next
: NULL
)
212 /* Skip omitted optional arguments. */
219 /* Evaluate the parameter. This will substitute scalarized
220 references automatically. */
221 gfc_init_se (&argse
, se
);
223 if (e
->ts
.type
== BT_CHARACTER
)
225 gfc_conv_expr (&argse
, e
);
226 gfc_conv_string_parameter (&argse
);
227 argarray
[curr_arg
++] = argse
.string_length
;
228 gcc_assert (curr_arg
< nargs
);
231 gfc_conv_expr_val (&argse
, e
);
233 /* If an optional argument is itself an optional dummy argument,
234 check its presence and substitute a null if absent. */
235 if (e
->expr_type
== EXPR_VARIABLE
236 && e
->symtree
->n
.sym
->attr
.optional
239 gfc_conv_missing_dummy (&argse
, e
, formal
->ts
, 0);
241 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
242 gfc_add_block_to_block (&se
->post
, &argse
.post
);
243 argarray
[curr_arg
] = argse
.expr
;
247 /* Count the number of actual arguments to the intrinsic function EXPR
248 including any "hidden" string length arguments. */
251 gfc_intrinsic_argument_list_length (gfc_expr
*expr
)
254 gfc_actual_arglist
*actual
;
256 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
261 if (actual
->expr
->ts
.type
== BT_CHARACTER
)
271 /* Conversions between different types are output by the frontend as
272 intrinsic functions. We implement these directly with inline code. */
275 gfc_conv_intrinsic_conversion (gfc_se
* se
, gfc_expr
* expr
)
281 nargs
= gfc_intrinsic_argument_list_length (expr
);
282 args
= XALLOCAVEC (tree
, nargs
);
284 /* Evaluate all the arguments passed. Whilst we're only interested in the
285 first one here, there are other parts of the front-end that assume this
286 and will trigger an ICE if it's not the case. */
287 type
= gfc_typenode_for_spec (&expr
->ts
);
288 gcc_assert (expr
->value
.function
.actual
->expr
);
289 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
291 /* Conversion between character kinds involves a call to a library
293 if (expr
->ts
.type
== BT_CHARACTER
)
295 tree fndecl
, var
, addr
, tmp
;
297 if (expr
->ts
.kind
== 1
298 && expr
->value
.function
.actual
->expr
->ts
.kind
== 4)
299 fndecl
= gfor_fndecl_convert_char4_to_char1
;
300 else if (expr
->ts
.kind
== 4
301 && expr
->value
.function
.actual
->expr
->ts
.kind
== 1)
302 fndecl
= gfor_fndecl_convert_char1_to_char4
;
306 /* Create the variable storing the converted value. */
307 type
= gfc_get_pchar_type (expr
->ts
.kind
);
308 var
= gfc_create_var (type
, "str");
309 addr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
311 /* Call the library function that will perform the conversion. */
312 gcc_assert (nargs
>= 2);
313 tmp
= build_call_expr_loc (input_location
,
314 fndecl
, 3, addr
, args
[0], args
[1]);
315 gfc_add_expr_to_block (&se
->pre
, tmp
);
317 /* Free the temporary afterwards. */
318 tmp
= gfc_call_free (var
);
319 gfc_add_expr_to_block (&se
->post
, tmp
);
322 se
->string_length
= args
[0];
327 /* Conversion from complex to non-complex involves taking the real
328 component of the value. */
329 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
330 && expr
->ts
.type
!= BT_COMPLEX
)
334 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
335 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
339 se
->expr
= convert (type
, args
[0]);
342 /* This is needed because the gcc backend only implements
343 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
344 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
345 Similarly for CEILING. */
348 build_fixbound_expr (stmtblock_t
* pblock
, tree arg
, tree type
, int up
)
355 argtype
= TREE_TYPE (arg
);
356 arg
= gfc_evaluate_now (arg
, pblock
);
358 intval
= convert (type
, arg
);
359 intval
= gfc_evaluate_now (intval
, pblock
);
361 tmp
= convert (argtype
, intval
);
362 cond
= fold_build2_loc (input_location
, up
? GE_EXPR
: LE_EXPR
,
363 boolean_type_node
, tmp
, arg
);
365 tmp
= fold_build2_loc (input_location
, up
? PLUS_EXPR
: MINUS_EXPR
, type
,
366 intval
, build_int_cst (type
, 1));
367 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, intval
, tmp
);
372 /* Round to nearest integer, away from zero. */
375 build_round_expr (tree arg
, tree restype
)
380 int argprec
, resprec
;
382 argtype
= TREE_TYPE (arg
);
383 argprec
= TYPE_PRECISION (argtype
);
384 resprec
= TYPE_PRECISION (restype
);
386 /* Depending on the type of the result, choose the long int intrinsic
387 (lround family) or long long intrinsic (llround). We might also
388 need to convert the result afterwards. */
389 if (resprec
<= LONG_TYPE_SIZE
)
391 else if (resprec
<= LONG_LONG_TYPE_SIZE
)
396 /* Now, depending on the argument type, we choose between intrinsics. */
398 fn
= builtin_decl_for_precision (BUILT_IN_LLROUND
, argprec
);
400 fn
= builtin_decl_for_precision (BUILT_IN_LROUND
, argprec
);
402 return fold_convert (restype
, build_call_expr_loc (input_location
,
407 /* Convert a real to an integer using a specific rounding mode.
408 Ideally we would just build the corresponding GENERIC node,
409 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
412 build_fix_expr (stmtblock_t
* pblock
, tree arg
, tree type
,
413 enum rounding_mode op
)
418 return build_fixbound_expr (pblock
, arg
, type
, 0);
422 return build_fixbound_expr (pblock
, arg
, type
, 1);
426 return build_round_expr (arg
, type
);
430 return fold_build1_loc (input_location
, FIX_TRUNC_EXPR
, type
, arg
);
439 /* Round a real value using the specified rounding mode.
440 We use a temporary integer of that same kind size as the result.
441 Values larger than those that can be represented by this kind are
442 unchanged, as they will not be accurate enough to represent the
444 huge = HUGE (KIND (a))
445 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
449 gfc_conv_intrinsic_aint (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
461 kind
= expr
->ts
.kind
;
462 nargs
= gfc_intrinsic_argument_list_length (expr
);
465 /* We have builtin functions for some cases. */
469 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND
, kind
);
473 decl
= gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC
, kind
);
480 /* Evaluate the argument. */
481 gcc_assert (expr
->value
.function
.actual
->expr
);
482 gfc_conv_intrinsic_function_args (se
, expr
, arg
, nargs
);
484 /* Use a builtin function if one exists. */
485 if (decl
!= NULL_TREE
)
487 se
->expr
= build_call_expr_loc (input_location
, decl
, 1, arg
[0]);
491 /* This code is probably redundant, but we'll keep it lying around just
493 type
= gfc_typenode_for_spec (&expr
->ts
);
494 arg
[0] = gfc_evaluate_now (arg
[0], &se
->pre
);
496 /* Test if the value is too large to handle sensibly. */
497 gfc_set_model_kind (kind
);
499 n
= gfc_validate_kind (BT_INTEGER
, kind
, false);
500 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
501 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
502 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, arg
[0],
505 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
506 tmp
= gfc_conv_mpfr_to_tree (huge
, kind
, 0);
507 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, arg
[0],
509 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
511 itype
= gfc_get_int_type (kind
);
513 tmp
= build_fix_expr (&se
->pre
, arg
[0], itype
, op
);
514 tmp
= convert (type
, tmp
);
515 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
521 /* Convert to an integer using the specified rounding mode. */
524 gfc_conv_intrinsic_int (gfc_se
* se
, gfc_expr
* expr
, enum rounding_mode op
)
530 nargs
= gfc_intrinsic_argument_list_length (expr
);
531 args
= XALLOCAVEC (tree
, nargs
);
533 /* Evaluate the argument, we process all arguments even though we only
534 use the first one for code generation purposes. */
535 type
= gfc_typenode_for_spec (&expr
->ts
);
536 gcc_assert (expr
->value
.function
.actual
->expr
);
537 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
539 if (TREE_CODE (TREE_TYPE (args
[0])) == INTEGER_TYPE
)
541 /* Conversion to a different integer kind. */
542 se
->expr
= convert (type
, args
[0]);
546 /* Conversion from complex to non-complex involves taking the real
547 component of the value. */
548 if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
549 && expr
->ts
.type
!= BT_COMPLEX
)
553 artype
= TREE_TYPE (TREE_TYPE (args
[0]));
554 args
[0] = fold_build1_loc (input_location
, REALPART_EXPR
, artype
,
558 se
->expr
= build_fix_expr (&se
->pre
, args
[0], type
, op
);
563 /* Get the imaginary component of a value. */
566 gfc_conv_intrinsic_imagpart (gfc_se
* se
, gfc_expr
* expr
)
570 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
571 se
->expr
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
572 TREE_TYPE (TREE_TYPE (arg
)), arg
);
576 /* Get the complex conjugate of a value. */
579 gfc_conv_intrinsic_conjg (gfc_se
* se
, gfc_expr
* expr
)
583 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
584 se
->expr
= fold_build1_loc (input_location
, CONJ_EXPR
, TREE_TYPE (arg
), arg
);
590 define_quad_builtin (const char *name
, tree type
, bool is_const
)
593 fndecl
= build_decl (input_location
, FUNCTION_DECL
, get_identifier (name
),
596 /* Mark the decl as external. */
597 DECL_EXTERNAL (fndecl
) = 1;
598 TREE_PUBLIC (fndecl
) = 1;
600 /* Mark it __attribute__((const)). */
601 TREE_READONLY (fndecl
) = is_const
;
603 rest_of_decl_compilation (fndecl
, 1, 0);
610 /* Initialize function decls for library functions. The external functions
611 are created as required. Builtin functions are added here. */
614 gfc_build_intrinsic_lib_fndecls (void)
616 gfc_intrinsic_map_t
*m
;
617 tree quad_decls
[END_BUILTINS
+ 1];
619 if (gfc_real16_is_float128
)
621 /* If we have soft-float types, we create the decls for their
622 C99-like library functions. For now, we only handle __float128
623 q-suffixed functions. */
625 tree type
, complex_type
, func_1
, func_2
, func_cabs
, func_frexp
;
626 tree func_lround
, func_llround
, func_scalbn
, func_cpow
;
628 memset (quad_decls
, 0, sizeof(tree
) * (END_BUILTINS
+ 1));
630 type
= float128_type_node
;
631 complex_type
= complex_float128_type_node
;
632 /* type (*) (type) */
633 func_1
= build_function_type_list (type
, type
, NULL_TREE
);
634 /* long (*) (type) */
635 func_lround
= build_function_type_list (long_integer_type_node
,
637 /* long long (*) (type) */
638 func_llround
= build_function_type_list (long_long_integer_type_node
,
640 /* type (*) (type, type) */
641 func_2
= build_function_type_list (type
, type
, type
, NULL_TREE
);
642 /* type (*) (type, &int) */
644 = build_function_type_list (type
,
646 build_pointer_type (integer_type_node
),
648 /* type (*) (type, int) */
649 func_scalbn
= build_function_type_list (type
,
650 type
, integer_type_node
, NULL_TREE
);
651 /* type (*) (complex type) */
652 func_cabs
= build_function_type_list (type
, complex_type
, NULL_TREE
);
653 /* complex type (*) (complex type, complex type) */
655 = build_function_type_list (complex_type
,
656 complex_type
, complex_type
, NULL_TREE
);
658 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
659 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
660 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
662 /* Only these built-ins are actually needed here. These are used directly
663 from the code, when calling builtin_decl_for_precision() or
664 builtin_decl_for_float_type(). The others are all constructed by
665 gfc_get_intrinsic_lib_fndecl(). */
666 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
667 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
669 #include "mathbuiltins.def"
673 #undef DEFINE_MATH_BUILTIN
674 #undef DEFINE_MATH_BUILTIN_C
678 /* Add GCC builtin functions. */
679 for (m
= gfc_intrinsic_map
;
680 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
682 if (m
->float_built_in
!= END_BUILTINS
)
683 m
->real4_decl
= builtin_decl_explicit (m
->float_built_in
);
684 if (m
->complex_float_built_in
!= END_BUILTINS
)
685 m
->complex4_decl
= builtin_decl_explicit (m
->complex_float_built_in
);
686 if (m
->double_built_in
!= END_BUILTINS
)
687 m
->real8_decl
= builtin_decl_explicit (m
->double_built_in
);
688 if (m
->complex_double_built_in
!= END_BUILTINS
)
689 m
->complex8_decl
= builtin_decl_explicit (m
->complex_double_built_in
);
691 /* If real(kind=10) exists, it is always long double. */
692 if (m
->long_double_built_in
!= END_BUILTINS
)
693 m
->real10_decl
= builtin_decl_explicit (m
->long_double_built_in
);
694 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
696 = builtin_decl_explicit (m
->complex_long_double_built_in
);
698 if (!gfc_real16_is_float128
)
700 if (m
->long_double_built_in
!= END_BUILTINS
)
701 m
->real16_decl
= builtin_decl_explicit (m
->long_double_built_in
);
702 if (m
->complex_long_double_built_in
!= END_BUILTINS
)
704 = builtin_decl_explicit (m
->complex_long_double_built_in
);
706 else if (quad_decls
[m
->double_built_in
] != NULL_TREE
)
708 /* Quad-precision function calls are constructed when first
709 needed by builtin_decl_for_precision(), except for those
710 that will be used directly (define by OTHER_BUILTIN). */
711 m
->real16_decl
= quad_decls
[m
->double_built_in
];
713 else if (quad_decls
[m
->complex_double_built_in
] != NULL_TREE
)
715 /* Same thing for the complex ones. */
716 m
->complex16_decl
= quad_decls
[m
->double_built_in
];
722 /* Create a fndecl for a simple intrinsic library function. */
725 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t
* m
, gfc_expr
* expr
)
728 VEC(tree
,gc
) *argtypes
;
730 gfc_actual_arglist
*actual
;
733 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
736 if (ts
->type
== BT_REAL
)
741 pdecl
= &m
->real4_decl
;
744 pdecl
= &m
->real8_decl
;
747 pdecl
= &m
->real10_decl
;
750 pdecl
= &m
->real16_decl
;
756 else if (ts
->type
== BT_COMPLEX
)
758 gcc_assert (m
->complex_available
);
763 pdecl
= &m
->complex4_decl
;
766 pdecl
= &m
->complex8_decl
;
769 pdecl
= &m
->complex10_decl
;
772 pdecl
= &m
->complex16_decl
;
786 int n
= gfc_validate_kind (BT_REAL
, ts
->kind
, false);
787 if (gfc_real_kinds
[n
].c_float
)
788 snprintf (name
, sizeof (name
), "%s%s%s",
789 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "f");
790 else if (gfc_real_kinds
[n
].c_double
)
791 snprintf (name
, sizeof (name
), "%s%s",
792 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
);
793 else if (gfc_real_kinds
[n
].c_long_double
)
794 snprintf (name
, sizeof (name
), "%s%s%s",
795 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "l");
796 else if (gfc_real_kinds
[n
].c_float128
)
797 snprintf (name
, sizeof (name
), "%s%s%s",
798 ts
->type
== BT_COMPLEX
? "c" : "", m
->name
, "q");
804 snprintf (name
, sizeof (name
), PREFIX ("%s_%c%d"), m
->name
,
805 ts
->type
== BT_COMPLEX
? 'c' : 'r',
810 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
812 type
= gfc_typenode_for_spec (&actual
->expr
->ts
);
813 VEC_safe_push (tree
, gc
, argtypes
, type
);
815 type
= build_function_type_vec (gfc_typenode_for_spec (ts
), argtypes
);
816 fndecl
= build_decl (input_location
,
817 FUNCTION_DECL
, get_identifier (name
), type
);
819 /* Mark the decl as external. */
820 DECL_EXTERNAL (fndecl
) = 1;
821 TREE_PUBLIC (fndecl
) = 1;
823 /* Mark it __attribute__((const)), if possible. */
824 TREE_READONLY (fndecl
) = m
->is_constant
;
826 rest_of_decl_compilation (fndecl
, 1, 0);
833 /* Convert an intrinsic function into an external or builtin call. */
836 gfc_conv_intrinsic_lib_function (gfc_se
* se
, gfc_expr
* expr
)
838 gfc_intrinsic_map_t
*m
;
842 unsigned int num_args
;
845 id
= expr
->value
.function
.isym
->id
;
846 /* Find the entry for this function. */
847 for (m
= gfc_intrinsic_map
;
848 m
->id
!= GFC_ISYM_NONE
|| m
->double_built_in
!= END_BUILTINS
; m
++)
854 if (m
->id
== GFC_ISYM_NONE
)
856 internal_error ("Intrinsic function %s(%d) not recognized",
857 expr
->value
.function
.name
, id
);
860 /* Get the decl and generate the call. */
861 num_args
= gfc_intrinsic_argument_list_length (expr
);
862 args
= XALLOCAVEC (tree
, num_args
);
864 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
865 fndecl
= gfc_get_intrinsic_lib_fndecl (m
, expr
);
866 rettype
= TREE_TYPE (TREE_TYPE (fndecl
));
868 fndecl
= build_addr (fndecl
, current_function_decl
);
869 se
->expr
= build_call_array_loc (input_location
, rettype
, fndecl
, num_args
, args
);
873 /* If bounds-checking is enabled, create code to verify at runtime that the
874 string lengths for both expressions are the same (needed for e.g. MERGE).
875 If bounds-checking is not enabled, does nothing. */
878 gfc_trans_same_strlen_check (const char* intr_name
, locus
* where
,
879 tree a
, tree b
, stmtblock_t
* target
)
884 /* If bounds-checking is disabled, do nothing. */
885 if (!(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
888 /* Compare the two string lengths. */
889 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, a
, b
);
891 /* Output the runtime-check. */
892 name
= gfc_build_cstring_const (intr_name
);
893 name
= gfc_build_addr_expr (pchar_type_node
, name
);
894 gfc_trans_runtime_check (true, false, cond
, target
, where
,
895 "Unequal character lengths (%ld/%ld) in %s",
896 fold_convert (long_integer_type_node
, a
),
897 fold_convert (long_integer_type_node
, b
), name
);
901 /* The EXPONENT(s) intrinsic function is translated into
908 gfc_conv_intrinsic_exponent (gfc_se
*se
, gfc_expr
*expr
)
910 tree arg
, type
, res
, tmp
, frexp
;
912 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
,
913 expr
->value
.function
.actual
->expr
->ts
.kind
);
915 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
917 res
= gfc_create_var (integer_type_node
, NULL
);
918 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
919 gfc_build_addr_expr (NULL_TREE
, res
));
920 gfc_add_expr_to_block (&se
->pre
, tmp
);
922 type
= gfc_typenode_for_spec (&expr
->ts
);
923 se
->expr
= fold_convert (type
, res
);
927 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
928 AR_FULL, suitable for the scalarizer. */
931 walk_coarray (gfc_expr
*e
)
935 gcc_assert (gfc_get_corank (e
) > 0);
937 ss
= gfc_walk_expr (e
);
939 /* Fix scalar coarray. */
940 if (ss
== gfc_ss_terminator
)
947 if (ref
->type
== REF_ARRAY
948 && ref
->u
.ar
.codimen
> 0)
954 gcc_assert (ref
!= NULL
);
955 if (ref
->u
.ar
.type
== AR_ELEMENT
)
956 ref
->u
.ar
.type
= AR_SECTION
;
957 ss
= gfc_reverse_ss (gfc_walk_array_ref (ss
, e
, ref
));
965 trans_this_image (gfc_se
* se
, gfc_expr
*expr
)
968 tree type
, desc
, dim_arg
, cond
, tmp
, m
, loop_var
, exit_label
, min_var
,
969 lbound
, ubound
, extent
, ml
;
974 /* The case -fcoarray=single is handled elsewhere. */
975 gcc_assert (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
);
977 gfc_init_coarray_decl (false);
979 /* Argument-free version: THIS_IMAGE(). */
980 if (expr
->value
.function
.actual
->expr
== NULL
)
982 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
983 gfort_gvar_caf_this_image
);
987 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
989 type
= gfc_get_int_type (gfc_default_integer_kind
);
990 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
991 rank
= expr
->value
.function
.actual
->expr
->rank
;
993 /* Obtain the descriptor of the COARRAY. */
994 gfc_init_se (&argse
, NULL
);
995 ss
= walk_coarray (expr
->value
.function
.actual
->expr
);
996 gcc_assert (ss
!= gfc_ss_terminator
);
997 argse
.want_coarray
= 1;
998 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
, ss
);
999 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1000 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1005 /* Create an implicit second parameter from the loop variable. */
1006 gcc_assert (!expr
->value
.function
.actual
->next
->expr
);
1007 gcc_assert (corank
> 0);
1008 gcc_assert (se
->loop
->dimen
== 1);
1009 gcc_assert (se
->ss
->info
->expr
== expr
);
1011 dim_arg
= se
->loop
->loopvar
[0];
1012 dim_arg
= fold_build2_loc (input_location
, PLUS_EXPR
,
1013 gfc_array_index_type
, dim_arg
,
1014 build_int_cst (TREE_TYPE (dim_arg
), 1));
1015 gfc_advance_se_ss_chain (se
);
1019 /* Use the passed DIM= argument. */
1020 gcc_assert (expr
->value
.function
.actual
->next
->expr
);
1021 gfc_init_se (&argse
, NULL
);
1022 gfc_conv_expr_type (&argse
, expr
->value
.function
.actual
->next
->expr
,
1023 gfc_array_index_type
);
1024 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1025 dim_arg
= argse
.expr
;
1027 if (INTEGER_CST_P (dim_arg
))
1031 hi
= TREE_INT_CST_HIGH (dim_arg
);
1032 co_dim
= TREE_INT_CST_LOW (dim_arg
);
1033 if (hi
|| co_dim
< 1
1034 || co_dim
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
1035 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1036 "dimension index", expr
->value
.function
.isym
->name
,
1039 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1041 dim_arg
= gfc_evaluate_now (dim_arg
, &se
->pre
);
1042 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1044 build_int_cst (TREE_TYPE (dim_arg
), 1));
1045 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1046 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1048 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1049 boolean_type_node
, cond
, tmp
);
1050 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1055 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1056 one always has a dim_arg argument.
1058 m = this_image() - 1
1061 sub(1) = m + lcobound(corank)
1065 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1068 extent = gfc_extent(i)
1076 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1077 : m + lcobound(corank)
1080 /* this_image () - 1. */
1081 tmp
= fold_convert (type
, gfort_gvar_caf_this_image
);
1082 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, tmp
,
1083 build_int_cst (type
, 1));
1086 /* sub(1) = m + lcobound(corank). */
1087 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1088 build_int_cst (TREE_TYPE (gfc_array_index_type
),
1090 lbound
= fold_convert (type
, lbound
);
1091 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1097 m
= gfc_create_var (type
, NULL
);
1098 ml
= gfc_create_var (type
, NULL
);
1099 loop_var
= gfc_create_var (integer_type_node
, NULL
);
1100 min_var
= gfc_create_var (integer_type_node
, NULL
);
1102 /* m = this_image () - 1. */
1103 gfc_add_modify (&se
->pre
, m
, tmp
);
1105 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1106 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1107 fold_convert (integer_type_node
, dim_arg
),
1108 build_int_cst (integer_type_node
, rank
- 1));
1109 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, integer_type_node
,
1110 build_int_cst (integer_type_node
, rank
+ corank
- 2),
1112 gfc_add_modify (&se
->pre
, min_var
, tmp
);
1115 tmp
= build_int_cst (integer_type_node
, rank
);
1116 gfc_add_modify (&se
->pre
, loop_var
, tmp
);
1118 exit_label
= gfc_build_label_decl (NULL_TREE
);
1119 TREE_USED (exit_label
) = 1;
1122 gfc_init_block (&loop
);
1125 gfc_add_modify (&loop
, ml
, m
);
1128 lbound
= gfc_conv_descriptor_lbound_get (desc
, loop_var
);
1129 ubound
= gfc_conv_descriptor_ubound_get (desc
, loop_var
);
1130 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1131 extent
= fold_convert (type
, extent
);
1134 gfc_add_modify (&loop
, m
,
1135 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, type
,
1138 /* Exit condition: if (i >= min_var) goto exit_label. */
1139 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, loop_var
,
1141 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1142 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1143 build_empty_stmt (input_location
));
1144 gfc_add_expr_to_block (&loop
, tmp
);
1146 /* Increment loop variable: i++. */
1147 gfc_add_modify (&loop
, loop_var
,
1148 fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1150 build_int_cst (integer_type_node
, 1)));
1152 /* Making the loop... actually loop! */
1153 tmp
= gfc_finish_block (&loop
);
1154 tmp
= build1_v (LOOP_EXPR
, tmp
);
1155 gfc_add_expr_to_block (&se
->pre
, tmp
);
1157 /* The exit label. */
1158 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1159 gfc_add_expr_to_block (&se
->pre
, tmp
);
1161 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1162 : m + lcobound(corank) */
1164 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, dim_arg
,
1165 build_int_cst (TREE_TYPE (dim_arg
), corank
));
1167 lbound
= gfc_conv_descriptor_lbound_get (desc
,
1168 fold_build2_loc (input_location
, PLUS_EXPR
,
1169 gfc_array_index_type
, dim_arg
,
1170 build_int_cst (TREE_TYPE (dim_arg
), rank
-1)));
1171 lbound
= fold_convert (type
, lbound
);
1173 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, ml
,
1174 fold_build2_loc (input_location
, MULT_EXPR
, type
,
1176 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, tmp
, lbound
);
1178 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
, tmp
,
1179 fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1185 trans_image_index (gfc_se
* se
, gfc_expr
*expr
)
1187 tree num_images
, cond
, coindex
, type
, lbound
, ubound
, desc
, subdesc
,
1189 gfc_se argse
, subse
;
1191 int rank
, corank
, codim
;
1193 type
= gfc_get_int_type (gfc_default_integer_kind
);
1194 corank
= gfc_get_corank (expr
->value
.function
.actual
->expr
);
1195 rank
= expr
->value
.function
.actual
->expr
->rank
;
1197 /* Obtain the descriptor of the COARRAY. */
1198 gfc_init_se (&argse
, NULL
);
1199 ss
= walk_coarray (expr
->value
.function
.actual
->expr
);
1200 gcc_assert (ss
!= gfc_ss_terminator
);
1201 argse
.want_coarray
= 1;
1202 gfc_conv_expr_descriptor (&argse
, expr
->value
.function
.actual
->expr
, ss
);
1203 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1204 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1207 /* Obtain a handle to the SUB argument. */
1208 gfc_init_se (&subse
, NULL
);
1209 subss
= gfc_walk_expr (expr
->value
.function
.actual
->next
->expr
);
1210 gcc_assert (subss
!= gfc_ss_terminator
);
1211 gfc_conv_expr_descriptor (&subse
, expr
->value
.function
.actual
->next
->expr
,
1213 gfc_add_block_to_block (&se
->pre
, &subse
.pre
);
1214 gfc_add_block_to_block (&se
->post
, &subse
.post
);
1215 subdesc
= build_fold_indirect_ref_loc (input_location
,
1216 gfc_conv_descriptor_data_get (subse
.expr
));
1218 /* Fortran 2008 does not require that the values remain in the cobounds,
1219 thus we need explicitly check this - and return 0 if they are exceeded. */
1221 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1222 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1], NULL
);
1223 invalid_bound
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1224 fold_convert (gfc_array_index_type
, tmp
),
1227 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1229 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1230 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1231 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1232 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1233 fold_convert (gfc_array_index_type
, tmp
),
1235 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1236 boolean_type_node
, invalid_bound
, cond
);
1237 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1238 fold_convert (gfc_array_index_type
, tmp
),
1240 invalid_bound
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1241 boolean_type_node
, invalid_bound
, cond
);
1244 invalid_bound
= gfc_unlikely (invalid_bound
);
1247 /* See Fortran 2008, C.10 for the following algorithm. */
1249 /* coindex = sub(corank) - lcobound(n). */
1250 coindex
= fold_convert (gfc_array_index_type
,
1251 gfc_build_array_ref (subdesc
, gfc_rank_cst
[corank
-1],
1253 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[rank
+corank
-1]);
1254 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1255 fold_convert (gfc_array_index_type
, coindex
),
1258 for (codim
= corank
+ rank
- 2; codim
>= rank
; codim
--)
1260 tree extent
, ubound
;
1262 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1263 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1264 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[codim
]);
1265 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1267 /* coindex *= extent. */
1268 coindex
= fold_build2_loc (input_location
, MULT_EXPR
,
1269 gfc_array_index_type
, coindex
, extent
);
1271 /* coindex += sub(codim). */
1272 tmp
= gfc_build_array_ref (subdesc
, gfc_rank_cst
[codim
-rank
], NULL
);
1273 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
,
1274 gfc_array_index_type
, coindex
,
1275 fold_convert (gfc_array_index_type
, tmp
));
1277 /* coindex -= lbound(codim). */
1278 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[codim
]);
1279 coindex
= fold_build2_loc (input_location
, MINUS_EXPR
,
1280 gfc_array_index_type
, coindex
, lbound
);
1283 coindex
= fold_build2_loc (input_location
, PLUS_EXPR
, type
,
1284 fold_convert(type
, coindex
),
1285 build_int_cst (type
, 1));
1287 /* Return 0 if "coindex" exceeds num_images(). */
1289 if (gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
1290 num_images
= build_int_cst (type
, 1);
1293 gfc_init_coarray_decl (false);
1294 num_images
= fold_convert (type
, gfort_gvar_caf_num_images
);
1297 tmp
= gfc_create_var (type
, NULL
);
1298 gfc_add_modify (&se
->pre
, tmp
, coindex
);
1300 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1302 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
1304 fold_convert (boolean_type_node
, invalid_bound
));
1305 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1306 build_int_cst (type
, 0), tmp
);
1311 trans_num_images (gfc_se
* se
)
1313 gfc_init_coarray_decl (false);
1314 se
->expr
= fold_convert (gfc_get_int_type (gfc_default_integer_kind
),
1315 gfort_gvar_caf_num_images
);
1319 /* Evaluate a single upper or lower bound. */
1320 /* TODO: bound intrinsic generates way too much unnecessary code. */
1323 gfc_conv_intrinsic_bound (gfc_se
* se
, gfc_expr
* expr
, int upper
)
1325 gfc_actual_arglist
*arg
;
1326 gfc_actual_arglist
*arg2
;
1331 tree cond
, cond1
, cond3
, cond4
, size
;
1336 gfc_array_spec
* as
;
1338 arg
= expr
->value
.function
.actual
;
1343 /* Create an implicit second parameter from the loop variable. */
1344 gcc_assert (!arg2
->expr
);
1345 gcc_assert (se
->loop
->dimen
== 1);
1346 gcc_assert (se
->ss
->info
->expr
== expr
);
1347 gfc_advance_se_ss_chain (se
);
1348 bound
= se
->loop
->loopvar
[0];
1349 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1350 gfc_array_index_type
, bound
,
1355 /* use the passed argument. */
1356 gcc_assert (arg2
->expr
);
1357 gfc_init_se (&argse
, NULL
);
1358 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1359 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1361 /* Convert from one based to zero based. */
1362 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1363 gfc_array_index_type
, bound
,
1364 gfc_index_one_node
);
1367 /* TODO: don't re-evaluate the descriptor on each iteration. */
1368 /* Get a descriptor for the first parameter. */
1369 ss
= gfc_walk_expr (arg
->expr
);
1370 gcc_assert (ss
!= gfc_ss_terminator
);
1371 gfc_init_se (&argse
, NULL
);
1372 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
1373 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1374 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1378 if (INTEGER_CST_P (bound
))
1382 hi
= TREE_INT_CST_HIGH (bound
);
1383 low
= TREE_INT_CST_LOW (bound
);
1384 if (hi
|| low
< 0 || low
>= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
)))
1385 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1386 "dimension index", upper
? "UBOUND" : "LBOUND",
1391 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1393 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1394 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1395 bound
, build_int_cst (TREE_TYPE (bound
), 0));
1396 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc
))];
1397 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1399 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1400 boolean_type_node
, cond
, tmp
);
1401 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1406 ubound
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1407 lbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1409 as
= gfc_get_full_arrayspec_from_expr (arg
->expr
);
1411 /* 13.14.53: Result value for LBOUND
1413 Case (i): For an array section or for an array expression other than a
1414 whole array or array structure component, LBOUND(ARRAY, DIM)
1415 has the value 1. For a whole array or array structure
1416 component, LBOUND(ARRAY, DIM) has the value:
1417 (a) equal to the lower bound for subscript DIM of ARRAY if
1418 dimension DIM of ARRAY does not have extent zero
1419 or if ARRAY is an assumed-size array of rank DIM,
1422 13.14.113: Result value for UBOUND
1424 Case (i): For an array section or for an array expression other than a
1425 whole array or array structure component, UBOUND(ARRAY, DIM)
1426 has the value equal to the number of elements in the given
1427 dimension; otherwise, it has a value equal to the upper bound
1428 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1429 not have size zero and has value zero if dimension DIM has
1434 tree stride
= gfc_conv_descriptor_stride_get (desc
, bound
);
1436 cond1
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1438 cond3
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
1439 stride
, gfc_index_zero_node
);
1440 cond3
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1441 boolean_type_node
, cond3
, cond1
);
1442 cond4
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1443 stride
, gfc_index_zero_node
);
1448 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1449 boolean_type_node
, cond3
, cond4
);
1450 cond5
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1451 gfc_index_one_node
, lbound
);
1452 cond5
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1453 boolean_type_node
, cond4
, cond5
);
1455 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1456 boolean_type_node
, cond
, cond5
);
1458 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1459 gfc_array_index_type
, cond
,
1460 ubound
, gfc_index_zero_node
);
1464 if (as
->type
== AS_ASSUMED_SIZE
)
1465 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1466 bound
, build_int_cst (TREE_TYPE (bound
),
1467 arg
->expr
->rank
- 1));
1469 cond
= boolean_false_node
;
1471 cond1
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1472 boolean_type_node
, cond3
, cond4
);
1473 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1474 boolean_type_node
, cond
, cond1
);
1476 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1477 gfc_array_index_type
, cond
,
1478 lbound
, gfc_index_one_node
);
1485 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
1486 gfc_array_index_type
, ubound
, lbound
);
1487 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
1488 gfc_array_index_type
, size
,
1489 gfc_index_one_node
);
1490 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
1491 gfc_array_index_type
, se
->expr
,
1492 gfc_index_zero_node
);
1495 se
->expr
= gfc_index_one_node
;
1498 type
= gfc_typenode_for_spec (&expr
->ts
);
1499 se
->expr
= convert (type
, se
->expr
);
1504 conv_intrinsic_cobound (gfc_se
* se
, gfc_expr
* expr
)
1506 gfc_actual_arglist
*arg
;
1507 gfc_actual_arglist
*arg2
;
1510 tree bound
, resbound
, resbound2
, desc
, cond
, tmp
;
1514 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
1515 || expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
1516 || expr
->value
.function
.isym
->id
== GFC_ISYM_THIS_IMAGE
);
1518 arg
= expr
->value
.function
.actual
;
1521 gcc_assert (arg
->expr
->expr_type
== EXPR_VARIABLE
);
1522 corank
= gfc_get_corank (arg
->expr
);
1524 ss
= walk_coarray (arg
->expr
);
1525 gcc_assert (ss
!= gfc_ss_terminator
);
1526 gfc_init_se (&argse
, NULL
);
1527 argse
.want_coarray
= 1;
1529 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
1530 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1531 gfc_add_block_to_block (&se
->post
, &argse
.post
);
1536 /* Create an implicit second parameter from the loop variable. */
1537 gcc_assert (!arg2
->expr
);
1538 gcc_assert (corank
> 0);
1539 gcc_assert (se
->loop
->dimen
== 1);
1540 gcc_assert (se
->ss
->info
->expr
== expr
);
1542 bound
= se
->loop
->loopvar
[0];
1543 bound
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1544 bound
, gfc_rank_cst
[arg
->expr
->rank
]);
1545 gfc_advance_se_ss_chain (se
);
1549 /* use the passed argument. */
1550 gcc_assert (arg2
->expr
);
1551 gfc_init_se (&argse
, NULL
);
1552 gfc_conv_expr_type (&argse
, arg2
->expr
, gfc_array_index_type
);
1553 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
1556 if (INTEGER_CST_P (bound
))
1560 hi
= TREE_INT_CST_HIGH (bound
);
1561 low
= TREE_INT_CST_LOW (bound
);
1562 if (hi
|| low
< 1 || low
> GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
)))
1563 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1564 "dimension index", expr
->value
.function
.isym
->name
,
1567 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1569 bound
= gfc_evaluate_now (bound
, &se
->pre
);
1570 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1571 bound
, build_int_cst (TREE_TYPE (bound
), 1));
1572 tmp
= gfc_rank_cst
[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc
))];
1573 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1575 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
1576 boolean_type_node
, cond
, tmp
);
1577 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
1582 /* Substract 1 to get to zero based and add dimensions. */
1583 switch (arg
->expr
->rank
)
1586 bound
= fold_build2_loc (input_location
, MINUS_EXPR
,
1587 gfc_array_index_type
, bound
,
1588 gfc_index_one_node
);
1592 bound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1593 gfc_array_index_type
, bound
,
1594 gfc_rank_cst
[arg
->expr
->rank
- 1]);
1598 resbound
= gfc_conv_descriptor_lbound_get (desc
, bound
);
1600 /* Handle UCOBOUND with special handling of the last codimension. */
1601 if (expr
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
)
1603 /* Last codimension: For -fcoarray=single just return
1604 the lcobound - otherwise add
1605 ceiling (real (num_images ()) / real (size)) - 1
1606 = (num_images () + size - 1) / size - 1
1607 = (num_images - 1) / size(),
1608 where size is the product of the extent of all but the last
1611 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& corank
> 1)
1615 gfc_init_coarray_decl (false);
1616 cosize
= gfc_conv_descriptor_cosize (desc
, arg
->expr
->rank
, corank
);
1618 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1619 gfc_array_index_type
,
1620 fold_convert (gfc_array_index_type
,
1621 gfort_gvar_caf_num_images
),
1622 build_int_cst (gfc_array_index_type
, 1));
1623 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1624 gfc_array_index_type
, tmp
,
1625 fold_convert (gfc_array_index_type
, cosize
));
1626 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1627 gfc_array_index_type
, resbound
, tmp
);
1629 else if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
1631 /* ubound = lbound + num_images() - 1. */
1632 gfc_init_coarray_decl (false);
1633 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1634 gfc_array_index_type
,
1635 fold_convert (gfc_array_index_type
,
1636 gfort_gvar_caf_num_images
),
1637 build_int_cst (gfc_array_index_type
, 1));
1638 resbound
= fold_build2_loc (input_location
, PLUS_EXPR
,
1639 gfc_array_index_type
, resbound
, tmp
);
1644 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1646 build_int_cst (TREE_TYPE (bound
),
1647 arg
->expr
->rank
+ corank
- 1));
1649 resbound2
= gfc_conv_descriptor_ubound_get (desc
, bound
);
1650 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1651 gfc_array_index_type
, cond
,
1652 resbound
, resbound2
);
1655 se
->expr
= resbound
;
1658 se
->expr
= resbound
;
1660 type
= gfc_typenode_for_spec (&expr
->ts
);
1661 se
->expr
= convert (type
, se
->expr
);
1666 gfc_conv_intrinsic_abs (gfc_se
* se
, gfc_expr
* expr
)
1670 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
1672 switch (expr
->value
.function
.actual
->expr
->ts
.type
)
1676 se
->expr
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (arg
),
1681 cabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_CABS
, expr
->ts
.kind
);
1682 se
->expr
= build_call_expr_loc (input_location
, cabs
, 1, arg
);
1691 /* Create a complex value from one or two real components. */
1694 gfc_conv_intrinsic_cmplx (gfc_se
* se
, gfc_expr
* expr
, int both
)
1700 unsigned int num_args
;
1702 num_args
= gfc_intrinsic_argument_list_length (expr
);
1703 args
= XALLOCAVEC (tree
, num_args
);
1705 type
= gfc_typenode_for_spec (&expr
->ts
);
1706 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
1707 real
= convert (TREE_TYPE (type
), args
[0]);
1709 imag
= convert (TREE_TYPE (type
), args
[1]);
1710 else if (TREE_CODE (TREE_TYPE (args
[0])) == COMPLEX_TYPE
)
1712 imag
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
1713 TREE_TYPE (TREE_TYPE (args
[0])), args
[0]);
1714 imag
= convert (TREE_TYPE (type
), imag
);
1717 imag
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
1719 se
->expr
= fold_build2_loc (input_location
, COMPLEX_EXPR
, type
, real
, imag
);
1722 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1723 MODULO(A, P) = A - FLOOR (A / P) * P */
1724 /* TODO: MOD(x, 0) */
1727 gfc_conv_intrinsic_mod (gfc_se
* se
, gfc_expr
* expr
, int modulo
)
1739 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1741 switch (expr
->ts
.type
)
1744 /* Integer case is easy, we've got a builtin op. */
1745 type
= TREE_TYPE (args
[0]);
1748 se
->expr
= fold_build2_loc (input_location
, FLOOR_MOD_EXPR
, type
,
1751 se
->expr
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
, type
,
1757 /* Check if we have a builtin fmod. */
1758 fmod
= gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD
, expr
->ts
.kind
);
1760 /* Use it if it exists. */
1761 if (fmod
!= NULL_TREE
)
1763 tmp
= build_addr (fmod
, current_function_decl
);
1764 se
->expr
= build_call_array_loc (input_location
,
1765 TREE_TYPE (TREE_TYPE (fmod
)),
1771 type
= TREE_TYPE (args
[0]);
1773 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1774 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
1777 modulo = arg - floor (arg/arg2) * arg2, so
1778 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1780 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1781 thereby avoiding another division and retaining the accuracy
1782 of the builtin function. */
1783 if (fmod
!= NULL_TREE
&& modulo
)
1785 tree zero
= gfc_build_const (type
, integer_zero_node
);
1786 tmp
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1787 test
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1789 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1791 test2
= fold_build2_loc (input_location
, TRUTH_XOR_EXPR
,
1792 boolean_type_node
, test
, test2
);
1793 test
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1795 test
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1796 boolean_type_node
, test
, test2
);
1797 test
= gfc_evaluate_now (test
, &se
->pre
);
1798 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, test
,
1799 fold_build2_loc (input_location
, PLUS_EXPR
,
1800 type
, tmp
, args
[1]), tmp
);
1804 /* If we do not have a built_in fmod, the calculation is going to
1805 have to be done longhand. */
1806 tmp
= fold_build2_loc (input_location
, RDIV_EXPR
, type
, args
[0], args
[1]);
1808 /* Test if the value is too large to handle sensibly. */
1809 gfc_set_model_kind (expr
->ts
.kind
);
1811 n
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, true);
1812 ikind
= expr
->ts
.kind
;
1815 n
= gfc_validate_kind (BT_INTEGER
, gfc_max_integer_kind
, false);
1816 ikind
= gfc_max_integer_kind
;
1818 mpfr_set_z (huge
, gfc_integer_kinds
[n
].huge
, GFC_RND_MODE
);
1819 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1820 test2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1823 mpfr_neg (huge
, huge
, GFC_RND_MODE
);
1824 test
= gfc_conv_mpfr_to_tree (huge
, expr
->ts
.kind
, 0);
1825 test
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp
,
1827 test2
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
1828 boolean_type_node
, test
, test2
);
1830 itype
= gfc_get_int_type (ikind
);
1832 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_FLOOR
);
1834 tmp
= build_fix_expr (&se
->pre
, tmp
, itype
, RND_TRUNC
);
1835 tmp
= convert (type
, tmp
);
1836 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, test2
, tmp
,
1838 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, tmp
, args
[1]);
1839 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0],
1849 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1850 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1851 where the right shifts are logical (i.e. 0's are shifted in).
1852 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1853 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1855 DSHIFTL(I,J,BITSIZE) = J
1857 DSHIFTR(I,J,BITSIZE) = I. */
1860 gfc_conv_intrinsic_dshift (gfc_se
* se
, gfc_expr
* expr
, bool dshiftl
)
1862 tree type
, utype
, stype
, arg1
, arg2
, shift
, res
, left
, right
;
1863 tree args
[3], cond
, tmp
;
1866 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
1868 gcc_assert (TREE_TYPE (args
[0]) == TREE_TYPE (args
[1]));
1869 type
= TREE_TYPE (args
[0]);
1870 bitsize
= TYPE_PRECISION (type
);
1871 utype
= unsigned_type_for (type
);
1872 stype
= TREE_TYPE (args
[2]);
1874 arg1
= gfc_evaluate_now (args
[0], &se
->pre
);
1875 arg2
= gfc_evaluate_now (args
[1], &se
->pre
);
1876 shift
= gfc_evaluate_now (args
[2], &se
->pre
);
1878 /* The generic case. */
1879 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, stype
,
1880 build_int_cst (stype
, bitsize
), shift
);
1881 left
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
1882 arg1
, dshiftl
? shift
: tmp
);
1884 right
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
,
1885 fold_convert (utype
, arg2
), dshiftl
? tmp
: shift
);
1886 right
= fold_convert (type
, right
);
1888 res
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
, left
, right
);
1890 /* Special cases. */
1891 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1892 build_int_cst (stype
, 0));
1893 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1894 dshiftl
? arg1
: arg2
, res
);
1896 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, shift
,
1897 build_int_cst (stype
, bitsize
));
1898 res
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
1899 dshiftl
? arg2
: arg1
, res
);
1905 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1908 gfc_conv_intrinsic_dim (gfc_se
* se
, gfc_expr
* expr
)
1916 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1917 type
= TREE_TYPE (args
[0]);
1919 val
= fold_build2_loc (input_location
, MINUS_EXPR
, type
, args
[0], args
[1]);
1920 val
= gfc_evaluate_now (val
, &se
->pre
);
1922 zero
= gfc_build_const (type
, integer_zero_node
);
1923 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, val
, zero
);
1924 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, zero
, val
);
1928 /* SIGN(A, B) is absolute value of A times sign of B.
1929 The real value versions use library functions to ensure the correct
1930 handling of negative zero. Integer case implemented as:
1931 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1935 gfc_conv_intrinsic_sign (gfc_se
* se
, gfc_expr
* expr
)
1941 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
1942 if (expr
->ts
.type
== BT_REAL
)
1946 tmp
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
1947 abs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
1949 /* We explicitly have to ignore the minus sign. We do so by using
1950 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1951 if (!gfc_option
.flag_sign_zero
1952 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args
[1]))))
1955 zero
= build_real_from_int_cst (TREE_TYPE (args
[1]), integer_zero_node
);
1956 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1958 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
1959 TREE_TYPE (args
[0]), cond
,
1960 build_call_expr_loc (input_location
, abs
, 1,
1962 build_call_expr_loc (input_location
, tmp
, 2,
1966 se
->expr
= build_call_expr_loc (input_location
, tmp
, 2,
1971 /* Having excluded floating point types, we know we are now dealing
1972 with signed integer types. */
1973 type
= TREE_TYPE (args
[0]);
1975 /* Args[0] is used multiple times below. */
1976 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
1978 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1979 the signs of A and B are the same, and of all ones if they differ. */
1980 tmp
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
, args
[0], args
[1]);
1981 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, tmp
,
1982 build_int_cst (type
, TYPE_PRECISION (type
) - 1));
1983 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1985 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1986 is all ones (i.e. -1). */
1987 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, type
,
1988 fold_build2_loc (input_location
, PLUS_EXPR
,
1989 type
, args
[0], tmp
), tmp
);
1993 /* Test for the presence of an optional argument. */
1996 gfc_conv_intrinsic_present (gfc_se
* se
, gfc_expr
* expr
)
2000 arg
= expr
->value
.function
.actual
->expr
;
2001 gcc_assert (arg
->expr_type
== EXPR_VARIABLE
);
2002 se
->expr
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2003 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
2007 /* Calculate the double precision product of two single precision values. */
2010 gfc_conv_intrinsic_dprod (gfc_se
* se
, gfc_expr
* expr
)
2015 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
2017 /* Convert the args to double precision before multiplying. */
2018 type
= gfc_typenode_for_spec (&expr
->ts
);
2019 args
[0] = convert (type
, args
[0]);
2020 args
[1] = convert (type
, args
[1]);
2021 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
, args
[0],
2026 /* Return a length one character string containing an ascii character. */
2029 gfc_conv_intrinsic_char (gfc_se
* se
, gfc_expr
* expr
)
2034 unsigned int num_args
;
2036 num_args
= gfc_intrinsic_argument_list_length (expr
);
2037 gfc_conv_intrinsic_function_args (se
, expr
, arg
, num_args
);
2039 type
= gfc_get_char_type (expr
->ts
.kind
);
2040 var
= gfc_create_var (type
, "char");
2042 arg
[0] = fold_build1_loc (input_location
, NOP_EXPR
, type
, arg
[0]);
2043 gfc_add_modify (&se
->pre
, var
, arg
[0]);
2044 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), var
);
2045 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2050 gfc_conv_intrinsic_ctime (gfc_se
* se
, gfc_expr
* expr
)
2058 unsigned int num_args
;
2060 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2061 args
= XALLOCAVEC (tree
, num_args
);
2063 var
= gfc_create_var (pchar_type_node
, "pstr");
2064 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2066 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2067 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2068 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2070 fndecl
= build_addr (gfor_fndecl_ctime
, current_function_decl
);
2071 tmp
= build_call_array_loc (input_location
,
2072 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime
)),
2073 fndecl
, num_args
, args
);
2074 gfc_add_expr_to_block (&se
->pre
, tmp
);
2076 /* Free the temporary afterwards, if necessary. */
2077 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2078 len
, build_int_cst (TREE_TYPE (len
), 0));
2079 tmp
= gfc_call_free (var
);
2080 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2081 gfc_add_expr_to_block (&se
->post
, tmp
);
2084 se
->string_length
= len
;
2089 gfc_conv_intrinsic_fdate (gfc_se
* se
, gfc_expr
* expr
)
2097 unsigned int num_args
;
2099 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2100 args
= XALLOCAVEC (tree
, num_args
);
2102 var
= gfc_create_var (pchar_type_node
, "pstr");
2103 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2105 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2106 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2107 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2109 fndecl
= build_addr (gfor_fndecl_fdate
, current_function_decl
);
2110 tmp
= build_call_array_loc (input_location
,
2111 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate
)),
2112 fndecl
, num_args
, args
);
2113 gfc_add_expr_to_block (&se
->pre
, tmp
);
2115 /* Free the temporary afterwards, if necessary. */
2116 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2117 len
, build_int_cst (TREE_TYPE (len
), 0));
2118 tmp
= gfc_call_free (var
);
2119 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2120 gfc_add_expr_to_block (&se
->post
, tmp
);
2123 se
->string_length
= len
;
2127 /* Return a character string containing the tty name. */
2130 gfc_conv_intrinsic_ttynam (gfc_se
* se
, gfc_expr
* expr
)
2138 unsigned int num_args
;
2140 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
2141 args
= XALLOCAVEC (tree
, num_args
);
2143 var
= gfc_create_var (pchar_type_node
, "pstr");
2144 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2146 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
2147 args
[0] = gfc_build_addr_expr (NULL_TREE
, var
);
2148 args
[1] = gfc_build_addr_expr (NULL_TREE
, len
);
2150 fndecl
= build_addr (gfor_fndecl_ttynam
, current_function_decl
);
2151 tmp
= build_call_array_loc (input_location
,
2152 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam
)),
2153 fndecl
, num_args
, args
);
2154 gfc_add_expr_to_block (&se
->pre
, tmp
);
2156 /* Free the temporary afterwards, if necessary. */
2157 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2158 len
, build_int_cst (TREE_TYPE (len
), 0));
2159 tmp
= gfc_call_free (var
);
2160 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2161 gfc_add_expr_to_block (&se
->post
, tmp
);
2164 se
->string_length
= len
;
2168 /* Get the minimum/maximum value of all the parameters.
2169 minmax (a1, a2, a3, ...)
2172 if (a2 .op. mvar || isnan(mvar))
2174 if (a3 .op. mvar || isnan(mvar))
2181 /* TODO: Mismatching types can occur when specific names are used.
2182 These should be handled during resolution. */
2184 gfc_conv_intrinsic_minmax (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2192 gfc_actual_arglist
*argexpr
;
2193 unsigned int i
, nargs
;
2195 nargs
= gfc_intrinsic_argument_list_length (expr
);
2196 args
= XALLOCAVEC (tree
, nargs
);
2198 gfc_conv_intrinsic_function_args (se
, expr
, args
, nargs
);
2199 type
= gfc_typenode_for_spec (&expr
->ts
);
2201 argexpr
= expr
->value
.function
.actual
;
2202 if (TREE_TYPE (args
[0]) != type
)
2203 args
[0] = convert (type
, args
[0]);
2204 /* Only evaluate the argument once. */
2205 if (TREE_CODE (args
[0]) != VAR_DECL
&& !TREE_CONSTANT (args
[0]))
2206 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
2208 mvar
= gfc_create_var (type
, "M");
2209 gfc_add_modify (&se
->pre
, mvar
, args
[0]);
2210 for (i
= 1, argexpr
= argexpr
->next
; i
< nargs
; i
++)
2216 /* Handle absent optional arguments by ignoring the comparison. */
2217 if (argexpr
->expr
->expr_type
== EXPR_VARIABLE
2218 && argexpr
->expr
->symtree
->n
.sym
->attr
.optional
2219 && TREE_CODE (val
) == INDIRECT_REF
)
2220 cond
= fold_build2_loc (input_location
,
2221 NE_EXPR
, boolean_type_node
,
2222 TREE_OPERAND (val
, 0),
2223 build_int_cst (TREE_TYPE (TREE_OPERAND (val
, 0)), 0));
2228 /* Only evaluate the argument once. */
2229 if (TREE_CODE (val
) != VAR_DECL
&& !TREE_CONSTANT (val
))
2230 val
= gfc_evaluate_now (val
, &se
->pre
);
2233 thencase
= build2_v (MODIFY_EXPR
, mvar
, convert (type
, val
));
2235 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
2236 convert (type
, val
), mvar
);
2238 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2239 __builtin_isnan might be made dependent on that module being loaded,
2240 to help performance of programs that don't rely on IEEE semantics. */
2241 if (FLOAT_TYPE_P (TREE_TYPE (mvar
)))
2243 isnan
= build_call_expr_loc (input_location
,
2244 builtin_decl_explicit (BUILT_IN_ISNAN
),
2246 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2247 boolean_type_node
, tmp
,
2248 fold_convert (boolean_type_node
, isnan
));
2250 tmp
= build3_v (COND_EXPR
, tmp
, thencase
,
2251 build_empty_stmt (input_location
));
2253 if (cond
!= NULL_TREE
)
2254 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
2255 build_empty_stmt (input_location
));
2257 gfc_add_expr_to_block (&se
->pre
, tmp
);
2258 argexpr
= argexpr
->next
;
2264 /* Generate library calls for MIN and MAX intrinsics for character
2267 gfc_conv_intrinsic_minmax_char (gfc_se
* se
, gfc_expr
* expr
, int op
)
2270 tree var
, len
, fndecl
, tmp
, cond
, function
;
2273 nargs
= gfc_intrinsic_argument_list_length (expr
);
2274 args
= XALLOCAVEC (tree
, nargs
+ 4);
2275 gfc_conv_intrinsic_function_args (se
, expr
, &args
[4], nargs
);
2277 /* Create the result variables. */
2278 len
= gfc_create_var (gfc_charlen_type_node
, "len");
2279 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
2280 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
2281 args
[1] = gfc_build_addr_expr (ppvoid_type_node
, var
);
2282 args
[2] = build_int_cst (integer_type_node
, op
);
2283 args
[3] = build_int_cst (integer_type_node
, nargs
/ 2);
2285 if (expr
->ts
.kind
== 1)
2286 function
= gfor_fndecl_string_minmax
;
2287 else if (expr
->ts
.kind
== 4)
2288 function
= gfor_fndecl_string_minmax_char4
;
2292 /* Make the function call. */
2293 fndecl
= build_addr (function
, current_function_decl
);
2294 tmp
= build_call_array_loc (input_location
,
2295 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
2297 gfc_add_expr_to_block (&se
->pre
, tmp
);
2299 /* Free the temporary afterwards, if necessary. */
2300 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2301 len
, build_int_cst (TREE_TYPE (len
), 0));
2302 tmp
= gfc_call_free (var
);
2303 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2304 gfc_add_expr_to_block (&se
->post
, tmp
);
2307 se
->string_length
= len
;
2311 /* Create a symbol node for this intrinsic. The symbol from the frontend
2312 has the generic name. */
2315 gfc_get_symbol_for_expr (gfc_expr
* expr
)
2319 /* TODO: Add symbols for intrinsic function to the global namespace. */
2320 gcc_assert (strlen (expr
->value
.function
.name
) <= GFC_MAX_SYMBOL_LEN
- 5);
2321 sym
= gfc_new_symbol (expr
->value
.function
.name
, NULL
);
2324 sym
->attr
.external
= 1;
2325 sym
->attr
.function
= 1;
2326 sym
->attr
.always_explicit
= 1;
2327 sym
->attr
.proc
= PROC_INTRINSIC
;
2328 sym
->attr
.flavor
= FL_PROCEDURE
;
2332 sym
->attr
.dimension
= 1;
2333 sym
->as
= gfc_get_array_spec ();
2334 sym
->as
->type
= AS_ASSUMED_SHAPE
;
2335 sym
->as
->rank
= expr
->rank
;
2338 gfc_copy_formal_args_intr (sym
, expr
->value
.function
.isym
);
2343 /* Generate a call to an external intrinsic function. */
2345 gfc_conv_intrinsic_funcall (gfc_se
* se
, gfc_expr
* expr
)
2348 VEC(tree
,gc
) *append_args
;
2350 gcc_assert (!se
->ss
|| se
->ss
->info
->expr
== expr
);
2353 gcc_assert (expr
->rank
> 0);
2355 gcc_assert (expr
->rank
== 0);
2357 sym
= gfc_get_symbol_for_expr (expr
);
2359 /* Calls to libgfortran_matmul need to be appended special arguments,
2360 to be able to call the BLAS ?gemm functions if required and possible. */
2362 if (expr
->value
.function
.isym
->id
== GFC_ISYM_MATMUL
2363 && sym
->ts
.type
!= BT_LOGICAL
)
2365 tree cint
= gfc_get_int_type (gfc_c_int_kind
);
2367 if (gfc_option
.flag_external_blas
2368 && (sym
->ts
.type
== BT_REAL
|| sym
->ts
.type
== BT_COMPLEX
)
2369 && (sym
->ts
.kind
== gfc_default_real_kind
2370 || sym
->ts
.kind
== gfc_default_double_kind
))
2374 if (sym
->ts
.type
== BT_REAL
)
2376 if (sym
->ts
.kind
== gfc_default_real_kind
)
2377 gemm_fndecl
= gfor_fndecl_sgemm
;
2379 gemm_fndecl
= gfor_fndecl_dgemm
;
2383 if (sym
->ts
.kind
== gfc_default_real_kind
)
2384 gemm_fndecl
= gfor_fndecl_cgemm
;
2386 gemm_fndecl
= gfor_fndecl_zgemm
;
2389 append_args
= VEC_alloc (tree
, gc
, 3);
2390 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 1));
2391 VEC_quick_push (tree
, append_args
,
2392 build_int_cst (cint
, gfc_option
.blas_matmul_limit
));
2393 VEC_quick_push (tree
, append_args
,
2394 gfc_build_addr_expr (NULL_TREE
, gemm_fndecl
));
2398 append_args
= VEC_alloc (tree
, gc
, 3);
2399 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
2400 VEC_quick_push (tree
, append_args
, build_int_cst (cint
, 0));
2401 VEC_quick_push (tree
, append_args
, null_pointer_node
);
2405 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
2407 gfc_free_symbol (sym
);
2410 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2430 gfc_conv_intrinsic_anyall (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
2439 gfc_actual_arglist
*actual
;
2446 gfc_conv_intrinsic_funcall (se
, expr
);
2450 actual
= expr
->value
.function
.actual
;
2451 type
= gfc_typenode_for_spec (&expr
->ts
);
2452 /* Initialize the result. */
2453 resvar
= gfc_create_var (type
, "test");
2455 tmp
= convert (type
, boolean_true_node
);
2457 tmp
= convert (type
, boolean_false_node
);
2458 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2460 /* Walk the arguments. */
2461 arrayss
= gfc_walk_expr (actual
->expr
);
2462 gcc_assert (arrayss
!= gfc_ss_terminator
);
2464 /* Initialize the scalarizer. */
2465 gfc_init_loopinfo (&loop
);
2466 exit_label
= gfc_build_label_decl (NULL_TREE
);
2467 TREE_USED (exit_label
) = 1;
2468 gfc_add_ss_to_loop (&loop
, arrayss
);
2470 /* Initialize the loop. */
2471 gfc_conv_ss_startstride (&loop
);
2472 gfc_conv_loop_setup (&loop
, &expr
->where
);
2474 gfc_mark_ss_chain_used (arrayss
, 1);
2475 /* Generate the loop body. */
2476 gfc_start_scalarized_body (&loop
, &body
);
2478 /* If the condition matches then set the return value. */
2479 gfc_start_block (&block
);
2481 tmp
= convert (type
, boolean_false_node
);
2483 tmp
= convert (type
, boolean_true_node
);
2484 gfc_add_modify (&block
, resvar
, tmp
);
2486 /* And break out of the loop. */
2487 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2488 gfc_add_expr_to_block (&block
, tmp
);
2490 found
= gfc_finish_block (&block
);
2492 /* Check this element. */
2493 gfc_init_se (&arrayse
, NULL
);
2494 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2495 arrayse
.ss
= arrayss
;
2496 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2498 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2499 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
, arrayse
.expr
,
2500 build_int_cst (TREE_TYPE (arrayse
.expr
), 0));
2501 tmp
= build3_v (COND_EXPR
, tmp
, found
, build_empty_stmt (input_location
));
2502 gfc_add_expr_to_block (&body
, tmp
);
2503 gfc_add_block_to_block (&body
, &arrayse
.post
);
2505 gfc_trans_scalarizing_loops (&loop
, &body
);
2507 /* Add the exit label. */
2508 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2509 gfc_add_expr_to_block (&loop
.pre
, tmp
);
2511 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2512 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2513 gfc_cleanup_loop (&loop
);
2518 /* COUNT(A) = Number of true elements in A. */
2520 gfc_conv_intrinsic_count (gfc_se
* se
, gfc_expr
* expr
)
2527 gfc_actual_arglist
*actual
;
2533 gfc_conv_intrinsic_funcall (se
, expr
);
2537 actual
= expr
->value
.function
.actual
;
2539 type
= gfc_typenode_for_spec (&expr
->ts
);
2540 /* Initialize the result. */
2541 resvar
= gfc_create_var (type
, "count");
2542 gfc_add_modify (&se
->pre
, resvar
, build_int_cst (type
, 0));
2544 /* Walk the arguments. */
2545 arrayss
= gfc_walk_expr (actual
->expr
);
2546 gcc_assert (arrayss
!= gfc_ss_terminator
);
2548 /* Initialize the scalarizer. */
2549 gfc_init_loopinfo (&loop
);
2550 gfc_add_ss_to_loop (&loop
, arrayss
);
2552 /* Initialize the loop. */
2553 gfc_conv_ss_startstride (&loop
);
2554 gfc_conv_loop_setup (&loop
, &expr
->where
);
2556 gfc_mark_ss_chain_used (arrayss
, 1);
2557 /* Generate the loop body. */
2558 gfc_start_scalarized_body (&loop
, &body
);
2560 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (resvar
),
2561 resvar
, build_int_cst (TREE_TYPE (resvar
), 1));
2562 tmp
= build2_v (MODIFY_EXPR
, resvar
, tmp
);
2564 gfc_init_se (&arrayse
, NULL
);
2565 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
2566 arrayse
.ss
= arrayss
;
2567 gfc_conv_expr_val (&arrayse
, actual
->expr
);
2568 tmp
= build3_v (COND_EXPR
, arrayse
.expr
, tmp
,
2569 build_empty_stmt (input_location
));
2571 gfc_add_block_to_block (&body
, &arrayse
.pre
);
2572 gfc_add_expr_to_block (&body
, tmp
);
2573 gfc_add_block_to_block (&body
, &arrayse
.post
);
2575 gfc_trans_scalarizing_loops (&loop
, &body
);
2577 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2578 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2579 gfc_cleanup_loop (&loop
);
2585 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
2586 struct and return the corresponding loopinfo. */
2588 static gfc_loopinfo
*
2589 enter_nested_loop (gfc_se
*se
)
2591 se
->ss
= se
->ss
->nested_ss
;
2592 gcc_assert (se
->ss
== se
->ss
->loop
->ss
);
2594 return se
->ss
->loop
;
2598 /* Inline implementation of the sum and product intrinsics. */
2600 gfc_conv_intrinsic_arith (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
,
2604 tree scale
= NULL_TREE
;
2609 gfc_loopinfo loop
, *ploop
;
2610 gfc_actual_arglist
*arg_array
, *arg_mask
;
2611 gfc_ss
*arrayss
= NULL
;
2612 gfc_ss
*maskss
= NULL
;
2616 gfc_expr
*arrayexpr
;
2621 gcc_assert (gfc_inline_intrinsic_function_p (expr
));
2627 type
= gfc_typenode_for_spec (&expr
->ts
);
2628 /* Initialize the result. */
2629 resvar
= gfc_create_var (type
, "val");
2634 scale
= gfc_create_var (type
, "scale");
2635 gfc_add_modify (&se
->pre
, scale
,
2636 gfc_build_const (type
, integer_one_node
));
2637 tmp
= gfc_build_const (type
, integer_zero_node
);
2639 else if (op
== PLUS_EXPR
|| op
== BIT_IOR_EXPR
|| op
== BIT_XOR_EXPR
)
2640 tmp
= gfc_build_const (type
, integer_zero_node
);
2641 else if (op
== NE_EXPR
)
2643 tmp
= convert (type
, boolean_false_node
);
2644 else if (op
== BIT_AND_EXPR
)
2645 tmp
= gfc_build_const (type
, fold_build1_loc (input_location
, NEGATE_EXPR
,
2646 type
, integer_one_node
));
2648 tmp
= gfc_build_const (type
, integer_one_node
);
2650 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2652 arg_array
= expr
->value
.function
.actual
;
2654 arrayexpr
= arg_array
->expr
;
2656 if (op
== NE_EXPR
|| norm2
)
2657 /* PARITY and NORM2. */
2661 arg_mask
= arg_array
->next
->next
;
2662 gcc_assert (arg_mask
!= NULL
);
2663 maskexpr
= arg_mask
->expr
;
2666 if (expr
->rank
== 0)
2668 /* Walk the arguments. */
2669 arrayss
= gfc_walk_expr (arrayexpr
);
2670 gcc_assert (arrayss
!= gfc_ss_terminator
);
2672 if (maskexpr
&& maskexpr
->rank
> 0)
2674 maskss
= gfc_walk_expr (maskexpr
);
2675 gcc_assert (maskss
!= gfc_ss_terminator
);
2680 /* Initialize the scalarizer. */
2681 gfc_init_loopinfo (&loop
);
2682 gfc_add_ss_to_loop (&loop
, arrayss
);
2683 if (maskexpr
&& maskexpr
->rank
> 0)
2684 gfc_add_ss_to_loop (&loop
, maskss
);
2686 /* Initialize the loop. */
2687 gfc_conv_ss_startstride (&loop
);
2688 gfc_conv_loop_setup (&loop
, &expr
->where
);
2690 gfc_mark_ss_chain_used (arrayss
, 1);
2691 if (maskexpr
&& maskexpr
->rank
> 0)
2692 gfc_mark_ss_chain_used (maskss
, 1);
2697 /* All the work has been done in the parent loops. */
2698 ploop
= enter_nested_loop (se
);
2702 /* Generate the loop body. */
2703 gfc_start_scalarized_body (ploop
, &body
);
2705 /* If we have a mask, only add this element if the mask is set. */
2706 if (maskexpr
&& maskexpr
->rank
> 0)
2708 gfc_init_se (&maskse
, parent_se
);
2709 gfc_copy_loopinfo_to_se (&maskse
, ploop
);
2710 if (expr
->rank
== 0)
2712 gfc_conv_expr_val (&maskse
, maskexpr
);
2713 gfc_add_block_to_block (&body
, &maskse
.pre
);
2715 gfc_start_block (&block
);
2718 gfc_init_block (&block
);
2720 /* Do the actual summation/product. */
2721 gfc_init_se (&arrayse
, parent_se
);
2722 gfc_copy_loopinfo_to_se (&arrayse
, ploop
);
2723 if (expr
->rank
== 0)
2724 arrayse
.ss
= arrayss
;
2725 gfc_conv_expr_val (&arrayse
, arrayexpr
);
2726 gfc_add_block_to_block (&block
, &arrayse
.pre
);
2736 result = 1.0 + result * val * val;
2742 result += val * val;
2745 tree res1
, res2
, cond
, absX
, val
;
2746 stmtblock_t ifblock1
, ifblock2
, ifblock3
;
2748 gfc_init_block (&ifblock1
);
2750 absX
= gfc_create_var (type
, "absX");
2751 gfc_add_modify (&ifblock1
, absX
,
2752 fold_build1_loc (input_location
, ABS_EXPR
, type
,
2754 val
= gfc_create_var (type
, "val");
2755 gfc_add_expr_to_block (&ifblock1
, val
);
2757 gfc_init_block (&ifblock2
);
2758 gfc_add_modify (&ifblock2
, val
,
2759 fold_build2_loc (input_location
, RDIV_EXPR
, type
, scale
,
2761 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2762 res1
= fold_build2_loc (input_location
, MULT_EXPR
, type
, resvar
, res1
);
2763 res1
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, res1
,
2764 gfc_build_const (type
, integer_one_node
));
2765 gfc_add_modify (&ifblock2
, resvar
, res1
);
2766 gfc_add_modify (&ifblock2
, scale
, absX
);
2767 res1
= gfc_finish_block (&ifblock2
);
2769 gfc_init_block (&ifblock3
);
2770 gfc_add_modify (&ifblock3
, val
,
2771 fold_build2_loc (input_location
, RDIV_EXPR
, type
, absX
,
2773 res2
= fold_build2_loc (input_location
, MULT_EXPR
, type
, val
, val
);
2774 res2
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, res2
);
2775 gfc_add_modify (&ifblock3
, resvar
, res2
);
2776 res2
= gfc_finish_block (&ifblock3
);
2778 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2780 tmp
= build3_v (COND_EXPR
, cond
, res1
, res2
);
2781 gfc_add_expr_to_block (&ifblock1
, tmp
);
2782 tmp
= gfc_finish_block (&ifblock1
);
2784 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
2786 gfc_build_const (type
, integer_zero_node
));
2788 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
2789 gfc_add_expr_to_block (&block
, tmp
);
2793 tmp
= fold_build2_loc (input_location
, op
, type
, resvar
, arrayse
.expr
);
2794 gfc_add_modify (&block
, resvar
, tmp
);
2797 gfc_add_block_to_block (&block
, &arrayse
.post
);
2799 if (maskexpr
&& maskexpr
->rank
> 0)
2801 /* We enclose the above in if (mask) {...} . */
2803 tmp
= gfc_finish_block (&block
);
2804 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2805 build_empty_stmt (input_location
));
2808 tmp
= gfc_finish_block (&block
);
2809 gfc_add_expr_to_block (&body
, tmp
);
2811 gfc_trans_scalarizing_loops (ploop
, &body
);
2813 /* For a scalar mask, enclose the loop in an if statement. */
2814 if (maskexpr
&& maskexpr
->rank
== 0)
2816 gfc_init_block (&block
);
2817 gfc_add_block_to_block (&block
, &ploop
->pre
);
2818 gfc_add_block_to_block (&block
, &ploop
->post
);
2819 tmp
= gfc_finish_block (&block
);
2823 tmp
= build3_v (COND_EXPR
, se
->ss
->info
->data
.scalar
.value
, tmp
,
2824 build_empty_stmt (input_location
));
2825 gfc_advance_se_ss_chain (se
);
2829 gcc_assert (expr
->rank
== 0);
2830 gfc_init_se (&maskse
, NULL
);
2831 gfc_conv_expr_val (&maskse
, maskexpr
);
2832 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
2833 build_empty_stmt (input_location
));
2836 gfc_add_expr_to_block (&block
, tmp
);
2837 gfc_add_block_to_block (&se
->pre
, &block
);
2838 gcc_assert (se
->post
.head
== NULL
);
2842 gfc_add_block_to_block (&se
->pre
, &ploop
->pre
);
2843 gfc_add_block_to_block (&se
->pre
, &ploop
->post
);
2846 if (expr
->rank
== 0)
2847 gfc_cleanup_loop (ploop
);
2851 /* result = scale * sqrt(result). */
2853 sqrt
= gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT
, expr
->ts
.kind
);
2854 resvar
= build_call_expr_loc (input_location
,
2856 resvar
= fold_build2_loc (input_location
, MULT_EXPR
, type
, scale
, resvar
);
2863 /* Inline implementation of the dot_product intrinsic. This function
2864 is based on gfc_conv_intrinsic_arith (the previous function). */
2866 gfc_conv_intrinsic_dot_product (gfc_se
* se
, gfc_expr
* expr
)
2874 gfc_actual_arglist
*actual
;
2875 gfc_ss
*arrayss1
, *arrayss2
;
2876 gfc_se arrayse1
, arrayse2
;
2877 gfc_expr
*arrayexpr1
, *arrayexpr2
;
2879 type
= gfc_typenode_for_spec (&expr
->ts
);
2881 /* Initialize the result. */
2882 resvar
= gfc_create_var (type
, "val");
2883 if (expr
->ts
.type
== BT_LOGICAL
)
2884 tmp
= build_int_cst (type
, 0);
2886 tmp
= gfc_build_const (type
, integer_zero_node
);
2888 gfc_add_modify (&se
->pre
, resvar
, tmp
);
2890 /* Walk argument #1. */
2891 actual
= expr
->value
.function
.actual
;
2892 arrayexpr1
= actual
->expr
;
2893 arrayss1
= gfc_walk_expr (arrayexpr1
);
2894 gcc_assert (arrayss1
!= gfc_ss_terminator
);
2896 /* Walk argument #2. */
2897 actual
= actual
->next
;
2898 arrayexpr2
= actual
->expr
;
2899 arrayss2
= gfc_walk_expr (arrayexpr2
);
2900 gcc_assert (arrayss2
!= gfc_ss_terminator
);
2902 /* Initialize the scalarizer. */
2903 gfc_init_loopinfo (&loop
);
2904 gfc_add_ss_to_loop (&loop
, arrayss1
);
2905 gfc_add_ss_to_loop (&loop
, arrayss2
);
2907 /* Initialize the loop. */
2908 gfc_conv_ss_startstride (&loop
);
2909 gfc_conv_loop_setup (&loop
, &expr
->where
);
2911 gfc_mark_ss_chain_used (arrayss1
, 1);
2912 gfc_mark_ss_chain_used (arrayss2
, 1);
2914 /* Generate the loop body. */
2915 gfc_start_scalarized_body (&loop
, &body
);
2916 gfc_init_block (&block
);
2918 /* Make the tree expression for [conjg(]array1[)]. */
2919 gfc_init_se (&arrayse1
, NULL
);
2920 gfc_copy_loopinfo_to_se (&arrayse1
, &loop
);
2921 arrayse1
.ss
= arrayss1
;
2922 gfc_conv_expr_val (&arrayse1
, arrayexpr1
);
2923 if (expr
->ts
.type
== BT_COMPLEX
)
2924 arrayse1
.expr
= fold_build1_loc (input_location
, CONJ_EXPR
, type
,
2926 gfc_add_block_to_block (&block
, &arrayse1
.pre
);
2928 /* Make the tree expression for array2. */
2929 gfc_init_se (&arrayse2
, NULL
);
2930 gfc_copy_loopinfo_to_se (&arrayse2
, &loop
);
2931 arrayse2
.ss
= arrayss2
;
2932 gfc_conv_expr_val (&arrayse2
, arrayexpr2
);
2933 gfc_add_block_to_block (&block
, &arrayse2
.pre
);
2935 /* Do the actual product and sum. */
2936 if (expr
->ts
.type
== BT_LOGICAL
)
2938 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, type
,
2939 arrayse1
.expr
, arrayse2
.expr
);
2940 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, type
, resvar
, tmp
);
2944 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, type
, arrayse1
.expr
,
2946 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, type
, resvar
, tmp
);
2948 gfc_add_modify (&block
, resvar
, tmp
);
2950 /* Finish up the loop block and the loop. */
2951 tmp
= gfc_finish_block (&block
);
2952 gfc_add_expr_to_block (&body
, tmp
);
2954 gfc_trans_scalarizing_loops (&loop
, &body
);
2955 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
2956 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
2957 gfc_cleanup_loop (&loop
);
2963 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2964 we need to handle. For performance reasons we sometimes create two
2965 loops instead of one, where the second one is much simpler.
2966 Examples for minloc intrinsic:
2967 1) Result is an array, a call is generated
2968 2) Array mask is used and NaNs need to be supported:
2974 if (pos == 0) pos = S + (1 - from);
2975 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2982 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2986 3) NaNs need to be supported, but it is known at compile time or cheaply
2987 at runtime whether array is nonempty or not:
2992 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2995 if (from <= to) pos = 1;
2999 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3003 4) NaNs aren't supported, array mask is used:
3004 limit = infinities_supported ? Infinity : huge (limit);
3008 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3014 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3018 5) Same without array mask:
3019 limit = infinities_supported ? Infinity : huge (limit);
3020 pos = (from <= to) ? 1 : 0;
3023 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3026 For 3) and 5), if mask is scalar, this all goes into a conditional,
3027 setting pos = 0; in the else branch. */
3030 gfc_conv_intrinsic_minmaxloc (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3034 stmtblock_t ifblock
;
3035 stmtblock_t elseblock
;
3046 gfc_actual_arglist
*actual
;
3051 gfc_expr
*arrayexpr
;
3058 gfc_conv_intrinsic_funcall (se
, expr
);
3062 /* Initialize the result. */
3063 pos
= gfc_create_var (gfc_array_index_type
, "pos");
3064 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3065 type
= gfc_typenode_for_spec (&expr
->ts
);
3067 /* Walk the arguments. */
3068 actual
= expr
->value
.function
.actual
;
3069 arrayexpr
= actual
->expr
;
3070 arrayss
= gfc_walk_expr (arrayexpr
);
3071 gcc_assert (arrayss
!= gfc_ss_terminator
);
3073 actual
= actual
->next
->next
;
3074 gcc_assert (actual
);
3075 maskexpr
= actual
->expr
;
3077 if (maskexpr
&& maskexpr
->rank
!= 0)
3079 maskss
= gfc_walk_expr (maskexpr
);
3080 gcc_assert (maskss
!= gfc_ss_terminator
);
3085 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3087 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3089 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3090 boolean_type_node
, nonempty
,
3091 gfc_index_zero_node
);
3096 limit
= gfc_create_var (gfc_typenode_for_spec (&arrayexpr
->ts
), "limit");
3097 switch (arrayexpr
->ts
.type
)
3100 tmp
= gfc_build_inf_or_huge (TREE_TYPE (limit
), arrayexpr
->ts
.kind
);
3104 n
= gfc_validate_kind (arrayexpr
->ts
.type
, arrayexpr
->ts
.kind
, false);
3105 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
,
3106 arrayexpr
->ts
.kind
);
3113 /* We start with the most negative possible value for MAXLOC, and the most
3114 positive possible value for MINLOC. The most negative possible value is
3115 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3116 possible value is HUGE in both cases. */
3118 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3119 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3120 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
), tmp
,
3121 build_int_cst (type
, 1));
3123 gfc_add_modify (&se
->pre
, limit
, tmp
);
3125 /* Initialize the scalarizer. */
3126 gfc_init_loopinfo (&loop
);
3127 gfc_add_ss_to_loop (&loop
, arrayss
);
3129 gfc_add_ss_to_loop (&loop
, maskss
);
3131 /* Initialize the loop. */
3132 gfc_conv_ss_startstride (&loop
);
3134 /* The code generated can have more than one loop in sequence (see the
3135 comment at the function header). This doesn't work well with the
3136 scalarizer, which changes arrays' offset when the scalarization loops
3137 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3138 are currently inlined in the scalar case only (for which loop is of rank
3139 one). As there is no dependency to care about in that case, there is no
3140 temporary, so that we can use the scalarizer temporary code to handle
3141 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3142 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3144 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3145 should eventually go away. We could either create two loops properly,
3146 or find another way to save/restore the array offsets between the two
3147 loops (without conflicting with temporary management), or use a single
3148 loop minmaxloc implementation. See PR 31067. */
3149 loop
.temp_dim
= loop
.dimen
;
3150 gfc_conv_loop_setup (&loop
, &expr
->where
);
3152 gcc_assert (loop
.dimen
== 1);
3153 if (nonempty
== NULL
&& maskss
== NULL
&& loop
.from
[0] && loop
.to
[0])
3154 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3155 loop
.from
[0], loop
.to
[0]);
3159 /* Initialize the position to zero, following Fortran 2003. We are free
3160 to do this because Fortran 95 allows the result of an entirely false
3161 mask to be processor dependent. If we know at compile time the array
3162 is non-empty and no MASK is used, we can initialize to 1 to simplify
3164 if (nonempty
!= NULL
&& !HONOR_NANS (DECL_MODE (limit
)))
3165 gfc_add_modify (&loop
.pre
, pos
,
3166 fold_build3_loc (input_location
, COND_EXPR
,
3167 gfc_array_index_type
,
3168 nonempty
, gfc_index_one_node
,
3169 gfc_index_zero_node
));
3172 gfc_add_modify (&loop
.pre
, pos
, gfc_index_zero_node
);
3173 lab1
= gfc_build_label_decl (NULL_TREE
);
3174 TREE_USED (lab1
) = 1;
3175 lab2
= gfc_build_label_decl (NULL_TREE
);
3176 TREE_USED (lab2
) = 1;
3179 /* An offset must be added to the loop
3180 counter to obtain the required position. */
3181 gcc_assert (loop
.from
[0]);
3183 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3184 gfc_index_one_node
, loop
.from
[0]);
3185 gfc_add_modify (&loop
.pre
, offset
, tmp
);
3187 gfc_mark_ss_chain_used (arrayss
, lab1
? 3 : 1);
3189 gfc_mark_ss_chain_used (maskss
, lab1
? 3 : 1);
3190 /* Generate the loop body. */
3191 gfc_start_scalarized_body (&loop
, &body
);
3193 /* If we have a mask, only check this element if the mask is set. */
3196 gfc_init_se (&maskse
, NULL
);
3197 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3199 gfc_conv_expr_val (&maskse
, maskexpr
);
3200 gfc_add_block_to_block (&body
, &maskse
.pre
);
3202 gfc_start_block (&block
);
3205 gfc_init_block (&block
);
3207 /* Compare with the current limit. */
3208 gfc_init_se (&arrayse
, NULL
);
3209 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3210 arrayse
.ss
= arrayss
;
3211 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3212 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3214 /* We do the following if this is a more extreme value. */
3215 gfc_start_block (&ifblock
);
3217 /* Assign the value to the limit... */
3218 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3220 if (nonempty
== NULL
&& HONOR_NANS (DECL_MODE (limit
)))
3222 stmtblock_t ifblock2
;
3225 gfc_start_block (&ifblock2
);
3226 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3227 loop
.loopvar
[0], offset
);
3228 gfc_add_modify (&ifblock2
, pos
, tmp
);
3229 ifbody2
= gfc_finish_block (&ifblock2
);
3230 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pos
,
3231 gfc_index_zero_node
);
3232 tmp
= build3_v (COND_EXPR
, cond
, ifbody2
,
3233 build_empty_stmt (input_location
));
3234 gfc_add_expr_to_block (&block
, tmp
);
3237 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3238 loop
.loopvar
[0], offset
);
3239 gfc_add_modify (&ifblock
, pos
, tmp
);
3242 gfc_add_expr_to_block (&ifblock
, build1_v (GOTO_EXPR
, lab1
));
3244 ifbody
= gfc_finish_block (&ifblock
);
3246 if (!lab1
|| HONOR_NANS (DECL_MODE (limit
)))
3249 cond
= fold_build2_loc (input_location
,
3250 op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3251 boolean_type_node
, arrayse
.expr
, limit
);
3253 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3254 arrayse
.expr
, limit
);
3256 ifbody
= build3_v (COND_EXPR
, cond
, ifbody
,
3257 build_empty_stmt (input_location
));
3259 gfc_add_expr_to_block (&block
, ifbody
);
3263 /* We enclose the above in if (mask) {...}. */
3264 tmp
= gfc_finish_block (&block
);
3266 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3267 build_empty_stmt (input_location
));
3270 tmp
= gfc_finish_block (&block
);
3271 gfc_add_expr_to_block (&body
, tmp
);
3275 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3277 if (HONOR_NANS (DECL_MODE (limit
)))
3279 if (nonempty
!= NULL
)
3281 ifbody
= build2_v (MODIFY_EXPR
, pos
, gfc_index_one_node
);
3282 tmp
= build3_v (COND_EXPR
, nonempty
, ifbody
,
3283 build_empty_stmt (input_location
));
3284 gfc_add_expr_to_block (&loop
.code
[0], tmp
);
3288 gfc_add_expr_to_block (&loop
.code
[0], build1_v (GOTO_EXPR
, lab2
));
3289 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab1
));
3291 /* If we have a mask, only check this element if the mask is set. */
3294 gfc_init_se (&maskse
, NULL
);
3295 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3297 gfc_conv_expr_val (&maskse
, maskexpr
);
3298 gfc_add_block_to_block (&body
, &maskse
.pre
);
3300 gfc_start_block (&block
);
3303 gfc_init_block (&block
);
3305 /* Compare with the current limit. */
3306 gfc_init_se (&arrayse
, NULL
);
3307 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3308 arrayse
.ss
= arrayss
;
3309 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3310 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3312 /* We do the following if this is a more extreme value. */
3313 gfc_start_block (&ifblock
);
3315 /* Assign the value to the limit... */
3316 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3318 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (pos
),
3319 loop
.loopvar
[0], offset
);
3320 gfc_add_modify (&ifblock
, pos
, tmp
);
3322 ifbody
= gfc_finish_block (&ifblock
);
3324 cond
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3325 arrayse
.expr
, limit
);
3327 tmp
= build3_v (COND_EXPR
, cond
, ifbody
,
3328 build_empty_stmt (input_location
));
3329 gfc_add_expr_to_block (&block
, tmp
);
3333 /* We enclose the above in if (mask) {...}. */
3334 tmp
= gfc_finish_block (&block
);
3336 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3337 build_empty_stmt (input_location
));
3340 tmp
= gfc_finish_block (&block
);
3341 gfc_add_expr_to_block (&body
, tmp
);
3342 /* Avoid initializing loopvar[0] again, it should be left where
3343 it finished by the first loop. */
3344 loop
.from
[0] = loop
.loopvar
[0];
3347 gfc_trans_scalarizing_loops (&loop
, &body
);
3350 gfc_add_expr_to_block (&loop
.pre
, build1_v (LABEL_EXPR
, lab2
));
3352 /* For a scalar mask, enclose the loop in an if statement. */
3353 if (maskexpr
&& maskss
== NULL
)
3355 gfc_init_se (&maskse
, NULL
);
3356 gfc_conv_expr_val (&maskse
, maskexpr
);
3357 gfc_init_block (&block
);
3358 gfc_add_block_to_block (&block
, &loop
.pre
);
3359 gfc_add_block_to_block (&block
, &loop
.post
);
3360 tmp
= gfc_finish_block (&block
);
3362 /* For the else part of the scalar mask, just initialize
3363 the pos variable the same way as above. */
3365 gfc_init_block (&elseblock
);
3366 gfc_add_modify (&elseblock
, pos
, gfc_index_zero_node
);
3367 elsetmp
= gfc_finish_block (&elseblock
);
3369 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, elsetmp
);
3370 gfc_add_expr_to_block (&block
, tmp
);
3371 gfc_add_block_to_block (&se
->pre
, &block
);
3375 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3376 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3378 gfc_cleanup_loop (&loop
);
3380 se
->expr
= convert (type
, pos
);
3383 /* Emit code for minval or maxval intrinsic. There are many different cases
3384 we need to handle. For performance reasons we sometimes create two
3385 loops instead of one, where the second one is much simpler.
3386 Examples for minval intrinsic:
3387 1) Result is an array, a call is generated
3388 2) Array mask is used and NaNs need to be supported, rank 1:
3393 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3396 limit = nonempty ? NaN : huge (limit);
3398 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3399 3) NaNs need to be supported, but it is known at compile time or cheaply
3400 at runtime whether array is nonempty or not, rank 1:
3403 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3404 limit = (from <= to) ? NaN : huge (limit);
3406 while (S <= to) { limit = min (a[S], limit); S++; }
3407 4) Array mask is used and NaNs need to be supported, rank > 1:
3416 if (fast) limit = min (a[S1][S2], limit);
3419 if (a[S1][S2] <= limit) {
3430 limit = nonempty ? NaN : huge (limit);
3431 5) NaNs need to be supported, but it is known at compile time or cheaply
3432 at runtime whether array is nonempty or not, rank > 1:
3439 if (fast) limit = min (a[S1][S2], limit);
3441 if (a[S1][S2] <= limit) {
3451 limit = (nonempty_array) ? NaN : huge (limit);
3452 6) NaNs aren't supported, but infinities are. Array mask is used:
3457 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3460 limit = nonempty ? limit : huge (limit);
3461 7) Same without array mask:
3464 while (S <= to) { limit = min (a[S], limit); S++; }
3465 limit = (from <= to) ? limit : huge (limit);
3466 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3467 limit = huge (limit);
3469 while (S <= to) { limit = min (a[S], limit); S++); }
3471 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3472 with array mask instead).
3473 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3474 setting limit = huge (limit); in the else branch. */
3477 gfc_conv_intrinsic_minmaxval (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3487 tree huge_cst
= NULL
, nan_cst
= NULL
;
3489 stmtblock_t block
, block2
;
3491 gfc_actual_arglist
*actual
;
3496 gfc_expr
*arrayexpr
;
3502 gfc_conv_intrinsic_funcall (se
, expr
);
3506 type
= gfc_typenode_for_spec (&expr
->ts
);
3507 /* Initialize the result. */
3508 limit
= gfc_create_var (type
, "limit");
3509 n
= gfc_validate_kind (expr
->ts
.type
, expr
->ts
.kind
, false);
3510 switch (expr
->ts
.type
)
3513 huge_cst
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[n
].huge
,
3515 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3517 REAL_VALUE_TYPE real
;
3519 tmp
= build_real (type
, real
);
3523 if (HONOR_NANS (DECL_MODE (limit
)))
3525 REAL_VALUE_TYPE real
;
3526 real_nan (&real
, "", 1, DECL_MODE (limit
));
3527 nan_cst
= build_real (type
, real
);
3532 tmp
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[n
].huge
, expr
->ts
.kind
);
3539 /* We start with the most negative possible value for MAXVAL, and the most
3540 positive possible value for MINVAL. The most negative possible value is
3541 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3542 possible value is HUGE in both cases. */
3545 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (tmp
), tmp
);
3547 huge_cst
= fold_build1_loc (input_location
, NEGATE_EXPR
,
3548 TREE_TYPE (huge_cst
), huge_cst
);
3551 if (op
== GT_EXPR
&& expr
->ts
.type
== BT_INTEGER
)
3552 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (tmp
),
3553 tmp
, build_int_cst (type
, 1));
3555 gfc_add_modify (&se
->pre
, limit
, tmp
);
3557 /* Walk the arguments. */
3558 actual
= expr
->value
.function
.actual
;
3559 arrayexpr
= actual
->expr
;
3560 arrayss
= gfc_walk_expr (arrayexpr
);
3561 gcc_assert (arrayss
!= gfc_ss_terminator
);
3563 actual
= actual
->next
->next
;
3564 gcc_assert (actual
);
3565 maskexpr
= actual
->expr
;
3567 if (maskexpr
&& maskexpr
->rank
!= 0)
3569 maskss
= gfc_walk_expr (maskexpr
);
3570 gcc_assert (maskss
!= gfc_ss_terminator
);
3575 if (gfc_array_size (arrayexpr
, &asize
) == SUCCESS
)
3577 nonempty
= gfc_conv_mpz_to_tree (asize
, gfc_index_integer_kind
);
3579 nonempty
= fold_build2_loc (input_location
, GT_EXPR
,
3580 boolean_type_node
, nonempty
,
3581 gfc_index_zero_node
);
3586 /* Initialize the scalarizer. */
3587 gfc_init_loopinfo (&loop
);
3588 gfc_add_ss_to_loop (&loop
, arrayss
);
3590 gfc_add_ss_to_loop (&loop
, maskss
);
3592 /* Initialize the loop. */
3593 gfc_conv_ss_startstride (&loop
);
3595 /* The code generated can have more than one loop in sequence (see the
3596 comment at the function header). This doesn't work well with the
3597 scalarizer, which changes arrays' offset when the scalarization loops
3598 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3599 are currently inlined in the scalar case only. As there is no dependency
3600 to care about in that case, there is no temporary, so that we can use the
3601 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3602 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3603 gfc_trans_scalarized_loop_boundary even later to restore offset.
3604 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3605 should eventually go away. We could either create two loops properly,
3606 or find another way to save/restore the array offsets between the two
3607 loops (without conflicting with temporary management), or use a single
3608 loop minmaxval implementation. See PR 31067. */
3609 loop
.temp_dim
= loop
.dimen
;
3610 gfc_conv_loop_setup (&loop
, &expr
->where
);
3612 if (nonempty
== NULL
&& maskss
== NULL
3613 && loop
.dimen
== 1 && loop
.from
[0] && loop
.to
[0])
3614 nonempty
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3615 loop
.from
[0], loop
.to
[0]);
3616 nonempty_var
= NULL
;
3617 if (nonempty
== NULL
3618 && (HONOR_INFINITIES (DECL_MODE (limit
))
3619 || HONOR_NANS (DECL_MODE (limit
))))
3621 nonempty_var
= gfc_create_var (boolean_type_node
, "nonempty");
3622 gfc_add_modify (&se
->pre
, nonempty_var
, boolean_false_node
);
3623 nonempty
= nonempty_var
;
3627 if (HONOR_NANS (DECL_MODE (limit
)))
3629 if (loop
.dimen
== 1)
3631 lab
= gfc_build_label_decl (NULL_TREE
);
3632 TREE_USED (lab
) = 1;
3636 fast
= gfc_create_var (boolean_type_node
, "fast");
3637 gfc_add_modify (&se
->pre
, fast
, boolean_false_node
);
3641 gfc_mark_ss_chain_used (arrayss
, lab
? 3 : 1);
3643 gfc_mark_ss_chain_used (maskss
, lab
? 3 : 1);
3644 /* Generate the loop body. */
3645 gfc_start_scalarized_body (&loop
, &body
);
3647 /* If we have a mask, only add this element if the mask is set. */
3650 gfc_init_se (&maskse
, NULL
);
3651 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3653 gfc_conv_expr_val (&maskse
, maskexpr
);
3654 gfc_add_block_to_block (&body
, &maskse
.pre
);
3656 gfc_start_block (&block
);
3659 gfc_init_block (&block
);
3661 /* Compare with the current limit. */
3662 gfc_init_se (&arrayse
, NULL
);
3663 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3664 arrayse
.ss
= arrayss
;
3665 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3666 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3668 gfc_init_block (&block2
);
3671 gfc_add_modify (&block2
, nonempty_var
, boolean_true_node
);
3673 if (HONOR_NANS (DECL_MODE (limit
)))
3675 tmp
= fold_build2_loc (input_location
, op
== GT_EXPR
? GE_EXPR
: LE_EXPR
,
3676 boolean_type_node
, arrayse
.expr
, limit
);
3678 ifbody
= build1_v (GOTO_EXPR
, lab
);
3681 stmtblock_t ifblock
;
3683 gfc_init_block (&ifblock
);
3684 gfc_add_modify (&ifblock
, limit
, arrayse
.expr
);
3685 gfc_add_modify (&ifblock
, fast
, boolean_true_node
);
3686 ifbody
= gfc_finish_block (&ifblock
);
3688 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3689 build_empty_stmt (input_location
));
3690 gfc_add_expr_to_block (&block2
, tmp
);
3694 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3696 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3698 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3699 arrayse
.expr
, limit
);
3700 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3701 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3702 build_empty_stmt (input_location
));
3703 gfc_add_expr_to_block (&block2
, tmp
);
3707 tmp
= fold_build2_loc (input_location
,
3708 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3709 type
, arrayse
.expr
, limit
);
3710 gfc_add_modify (&block2
, limit
, tmp
);
3716 tree elsebody
= gfc_finish_block (&block2
);
3718 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3720 if (HONOR_NANS (DECL_MODE (limit
))
3721 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3723 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3724 arrayse
.expr
, limit
);
3725 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3726 ifbody
= build3_v (COND_EXPR
, tmp
, ifbody
,
3727 build_empty_stmt (input_location
));
3731 tmp
= fold_build2_loc (input_location
,
3732 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3733 type
, arrayse
.expr
, limit
);
3734 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3736 tmp
= build3_v (COND_EXPR
, fast
, ifbody
, elsebody
);
3737 gfc_add_expr_to_block (&block
, tmp
);
3740 gfc_add_block_to_block (&block
, &block2
);
3742 gfc_add_block_to_block (&block
, &arrayse
.post
);
3744 tmp
= gfc_finish_block (&block
);
3746 /* We enclose the above in if (mask) {...}. */
3747 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3748 build_empty_stmt (input_location
));
3749 gfc_add_expr_to_block (&body
, tmp
);
3753 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3755 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3757 gfc_add_modify (&loop
.code
[0], limit
, tmp
);
3758 gfc_add_expr_to_block (&loop
.code
[0], build1_v (LABEL_EXPR
, lab
));
3760 /* If we have a mask, only add this element if the mask is set. */
3763 gfc_init_se (&maskse
, NULL
);
3764 gfc_copy_loopinfo_to_se (&maskse
, &loop
);
3766 gfc_conv_expr_val (&maskse
, maskexpr
);
3767 gfc_add_block_to_block (&body
, &maskse
.pre
);
3769 gfc_start_block (&block
);
3772 gfc_init_block (&block
);
3774 /* Compare with the current limit. */
3775 gfc_init_se (&arrayse
, NULL
);
3776 gfc_copy_loopinfo_to_se (&arrayse
, &loop
);
3777 arrayse
.ss
= arrayss
;
3778 gfc_conv_expr_val (&arrayse
, arrayexpr
);
3779 gfc_add_block_to_block (&block
, &arrayse
.pre
);
3781 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3783 if (HONOR_NANS (DECL_MODE (limit
))
3784 || HONOR_SIGNED_ZEROS (DECL_MODE (limit
)))
3786 tmp
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3787 arrayse
.expr
, limit
);
3788 ifbody
= build2_v (MODIFY_EXPR
, limit
, arrayse
.expr
);
3789 tmp
= build3_v (COND_EXPR
, tmp
, ifbody
,
3790 build_empty_stmt (input_location
));
3791 gfc_add_expr_to_block (&block
, tmp
);
3795 tmp
= fold_build2_loc (input_location
,
3796 op
== GT_EXPR
? MAX_EXPR
: MIN_EXPR
,
3797 type
, arrayse
.expr
, limit
);
3798 gfc_add_modify (&block
, limit
, tmp
);
3801 gfc_add_block_to_block (&block
, &arrayse
.post
);
3803 tmp
= gfc_finish_block (&block
);
3805 /* We enclose the above in if (mask) {...}. */
3806 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
,
3807 build_empty_stmt (input_location
));
3808 gfc_add_expr_to_block (&body
, tmp
);
3809 /* Avoid initializing loopvar[0] again, it should be left where
3810 it finished by the first loop. */
3811 loop
.from
[0] = loop
.loopvar
[0];
3813 gfc_trans_scalarizing_loops (&loop
, &body
);
3817 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
,
3819 ifbody
= build2_v (MODIFY_EXPR
, limit
, tmp
);
3820 tmp
= build3_v (COND_EXPR
, fast
, build_empty_stmt (input_location
),
3822 gfc_add_expr_to_block (&loop
.pre
, tmp
);
3824 else if (HONOR_INFINITIES (DECL_MODE (limit
)) && !lab
)
3826 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, nonempty
, limit
,
3828 gfc_add_modify (&loop
.pre
, limit
, tmp
);
3831 /* For a scalar mask, enclose the loop in an if statement. */
3832 if (maskexpr
&& maskss
== NULL
)
3836 gfc_init_se (&maskse
, NULL
);
3837 gfc_conv_expr_val (&maskse
, maskexpr
);
3838 gfc_init_block (&block
);
3839 gfc_add_block_to_block (&block
, &loop
.pre
);
3840 gfc_add_block_to_block (&block
, &loop
.post
);
3841 tmp
= gfc_finish_block (&block
);
3843 if (HONOR_INFINITIES (DECL_MODE (limit
)))
3844 else_stmt
= build2_v (MODIFY_EXPR
, limit
, huge_cst
);
3846 else_stmt
= build_empty_stmt (input_location
);
3847 tmp
= build3_v (COND_EXPR
, maskse
.expr
, tmp
, else_stmt
);
3848 gfc_add_expr_to_block (&block
, tmp
);
3849 gfc_add_block_to_block (&se
->pre
, &block
);
3853 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
3854 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
3857 gfc_cleanup_loop (&loop
);
3862 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3864 gfc_conv_intrinsic_btest (gfc_se
* se
, gfc_expr
* expr
)
3870 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3871 type
= TREE_TYPE (args
[0]);
3873 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3874 build_int_cst (type
, 1), args
[1]);
3875 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], tmp
);
3876 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
3877 build_int_cst (type
, 0));
3878 type
= gfc_typenode_for_spec (&expr
->ts
);
3879 se
->expr
= convert (type
, tmp
);
3883 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3885 gfc_conv_intrinsic_bitcomp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3889 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3891 /* Convert both arguments to the unsigned type of the same size. */
3892 args
[0] = fold_convert (unsigned_type_for (TREE_TYPE (args
[0])), args
[0]);
3893 args
[1] = fold_convert (unsigned_type_for (TREE_TYPE (args
[1])), args
[1]);
3895 /* If they have unequal type size, convert to the larger one. */
3896 if (TYPE_PRECISION (TREE_TYPE (args
[0]))
3897 > TYPE_PRECISION (TREE_TYPE (args
[1])))
3898 args
[1] = fold_convert (TREE_TYPE (args
[0]), args
[1]);
3899 else if (TYPE_PRECISION (TREE_TYPE (args
[1]))
3900 > TYPE_PRECISION (TREE_TYPE (args
[0])))
3901 args
[0] = fold_convert (TREE_TYPE (args
[1]), args
[0]);
3903 /* Now, we compare them. */
3904 se
->expr
= fold_build2_loc (input_location
, op
, boolean_type_node
,
3909 /* Generate code to perform the specified operation. */
3911 gfc_conv_intrinsic_bitop (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
3915 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3916 se
->expr
= fold_build2_loc (input_location
, op
, TREE_TYPE (args
[0]),
3922 gfc_conv_intrinsic_not (gfc_se
* se
, gfc_expr
* expr
)
3926 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
3927 se
->expr
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
3928 TREE_TYPE (arg
), arg
);
3931 /* Set or clear a single bit. */
3933 gfc_conv_intrinsic_singlebitop (gfc_se
* se
, gfc_expr
* expr
, int set
)
3940 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3941 type
= TREE_TYPE (args
[0]);
3943 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3944 build_int_cst (type
, 1), args
[1]);
3950 tmp
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, tmp
);
3952 se
->expr
= fold_build2_loc (input_location
, op
, type
, args
[0], tmp
);
3955 /* Extract a sequence of bits.
3956 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3958 gfc_conv_intrinsic_ibits (gfc_se
* se
, gfc_expr
* expr
)
3965 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
3966 type
= TREE_TYPE (args
[0]);
3968 mask
= build_int_cst (type
, -1);
3969 mask
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, mask
, args
[2]);
3970 mask
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, type
, mask
);
3972 tmp
= fold_build2_loc (input_location
, RSHIFT_EXPR
, type
, args
[0], args
[1]);
3974 se
->expr
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, tmp
, mask
);
3978 gfc_conv_intrinsic_shift (gfc_se
* se
, gfc_expr
* expr
, bool right_shift
,
3981 tree args
[2], type
, num_bits
, cond
;
3983 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
3985 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
3986 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
3987 type
= TREE_TYPE (args
[0]);
3990 args
[0] = fold_convert (unsigned_type_for (type
), args
[0]);
3992 gcc_assert (right_shift
);
3994 se
->expr
= fold_build2_loc (input_location
,
3995 right_shift
? RSHIFT_EXPR
: LSHIFT_EXPR
,
3996 TREE_TYPE (args
[0]), args
[0], args
[1]);
3999 se
->expr
= fold_convert (type
, se
->expr
);
4001 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4002 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4004 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4005 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
,
4008 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4009 build_int_cst (type
, 0), se
->expr
);
4012 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4014 : ((shift >= 0) ? i << shift : i >> -shift)
4015 where all shifts are logical shifts. */
4017 gfc_conv_intrinsic_ishft (gfc_se
* se
, gfc_expr
* expr
)
4029 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4031 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4032 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4034 type
= TREE_TYPE (args
[0]);
4035 utype
= unsigned_type_for (type
);
4037 width
= fold_build1_loc (input_location
, ABS_EXPR
, TREE_TYPE (args
[1]),
4040 /* Left shift if positive. */
4041 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
, args
[0], width
);
4043 /* Right shift if negative.
4044 We convert to an unsigned type because we want a logical shift.
4045 The standard doesn't define the case of shifting negative
4046 numbers, and we try to be compatible with other compilers, most
4047 notably g77, here. */
4048 rshift
= fold_convert (type
, fold_build2_loc (input_location
, RSHIFT_EXPR
,
4049 utype
, convert (utype
, args
[0]), width
));
4051 tmp
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, args
[1],
4052 build_int_cst (TREE_TYPE (args
[1]), 0));
4053 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lshift
, rshift
);
4055 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4056 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4058 num_bits
= build_int_cst (TREE_TYPE (args
[1]), TYPE_PRECISION (type
));
4059 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, width
,
4061 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond
,
4062 build_int_cst (type
, 0), tmp
);
4066 /* Circular shift. AKA rotate or barrel shift. */
4069 gfc_conv_intrinsic_ishftc (gfc_se
* se
, gfc_expr
* expr
)
4077 unsigned int num_args
;
4079 num_args
= gfc_intrinsic_argument_list_length (expr
);
4080 args
= XALLOCAVEC (tree
, num_args
);
4082 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4086 /* Use a library function for the 3 parameter version. */
4087 tree int4type
= gfc_get_int_type (4);
4089 type
= TREE_TYPE (args
[0]);
4090 /* We convert the first argument to at least 4 bytes, and
4091 convert back afterwards. This removes the need for library
4092 functions for all argument sizes, and function will be
4093 aligned to at least 32 bits, so there's no loss. */
4094 if (expr
->ts
.kind
< 4)
4095 args
[0] = convert (int4type
, args
[0]);
4097 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4098 need loads of library functions. They cannot have values >
4099 BIT_SIZE (I) so the conversion is safe. */
4100 args
[1] = convert (int4type
, args
[1]);
4101 args
[2] = convert (int4type
, args
[2]);
4103 switch (expr
->ts
.kind
)
4108 tmp
= gfor_fndecl_math_ishftc4
;
4111 tmp
= gfor_fndecl_math_ishftc8
;
4114 tmp
= gfor_fndecl_math_ishftc16
;
4119 se
->expr
= build_call_expr_loc (input_location
,
4120 tmp
, 3, args
[0], args
[1], args
[2]);
4121 /* Convert the result back to the original type, if we extended
4122 the first argument's width above. */
4123 if (expr
->ts
.kind
< 4)
4124 se
->expr
= convert (type
, se
->expr
);
4128 type
= TREE_TYPE (args
[0]);
4130 /* Evaluate arguments only once. */
4131 args
[0] = gfc_evaluate_now (args
[0], &se
->pre
);
4132 args
[1] = gfc_evaluate_now (args
[1], &se
->pre
);
4134 /* Rotate left if positive. */
4135 lrot
= fold_build2_loc (input_location
, LROTATE_EXPR
, type
, args
[0], args
[1]);
4137 /* Rotate right if negative. */
4138 tmp
= fold_build1_loc (input_location
, NEGATE_EXPR
, TREE_TYPE (args
[1]),
4140 rrot
= fold_build2_loc (input_location
,RROTATE_EXPR
, type
, args
[0], tmp
);
4142 zero
= build_int_cst (TREE_TYPE (args
[1]), 0);
4143 tmp
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, args
[1],
4145 rrot
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, lrot
, rrot
);
4147 /* Do nothing if shift == 0. */
4148 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, args
[1],
4150 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
, args
[0],
4155 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4156 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4158 The conditional expression is necessary because the result of LEADZ(0)
4159 is defined, but the result of __builtin_clz(0) is undefined for most
4162 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4163 difference in bit size between the argument of LEADZ and the C int. */
4166 gfc_conv_intrinsic_leadz (gfc_se
* se
, gfc_expr
* expr
)
4178 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4179 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4181 /* Which variant of __builtin_clz* should we call? */
4182 if (argsize
<= INT_TYPE_SIZE
)
4184 arg_type
= unsigned_type_node
;
4185 func
= builtin_decl_explicit (BUILT_IN_CLZ
);
4187 else if (argsize
<= LONG_TYPE_SIZE
)
4189 arg_type
= long_unsigned_type_node
;
4190 func
= builtin_decl_explicit (BUILT_IN_CLZL
);
4192 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4194 arg_type
= long_long_unsigned_type_node
;
4195 func
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4199 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4200 arg_type
= gfc_build_uint_type (argsize
);
4204 /* Convert the actual argument twice: first, to the unsigned type of the
4205 same size; then, to the proper argument type for the built-in
4206 function. But the return type is of the default INTEGER kind. */
4207 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4208 arg
= fold_convert (arg_type
, arg
);
4209 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4210 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4212 /* Compute LEADZ for the case i .ne. 0. */
4215 s
= TYPE_PRECISION (arg_type
) - argsize
;
4216 tmp
= fold_convert (result_type
,
4217 build_call_expr_loc (input_location
, func
,
4219 leadz
= fold_build2_loc (input_location
, MINUS_EXPR
, result_type
,
4220 tmp
, build_int_cst (result_type
, s
));
4224 /* We end up here if the argument type is larger than 'long long'.
4225 We generate this code:
4227 if (x & (ULL_MAX << ULL_SIZE) != 0)
4228 return clzll ((unsigned long long) (x >> ULLSIZE));
4230 return ULL_SIZE + clzll ((unsigned long long) x);
4231 where ULL_MAX is the largest value that a ULL_MAX can hold
4232 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4233 is the bit-size of the long long type (64 in this example). */
4234 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4236 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4237 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4238 long_long_unsigned_type_node
,
4239 build_int_cst (long_long_unsigned_type_node
,
4242 cond
= fold_build2_loc (input_location
, LSHIFT_EXPR
, arg_type
,
4243 fold_convert (arg_type
, ullmax
), ullsize
);
4244 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
,
4246 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
4247 cond
, build_int_cst (arg_type
, 0));
4249 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4251 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4252 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4253 tmp1
= fold_convert (result_type
,
4254 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4256 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4257 btmp
= builtin_decl_explicit (BUILT_IN_CLZLL
);
4258 tmp2
= fold_convert (result_type
,
4259 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4260 tmp2
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4263 leadz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4267 /* Build BIT_SIZE. */
4268 bit_size
= build_int_cst (result_type
, argsize
);
4270 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4271 arg
, build_int_cst (arg_type
, 0));
4272 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4277 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4279 The conditional expression is necessary because the result of TRAILZ(0)
4280 is defined, but the result of __builtin_ctz(0) is undefined for most
4284 gfc_conv_intrinsic_trailz (gfc_se
* se
, gfc_expr
*expr
)
4295 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4296 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4298 /* Which variant of __builtin_ctz* should we call? */
4299 if (argsize
<= INT_TYPE_SIZE
)
4301 arg_type
= unsigned_type_node
;
4302 func
= builtin_decl_explicit (BUILT_IN_CTZ
);
4304 else if (argsize
<= LONG_TYPE_SIZE
)
4306 arg_type
= long_unsigned_type_node
;
4307 func
= builtin_decl_explicit (BUILT_IN_CTZL
);
4309 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4311 arg_type
= long_long_unsigned_type_node
;
4312 func
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4316 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4317 arg_type
= gfc_build_uint_type (argsize
);
4321 /* Convert the actual argument twice: first, to the unsigned type of the
4322 same size; then, to the proper argument type for the built-in
4323 function. But the return type is of the default INTEGER kind. */
4324 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4325 arg
= fold_convert (arg_type
, arg
);
4326 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4327 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4329 /* Compute TRAILZ for the case i .ne. 0. */
4331 trailz
= fold_convert (result_type
, build_call_expr_loc (input_location
,
4335 /* We end up here if the argument type is larger than 'long long'.
4336 We generate this code:
4338 if ((x & ULL_MAX) == 0)
4339 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4341 return ctzll ((unsigned long long) x);
4343 where ULL_MAX is the largest value that a ULL_MAX can hold
4344 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4345 is the bit-size of the long long type (64 in this example). */
4346 tree ullsize
, ullmax
, tmp1
, tmp2
, btmp
;
4348 ullsize
= build_int_cst (result_type
, LONG_LONG_TYPE_SIZE
);
4349 ullmax
= fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4350 long_long_unsigned_type_node
,
4351 build_int_cst (long_long_unsigned_type_node
, 0));
4353 cond
= fold_build2_loc (input_location
, BIT_AND_EXPR
, arg_type
, arg
,
4354 fold_convert (arg_type
, ullmax
));
4355 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, cond
,
4356 build_int_cst (arg_type
, 0));
4358 tmp1
= fold_build2_loc (input_location
, RSHIFT_EXPR
, arg_type
,
4360 tmp1
= fold_convert (long_long_unsigned_type_node
, tmp1
);
4361 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4362 tmp1
= fold_convert (result_type
,
4363 build_call_expr_loc (input_location
, btmp
, 1, tmp1
));
4364 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4367 tmp2
= fold_convert (long_long_unsigned_type_node
, arg
);
4368 btmp
= builtin_decl_explicit (BUILT_IN_CTZLL
);
4369 tmp2
= fold_convert (result_type
,
4370 build_call_expr_loc (input_location
, btmp
, 1, tmp2
));
4372 trailz
= fold_build3_loc (input_location
, COND_EXPR
, result_type
,
4376 /* Build BIT_SIZE. */
4377 bit_size
= build_int_cst (result_type
, argsize
);
4379 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4380 arg
, build_int_cst (arg_type
, 0));
4381 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, result_type
, cond
,
4385 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4386 for types larger than "long long", we call the long long built-in for
4387 the lower and higher bits and combine the result. */
4390 gfc_conv_intrinsic_popcnt_poppar (gfc_se
* se
, gfc_expr
*expr
, int parity
)
4398 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4399 argsize
= TYPE_PRECISION (TREE_TYPE (arg
));
4400 result_type
= gfc_get_int_type (gfc_default_integer_kind
);
4402 /* Which variant of the builtin should we call? */
4403 if (argsize
<= INT_TYPE_SIZE
)
4405 arg_type
= unsigned_type_node
;
4406 func
= builtin_decl_explicit (parity
4408 : BUILT_IN_POPCOUNT
);
4410 else if (argsize
<= LONG_TYPE_SIZE
)
4412 arg_type
= long_unsigned_type_node
;
4413 func
= builtin_decl_explicit (parity
4415 : BUILT_IN_POPCOUNTL
);
4417 else if (argsize
<= LONG_LONG_TYPE_SIZE
)
4419 arg_type
= long_long_unsigned_type_node
;
4420 func
= builtin_decl_explicit (parity
4422 : BUILT_IN_POPCOUNTLL
);
4426 /* Our argument type is larger than 'long long', which mean none
4427 of the POPCOUNT builtins covers it. We thus call the 'long long'
4428 variant multiple times, and add the results. */
4429 tree utype
, arg2
, call1
, call2
;
4431 /* For now, we only cover the case where argsize is twice as large
4433 gcc_assert (argsize
== 2 * LONG_LONG_TYPE_SIZE
);
4435 func
= builtin_decl_explicit (parity
4437 : BUILT_IN_POPCOUNTLL
);
4439 /* Convert it to an integer, and store into a variable. */
4440 utype
= gfc_build_uint_type (argsize
);
4441 arg
= fold_convert (utype
, arg
);
4442 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4444 /* Call the builtin twice. */
4445 call1
= build_call_expr_loc (input_location
, func
, 1,
4446 fold_convert (long_long_unsigned_type_node
,
4449 arg2
= fold_build2_loc (input_location
, RSHIFT_EXPR
, utype
, arg
,
4450 build_int_cst (utype
, LONG_LONG_TYPE_SIZE
));
4451 call2
= build_call_expr_loc (input_location
, func
, 1,
4452 fold_convert (long_long_unsigned_type_node
,
4455 /* Combine the results. */
4457 se
->expr
= fold_build2_loc (input_location
, BIT_XOR_EXPR
, result_type
,
4460 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
, result_type
,
4466 /* Convert the actual argument twice: first, to the unsigned type of the
4467 same size; then, to the proper argument type for the built-in
4469 arg
= fold_convert (gfc_build_uint_type (argsize
), arg
);
4470 arg
= fold_convert (arg_type
, arg
);
4472 se
->expr
= fold_convert (result_type
,
4473 build_call_expr_loc (input_location
, func
, 1, arg
));
4477 /* Process an intrinsic with unspecified argument-types that has an optional
4478 argument (which could be of type character), e.g. EOSHIFT. For those, we
4479 need to append the string length of the optional argument if it is not
4480 present and the type is really character.
4481 primary specifies the position (starting at 1) of the non-optional argument
4482 specifying the type and optional gives the position of the optional
4483 argument in the arglist. */
4486 conv_generic_with_optional_char_arg (gfc_se
* se
, gfc_expr
* expr
,
4487 unsigned primary
, unsigned optional
)
4489 gfc_actual_arglist
* prim_arg
;
4490 gfc_actual_arglist
* opt_arg
;
4492 gfc_actual_arglist
* arg
;
4494 VEC(tree
,gc
) *append_args
;
4496 /* Find the two arguments given as position. */
4500 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
4504 if (cur_pos
== primary
)
4506 if (cur_pos
== optional
)
4509 if (cur_pos
>= primary
&& cur_pos
>= optional
)
4512 gcc_assert (prim_arg
);
4513 gcc_assert (prim_arg
->expr
);
4514 gcc_assert (opt_arg
);
4516 /* If we do have type CHARACTER and the optional argument is really absent,
4517 append a dummy 0 as string length. */
4519 if (prim_arg
->expr
->ts
.type
== BT_CHARACTER
&& !opt_arg
->expr
)
4523 dummy
= build_int_cst (gfc_charlen_type_node
, 0);
4524 append_args
= VEC_alloc (tree
, gc
, 1);
4525 VEC_quick_push (tree
, append_args
, dummy
);
4528 /* Build the call itself. */
4529 sym
= gfc_get_symbol_for_expr (expr
);
4530 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
4536 /* The length of a character string. */
4538 gfc_conv_intrinsic_len (gfc_se
* se
, gfc_expr
* expr
)
4548 gcc_assert (!se
->ss
);
4550 arg
= expr
->value
.function
.actual
->expr
;
4552 type
= gfc_typenode_for_spec (&expr
->ts
);
4553 switch (arg
->expr_type
)
4556 len
= build_int_cst (gfc_charlen_type_node
, arg
->value
.character
.length
);
4560 /* Obtain the string length from the function used by
4561 trans-array.c(gfc_trans_array_constructor). */
4563 get_array_ctor_strlen (&se
->pre
, arg
->value
.constructor
, &len
);
4567 if (arg
->ref
== NULL
4568 || (arg
->ref
->next
== NULL
&& arg
->ref
->type
== REF_ARRAY
))
4570 /* This doesn't catch all cases.
4571 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4572 and the surrounding thread. */
4573 sym
= arg
->symtree
->n
.sym
;
4574 decl
= gfc_get_symbol_decl (sym
);
4575 if (decl
== current_function_decl
&& sym
->attr
.function
4576 && (sym
->result
== sym
))
4577 decl
= gfc_get_fake_result_decl (sym
, 0);
4579 len
= sym
->ts
.u
.cl
->backend_decl
;
4584 /* Otherwise fall through. */
4587 /* Anybody stupid enough to do this deserves inefficient code. */
4588 ss
= gfc_walk_expr (arg
);
4589 gfc_init_se (&argse
, se
);
4590 if (ss
== gfc_ss_terminator
)
4591 gfc_conv_expr (&argse
, arg
);
4593 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
4594 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
4595 gfc_add_block_to_block (&se
->post
, &argse
.post
);
4596 len
= argse
.string_length
;
4599 se
->expr
= convert (type
, len
);
4602 /* The length of a character string not including trailing blanks. */
4604 gfc_conv_intrinsic_len_trim (gfc_se
* se
, gfc_expr
* expr
)
4606 int kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
4607 tree args
[2], type
, fndecl
;
4609 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4610 type
= gfc_typenode_for_spec (&expr
->ts
);
4613 fndecl
= gfor_fndecl_string_len_trim
;
4615 fndecl
= gfor_fndecl_string_len_trim_char4
;
4619 se
->expr
= build_call_expr_loc (input_location
,
4620 fndecl
, 2, args
[0], args
[1]);
4621 se
->expr
= convert (type
, se
->expr
);
4625 /* Returns the starting position of a substring within a string. */
4628 gfc_conv_intrinsic_index_scan_verify (gfc_se
* se
, gfc_expr
* expr
,
4631 tree logical4_type_node
= gfc_get_logical_type (4);
4635 unsigned int num_args
;
4637 args
= XALLOCAVEC (tree
, 5);
4639 /* Get number of arguments; characters count double due to the
4640 string length argument. Kind= is not passed to the library
4641 and thus ignored. */
4642 if (expr
->value
.function
.actual
->next
->next
->expr
== NULL
)
4647 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4648 type
= gfc_typenode_for_spec (&expr
->ts
);
4651 args
[4] = build_int_cst (logical4_type_node
, 0);
4653 args
[4] = convert (logical4_type_node
, args
[4]);
4655 fndecl
= build_addr (function
, current_function_decl
);
4656 se
->expr
= build_call_array_loc (input_location
,
4657 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
4659 se
->expr
= convert (type
, se
->expr
);
4663 /* The ascii value for a single character. */
4665 gfc_conv_intrinsic_ichar (gfc_se
* se
, gfc_expr
* expr
)
4667 tree args
[2], type
, pchartype
;
4669 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4670 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args
[1])));
4671 pchartype
= gfc_get_pchar_type (expr
->value
.function
.actual
->expr
->ts
.kind
);
4672 args
[1] = fold_build1_loc (input_location
, NOP_EXPR
, pchartype
, args
[1]);
4673 type
= gfc_typenode_for_spec (&expr
->ts
);
4675 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4677 se
->expr
= convert (type
, se
->expr
);
4681 /* Intrinsic ISNAN calls __builtin_isnan. */
4684 gfc_conv_intrinsic_isnan (gfc_se
* se
, gfc_expr
* expr
)
4688 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4689 se
->expr
= build_call_expr_loc (input_location
,
4690 builtin_decl_explicit (BUILT_IN_ISNAN
),
4692 STRIP_TYPE_NOPS (se
->expr
);
4693 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
4697 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4698 their argument against a constant integer value. */
4701 gfc_conv_has_intvalue (gfc_se
* se
, gfc_expr
* expr
, const int value
)
4705 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4706 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
,
4707 gfc_typenode_for_spec (&expr
->ts
),
4708 arg
, build_int_cst (TREE_TYPE (arg
), value
));
4713 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4716 gfc_conv_intrinsic_merge (gfc_se
* se
, gfc_expr
* expr
)
4724 unsigned int num_args
;
4726 num_args
= gfc_intrinsic_argument_list_length (expr
);
4727 args
= XALLOCAVEC (tree
, num_args
);
4729 gfc_conv_intrinsic_function_args (se
, expr
, args
, num_args
);
4730 if (expr
->ts
.type
!= BT_CHARACTER
)
4738 /* We do the same as in the non-character case, but the argument
4739 list is different because of the string length arguments. We
4740 also have to set the string length for the result. */
4747 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr
->where
, len
, len2
,
4749 se
->string_length
= len
;
4751 type
= TREE_TYPE (tsource
);
4752 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, mask
, tsource
,
4753 fold_convert (type
, fsource
));
4757 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4760 gfc_conv_intrinsic_merge_bits (gfc_se
* se
, gfc_expr
* expr
)
4762 tree args
[3], mask
, type
;
4764 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
4765 mask
= gfc_evaluate_now (args
[2], &se
->pre
);
4767 type
= TREE_TYPE (args
[0]);
4768 gcc_assert (TREE_TYPE (args
[1]) == type
);
4769 gcc_assert (TREE_TYPE (mask
) == type
);
4771 args
[0] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[0], mask
);
4772 args
[1] = fold_build2_loc (input_location
, BIT_AND_EXPR
, type
, args
[1],
4773 fold_build1_loc (input_location
, BIT_NOT_EXPR
,
4775 se
->expr
= fold_build2_loc (input_location
, BIT_IOR_EXPR
, type
,
4780 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4781 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4784 gfc_conv_intrinsic_mask (gfc_se
* se
, gfc_expr
* expr
, int left
)
4786 tree arg
, allones
, type
, utype
, res
, cond
, bitsize
;
4789 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4790 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4792 type
= gfc_get_int_type (expr
->ts
.kind
);
4793 utype
= unsigned_type_for (type
);
4795 i
= gfc_validate_kind (BT_INTEGER
, expr
->ts
.kind
, false);
4796 bitsize
= build_int_cst (TREE_TYPE (arg
), gfc_integer_kinds
[i
].bit_size
);
4798 allones
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
,
4799 build_int_cst (utype
, 0));
4803 /* Left-justified mask. */
4804 res
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (arg
),
4806 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4807 fold_convert (utype
, res
));
4809 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4810 smaller than type width. */
4811 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4812 build_int_cst (TREE_TYPE (arg
), 0));
4813 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
, cond
,
4814 build_int_cst (utype
, 0), res
);
4818 /* Right-justified mask. */
4819 res
= fold_build2_loc (input_location
, LSHIFT_EXPR
, utype
, allones
,
4820 fold_convert (utype
, arg
));
4821 res
= fold_build1_loc (input_location
, BIT_NOT_EXPR
, utype
, res
);
4823 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4824 strictly smaller than type width. */
4825 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4827 res
= fold_build3_loc (input_location
, COND_EXPR
, utype
,
4828 cond
, allones
, res
);
4831 se
->expr
= fold_convert (type
, res
);
4835 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4837 gfc_conv_intrinsic_fraction (gfc_se
* se
, gfc_expr
* expr
)
4839 tree arg
, type
, tmp
, frexp
;
4841 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4843 type
= gfc_typenode_for_spec (&expr
->ts
);
4844 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4845 tmp
= gfc_create_var (integer_type_node
, NULL
);
4846 se
->expr
= build_call_expr_loc (input_location
, frexp
, 2,
4847 fold_convert (type
, arg
),
4848 gfc_build_addr_expr (NULL_TREE
, tmp
));
4849 se
->expr
= fold_convert (type
, se
->expr
);
4853 /* NEAREST (s, dir) is translated into
4854 tmp = copysign (HUGE_VAL, dir);
4855 return nextafter (s, tmp);
4858 gfc_conv_intrinsic_nearest (gfc_se
* se
, gfc_expr
* expr
)
4860 tree args
[2], type
, tmp
, nextafter
, copysign
, huge_val
;
4862 nextafter
= gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER
, expr
->ts
.kind
);
4863 copysign
= gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN
, expr
->ts
.kind
);
4865 type
= gfc_typenode_for_spec (&expr
->ts
);
4866 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
4868 huge_val
= gfc_build_inf_or_huge (type
, expr
->ts
.kind
);
4869 tmp
= build_call_expr_loc (input_location
, copysign
, 2, huge_val
,
4870 fold_convert (type
, args
[1]));
4871 se
->expr
= build_call_expr_loc (input_location
, nextafter
, 2,
4872 fold_convert (type
, args
[0]), tmp
);
4873 se
->expr
= fold_convert (type
, se
->expr
);
4877 /* SPACING (s) is translated into
4885 e = MAX_EXPR (e, emin);
4886 res = scalbn (1., e);
4890 where prec is the precision of s, gfc_real_kinds[k].digits,
4891 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4892 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4895 gfc_conv_intrinsic_spacing (gfc_se
* se
, gfc_expr
* expr
)
4897 tree arg
, type
, prec
, emin
, tiny
, res
, e
;
4898 tree cond
, tmp
, frexp
, scalbn
;
4902 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4903 prec
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].digits
);
4904 emin
= build_int_cst (integer_type_node
, gfc_real_kinds
[k
].min_exponent
- 1);
4905 tiny
= gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].tiny
, expr
->ts
.kind
, 0);
4907 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4908 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4910 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4911 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4913 type
= gfc_typenode_for_spec (&expr
->ts
);
4914 e
= gfc_create_var (integer_type_node
, NULL
);
4915 res
= gfc_create_var (type
, NULL
);
4918 /* Build the block for s /= 0. */
4919 gfc_start_block (&block
);
4920 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4921 gfc_build_addr_expr (NULL_TREE
, e
));
4922 gfc_add_expr_to_block (&block
, tmp
);
4924 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
, e
,
4926 gfc_add_modify (&block
, e
, fold_build2_loc (input_location
, MAX_EXPR
,
4927 integer_type_node
, tmp
, emin
));
4929 tmp
= build_call_expr_loc (input_location
, scalbn
, 2,
4930 build_real_from_int_cst (type
, integer_one_node
), e
);
4931 gfc_add_modify (&block
, res
, tmp
);
4933 /* Finish by building the IF statement. */
4934 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, arg
,
4935 build_real_from_int_cst (type
, integer_zero_node
));
4936 tmp
= build3_v (COND_EXPR
, cond
, build2_v (MODIFY_EXPR
, res
, tiny
),
4937 gfc_finish_block (&block
));
4939 gfc_add_expr_to_block (&se
->pre
, tmp
);
4944 /* RRSPACING (s) is translated into
4951 x = scalbn (x, precision - e);
4955 where precision is gfc_real_kinds[k].digits. */
4958 gfc_conv_intrinsic_rrspacing (gfc_se
* se
, gfc_expr
* expr
)
4960 tree arg
, type
, e
, x
, cond
, stmt
, tmp
, frexp
, scalbn
, fabs
;
4964 k
= gfc_validate_kind (BT_REAL
, expr
->ts
.kind
, false);
4965 prec
= gfc_real_kinds
[k
].digits
;
4967 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
4968 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
4969 fabs
= gfc_builtin_decl_for_float_kind (BUILT_IN_FABS
, expr
->ts
.kind
);
4971 type
= gfc_typenode_for_spec (&expr
->ts
);
4972 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
4973 arg
= gfc_evaluate_now (arg
, &se
->pre
);
4975 e
= gfc_create_var (integer_type_node
, NULL
);
4976 x
= gfc_create_var (type
, NULL
);
4977 gfc_add_modify (&se
->pre
, x
,
4978 build_call_expr_loc (input_location
, fabs
, 1, arg
));
4981 gfc_start_block (&block
);
4982 tmp
= build_call_expr_loc (input_location
, frexp
, 2, arg
,
4983 gfc_build_addr_expr (NULL_TREE
, e
));
4984 gfc_add_expr_to_block (&block
, tmp
);
4986 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
4987 build_int_cst (integer_type_node
, prec
), e
);
4988 tmp
= build_call_expr_loc (input_location
, scalbn
, 2, x
, tmp
);
4989 gfc_add_modify (&block
, x
, tmp
);
4990 stmt
= gfc_finish_block (&block
);
4992 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, x
,
4993 build_real_from_int_cst (type
, integer_zero_node
));
4994 tmp
= build3_v (COND_EXPR
, cond
, stmt
, build_empty_stmt (input_location
));
4995 gfc_add_expr_to_block (&se
->pre
, tmp
);
4997 se
->expr
= fold_convert (type
, x
);
5001 /* SCALE (s, i) is translated into scalbn (s, i). */
5003 gfc_conv_intrinsic_scale (gfc_se
* se
, gfc_expr
* expr
)
5005 tree args
[2], type
, scalbn
;
5007 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5009 type
= gfc_typenode_for_spec (&expr
->ts
);
5010 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5011 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2,
5012 fold_convert (type
, args
[0]),
5013 fold_convert (integer_type_node
, args
[1]));
5014 se
->expr
= fold_convert (type
, se
->expr
);
5018 /* SET_EXPONENT (s, i) is translated into
5019 scalbn (frexp (s, &dummy_int), i). */
5021 gfc_conv_intrinsic_set_exponent (gfc_se
* se
, gfc_expr
* expr
)
5023 tree args
[2], type
, tmp
, frexp
, scalbn
;
5025 frexp
= gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP
, expr
->ts
.kind
);
5026 scalbn
= gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN
, expr
->ts
.kind
);
5028 type
= gfc_typenode_for_spec (&expr
->ts
);
5029 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5031 tmp
= gfc_create_var (integer_type_node
, NULL
);
5032 tmp
= build_call_expr_loc (input_location
, frexp
, 2,
5033 fold_convert (type
, args
[0]),
5034 gfc_build_addr_expr (NULL_TREE
, tmp
));
5035 se
->expr
= build_call_expr_loc (input_location
, scalbn
, 2, tmp
,
5036 fold_convert (integer_type_node
, args
[1]));
5037 se
->expr
= fold_convert (type
, se
->expr
);
5042 gfc_conv_intrinsic_size (gfc_se
* se
, gfc_expr
* expr
)
5044 gfc_actual_arglist
*actual
;
5052 gfc_init_se (&argse
, NULL
);
5053 actual
= expr
->value
.function
.actual
;
5055 if (actual
->expr
->ts
.type
== BT_CLASS
)
5056 gfc_add_class_array_ref (actual
->expr
);
5058 ss
= gfc_walk_expr (actual
->expr
);
5059 gcc_assert (ss
!= gfc_ss_terminator
);
5060 argse
.want_pointer
= 1;
5061 argse
.data_not_needed
= 1;
5062 gfc_conv_expr_descriptor (&argse
, actual
->expr
, ss
);
5063 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5064 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5065 arg1
= gfc_evaluate_now (argse
.expr
, &se
->pre
);
5067 /* Build the call to size0. */
5068 fncall0
= build_call_expr_loc (input_location
,
5069 gfor_fndecl_size0
, 1, arg1
);
5071 actual
= actual
->next
;
5075 gfc_init_se (&argse
, NULL
);
5076 gfc_conv_expr_type (&argse
, actual
->expr
,
5077 gfc_array_index_type
);
5078 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5080 /* Unusually, for an intrinsic, size does not exclude
5081 an optional arg2, so we must test for it. */
5082 if (actual
->expr
->expr_type
== EXPR_VARIABLE
5083 && actual
->expr
->symtree
->n
.sym
->attr
.dummy
5084 && actual
->expr
->symtree
->n
.sym
->attr
.optional
)
5087 /* Build the call to size1. */
5088 fncall1
= build_call_expr_loc (input_location
,
5089 gfor_fndecl_size1
, 2,
5092 gfc_init_se (&argse
, NULL
);
5093 argse
.want_pointer
= 1;
5094 argse
.data_not_needed
= 1;
5095 gfc_conv_expr (&argse
, actual
->expr
);
5096 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5097 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5098 argse
.expr
, null_pointer_node
);
5099 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5100 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
,
5101 pvoid_type_node
, tmp
, fncall1
, fncall0
);
5105 se
->expr
= NULL_TREE
;
5106 argse
.expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5107 gfc_array_index_type
,
5108 argse
.expr
, gfc_index_one_node
);
5111 else if (expr
->value
.function
.actual
->expr
->rank
== 1)
5113 argse
.expr
= gfc_index_zero_node
;
5114 se
->expr
= NULL_TREE
;
5119 if (se
->expr
== NULL_TREE
)
5121 tree ubound
, lbound
;
5123 arg1
= build_fold_indirect_ref_loc (input_location
,
5125 ubound
= gfc_conv_descriptor_ubound_get (arg1
, argse
.expr
);
5126 lbound
= gfc_conv_descriptor_lbound_get (arg1
, argse
.expr
);
5127 se
->expr
= fold_build2_loc (input_location
, MINUS_EXPR
,
5128 gfc_array_index_type
, ubound
, lbound
);
5129 se
->expr
= fold_build2_loc (input_location
, PLUS_EXPR
,
5130 gfc_array_index_type
,
5131 se
->expr
, gfc_index_one_node
);
5132 se
->expr
= fold_build2_loc (input_location
, MAX_EXPR
,
5133 gfc_array_index_type
, se
->expr
,
5134 gfc_index_zero_node
);
5137 type
= gfc_typenode_for_spec (&expr
->ts
);
5138 se
->expr
= convert (type
, se
->expr
);
5142 /* Helper function to compute the size of a character variable,
5143 excluding the terminating null characters. The result has
5144 gfc_array_index_type type. */
5147 size_of_string_in_bytes (int kind
, tree string_length
)
5150 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
5152 bytesize
= build_int_cst (gfc_array_index_type
,
5153 gfc_character_kinds
[i
].bit_size
/ 8);
5155 return fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5157 fold_convert (gfc_array_index_type
, string_length
));
5162 gfc_conv_intrinsic_sizeof (gfc_se
*se
, gfc_expr
*expr
)
5174 arg
= expr
->value
.function
.actual
->expr
;
5176 gfc_init_se (&argse
, NULL
);
5177 ss
= gfc_walk_expr (arg
);
5179 if (ss
== gfc_ss_terminator
)
5181 if (arg
->ts
.type
== BT_CLASS
)
5182 gfc_add_data_component (arg
);
5184 gfc_conv_expr_reference (&argse
, arg
);
5186 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5189 /* Obtain the source word length. */
5190 if (arg
->ts
.type
== BT_CHARACTER
)
5191 se
->expr
= size_of_string_in_bytes (arg
->ts
.kind
,
5192 argse
.string_length
);
5194 se
->expr
= fold_convert (gfc_array_index_type
, size_in_bytes (type
));
5198 source_bytes
= gfc_create_var (gfc_array_index_type
, "bytes");
5199 argse
.want_pointer
= 0;
5200 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
5201 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5203 /* Obtain the argument's word length. */
5204 if (arg
->ts
.type
== BT_CHARACTER
)
5205 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5207 tmp
= fold_convert (gfc_array_index_type
,
5208 size_in_bytes (type
));
5209 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5211 /* Obtain the size of the array in bytes. */
5212 for (n
= 0; n
< arg
->rank
; n
++)
5215 idx
= gfc_rank_cst
[n
];
5216 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5217 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5218 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5219 gfc_array_index_type
, upper
, lower
);
5220 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5221 gfc_array_index_type
, tmp
, gfc_index_one_node
);
5222 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5223 gfc_array_index_type
, tmp
, source_bytes
);
5224 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5226 se
->expr
= source_bytes
;
5229 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5234 gfc_conv_intrinsic_storage_size (gfc_se
*se
, gfc_expr
*expr
)
5239 tree type
, result_type
, tmp
;
5241 arg
= expr
->value
.function
.actual
->expr
;
5242 gfc_init_se (&eight
, NULL
);
5243 gfc_conv_expr (&eight
, gfc_get_int_expr (expr
->ts
.kind
, NULL
, 8));
5245 gfc_init_se (&argse
, NULL
);
5246 ss
= gfc_walk_expr (arg
);
5247 result_type
= gfc_get_int_type (expr
->ts
.kind
);
5249 if (ss
== gfc_ss_terminator
)
5251 if (arg
->ts
.type
== BT_CLASS
)
5253 gfc_add_vptr_component (arg
);
5254 gfc_add_size_component (arg
);
5255 gfc_conv_expr (&argse
, arg
);
5256 tmp
= fold_convert (result_type
, argse
.expr
);
5260 gfc_conv_expr_reference (&argse
, arg
);
5261 type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5266 argse
.want_pointer
= 0;
5267 gfc_conv_expr_descriptor (&argse
, arg
, ss
);
5268 type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5271 /* Obtain the argument's word length. */
5272 if (arg
->ts
.type
== BT_CHARACTER
)
5273 tmp
= size_of_string_in_bytes (arg
->ts
.kind
, argse
.string_length
);
5275 tmp
= fold_convert (result_type
, size_in_bytes (type
));
5278 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, result_type
, tmp
,
5280 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5284 /* Intrinsic string comparison functions. */
5287 gfc_conv_intrinsic_strcmp (gfc_se
* se
, gfc_expr
* expr
, enum tree_code op
)
5291 gfc_conv_intrinsic_function_args (se
, expr
, args
, 4);
5294 = gfc_build_compare_string (args
[0], args
[1], args
[2], args
[3],
5295 expr
->value
.function
.actual
->expr
->ts
.kind
,
5297 se
->expr
= fold_build2_loc (input_location
, op
,
5298 gfc_typenode_for_spec (&expr
->ts
), se
->expr
,
5299 build_int_cst (TREE_TYPE (se
->expr
), 0));
5302 /* Generate a call to the adjustl/adjustr library function. */
5304 gfc_conv_intrinsic_adjust (gfc_se
* se
, gfc_expr
* expr
, tree fndecl
)
5312 gfc_conv_intrinsic_function_args (se
, expr
, &args
[1], 2);
5315 type
= TREE_TYPE (args
[2]);
5316 var
= gfc_conv_string_tmp (se
, type
, len
);
5319 tmp
= build_call_expr_loc (input_location
,
5320 fndecl
, 3, args
[0], args
[1], args
[2]);
5321 gfc_add_expr_to_block (&se
->pre
, tmp
);
5323 se
->string_length
= len
;
5327 /* Generate code for the TRANSFER intrinsic:
5329 DEST = TRANSFER (SOURCE, MOLD)
5331 typeof<DEST> = typeof<MOLD>
5336 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5338 typeof<DEST> = typeof<MOLD>
5340 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5341 sizeof (DEST(0) * SIZE). */
5343 gfc_conv_intrinsic_transfer (gfc_se
* se
, gfc_expr
* expr
)
5359 gfc_actual_arglist
*arg
;
5362 gfc_array_info
*info
;
5369 info
= &se
->ss
->info
->data
.array
;
5371 /* Convert SOURCE. The output from this stage is:-
5372 source_bytes = length of the source in bytes
5373 source = pointer to the source data. */
5374 arg
= expr
->value
.function
.actual
;
5376 /* Ensure double transfer through LOGICAL preserves all
5378 if (arg
->expr
->expr_type
== EXPR_FUNCTION
5379 && arg
->expr
->value
.function
.esym
== NULL
5380 && arg
->expr
->value
.function
.isym
!= NULL
5381 && arg
->expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
5382 && arg
->expr
->ts
.type
== BT_LOGICAL
5383 && expr
->ts
.type
!= arg
->expr
->ts
.type
)
5384 arg
->expr
->value
.function
.name
= "__transfer_in_transfer";
5386 gfc_init_se (&argse
, NULL
);
5387 ss
= gfc_walk_expr (arg
->expr
);
5389 source_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5391 /* Obtain the pointer to source and the length of source in bytes. */
5392 if (ss
== gfc_ss_terminator
)
5394 gfc_conv_expr_reference (&argse
, arg
->expr
);
5395 source
= argse
.expr
;
5397 source_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5400 /* Obtain the source word length. */
5401 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5402 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5403 argse
.string_length
);
5405 tmp
= fold_convert (gfc_array_index_type
,
5406 size_in_bytes (source_type
));
5410 argse
.want_pointer
= 0;
5411 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
5412 source
= gfc_conv_descriptor_data_get (argse
.expr
);
5413 source_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5415 /* Repack the source if not a full variable array. */
5416 if (arg
->expr
->expr_type
== EXPR_VARIABLE
5417 && arg
->expr
->ref
->u
.ar
.type
!= AR_FULL
)
5419 tmp
= gfc_build_addr_expr (NULL_TREE
, argse
.expr
);
5421 if (gfc_option
.warn_array_temp
)
5422 gfc_warning ("Creating array temporary at %L", &expr
->where
);
5424 source
= build_call_expr_loc (input_location
,
5425 gfor_fndecl_in_pack
, 1, tmp
);
5426 source
= gfc_evaluate_now (source
, &argse
.pre
);
5428 /* Free the temporary. */
5429 gfc_start_block (&block
);
5430 tmp
= gfc_call_free (convert (pvoid_type_node
, source
));
5431 gfc_add_expr_to_block (&block
, tmp
);
5432 stmt
= gfc_finish_block (&block
);
5434 /* Clean up if it was repacked. */
5435 gfc_init_block (&block
);
5436 tmp
= gfc_conv_array_data (argse
.expr
);
5437 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5439 tmp
= build3_v (COND_EXPR
, tmp
, stmt
,
5440 build_empty_stmt (input_location
));
5441 gfc_add_expr_to_block (&block
, tmp
);
5442 gfc_add_block_to_block (&block
, &se
->post
);
5443 gfc_init_block (&se
->post
);
5444 gfc_add_block_to_block (&se
->post
, &block
);
5447 /* Obtain the source word length. */
5448 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5449 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
,
5450 argse
.string_length
);
5452 tmp
= fold_convert (gfc_array_index_type
,
5453 size_in_bytes (source_type
));
5455 /* Obtain the size of the array in bytes. */
5456 extent
= gfc_create_var (gfc_array_index_type
, NULL
);
5457 for (n
= 0; n
< arg
->expr
->rank
; n
++)
5460 idx
= gfc_rank_cst
[n
];
5461 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5462 lower
= gfc_conv_descriptor_lbound_get (argse
.expr
, idx
);
5463 upper
= gfc_conv_descriptor_ubound_get (argse
.expr
, idx
);
5464 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5465 gfc_array_index_type
, upper
, lower
);
5466 gfc_add_modify (&argse
.pre
, extent
, tmp
);
5467 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5468 gfc_array_index_type
, extent
,
5469 gfc_index_one_node
);
5470 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5471 gfc_array_index_type
, tmp
, source_bytes
);
5475 gfc_add_modify (&argse
.pre
, source_bytes
, tmp
);
5476 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5477 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5479 /* Now convert MOLD. The outputs are:
5480 mold_type = the TREE type of MOLD
5481 dest_word_len = destination word length in bytes. */
5484 gfc_init_se (&argse
, NULL
);
5485 ss
= gfc_walk_expr (arg
->expr
);
5487 scalar_mold
= arg
->expr
->rank
== 0;
5489 if (ss
== gfc_ss_terminator
)
5491 gfc_conv_expr_reference (&argse
, arg
->expr
);
5492 mold_type
= TREE_TYPE (build_fold_indirect_ref_loc (input_location
,
5497 gfc_init_se (&argse
, NULL
);
5498 argse
.want_pointer
= 0;
5499 gfc_conv_expr_descriptor (&argse
, arg
->expr
, ss
);
5500 mold_type
= gfc_get_element_type (TREE_TYPE (argse
.expr
));
5503 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5504 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5506 if (strcmp (expr
->value
.function
.name
, "__transfer_in_transfer") == 0)
5508 /* If this TRANSFER is nested in another TRANSFER, use a type
5509 that preserves all bits. */
5510 if (arg
->expr
->ts
.type
== BT_LOGICAL
)
5511 mold_type
= gfc_get_int_type (arg
->expr
->ts
.kind
);
5514 if (arg
->expr
->ts
.type
== BT_CHARACTER
)
5516 tmp
= size_of_string_in_bytes (arg
->expr
->ts
.kind
, argse
.string_length
);
5517 mold_type
= gfc_get_character_type_len (arg
->expr
->ts
.kind
, tmp
);
5520 tmp
= fold_convert (gfc_array_index_type
,
5521 size_in_bytes (mold_type
));
5523 dest_word_len
= gfc_create_var (gfc_array_index_type
, NULL
);
5524 gfc_add_modify (&se
->pre
, dest_word_len
, tmp
);
5526 /* Finally convert SIZE, if it is present. */
5528 size_words
= gfc_create_var (gfc_array_index_type
, NULL
);
5532 gfc_init_se (&argse
, NULL
);
5533 gfc_conv_expr_reference (&argse
, arg
->expr
);
5534 tmp
= convert (gfc_array_index_type
,
5535 build_fold_indirect_ref_loc (input_location
,
5537 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5538 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5543 /* Separate array and scalar results. */
5544 if (scalar_mold
&& tmp
== NULL_TREE
)
5545 goto scalar_transfer
;
5547 size_bytes
= gfc_create_var (gfc_array_index_type
, NULL
);
5548 if (tmp
!= NULL_TREE
)
5549 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5550 tmp
, dest_word_len
);
5554 gfc_add_modify (&se
->pre
, size_bytes
, tmp
);
5555 gfc_add_modify (&se
->pre
, size_words
,
5556 fold_build2_loc (input_location
, CEIL_DIV_EXPR
,
5557 gfc_array_index_type
,
5558 size_bytes
, dest_word_len
));
5560 /* Evaluate the bounds of the result. If the loop range exists, we have
5561 to check if it is too large. If so, we modify loop->to be consistent
5562 with min(size, size(source)). Otherwise, size is made consistent with
5563 the loop range, so that the right number of bytes is transferred.*/
5564 n
= se
->loop
->order
[0];
5565 if (se
->loop
->to
[n
] != NULL_TREE
)
5567 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5568 se
->loop
->to
[n
], se
->loop
->from
[n
]);
5569 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5570 tmp
, gfc_index_one_node
);
5571 tmp
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5573 gfc_add_modify (&se
->pre
, size_words
, tmp
);
5574 gfc_add_modify (&se
->pre
, size_bytes
,
5575 fold_build2_loc (input_location
, MULT_EXPR
,
5576 gfc_array_index_type
,
5577 size_words
, dest_word_len
));
5578 upper
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5579 size_words
, se
->loop
->from
[n
]);
5580 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5581 upper
, gfc_index_one_node
);
5585 upper
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5586 size_words
, gfc_index_one_node
);
5587 se
->loop
->from
[n
] = gfc_index_zero_node
;
5590 se
->loop
->to
[n
] = upper
;
5592 /* Build a destination descriptor, using the pointer, source, as the
5594 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
, mold_type
,
5595 NULL_TREE
, false, true, false, &expr
->where
);
5597 /* Cast the pointer to the result. */
5598 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5599 tmp
= fold_convert (pvoid_type_node
, tmp
);
5601 /* Use memcpy to do the transfer. */
5602 tmp
= build_call_expr_loc (input_location
,
5603 builtin_decl_explicit (BUILT_IN_MEMCPY
),
5606 fold_convert (pvoid_type_node
, source
),
5607 fold_build2_loc (input_location
, MIN_EXPR
,
5608 gfc_array_index_type
,
5609 size_bytes
, source_bytes
));
5610 gfc_add_expr_to_block (&se
->pre
, tmp
);
5612 se
->expr
= info
->descriptor
;
5613 if (expr
->ts
.type
== BT_CHARACTER
)
5614 se
->string_length
= fold_convert (gfc_charlen_type_node
, dest_word_len
);
5618 /* Deal with scalar results. */
5620 extent
= fold_build2_loc (input_location
, MIN_EXPR
, gfc_array_index_type
,
5621 dest_word_len
, source_bytes
);
5622 extent
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_array_index_type
,
5623 extent
, gfc_index_zero_node
);
5625 if (expr
->ts
.type
== BT_CHARACTER
)
5630 ptr
= convert (gfc_get_pchar_type (expr
->ts
.kind
), source
);
5631 tmpdecl
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
),
5634 /* If source is longer than the destination, use a pointer to
5635 the source directly. */
5636 gfc_init_block (&block
);
5637 gfc_add_modify (&block
, tmpdecl
, ptr
);
5638 direct
= gfc_finish_block (&block
);
5640 /* Otherwise, allocate a string with the length of the destination
5641 and copy the source into it. */
5642 gfc_init_block (&block
);
5643 tmp
= gfc_get_pchar_type (expr
->ts
.kind
);
5644 tmp
= gfc_call_malloc (&block
, tmp
, dest_word_len
);
5645 gfc_add_modify (&block
, tmpdecl
,
5646 fold_convert (TREE_TYPE (ptr
), tmp
));
5647 tmp
= build_call_expr_loc (input_location
,
5648 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5649 fold_convert (pvoid_type_node
, tmpdecl
),
5650 fold_convert (pvoid_type_node
, ptr
),
5652 gfc_add_expr_to_block (&block
, tmp
);
5653 indirect
= gfc_finish_block (&block
);
5655 /* Wrap it up with the condition. */
5656 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
5657 dest_word_len
, source_bytes
);
5658 tmp
= build3_v (COND_EXPR
, tmp
, direct
, indirect
);
5659 gfc_add_expr_to_block (&se
->pre
, tmp
);
5662 se
->string_length
= dest_word_len
;
5666 tmpdecl
= gfc_create_var (mold_type
, "transfer");
5668 ptr
= convert (build_pointer_type (mold_type
), source
);
5670 /* Use memcpy to do the transfer. */
5671 tmp
= gfc_build_addr_expr (NULL_TREE
, tmpdecl
);
5672 tmp
= build_call_expr_loc (input_location
,
5673 builtin_decl_explicit (BUILT_IN_MEMCPY
), 3,
5674 fold_convert (pvoid_type_node
, tmp
),
5675 fold_convert (pvoid_type_node
, ptr
),
5677 gfc_add_expr_to_block (&se
->pre
, tmp
);
5684 /* Generate code for the ALLOCATED intrinsic.
5685 Generate inline code that directly check the address of the argument. */
5688 gfc_conv_allocated (gfc_se
*se
, gfc_expr
*expr
)
5690 gfc_actual_arglist
*arg1
;
5695 gfc_init_se (&arg1se
, NULL
);
5696 arg1
= expr
->value
.function
.actual
;
5698 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5700 /* Make sure that class array expressions have both a _data
5701 component reference and an array reference.... */
5702 if (CLASS_DATA (arg1
->expr
)->attr
.dimension
)
5703 gfc_add_class_array_ref (arg1
->expr
);
5704 /* .... whilst scalars only need the _data component. */
5706 gfc_add_data_component (arg1
->expr
);
5709 ss1
= gfc_walk_expr (arg1
->expr
);
5711 if (ss1
== gfc_ss_terminator
)
5713 /* Allocatable scalar. */
5714 arg1se
.want_pointer
= 1;
5715 gfc_conv_expr (&arg1se
, arg1
->expr
);
5720 /* Allocatable array. */
5721 arg1se
.descriptor_only
= 1;
5722 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5723 tmp
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5726 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
5727 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5728 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5732 /* Generate code for the ASSOCIATED intrinsic.
5733 If both POINTER and TARGET are arrays, generate a call to library function
5734 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5735 In other cases, generate inline code that directly compare the address of
5736 POINTER with the address of TARGET. */
5739 gfc_conv_associated (gfc_se
*se
, gfc_expr
*expr
)
5741 gfc_actual_arglist
*arg1
;
5742 gfc_actual_arglist
*arg2
;
5747 tree nonzero_charlen
;
5748 tree nonzero_arraylen
;
5751 gfc_init_se (&arg1se
, NULL
);
5752 gfc_init_se (&arg2se
, NULL
);
5753 arg1
= expr
->value
.function
.actual
;
5754 if (arg1
->expr
->ts
.type
== BT_CLASS
)
5755 gfc_add_data_component (arg1
->expr
);
5757 ss1
= gfc_walk_expr (arg1
->expr
);
5761 /* No optional target. */
5762 if (ss1
== gfc_ss_terminator
)
5764 /* A pointer to a scalar. */
5765 arg1se
.want_pointer
= 1;
5766 gfc_conv_expr (&arg1se
, arg1
->expr
);
5771 /* A pointer to an array. */
5772 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5773 tmp2
= gfc_conv_descriptor_data_get (arg1se
.expr
);
5775 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5776 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5777 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
5778 fold_convert (TREE_TYPE (tmp2
), null_pointer_node
));
5783 /* An optional target. */
5784 if (arg2
->expr
->ts
.type
== BT_CLASS
)
5785 gfc_add_data_component (arg2
->expr
);
5786 ss2
= gfc_walk_expr (arg2
->expr
);
5788 nonzero_charlen
= NULL_TREE
;
5789 if (arg1
->expr
->ts
.type
== BT_CHARACTER
)
5790 nonzero_charlen
= fold_build2_loc (input_location
, NE_EXPR
,
5792 arg1
->expr
->ts
.u
.cl
->backend_decl
,
5795 if (ss1
== gfc_ss_terminator
)
5797 /* A pointer to a scalar. */
5798 gcc_assert (ss2
== gfc_ss_terminator
);
5799 arg1se
.want_pointer
= 1;
5800 gfc_conv_expr (&arg1se
, arg1
->expr
);
5801 arg2se
.want_pointer
= 1;
5802 gfc_conv_expr (&arg2se
, arg2
->expr
);
5803 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
5804 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
5805 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5806 arg1se
.expr
, arg2se
.expr
);
5807 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5808 arg1se
.expr
, null_pointer_node
);
5809 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5810 boolean_type_node
, tmp
, tmp2
);
5814 /* An array pointer of zero length is not associated if target is
5816 arg1se
.descriptor_only
= 1;
5817 gfc_conv_expr_lhs (&arg1se
, arg1
->expr
);
5818 tmp
= gfc_conv_descriptor_stride_get (arg1se
.expr
,
5819 gfc_rank_cst
[arg1
->expr
->rank
- 1]);
5820 nonzero_arraylen
= fold_build2_loc (input_location
, NE_EXPR
,
5821 boolean_type_node
, tmp
,
5822 build_int_cst (TREE_TYPE (tmp
), 0));
5824 /* A pointer to an array, call library function _gfor_associated. */
5825 gcc_assert (ss2
!= gfc_ss_terminator
);
5826 arg1se
.want_pointer
= 1;
5827 gfc_conv_expr_descriptor (&arg1se
, arg1
->expr
, ss1
);
5829 arg2se
.want_pointer
= 1;
5830 gfc_conv_expr_descriptor (&arg2se
, arg2
->expr
, ss2
);
5831 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
5832 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
5833 se
->expr
= build_call_expr_loc (input_location
,
5834 gfor_fndecl_associated
, 2,
5835 arg1se
.expr
, arg2se
.expr
);
5836 se
->expr
= convert (boolean_type_node
, se
->expr
);
5837 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5838 boolean_type_node
, se
->expr
,
5842 /* If target is present zero character length pointers cannot
5844 if (nonzero_charlen
!= NULL_TREE
)
5845 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5847 se
->expr
, nonzero_charlen
);
5850 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5854 /* Generate code for the SAME_TYPE_AS intrinsic.
5855 Generate inline code that directly checks the vindices. */
5858 gfc_conv_same_type_as (gfc_se
*se
, gfc_expr
*expr
)
5864 gfc_init_se (&se1
, NULL
);
5865 gfc_init_se (&se2
, NULL
);
5867 a
= expr
->value
.function
.actual
->expr
;
5868 b
= expr
->value
.function
.actual
->next
->expr
;
5870 if (a
->ts
.type
== BT_CLASS
)
5872 gfc_add_vptr_component (a
);
5873 gfc_add_hash_component (a
);
5875 else if (a
->ts
.type
== BT_DERIVED
)
5876 a
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5877 a
->ts
.u
.derived
->hash_value
);
5879 if (b
->ts
.type
== BT_CLASS
)
5881 gfc_add_vptr_component (b
);
5882 gfc_add_hash_component (b
);
5884 else if (b
->ts
.type
== BT_DERIVED
)
5885 b
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5886 b
->ts
.u
.derived
->hash_value
);
5888 gfc_conv_expr (&se1
, a
);
5889 gfc_conv_expr (&se2
, b
);
5891 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5892 se1
.expr
, fold_convert (TREE_TYPE (se1
.expr
), se2
.expr
));
5893 se
->expr
= convert (gfc_typenode_for_spec (&expr
->ts
), tmp
);
5897 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
5900 gfc_conv_intrinsic_sc_kind (gfc_se
*se
, gfc_expr
*expr
)
5904 gfc_conv_intrinsic_function_args (se
, expr
, args
, 2);
5905 se
->expr
= build_call_expr_loc (input_location
,
5906 gfor_fndecl_sc_kind
, 2, args
[0], args
[1]);
5907 se
->expr
= fold_convert (gfc_typenode_for_spec (&expr
->ts
), se
->expr
);
5911 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
5914 gfc_conv_intrinsic_si_kind (gfc_se
*se
, gfc_expr
*expr
)
5918 gfc_conv_intrinsic_function_args (se
, expr
, &arg
, 1);
5920 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5921 type
= gfc_get_int_type (4);
5922 arg
= gfc_build_addr_expr (NULL_TREE
, fold_convert (type
, arg
));
5924 /* Convert it to the required type. */
5925 type
= gfc_typenode_for_spec (&expr
->ts
);
5926 se
->expr
= build_call_expr_loc (input_location
,
5927 gfor_fndecl_si_kind
, 1, arg
);
5928 se
->expr
= fold_convert (type
, se
->expr
);
5932 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
5935 gfc_conv_intrinsic_sr_kind (gfc_se
*se
, gfc_expr
*expr
)
5937 gfc_actual_arglist
*actual
;
5940 VEC(tree
,gc
) *args
= NULL
;
5942 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
5944 gfc_init_se (&argse
, se
);
5946 /* Pass a NULL pointer for an absent arg. */
5947 if (actual
->expr
== NULL
)
5948 argse
.expr
= null_pointer_node
;
5954 if (actual
->expr
->ts
.kind
!= gfc_c_int_kind
)
5956 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
5957 ts
.type
= BT_INTEGER
;
5958 ts
.kind
= gfc_c_int_kind
;
5959 gfc_convert_type (actual
->expr
, &ts
, 2);
5961 gfc_conv_expr_reference (&argse
, actual
->expr
);
5964 gfc_add_block_to_block (&se
->pre
, &argse
.pre
);
5965 gfc_add_block_to_block (&se
->post
, &argse
.post
);
5966 VEC_safe_push (tree
, gc
, args
, argse
.expr
);
5969 /* Convert it to the required type. */
5970 type
= gfc_typenode_for_spec (&expr
->ts
);
5971 se
->expr
= build_call_expr_loc_vec (input_location
,
5972 gfor_fndecl_sr_kind
, args
);
5973 se
->expr
= fold_convert (type
, se
->expr
);
5977 /* Generate code for TRIM (A) intrinsic function. */
5980 gfc_conv_intrinsic_trim (gfc_se
* se
, gfc_expr
* expr
)
5990 unsigned int num_args
;
5992 num_args
= gfc_intrinsic_argument_list_length (expr
) + 2;
5993 args
= XALLOCAVEC (tree
, num_args
);
5995 var
= gfc_create_var (gfc_get_pchar_type (expr
->ts
.kind
), "pstr");
5996 addr
= gfc_build_addr_expr (ppvoid_type_node
, var
);
5997 len
= gfc_create_var (gfc_charlen_type_node
, "len");
5999 gfc_conv_intrinsic_function_args (se
, expr
, &args
[2], num_args
- 2);
6000 args
[0] = gfc_build_addr_expr (NULL_TREE
, len
);
6003 if (expr
->ts
.kind
== 1)
6004 function
= gfor_fndecl_string_trim
;
6005 else if (expr
->ts
.kind
== 4)
6006 function
= gfor_fndecl_string_trim_char4
;
6010 fndecl
= build_addr (function
, current_function_decl
);
6011 tmp
= build_call_array_loc (input_location
,
6012 TREE_TYPE (TREE_TYPE (function
)), fndecl
,
6014 gfc_add_expr_to_block (&se
->pre
, tmp
);
6016 /* Free the temporary afterwards, if necessary. */
6017 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6018 len
, build_int_cst (TREE_TYPE (len
), 0));
6019 tmp
= gfc_call_free (var
);
6020 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt (input_location
));
6021 gfc_add_expr_to_block (&se
->post
, tmp
);
6024 se
->string_length
= len
;
6028 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6031 gfc_conv_intrinsic_repeat (gfc_se
* se
, gfc_expr
* expr
)
6033 tree args
[3], ncopies
, dest
, dlen
, src
, slen
, ncopies_type
;
6034 tree type
, cond
, tmp
, count
, exit_label
, n
, max
, largest
;
6036 stmtblock_t block
, body
;
6039 /* We store in charsize the size of a character. */
6040 i
= gfc_validate_kind (BT_CHARACTER
, expr
->ts
.kind
, false);
6041 size
= build_int_cst (size_type_node
, gfc_character_kinds
[i
].bit_size
/ 8);
6043 /* Get the arguments. */
6044 gfc_conv_intrinsic_function_args (se
, expr
, args
, 3);
6045 slen
= fold_convert (size_type_node
, gfc_evaluate_now (args
[0], &se
->pre
));
6047 ncopies
= gfc_evaluate_now (args
[2], &se
->pre
);
6048 ncopies_type
= TREE_TYPE (ncopies
);
6050 /* Check that NCOPIES is not negative. */
6051 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, ncopies
,
6052 build_int_cst (ncopies_type
, 0));
6053 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6054 "Argument NCOPIES of REPEAT intrinsic is negative "
6055 "(its value is %ld)",
6056 fold_convert (long_integer_type_node
, ncopies
));
6058 /* If the source length is zero, any non negative value of NCOPIES
6059 is valid, and nothing happens. */
6060 n
= gfc_create_var (ncopies_type
, "ncopies");
6061 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6062 build_int_cst (size_type_node
, 0));
6063 tmp
= fold_build3_loc (input_location
, COND_EXPR
, ncopies_type
, cond
,
6064 build_int_cst (ncopies_type
, 0), ncopies
);
6065 gfc_add_modify (&se
->pre
, n
, tmp
);
6068 /* Check that ncopies is not too large: ncopies should be less than
6069 (or equal to) MAX / slen, where MAX is the maximal integer of
6070 the gfc_charlen_type_node type. If slen == 0, we need a special
6071 case to avoid the division by zero. */
6072 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6073 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, gfc_charlen_int_kind
);
6074 max
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
6075 fold_convert (size_type_node
, max
), slen
);
6076 largest
= TYPE_PRECISION (size_type_node
) > TYPE_PRECISION (ncopies_type
)
6077 ? size_type_node
: ncopies_type
;
6078 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
6079 fold_convert (largest
, ncopies
),
6080 fold_convert (largest
, max
));
6081 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, slen
,
6082 build_int_cst (size_type_node
, 0));
6083 cond
= fold_build3_loc (input_location
, COND_EXPR
, boolean_type_node
, tmp
,
6084 boolean_false_node
, cond
);
6085 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &expr
->where
,
6086 "Argument NCOPIES of REPEAT intrinsic is too large");
6088 /* Compute the destination length. */
6089 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6090 fold_convert (gfc_charlen_type_node
, slen
),
6091 fold_convert (gfc_charlen_type_node
, ncopies
));
6092 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
6093 dest
= gfc_conv_string_tmp (se
, build_pointer_type (type
), dlen
);
6095 /* Generate the code to do the repeat operation:
6096 for (i = 0; i < ncopies; i++)
6097 memmove (dest + (i * slen * size), src, slen*size); */
6098 gfc_start_block (&block
);
6099 count
= gfc_create_var (ncopies_type
, "count");
6100 gfc_add_modify (&block
, count
, build_int_cst (ncopies_type
, 0));
6101 exit_label
= gfc_build_label_decl (NULL_TREE
);
6103 /* Start the loop body. */
6104 gfc_start_block (&body
);
6106 /* Exit the loop if count >= ncopies. */
6107 cond
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, count
,
6109 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6110 TREE_USED (exit_label
) = 1;
6111 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6112 build_empty_stmt (input_location
));
6113 gfc_add_expr_to_block (&body
, tmp
);
6115 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6116 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6117 fold_convert (gfc_charlen_type_node
, slen
),
6118 fold_convert (gfc_charlen_type_node
, count
));
6119 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_charlen_type_node
,
6120 tmp
, fold_convert (gfc_charlen_type_node
, size
));
6121 tmp
= fold_build_pointer_plus_loc (input_location
,
6122 fold_convert (pvoid_type_node
, dest
), tmp
);
6123 tmp
= build_call_expr_loc (input_location
,
6124 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6126 fold_build2_loc (input_location
, MULT_EXPR
,
6127 size_type_node
, slen
,
6128 fold_convert (size_type_node
,
6130 gfc_add_expr_to_block (&body
, tmp
);
6132 /* Increment count. */
6133 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, ncopies_type
,
6134 count
, build_int_cst (TREE_TYPE (count
), 1));
6135 gfc_add_modify (&body
, count
, tmp
);
6137 /* Build the loop. */
6138 tmp
= build1_v (LOOP_EXPR
, gfc_finish_block (&body
));
6139 gfc_add_expr_to_block (&block
, tmp
);
6141 /* Add the exit label. */
6142 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6143 gfc_add_expr_to_block (&block
, tmp
);
6145 /* Finish the block. */
6146 tmp
= gfc_finish_block (&block
);
6147 gfc_add_expr_to_block (&se
->pre
, tmp
);
6149 /* Set the result value. */
6151 se
->string_length
= dlen
;
6155 /* Generate code for the IARGC intrinsic. */
6158 gfc_conv_intrinsic_iargc (gfc_se
* se
, gfc_expr
* expr
)
6164 /* Call the library function. This always returns an INTEGER(4). */
6165 fndecl
= gfor_fndecl_iargc
;
6166 tmp
= build_call_expr_loc (input_location
,
6169 /* Convert it to the required type. */
6170 type
= gfc_typenode_for_spec (&expr
->ts
);
6171 tmp
= fold_convert (type
, tmp
);
6177 /* The loc intrinsic returns the address of its argument as
6178 gfc_index_integer_kind integer. */
6181 gfc_conv_intrinsic_loc (gfc_se
* se
, gfc_expr
* expr
)
6187 gcc_assert (!se
->ss
);
6189 arg_expr
= expr
->value
.function
.actual
->expr
;
6190 ss
= gfc_walk_expr (arg_expr
);
6191 if (ss
== gfc_ss_terminator
)
6192 gfc_conv_expr_reference (se
, arg_expr
);
6194 gfc_conv_array_parameter (se
, arg_expr
, ss
, true, NULL
, NULL
, NULL
);
6195 se
->expr
= convert (gfc_get_int_type (gfc_index_integer_kind
), se
->expr
);
6197 /* Create a temporary variable for loc return value. Without this,
6198 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6199 temp_var
= gfc_create_var (gfc_get_int_type (gfc_index_integer_kind
), NULL
);
6200 gfc_add_modify (&se
->pre
, temp_var
, se
->expr
);
6201 se
->expr
= temp_var
;
6204 /* Generate code for an intrinsic function. Some map directly to library
6205 calls, others get special handling. In some cases the name of the function
6206 used depends on the type specifiers. */
6209 gfc_conv_intrinsic_function (gfc_se
* se
, gfc_expr
* expr
)
6215 name
= &expr
->value
.function
.name
[2];
6219 lib
= gfc_is_intrinsic_libcall (expr
);
6223 se
->ignore_optional
= 1;
6225 switch (expr
->value
.function
.isym
->id
)
6227 case GFC_ISYM_EOSHIFT
:
6229 case GFC_ISYM_RESHAPE
:
6230 /* For all of those the first argument specifies the type and the
6231 third is optional. */
6232 conv_generic_with_optional_char_arg (se
, expr
, 1, 3);
6236 gfc_conv_intrinsic_funcall (se
, expr
);
6244 switch (expr
->value
.function
.isym
->id
)
6249 case GFC_ISYM_REPEAT
:
6250 gfc_conv_intrinsic_repeat (se
, expr
);
6254 gfc_conv_intrinsic_trim (se
, expr
);
6257 case GFC_ISYM_SC_KIND
:
6258 gfc_conv_intrinsic_sc_kind (se
, expr
);
6261 case GFC_ISYM_SI_KIND
:
6262 gfc_conv_intrinsic_si_kind (se
, expr
);
6265 case GFC_ISYM_SR_KIND
:
6266 gfc_conv_intrinsic_sr_kind (se
, expr
);
6269 case GFC_ISYM_EXPONENT
:
6270 gfc_conv_intrinsic_exponent (se
, expr
);
6274 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6276 fndecl
= gfor_fndecl_string_scan
;
6278 fndecl
= gfor_fndecl_string_scan_char4
;
6282 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6285 case GFC_ISYM_VERIFY
:
6286 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6288 fndecl
= gfor_fndecl_string_verify
;
6290 fndecl
= gfor_fndecl_string_verify_char4
;
6294 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6297 case GFC_ISYM_ALLOCATED
:
6298 gfc_conv_allocated (se
, expr
);
6301 case GFC_ISYM_ASSOCIATED
:
6302 gfc_conv_associated(se
, expr
);
6305 case GFC_ISYM_SAME_TYPE_AS
:
6306 gfc_conv_same_type_as (se
, expr
);
6310 gfc_conv_intrinsic_abs (se
, expr
);
6313 case GFC_ISYM_ADJUSTL
:
6314 if (expr
->ts
.kind
== 1)
6315 fndecl
= gfor_fndecl_adjustl
;
6316 else if (expr
->ts
.kind
== 4)
6317 fndecl
= gfor_fndecl_adjustl_char4
;
6321 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6324 case GFC_ISYM_ADJUSTR
:
6325 if (expr
->ts
.kind
== 1)
6326 fndecl
= gfor_fndecl_adjustr
;
6327 else if (expr
->ts
.kind
== 4)
6328 fndecl
= gfor_fndecl_adjustr_char4
;
6332 gfc_conv_intrinsic_adjust (se
, expr
, fndecl
);
6335 case GFC_ISYM_AIMAG
:
6336 gfc_conv_intrinsic_imagpart (se
, expr
);
6340 gfc_conv_intrinsic_aint (se
, expr
, RND_TRUNC
);
6344 gfc_conv_intrinsic_anyall (se
, expr
, EQ_EXPR
);
6347 case GFC_ISYM_ANINT
:
6348 gfc_conv_intrinsic_aint (se
, expr
, RND_ROUND
);
6352 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6356 gfc_conv_intrinsic_anyall (se
, expr
, NE_EXPR
);
6359 case GFC_ISYM_BTEST
:
6360 gfc_conv_intrinsic_btest (se
, expr
);
6364 gfc_conv_intrinsic_bitcomp (se
, expr
, GE_EXPR
);
6368 gfc_conv_intrinsic_bitcomp (se
, expr
, GT_EXPR
);
6372 gfc_conv_intrinsic_bitcomp (se
, expr
, LE_EXPR
);
6376 gfc_conv_intrinsic_bitcomp (se
, expr
, LT_EXPR
);
6379 case GFC_ISYM_ACHAR
:
6381 gfc_conv_intrinsic_char (se
, expr
);
6384 case GFC_ISYM_CONVERSION
:
6386 case GFC_ISYM_LOGICAL
:
6388 gfc_conv_intrinsic_conversion (se
, expr
);
6391 /* Integer conversions are handled separately to make sure we get the
6392 correct rounding mode. */
6397 gfc_conv_intrinsic_int (se
, expr
, RND_TRUNC
);
6401 gfc_conv_intrinsic_int (se
, expr
, RND_ROUND
);
6404 case GFC_ISYM_CEILING
:
6405 gfc_conv_intrinsic_int (se
, expr
, RND_CEIL
);
6408 case GFC_ISYM_FLOOR
:
6409 gfc_conv_intrinsic_int (se
, expr
, RND_FLOOR
);
6413 gfc_conv_intrinsic_mod (se
, expr
, 0);
6416 case GFC_ISYM_MODULO
:
6417 gfc_conv_intrinsic_mod (se
, expr
, 1);
6420 case GFC_ISYM_CMPLX
:
6421 gfc_conv_intrinsic_cmplx (se
, expr
, name
[5] == '1');
6424 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
6425 gfc_conv_intrinsic_iargc (se
, expr
);
6428 case GFC_ISYM_COMPLEX
:
6429 gfc_conv_intrinsic_cmplx (se
, expr
, 1);
6432 case GFC_ISYM_CONJG
:
6433 gfc_conv_intrinsic_conjg (se
, expr
);
6436 case GFC_ISYM_COUNT
:
6437 gfc_conv_intrinsic_count (se
, expr
);
6440 case GFC_ISYM_CTIME
:
6441 gfc_conv_intrinsic_ctime (se
, expr
);
6445 gfc_conv_intrinsic_dim (se
, expr
);
6448 case GFC_ISYM_DOT_PRODUCT
:
6449 gfc_conv_intrinsic_dot_product (se
, expr
);
6452 case GFC_ISYM_DPROD
:
6453 gfc_conv_intrinsic_dprod (se
, expr
);
6456 case GFC_ISYM_DSHIFTL
:
6457 gfc_conv_intrinsic_dshift (se
, expr
, true);
6460 case GFC_ISYM_DSHIFTR
:
6461 gfc_conv_intrinsic_dshift (se
, expr
, false);
6464 case GFC_ISYM_FDATE
:
6465 gfc_conv_intrinsic_fdate (se
, expr
);
6468 case GFC_ISYM_FRACTION
:
6469 gfc_conv_intrinsic_fraction (se
, expr
);
6473 gfc_conv_intrinsic_arith (se
, expr
, BIT_AND_EXPR
, false);
6477 gfc_conv_intrinsic_bitop (se
, expr
, BIT_AND_EXPR
);
6481 gfc_conv_intrinsic_arith (se
, expr
, BIT_IOR_EXPR
, false);
6484 case GFC_ISYM_IBCLR
:
6485 gfc_conv_intrinsic_singlebitop (se
, expr
, 0);
6488 case GFC_ISYM_IBITS
:
6489 gfc_conv_intrinsic_ibits (se
, expr
);
6492 case GFC_ISYM_IBSET
:
6493 gfc_conv_intrinsic_singlebitop (se
, expr
, 1);
6496 case GFC_ISYM_IACHAR
:
6497 case GFC_ISYM_ICHAR
:
6498 /* We assume ASCII character sequence. */
6499 gfc_conv_intrinsic_ichar (se
, expr
);
6502 case GFC_ISYM_IARGC
:
6503 gfc_conv_intrinsic_iargc (se
, expr
);
6507 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6510 case GFC_ISYM_INDEX
:
6511 kind
= expr
->value
.function
.actual
->expr
->ts
.kind
;
6513 fndecl
= gfor_fndecl_string_index
;
6515 fndecl
= gfor_fndecl_string_index_char4
;
6519 gfc_conv_intrinsic_index_scan_verify (se
, expr
, fndecl
);
6523 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6526 case GFC_ISYM_IPARITY
:
6527 gfc_conv_intrinsic_arith (se
, expr
, BIT_XOR_EXPR
, false);
6530 case GFC_ISYM_IS_IOSTAT_END
:
6531 gfc_conv_has_intvalue (se
, expr
, LIBERROR_END
);
6534 case GFC_ISYM_IS_IOSTAT_EOR
:
6535 gfc_conv_has_intvalue (se
, expr
, LIBERROR_EOR
);
6538 case GFC_ISYM_ISNAN
:
6539 gfc_conv_intrinsic_isnan (se
, expr
);
6542 case GFC_ISYM_LSHIFT
:
6543 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6546 case GFC_ISYM_RSHIFT
:
6547 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6550 case GFC_ISYM_SHIFTA
:
6551 gfc_conv_intrinsic_shift (se
, expr
, true, true);
6554 case GFC_ISYM_SHIFTL
:
6555 gfc_conv_intrinsic_shift (se
, expr
, false, false);
6558 case GFC_ISYM_SHIFTR
:
6559 gfc_conv_intrinsic_shift (se
, expr
, true, false);
6562 case GFC_ISYM_ISHFT
:
6563 gfc_conv_intrinsic_ishft (se
, expr
);
6566 case GFC_ISYM_ISHFTC
:
6567 gfc_conv_intrinsic_ishftc (se
, expr
);
6570 case GFC_ISYM_LEADZ
:
6571 gfc_conv_intrinsic_leadz (se
, expr
);
6574 case GFC_ISYM_TRAILZ
:
6575 gfc_conv_intrinsic_trailz (se
, expr
);
6578 case GFC_ISYM_POPCNT
:
6579 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 0);
6582 case GFC_ISYM_POPPAR
:
6583 gfc_conv_intrinsic_popcnt_poppar (se
, expr
, 1);
6586 case GFC_ISYM_LBOUND
:
6587 gfc_conv_intrinsic_bound (se
, expr
, 0);
6590 case GFC_ISYM_LCOBOUND
:
6591 conv_intrinsic_cobound (se
, expr
);
6594 case GFC_ISYM_TRANSPOSE
:
6595 /* The scalarizer has already been set up for reversed dimension access
6596 order ; now we just get the argument value normally. */
6597 gfc_conv_expr (se
, expr
->value
.function
.actual
->expr
);
6601 gfc_conv_intrinsic_len (se
, expr
);
6604 case GFC_ISYM_LEN_TRIM
:
6605 gfc_conv_intrinsic_len_trim (se
, expr
);
6609 gfc_conv_intrinsic_strcmp (se
, expr
, GE_EXPR
);
6613 gfc_conv_intrinsic_strcmp (se
, expr
, GT_EXPR
);
6617 gfc_conv_intrinsic_strcmp (se
, expr
, LE_EXPR
);
6621 gfc_conv_intrinsic_strcmp (se
, expr
, LT_EXPR
);
6624 case GFC_ISYM_MASKL
:
6625 gfc_conv_intrinsic_mask (se
, expr
, 1);
6628 case GFC_ISYM_MASKR
:
6629 gfc_conv_intrinsic_mask (se
, expr
, 0);
6633 if (expr
->ts
.type
== BT_CHARACTER
)
6634 gfc_conv_intrinsic_minmax_char (se
, expr
, 1);
6636 gfc_conv_intrinsic_minmax (se
, expr
, GT_EXPR
);
6639 case GFC_ISYM_MAXLOC
:
6640 gfc_conv_intrinsic_minmaxloc (se
, expr
, GT_EXPR
);
6643 case GFC_ISYM_MAXVAL
:
6644 gfc_conv_intrinsic_minmaxval (se
, expr
, GT_EXPR
);
6647 case GFC_ISYM_MERGE
:
6648 gfc_conv_intrinsic_merge (se
, expr
);
6651 case GFC_ISYM_MERGE_BITS
:
6652 gfc_conv_intrinsic_merge_bits (se
, expr
);
6656 if (expr
->ts
.type
== BT_CHARACTER
)
6657 gfc_conv_intrinsic_minmax_char (se
, expr
, -1);
6659 gfc_conv_intrinsic_minmax (se
, expr
, LT_EXPR
);
6662 case GFC_ISYM_MINLOC
:
6663 gfc_conv_intrinsic_minmaxloc (se
, expr
, LT_EXPR
);
6666 case GFC_ISYM_MINVAL
:
6667 gfc_conv_intrinsic_minmaxval (se
, expr
, LT_EXPR
);
6670 case GFC_ISYM_NEAREST
:
6671 gfc_conv_intrinsic_nearest (se
, expr
);
6674 case GFC_ISYM_NORM2
:
6675 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, true);
6679 gfc_conv_intrinsic_not (se
, expr
);
6683 gfc_conv_intrinsic_bitop (se
, expr
, BIT_IOR_EXPR
);
6686 case GFC_ISYM_PARITY
:
6687 gfc_conv_intrinsic_arith (se
, expr
, NE_EXPR
, false);
6690 case GFC_ISYM_PRESENT
:
6691 gfc_conv_intrinsic_present (se
, expr
);
6694 case GFC_ISYM_PRODUCT
:
6695 gfc_conv_intrinsic_arith (se
, expr
, MULT_EXPR
, false);
6698 case GFC_ISYM_RRSPACING
:
6699 gfc_conv_intrinsic_rrspacing (se
, expr
);
6702 case GFC_ISYM_SET_EXPONENT
:
6703 gfc_conv_intrinsic_set_exponent (se
, expr
);
6706 case GFC_ISYM_SCALE
:
6707 gfc_conv_intrinsic_scale (se
, expr
);
6711 gfc_conv_intrinsic_sign (se
, expr
);
6715 gfc_conv_intrinsic_size (se
, expr
);
6718 case GFC_ISYM_SIZEOF
:
6719 case GFC_ISYM_C_SIZEOF
:
6720 gfc_conv_intrinsic_sizeof (se
, expr
);
6723 case GFC_ISYM_STORAGE_SIZE
:
6724 gfc_conv_intrinsic_storage_size (se
, expr
);
6727 case GFC_ISYM_SPACING
:
6728 gfc_conv_intrinsic_spacing (se
, expr
);
6732 gfc_conv_intrinsic_arith (se
, expr
, PLUS_EXPR
, false);
6735 case GFC_ISYM_TRANSFER
:
6736 if (se
->ss
&& se
->ss
->info
->useflags
)
6737 /* Access the previously obtained result. */
6738 gfc_conv_tmp_array_ref (se
);
6740 gfc_conv_intrinsic_transfer (se
, expr
);
6743 case GFC_ISYM_TTYNAM
:
6744 gfc_conv_intrinsic_ttynam (se
, expr
);
6747 case GFC_ISYM_UBOUND
:
6748 gfc_conv_intrinsic_bound (se
, expr
, 1);
6751 case GFC_ISYM_UCOBOUND
:
6752 conv_intrinsic_cobound (se
, expr
);
6756 gfc_conv_intrinsic_bitop (se
, expr
, BIT_XOR_EXPR
);
6760 gfc_conv_intrinsic_loc (se
, expr
);
6763 case GFC_ISYM_THIS_IMAGE
:
6764 /* For num_images() == 1, handle as LCOBOUND. */
6765 if (expr
->value
.function
.actual
->expr
6766 && gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)
6767 conv_intrinsic_cobound (se
, expr
);
6769 trans_this_image (se
, expr
);
6772 case GFC_ISYM_IMAGE_INDEX
:
6773 trans_image_index (se
, expr
);
6776 case GFC_ISYM_NUM_IMAGES
:
6777 trans_num_images (se
);
6780 case GFC_ISYM_ACCESS
:
6781 case GFC_ISYM_CHDIR
:
6782 case GFC_ISYM_CHMOD
:
6783 case GFC_ISYM_DTIME
:
6784 case GFC_ISYM_ETIME
:
6785 case GFC_ISYM_EXTENDS_TYPE_OF
:
6787 case GFC_ISYM_FGETC
:
6790 case GFC_ISYM_FPUTC
:
6791 case GFC_ISYM_FSTAT
:
6792 case GFC_ISYM_FTELL
:
6793 case GFC_ISYM_GETCWD
:
6794 case GFC_ISYM_GETGID
:
6795 case GFC_ISYM_GETPID
:
6796 case GFC_ISYM_GETUID
:
6797 case GFC_ISYM_HOSTNM
:
6799 case GFC_ISYM_IERRNO
:
6800 case GFC_ISYM_IRAND
:
6801 case GFC_ISYM_ISATTY
:
6804 case GFC_ISYM_LSTAT
:
6805 case GFC_ISYM_MALLOC
:
6806 case GFC_ISYM_MATMUL
:
6807 case GFC_ISYM_MCLOCK
:
6808 case GFC_ISYM_MCLOCK8
:
6810 case GFC_ISYM_RENAME
:
6811 case GFC_ISYM_SECOND
:
6812 case GFC_ISYM_SECNDS
:
6813 case GFC_ISYM_SIGNAL
:
6815 case GFC_ISYM_SYMLNK
:
6816 case GFC_ISYM_SYSTEM
:
6818 case GFC_ISYM_TIME8
:
6819 case GFC_ISYM_UMASK
:
6820 case GFC_ISYM_UNLINK
:
6822 gfc_conv_intrinsic_funcall (se
, expr
);
6825 case GFC_ISYM_EOSHIFT
:
6827 case GFC_ISYM_RESHAPE
:
6828 /* For those, expr->rank should always be >0 and thus the if above the
6829 switch should have matched. */
6834 gfc_conv_intrinsic_lib_function (se
, expr
);
6841 walk_inline_intrinsic_transpose (gfc_ss
*ss
, gfc_expr
*expr
)
6843 gfc_ss
*arg_ss
, *tmp_ss
;
6844 gfc_actual_arglist
*arg
;
6846 arg
= expr
->value
.function
.actual
;
6848 gcc_assert (arg
->expr
);
6850 arg_ss
= gfc_walk_subexpr (gfc_ss_terminator
, arg
->expr
);
6851 gcc_assert (arg_ss
!= gfc_ss_terminator
);
6853 for (tmp_ss
= arg_ss
; ; tmp_ss
= tmp_ss
->next
)
6855 if (tmp_ss
->info
->type
!= GFC_SS_SCALAR
6856 && tmp_ss
->info
->type
!= GFC_SS_REFERENCE
)
6860 gcc_assert (tmp_ss
->dimen
== 2);
6862 /* We just invert dimensions. */
6863 tmp_dim
= tmp_ss
->dim
[0];
6864 tmp_ss
->dim
[0] = tmp_ss
->dim
[1];
6865 tmp_ss
->dim
[1] = tmp_dim
;
6868 /* Stop when tmp_ss points to the last valid element of the chain... */
6869 if (tmp_ss
->next
== gfc_ss_terminator
)
6873 /* ... so that we can attach the rest of the chain to it. */
6880 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
6881 This has the side effect of reversing the nested list, so there is no
6882 need to call gfc_reverse_ss on it (the given list is assumed not to be
6886 nest_loop_dimension (gfc_ss
*ss
, int dim
)
6889 gfc_ss
*new_ss
, *prev_ss
= gfc_ss_terminator
;
6890 gfc_loopinfo
*new_loop
;
6892 gcc_assert (ss
!= gfc_ss_terminator
);
6894 for (; ss
!= gfc_ss_terminator
; ss
= ss
->next
)
6896 new_ss
= gfc_get_ss ();
6897 new_ss
->next
= prev_ss
;
6898 new_ss
->parent
= ss
;
6899 new_ss
->info
= ss
->info
;
6900 new_ss
->info
->refcount
++;
6903 gcc_assert (ss
->info
->type
!= GFC_SS_SCALAR
6904 && ss
->info
->type
!= GFC_SS_REFERENCE
);
6907 new_ss
->dim
[0] = ss
->dim
[dim
];
6909 gcc_assert (dim
< ss
->dimen
);
6911 ss_dim
= --ss
->dimen
;
6912 for (i
= dim
; i
< ss_dim
; i
++)
6913 ss
->dim
[i
] = ss
->dim
[i
+ 1];
6915 ss
->dim
[ss_dim
] = 0;
6921 ss
->nested_ss
->parent
= new_ss
;
6922 new_ss
->nested_ss
= ss
->nested_ss
;
6924 ss
->nested_ss
= new_ss
;
6927 new_loop
= gfc_get_loopinfo ();
6928 gfc_init_loopinfo (new_loop
);
6930 gcc_assert (prev_ss
!= NULL
);
6931 gcc_assert (prev_ss
!= gfc_ss_terminator
);
6932 gfc_add_ss_to_loop (new_loop
, prev_ss
);
6933 return new_ss
->parent
;
6937 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
6938 is to be inlined. */
6941 walk_inline_intrinsic_arith (gfc_ss
*ss
, gfc_expr
*expr
)
6943 gfc_ss
*tmp_ss
, *tail
, *array_ss
;
6944 gfc_actual_arglist
*arg1
, *arg2
, *arg3
;
6946 bool scalar_mask
= false;
6948 /* The rank of the result will be determined later. */
6949 arg1
= expr
->value
.function
.actual
;
6952 gcc_assert (arg3
!= NULL
);
6954 if (expr
->rank
== 0)
6957 tmp_ss
= gfc_ss_terminator
;
6963 mask_ss
= gfc_walk_subexpr (tmp_ss
, arg3
->expr
);
6964 if (mask_ss
== tmp_ss
)
6970 array_ss
= gfc_walk_subexpr (tmp_ss
, arg1
->expr
);
6971 gcc_assert (array_ss
!= tmp_ss
);
6973 /* Odd thing: If the mask is scalar, it is used by the frontend after
6974 the array (to make an if around the nested loop). Thus it shall
6975 be after array_ss once the gfc_ss list is reversed. */
6977 tmp_ss
= gfc_get_scalar_ss (array_ss
, arg3
->expr
);
6981 /* "Hide" the dimension on which we will sum in the first arg's scalarization
6983 sum_dim
= mpz_get_si (arg2
->expr
->value
.integer
) - 1;
6984 tail
= nest_loop_dimension (tmp_ss
, sum_dim
);
6992 walk_inline_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
)
6995 switch (expr
->value
.function
.isym
->id
)
6997 case GFC_ISYM_PRODUCT
:
6999 return walk_inline_intrinsic_arith (ss
, expr
);
7001 case GFC_ISYM_TRANSPOSE
:
7002 return walk_inline_intrinsic_transpose (ss
, expr
);
7011 /* This generates code to execute before entering the scalarization loop.
7012 Currently does nothing. */
7015 gfc_add_intrinsic_ss_code (gfc_loopinfo
* loop ATTRIBUTE_UNUSED
, gfc_ss
* ss
)
7017 switch (ss
->info
->expr
->value
.function
.isym
->id
)
7019 case GFC_ISYM_UBOUND
:
7020 case GFC_ISYM_LBOUND
:
7021 case GFC_ISYM_UCOBOUND
:
7022 case GFC_ISYM_LCOBOUND
:
7023 case GFC_ISYM_THIS_IMAGE
:
7032 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
7033 are expanded into code inside the scalarization loop. */
7036 gfc_walk_intrinsic_bound (gfc_ss
* ss
, gfc_expr
* expr
)
7038 if (expr
->value
.function
.actual
->expr
->ts
.type
== BT_CLASS
)
7039 gfc_add_class_array_ref (expr
->value
.function
.actual
->expr
);
7041 /* The two argument version returns a scalar. */
7042 if (expr
->value
.function
.actual
->next
->expr
)
7045 return gfc_get_array_ss (ss
, expr
, 1, GFC_SS_INTRINSIC
);
7049 /* Walk an intrinsic array libcall. */
7052 gfc_walk_intrinsic_libfunc (gfc_ss
* ss
, gfc_expr
* expr
)
7054 gcc_assert (expr
->rank
> 0);
7055 return gfc_get_array_ss (ss
, expr
, expr
->rank
, GFC_SS_FUNCTION
);
7059 /* Return whether the function call expression EXPR will be expanded
7060 inline by gfc_conv_intrinsic_function. */
7063 gfc_inline_intrinsic_function_p (gfc_expr
*expr
)
7065 gfc_actual_arglist
*args
;
7067 if (!expr
->value
.function
.isym
)
7070 switch (expr
->value
.function
.isym
->id
)
7072 case GFC_ISYM_PRODUCT
:
7074 /* Disable inline expansion if code size matters. */
7078 args
= expr
->value
.function
.actual
;
7079 /* We need to be able to subset the SUM argument at compile-time. */
7080 if (args
->next
->expr
&& args
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
7085 case GFC_ISYM_TRANSPOSE
:
7094 /* Returns nonzero if the specified intrinsic function call maps directly to
7095 an external library call. Should only be used for functions that return
7099 gfc_is_intrinsic_libcall (gfc_expr
* expr
)
7101 gcc_assert (expr
->expr_type
== EXPR_FUNCTION
&& expr
->value
.function
.isym
);
7102 gcc_assert (expr
->rank
> 0);
7104 if (gfc_inline_intrinsic_function_p (expr
))
7107 switch (expr
->value
.function
.isym
->id
)
7111 case GFC_ISYM_COUNT
:
7115 case GFC_ISYM_IPARITY
:
7116 case GFC_ISYM_MATMUL
:
7117 case GFC_ISYM_MAXLOC
:
7118 case GFC_ISYM_MAXVAL
:
7119 case GFC_ISYM_MINLOC
:
7120 case GFC_ISYM_MINVAL
:
7121 case GFC_ISYM_NORM2
:
7122 case GFC_ISYM_PARITY
:
7123 case GFC_ISYM_PRODUCT
:
7125 case GFC_ISYM_SHAPE
:
7126 case GFC_ISYM_SPREAD
:
7128 /* Ignore absent optional parameters. */
7131 case GFC_ISYM_RESHAPE
:
7132 case GFC_ISYM_CSHIFT
:
7133 case GFC_ISYM_EOSHIFT
:
7135 case GFC_ISYM_UNPACK
:
7136 /* Pass absent optional parameters. */
7144 /* Walk an intrinsic function. */
7146 gfc_walk_intrinsic_function (gfc_ss
* ss
, gfc_expr
* expr
,
7147 gfc_intrinsic_sym
* isym
)
7151 if (isym
->elemental
)
7152 return gfc_walk_elemental_function_args (ss
, expr
->value
.function
.actual
,
7153 NULL
, GFC_SS_SCALAR
);
7155 if (expr
->rank
== 0)
7158 if (gfc_inline_intrinsic_function_p (expr
))
7159 return walk_inline_intrinsic_function (ss
, expr
);
7161 if (gfc_is_intrinsic_libcall (expr
))
7162 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7164 /* Special cases. */
7167 case GFC_ISYM_LBOUND
:
7168 case GFC_ISYM_LCOBOUND
:
7169 case GFC_ISYM_UBOUND
:
7170 case GFC_ISYM_UCOBOUND
:
7171 case GFC_ISYM_THIS_IMAGE
:
7172 return gfc_walk_intrinsic_bound (ss
, expr
);
7174 case GFC_ISYM_TRANSFER
:
7175 return gfc_walk_intrinsic_libfunc (ss
, expr
);
7178 /* This probably meant someone forgot to add an intrinsic to the above
7179 list(s) when they implemented it, or something's gone horribly
7187 conv_intrinsic_atomic_def (gfc_code
*code
)
7192 gfc_init_se (&atom
, NULL
);
7193 gfc_init_se (&value
, NULL
);
7194 gfc_conv_expr (&atom
, code
->ext
.actual
->expr
);
7195 gfc_conv_expr (&value
, code
->ext
.actual
->next
->expr
);
7197 gfc_init_block (&block
);
7198 gfc_add_modify (&block
, atom
.expr
,
7199 fold_convert (TREE_TYPE (atom
.expr
), value
.expr
));
7200 return gfc_finish_block (&block
);
7205 conv_intrinsic_atomic_ref (gfc_code
*code
)
7210 gfc_init_se (&atom
, NULL
);
7211 gfc_init_se (&value
, NULL
);
7212 gfc_conv_expr (&value
, code
->ext
.actual
->expr
);
7213 gfc_conv_expr (&atom
, code
->ext
.actual
->next
->expr
);
7215 gfc_init_block (&block
);
7216 gfc_add_modify (&block
, value
.expr
,
7217 fold_convert (TREE_TYPE (value
.expr
), atom
.expr
));
7218 return gfc_finish_block (&block
);
7223 conv_intrinsic_move_alloc (gfc_code
*code
)
7226 gfc_expr
*from_expr
, *to_expr
;
7227 gfc_expr
*to_expr2
, *from_expr2
= NULL
;
7228 gfc_se from_se
, to_se
;
7229 gfc_ss
*from_ss
, *to_ss
;
7232 gfc_start_block (&block
);
7234 from_expr
= code
->ext
.actual
->expr
;
7235 to_expr
= code
->ext
.actual
->next
->expr
;
7237 gfc_init_se (&from_se
, NULL
);
7238 gfc_init_se (&to_se
, NULL
);
7240 if (from_expr
->rank
== 0)
7242 gcc_assert (from_expr
->ts
.type
!= BT_CLASS
7243 || to_expr
->ts
.type
== BT_CLASS
);
7244 if (from_expr
->ts
.type
!= BT_CLASS
)
7245 from_expr2
= from_expr
;
7248 from_expr2
= gfc_copy_expr (from_expr
);
7249 gfc_add_data_component (from_expr2
);
7252 if (to_expr
->ts
.type
!= BT_CLASS
)
7256 to_expr2
= gfc_copy_expr (to_expr
);
7257 gfc_add_data_component (to_expr2
);
7260 from_se
.want_pointer
= 1;
7261 to_se
.want_pointer
= 1;
7262 gfc_conv_expr (&from_se
, from_expr2
);
7263 gfc_conv_expr (&to_se
, to_expr2
);
7264 gfc_add_block_to_block (&block
, &from_se
.pre
);
7265 gfc_add_block_to_block (&block
, &to_se
.pre
);
7267 /* Deallocate "to". */
7268 tmp
= gfc_deallocate_scalar_with_status (to_se
.expr
, NULL_TREE
, true,
7269 to_expr2
, to_expr
->ts
);
7270 gfc_add_expr_to_block (&block
, tmp
);
7272 /* Assign (_data) pointers. */
7273 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7274 fold_convert (TREE_TYPE (to_se
.expr
), from_se
.expr
));
7276 /* Set "from" to NULL. */
7277 gfc_add_modify_loc (input_location
, &block
, from_se
.expr
,
7278 fold_convert (TREE_TYPE (from_se
.expr
), null_pointer_node
));
7280 gfc_add_block_to_block (&block
, &from_se
.post
);
7281 gfc_add_block_to_block (&block
, &to_se
.post
);
7284 if (to_expr
->ts
.type
== BT_CLASS
)
7286 gfc_free_expr (to_expr2
);
7287 gfc_init_se (&to_se
, NULL
);
7288 to_se
.want_pointer
= 1;
7289 gfc_add_vptr_component (to_expr
);
7290 gfc_conv_expr (&to_se
, to_expr
);
7292 if (from_expr
->ts
.type
== BT_CLASS
)
7294 gfc_free_expr (from_expr2
);
7295 gfc_init_se (&from_se
, NULL
);
7296 from_se
.want_pointer
= 1;
7297 gfc_add_vptr_component (from_expr
);
7298 gfc_conv_expr (&from_se
, from_expr
);
7304 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7306 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7309 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7310 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7313 return gfc_finish_block (&block
);
7316 /* Update _vptr component. */
7317 if (to_expr
->ts
.type
== BT_CLASS
)
7319 to_se
.want_pointer
= 1;
7320 to_expr2
= gfc_copy_expr (to_expr
);
7321 gfc_add_vptr_component (to_expr2
);
7322 gfc_conv_expr (&to_se
, to_expr2
);
7324 if (from_expr
->ts
.type
== BT_CLASS
)
7326 from_se
.want_pointer
= 1;
7327 from_expr2
= gfc_copy_expr (from_expr
);
7328 gfc_add_vptr_component (from_expr2
);
7329 gfc_conv_expr (&from_se
, from_expr2
);
7335 vtab
= gfc_find_derived_vtab (from_expr
->ts
.u
.derived
);
7337 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
7340 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
,
7341 fold_convert (TREE_TYPE (to_se
.expr
), tmp
));
7342 gfc_free_expr (to_expr2
);
7343 gfc_init_se (&to_se
, NULL
);
7345 if (from_expr
->ts
.type
== BT_CLASS
)
7347 gfc_free_expr (from_expr2
);
7348 gfc_init_se (&from_se
, NULL
);
7352 /* Deallocate "to". */
7353 to_ss
= gfc_walk_expr (to_expr
);
7354 from_ss
= gfc_walk_expr (from_expr
);
7355 gfc_conv_expr_descriptor (&to_se
, to_expr
, to_ss
);
7356 gfc_conv_expr_descriptor (&from_se
, from_expr
, from_ss
);
7358 tmp
= gfc_conv_descriptor_data_get (to_se
.expr
);
7359 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
, NULL_TREE
,
7360 NULL_TREE
, true, to_expr
, false);
7361 gfc_add_expr_to_block (&block
, tmp
);
7363 /* Move the pointer and update the array descriptor data. */
7364 gfc_add_modify_loc (input_location
, &block
, to_se
.expr
, from_se
.expr
);
7366 /* Set "to" to NULL. */
7367 tmp
= gfc_conv_descriptor_data_get (from_se
.expr
);
7368 gfc_add_modify_loc (input_location
, &block
, tmp
,
7369 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7371 return gfc_finish_block (&block
);
7376 gfc_conv_intrinsic_subroutine (gfc_code
*code
)
7380 gcc_assert (code
->resolved_isym
);
7382 switch (code
->resolved_isym
->id
)
7384 case GFC_ISYM_MOVE_ALLOC
:
7385 res
= conv_intrinsic_move_alloc (code
);
7388 case GFC_ISYM_ATOMIC_DEF
:
7389 res
= conv_intrinsic_atomic_def (code
);
7392 case GFC_ISYM_ATOMIC_REF
:
7393 res
= conv_intrinsic_atomic_ref (code
);
7404 #include "gt-fortran-trans-intrinsic.h"